From: Ed Schonberg Date: Thu, 11 Jul 2019 08:01:54 +0000 (+0000) Subject: [Ada] Compile-time evaluation of predicate checks X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=a081ded4df03e30cd4aefa1e946eb31aa423bfb2;p=gcc.git [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 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 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 9d5a50f163f..b79a8173388 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,9 @@ +2019-07-11 Ed Schonberg + + * 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 * 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 feeac7b0213..0251d008eea 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 a761f79f7a2..bbfada284f9 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2019-07-11 Ed Schonberg + + * gnat.dg/predicate11.adb: New testcase. + 2019-07-11 Hristian Kirtchev * 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 00000000000..dc92a9182dc --- /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;