[Ada] Compile-time evaluation of predicate checks

This patch recognizes case of dynamic predicates on integer subtypes
that are simple enough to be evaluated statically when the argument is
itself a literal. Even though in many cases such predicate checks will
be removed by the back-end with any level of optimization, it is
preferable to perform this constant folding in the front-end, wich also
cleans up the output of CCG, as well as producing explicit warnings when
the test will fail.

2019-07-11  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* exp_ch6.adb (Can_Fold_Predicate_Call): New function,
	subsidiary of Expand_Call_Helper, to compute statically a
	predicate check when the argument is a static integer.

gcc/testsuite/

	* gnat.dg/predicate11.adb: New testcase.

From-SVN: r273386

4 files changed, 130 insertions, 0 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 9d5a50f..b79a817 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,9 @@
+2019-07-11  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch6.adb (Can_Fold_Predicate_Call): New function,
+	subsidiary of Expand_Call_Helper, to compute statically a
+	predicate check when the argument is a static integer.
+
 2019-07-11  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* sem_res.adb (Resolve_Op_Not): Do not rewrite an equality
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index feeac7b..0251d00 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -2319,6 +2319,13 @@ package body Exp_Ch6 is
       --  Adds invariant checks for every intermediate type between the range
       --  of a view converted argument to its ancestor (from parent to child).
 
+      function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean;
+      --  Try to constant-fold a predicate check, which often enough is a
+      --  simple arithmetic expression that can be computed statically if
+      --  its argument is static. This cleans up the output of CCG, even
+      --  though useless predicate checks will be generally removed by
+      --  back-end optimizations.
+
       function Inherited_From_Formal (S : Entity_Id) return Entity_Id;
       --  Within an instance, a type derived from an untagged formal derived
       --  type inherits from the original parent, not from the actual. The
@@ -2467,6 +2474,89 @@ package body Exp_Ch6 is
          end if;
       end Add_View_Conversion_Invariants;
 
+      -----------------------------
+      -- Can_Fold_Predicate_Call --
+      -----------------------------
+
+      function Can_Fold_Predicate_Call (P : Entity_Id) return Boolean is
+         Actual : constant Node_Id :=
+                    First (Parameter_Associations (Call_Node));
+         Subt : constant Entity_Id := Etype (First_Entity (P));
+         Pred : Node_Id;
+
+         function May_Fold (N : Node_Id) return Traverse_Result;
+         --  The predicate expression is foldable if it only contains operators
+         --  and literals. During this check, we also replace occurrences of
+         --  the formal of the constructed predicate function with the static
+         --  value of the actual. This is done on a copy of the analyzed
+         --  expression for the predicate.
+
+         function May_Fold (N : Node_Id) return Traverse_Result is
+         begin
+            case Nkind (N) is
+               when N_Binary_Op | N_Unary_Op  =>
+                  return OK;
+
+               when N_Identifier | N_Expanded_Name =>
+                  if Ekind (Entity (N)) = E_In_Parameter
+                    and then Entity (N) = First_Entity (P)
+                  then
+                     Rewrite (N, New_Copy (Actual));
+                     Set_Is_Static_Expression (N);
+                     return OK;
+
+                  elsif Ekind (Entity (N)) = E_Enumeration_Literal then
+                     return OK;
+
+                  else
+                     return Abandon;
+                  end if;
+
+               when N_If_Expression | N_Case_Expression =>
+                  return OK;
+
+               when N_Integer_Literal =>
+                  return OK;
+
+               when others =>
+                  return Abandon;
+            end case;
+         end May_Fold;
+
+         function Try_Fold is new Traverse_Func (May_Fold);
+
+      --  Start of processing for Can_Fold_Predicate_Call
+
+      begin
+         --  Folding is only interesting if the actual is static and its type
+         --  has a Dynamic_Predicate aspect. For CodePeer we preserve the
+         --  function call.
+
+         if Nkind (Actual) /= N_Integer_Literal
+           or else not Has_Dynamic_Predicate_Aspect (Subt)
+           or else CodePeer_Mode
+         then
+            return False;
+         end if;
+
+         --  Retrieve the analyzed expression for the predicate
+
+         Pred :=
+            New_Copy_Tree
+              (Expression (Find_Aspect (Subt, Aspect_Dynamic_Predicate)));
+
+         if Try_Fold (Pred) = OK then
+            Rewrite (Call_Node, Pred);
+            Analyze_And_Resolve (Call_Node, Standard_Boolean);
+            return True;
+
+         else
+            --  Continue expansion of function call
+
+            return False;
+         end if;
+      end Can_Fold_Predicate_Call;
+
       ---------------------------
       -- Inherited_From_Formal --
       ---------------------------
@@ -2815,6 +2905,17 @@ package body Exp_Ch6 is
          end;
       end if;
 
+      --  if this is a call to a predicate function, try to constant
+      --  fold it.
+
+      if Nkind (Call_Node) = N_Function_Call
+        and then Is_Entity_Name (Name (Call_Node))
+        and then Is_Predicate_Function (Subp)
+        and then Can_Fold_Predicate_Call (Subp)
+      then
+         return;
+      end if;
+
       if Modify_Tree_For_C
         and then Nkind (Call_Node) = N_Function_Call
         and then Is_Entity_Name (Name (Call_Node))
diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog
index a761f79..bbfada2 100644
--- a/gcc/testsuite/ChangeLog
+++ b/gcc/testsuite/ChangeLog
@@ -1,3 +1,7 @@
+2019-07-11  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/predicate11.adb: New testcase.
+
 2019-07-11  Hristian Kirtchev  <kirtchev@adacore.com>
 
 	* gnat.dg/equal9.adb: New testcase.
diff --git a/gcc/testsuite/gnat.dg/predicate11.adb b/gcc/testsuite/gnat.dg/predicate11.adb
new file mode 100644
index 0000000..dc92a91
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/predicate11.adb
@@ -0,0 +1,19 @@
+--  { dg-do compile }
+--  { dg-options "-gnata" }
+
+procedure Predicate11 is
+   type T_BYTES  is new Integer range 0 .. 2**15 - 1  with Size => 32;
+   subtype TYPE5_SCALAR is T_BYTES
+     with Dynamic_Predicate => TYPE5_SCALAR mod 4 = 0;
+   subtype Cond is Integer
+     with dynamic_predicate => (if cond < 5 then false else True);
+
+   Thing1 : Type5_Scalar := 7;  --  { dg-warning "check will fail at run time" }
+   function OK (C :Type5_scalar) return Boolean is (True);
+   Thing2 : Type5_Scalar;
+   Thing3 : Cond;
+begin
+   if not OK (7) then raise Program_Error; end if;  --  { dg-warning "check will fail at run time" }
+   Thing2 := 8;
+   Thing3 := 1;  --  { dg-warning "check will fail at run time" }
+end;