From 98032cd46ffc18adfdbf6fb7b585998283ada9f5 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 2 Dec 2020 14:14:25 -0500 Subject: [PATCH] [Ada] Code cleanup: remove Old_Requires_Transient_Scope gcc/ada/ * sem_util.adb (New_Requires_Transient_Scope): Renamed Requires_Transient_Scope. (Requires_Transient_Scope, Old_Requires_Transient_Scope, Results_Differ): Removed. * debug.adb: Remove -gnatdQ. --- gcc/ada/debug.adb | 7 +- gcc/ada/sem_util.adb | 663 ++++++++++++++++--------------------------- 2 files changed, 244 insertions(+), 426 deletions(-) diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index f57b1485541..2c7c7127fa2 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -74,7 +74,7 @@ package body Debug is -- dN No file name information in exception messages -- dO Output immediate error messages -- dP Do not check for controlled objects in preelaborable packages - -- dQ Use old secondary stack method + -- dQ -- dR Bypass check for correct version of s-rpc -- dS Never convert numbers to machine numbers in Sem_Eval -- dT Convert to machine numbers only for constant declarations @@ -643,11 +643,6 @@ package body Debug is -- in preelaborable packages, but this restriction is a huge pain, -- especially in the predefined library units. - -- dQ Use old method for determining what goes on the secondary stack. - -- This disables some newer optimizations. The intent is to use this - -- temporarily to measure before/after efficiency. ???Remove this - -- when we are done (see Sem_Util.Requires_Transient_Scope). - -- dR Bypass the check for a proper version of s-rpc being present -- to use the -gnatz? switch. This allows debugging of the use -- of stubs generation without needing to have GLADE (or some diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 759c727b29b..01b8dccecaa 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -23,8 +23,6 @@ -- -- ------------------------------------------------------------------------------ -with Treepr; -- ???For debugging code below - with Casing; use Casing; with Checks; use Checks; with Debug; use Debug; @@ -170,24 +168,6 @@ package body Sem_Util is -- routine does not take simple flow diagnostics into account, it relies on -- static facts such as the presence of null exclusions. - function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean; - function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean; - -- ???We retain the old and new algorithms for Requires_Transient_Scope for - -- the time being. New_Requires_Transient_Scope is used by default; the - -- debug switch -gnatdQ can be used to do Old_Requires_Transient_Scope - -- instead. The intent is to use this temporarily to measure before/after - -- efficiency. Note: when this temporary code is removed, the documentation - -- of dQ in debug.adb should be removed. - - procedure Results_Differ - (Id : Entity_Id; - Old_Val : Boolean; - New_Val : Boolean); - -- ???Debugging code. Called when the Old_Val and New_Val differ. This - -- routine will be removed eventially when New_Requires_Transient_Scope - -- becomes Requires_Transient_Scope and Old_Requires_Transient_Scope is - -- eliminated. - function Subprogram_Name (N : Node_Id) return String; -- Return the fully qualified name of the enclosing subprogram for the -- given node N, with file:line:col information appended, e.g. @@ -24420,228 +24400,6 @@ package body Sem_Util is Node := Next_Global (Node); end Next_Global; - ---------------------------------- - -- New_Requires_Transient_Scope -- - ---------------------------------- - - function New_Requires_Transient_Scope (Id : Entity_Id) return Boolean is - function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean; - -- This is called for untagged records and protected types, with - -- nondefaulted discriminants. Returns True if the size of function - -- results is known at the call site, False otherwise. Returns False - -- if there is a variant part that depends on the discriminants of - -- this type, or if there is an array constrained by the discriminants - -- of this type. ???Currently, this is overly conservative (the array - -- could be nested inside some other record that is constrained by - -- nondiscriminants). That is, the recursive calls are too conservative. - - function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; - -- Returns True if Typ is a nonlimited record with defaulted - -- discriminants whose max size makes it unsuitable for allocating on - -- the primary stack. - - ------------------------------ - -- Caller_Known_Size_Record -- - ------------------------------ - - function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is - pragma Assert (Typ = Underlying_Type (Typ)); - - begin - if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then - return False; - end if; - - declare - Comp : Entity_Id; - - begin - Comp := First_Component (Typ); - while Present (Comp) loop - - -- Only look at E_Component entities. No need to look at - -- E_Discriminant entities, and we must ignore internal - -- subtypes generated for constrained components. - - declare - Comp_Type : constant Entity_Id := - Underlying_Type (Etype (Comp)); - - begin - if Is_Record_Type (Comp_Type) - or else - Is_Protected_Type (Comp_Type) - then - if not Caller_Known_Size_Record (Comp_Type) then - return False; - end if; - - elsif Is_Array_Type (Comp_Type) then - if Size_Depends_On_Discriminant (Comp_Type) then - return False; - end if; - end if; - end; - - Next_Component (Comp); - end loop; - end; - - return True; - end Caller_Known_Size_Record; - - ------------------------------ - -- Large_Max_Size_Mutable -- - ------------------------------ - - function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is - pragma Assert (Typ = Underlying_Type (Typ)); - - function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; - -- Returns true if the discrete type T has a large range - - ---------------------------- - -- Is_Large_Discrete_Type -- - ---------------------------- - - function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is - Threshold : constant Int := 16; - -- Arbitrary threshold above which we consider it "large". We want - -- a fairly large threshold, because these large types really - -- shouldn't have default discriminants in the first place, in - -- most cases. - - begin - return UI_To_Int (RM_Size (T)) > Threshold; - end Is_Large_Discrete_Type; - - -- Start of processing for Large_Max_Size_Mutable - - begin - if Is_Record_Type (Typ) - and then not Is_Limited_View (Typ) - and then Has_Defaulted_Discriminants (Typ) - then - -- Loop through the components, looking for an array whose upper - -- bound(s) depends on discriminants, where both the subtype of - -- the discriminant and the index subtype are too large. - - declare - Comp : Entity_Id; - - begin - Comp := First_Component (Typ); - while Present (Comp) loop - declare - Comp_Type : constant Entity_Id := - Underlying_Type (Etype (Comp)); - - Hi : Node_Id; - Indx : Node_Id; - Ityp : Entity_Id; - - begin - if Is_Array_Type (Comp_Type) then - Indx := First_Index (Comp_Type); - - while Present (Indx) loop - Ityp := Etype (Indx); - Hi := Type_High_Bound (Ityp); - - if Nkind (Hi) = N_Identifier - and then Ekind (Entity (Hi)) = E_Discriminant - and then Is_Large_Discrete_Type (Ityp) - and then Is_Large_Discrete_Type - (Etype (Entity (Hi))) - then - return True; - end if; - - Next_Index (Indx); - end loop; - end if; - end; - - Next_Component (Comp); - end loop; - end; - end if; - - return False; - end Large_Max_Size_Mutable; - - -- Local declarations - - Typ : constant Entity_Id := Underlying_Type (Id); - - -- Start of processing for New_Requires_Transient_Scope - - begin - -- This is a private type which is not completed yet. This can only - -- happen in a default expression (of a formal parameter or of a - -- record component). Do not expand transient scope in this case. - - if No (Typ) then - return False; - - -- Do not expand transient scope for non-existent procedure return or - -- string literal types. - - elsif Typ = Standard_Void_Type - or else Ekind (Typ) = E_String_Literal_Subtype - then - return False; - - -- If Typ is a generic formal incomplete type, then we want to look at - -- the actual type. - - elsif Ekind (Typ) = E_Record_Subtype - and then Present (Cloned_Subtype (Typ)) - then - return New_Requires_Transient_Scope (Cloned_Subtype (Typ)); - - -- Functions returning specific tagged types may dispatch on result, so - -- their returned value is allocated on the secondary stack, even in the - -- definite case. We must treat nondispatching functions the same way, - -- because access-to-function types can point at both, so the calling - -- conventions must be compatible. Is_Tagged_Type includes controlled - -- types and class-wide types. Controlled type temporaries need - -- finalization. - - -- ???It's not clear why we need to return noncontrolled types with - -- controlled components on the secondary stack. - - elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then - return True; - - -- Untagged definite subtypes are known size. This includes all - -- elementary [sub]types. Tasks are known size even if they have - -- discriminants. So we return False here, with one exception: - -- For a type like: - -- type T (Last : Natural := 0) is - -- X : String (1 .. Last); - -- end record; - -- we return True. That's because for "P(F(...));", where F returns T, - -- we don't know the size of the result at the call site, so if we - -- allocated it on the primary stack, we would have to allocate the - -- maximum size, which is way too big. - - elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then - return Large_Max_Size_Mutable (Typ); - - -- Indefinite (discriminated) untagged record or protected type - - elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then - return not Caller_Known_Size_Record (Typ); - - -- Unconstrained array - - else - pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ)); - return True; - end if; - end New_Requires_Transient_Scope; - ------------------------ -- No_Caching_Enabled -- ------------------------ @@ -25516,140 +25274,41 @@ package body Sem_Util is return Num; end Number_Of_Elements_In_Array; - ---------------------------------- - -- Old_Requires_Transient_Scope -- - ---------------------------------- + --------------------------------- + -- Original_Aspect_Pragma_Name -- + --------------------------------- - function Old_Requires_Transient_Scope (Id : Entity_Id) return Boolean is - Typ : constant Entity_Id := Underlying_Type (Id); + function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is + Item : Node_Id; + Item_Nam : Name_Id; begin - -- This is a private type which is not completed yet. This can only - -- happen in a default expression (of a formal parameter or of a - -- record component). Do not expand transient scope in this case. + pragma Assert (Nkind (N) in N_Aspect_Specification | N_Pragma); - if No (Typ) then - return False; + Item := N; - -- Do not expand transient scope for non-existent procedure return + -- The pragma was generated to emulate an aspect, use the original + -- aspect specification. - elsif Typ = Standard_Void_Type then - return False; + if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then + Item := Corresponding_Aspect (Item); + end if; - -- Elementary types do not require a transient scope + -- Retrieve the name of the aspect/pragma. As assertion pragmas from + -- a generic instantiation might have been rewritten into pragma Check, + -- we look at the original node for Item. Note also that Pre, Pre_Class, + -- Post and Post_Class rewrite their pragma identifier to preserve the + -- original name, so we look at the original node for the identifier. + -- ??? this is kludgey - elsif Is_Elementary_Type (Typ) then - return False; + if Nkind (Item) = N_Pragma then + Item_Nam := + Chars (Original_Node (Pragma_Identifier (Original_Node (Item)))); - -- Generally, indefinite subtypes require a transient scope, since the - -- back end cannot generate temporaries, since this is not a valid type - -- for declaring an object. It might be possible to relax this in the - -- future, e.g. by declaring the maximum possible space for the type. - - elsif not Is_Definite_Subtype (Typ) then - return True; - - -- Functions returning tagged types may dispatch on result so their - -- returned value is allocated on the secondary stack. Controlled - -- type temporaries need finalization. - - elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then - return True; - - -- Record type - - elsif Is_Record_Type (Typ) then - declare - Comp : Entity_Id; - - begin - Comp := First_Entity (Typ); - while Present (Comp) loop - if Ekind (Comp) = E_Component then - - -- ???It's not clear we need a full recursive call to - -- Old_Requires_Transient_Scope here. Note that the - -- following can't happen. - - pragma Assert (Is_Definite_Subtype (Etype (Comp))); - pragma Assert (not Has_Controlled_Component (Etype (Comp))); - - if Old_Requires_Transient_Scope (Etype (Comp)) then - return True; - end if; - end if; - - Next_Entity (Comp); - end loop; - end; - - return False; - - -- String literal types never require transient scope - - elsif Ekind (Typ) = E_String_Literal_Subtype then - return False; - - -- Array type. Note that we already know that this is a constrained - -- array, since unconstrained arrays will fail the indefinite test. - - elsif Is_Array_Type (Typ) then - - -- If component type requires a transient scope, the array does too - - if Old_Requires_Transient_Scope (Component_Type (Typ)) then - return True; - - -- Otherwise, we only need a transient scope if the size depends on - -- the value of one or more discriminants. - - else - return Size_Depends_On_Discriminant (Typ); - end if; - - -- All other cases do not require a transient scope - - else - pragma Assert (Is_Concurrent_Type (Typ)); - return False; - end if; - end Old_Requires_Transient_Scope; - - --------------------------------- - -- Original_Aspect_Pragma_Name -- - --------------------------------- - - function Original_Aspect_Pragma_Name (N : Node_Id) return Name_Id is - Item : Node_Id; - Item_Nam : Name_Id; - - begin - pragma Assert (Nkind (N) in N_Aspect_Specification | N_Pragma); - - Item := N; - - -- The pragma was generated to emulate an aspect, use the original - -- aspect specification. - - if Nkind (Item) = N_Pragma and then From_Aspect_Specification (Item) then - Item := Corresponding_Aspect (Item); - end if; - - -- Retrieve the name of the aspect/pragma. As assertion pragmas from - -- a generic instantiation might have been rewritten into pragma Check, - -- we look at the original node for Item. Note also that Pre, Pre_Class, - -- Post and Post_Class rewrite their pragma identifier to preserve the - -- original name, so we look at the original node for the identifier. - -- ??? this is kludgey - - if Nkind (Item) = N_Pragma then - Item_Nam := - Chars (Original_Node (Pragma_Identifier (Original_Node (Item)))); - - else - pragma Assert (Nkind (Item) = N_Aspect_Specification); - Item_Nam := Chars (Identifier (Item)); - end if; + else + pragma Assert (Nkind (Item) = N_Aspect_Specification); + Item_Nam := Chars (Identifier (Item)); + end if; -- Deal with 'Class by converting the name to its _XXX form @@ -26712,18 +26371,82 @@ package body Sem_Util is -- generated before the next instruction. function Requires_Transient_Scope (Id : Entity_Id) return Boolean is - Old_Result : constant Boolean := Old_Requires_Transient_Scope (Id); + function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean; + -- This is called for untagged records and protected types, with + -- nondefaulted discriminants. Returns True if the size of function + -- results is known at the call site, False otherwise. Returns False + -- if there is a variant part that depends on the discriminants of + -- this type, or if there is an array constrained by the discriminants + -- of this type. ???Currently, this is overly conservative (the array + -- could be nested inside some other record that is constrained by + -- nondiscriminants). That is, the recursive calls are too conservative. procedure Ensure_Minimum_Decoration (Typ : Entity_Id); -- If Typ is not frozen then add to Typ the minimum decoration required -- by Requires_Transient_Scope to reliably provide its functionality; -- otherwise no action is performed. + function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean; + -- Returns True if Typ is a nonlimited record with defaulted + -- discriminants whose max size makes it unsuitable for allocating on + -- the primary stack. + + ------------------------------ + -- Caller_Known_Size_Record -- + ------------------------------ + + function Caller_Known_Size_Record (Typ : Entity_Id) return Boolean is + pragma Assert (Typ = Underlying_Type (Typ)); + + begin + if Has_Variant_Part (Typ) and then not Is_Definite_Subtype (Typ) then + return False; + end if; + + declare + Comp : Entity_Id; + + begin + Comp := First_Component (Typ); + while Present (Comp) loop + + -- Only look at E_Component entities. No need to look at + -- E_Discriminant entities, and we must ignore internal + -- subtypes generated for constrained components. + + declare + Comp_Type : constant Entity_Id := + Underlying_Type (Etype (Comp)); + + begin + if Is_Record_Type (Comp_Type) + or else + Is_Protected_Type (Comp_Type) + then + if not Caller_Known_Size_Record (Comp_Type) then + return False; + end if; + + elsif Is_Array_Type (Comp_Type) then + if Size_Depends_On_Discriminant (Comp_Type) then + return False; + end if; + end if; + end; + + Next_Component (Comp); + end loop; + end; + + return True; + end Caller_Known_Size_Record; + ------------------------------- -- Ensure_Minimum_Decoration -- ------------------------------- procedure Ensure_Minimum_Decoration (Typ : Entity_Id) is + Comp : Entity_Id; begin -- Do not set Has_Controlled_Component on a class-wide equivalent -- type. See Make_CW_Equivalent_Type. @@ -26735,82 +26458,182 @@ package body Sem_Util is or else Is_Incomplete_Or_Private_Type (Typ)) and then not Is_Class_Wide_Equivalent_Type (Typ) then + Comp := First_Component (Typ); + while Present (Comp) loop + if Has_Controlled_Component (Etype (Comp)) + or else + (Chars (Comp) /= Name_uParent + and then Is_Controlled (Etype (Comp))) + or else + (Is_Protected_Type (Etype (Comp)) + and then + Present (Corresponding_Record_Type (Etype (Comp))) + and then + Has_Controlled_Component + (Corresponding_Record_Type (Etype (Comp)))) + then + Set_Has_Controlled_Component (Typ); + exit; + end if; + + Next_Component (Comp); + end loop; + end if; + end Ensure_Minimum_Decoration; + + ------------------------------ + -- Large_Max_Size_Mutable -- + ------------------------------ + + function Large_Max_Size_Mutable (Typ : Entity_Id) return Boolean is + pragma Assert (Typ = Underlying_Type (Typ)); + + function Is_Large_Discrete_Type (T : Entity_Id) return Boolean; + -- Returns true if the discrete type T has a large range + + ---------------------------- + -- Is_Large_Discrete_Type -- + ---------------------------- + + function Is_Large_Discrete_Type (T : Entity_Id) return Boolean is + Threshold : constant Int := 16; + -- Arbitrary threshold above which we consider it "large". We want + -- a fairly large threshold, because these large types really + -- shouldn't have default discriminants in the first place, in + -- most cases. + + begin + return UI_To_Int (RM_Size (T)) > Threshold; + end Is_Large_Discrete_Type; + + -- Start of processing for Large_Max_Size_Mutable + + begin + if Is_Record_Type (Typ) + and then not Is_Limited_View (Typ) + and then Has_Defaulted_Discriminants (Typ) + then + -- Loop through the components, looking for an array whose upper + -- bound(s) depends on discriminants, where both the subtype of + -- the discriminant and the index subtype are too large. + declare Comp : Entity_Id; begin Comp := First_Component (Typ); while Present (Comp) loop - if Has_Controlled_Component (Etype (Comp)) - or else - (Chars (Comp) /= Name_uParent - and then Is_Controlled (Etype (Comp))) - or else - (Is_Protected_Type (Etype (Comp)) - and then - Present (Corresponding_Record_Type (Etype (Comp))) - and then - Has_Controlled_Component - (Corresponding_Record_Type (Etype (Comp)))) - then - Set_Has_Controlled_Component (Typ); - exit; - end if; + declare + Comp_Type : constant Entity_Id := + Underlying_Type (Etype (Comp)); + + Hi : Node_Id; + Indx : Node_Id; + Ityp : Entity_Id; + + begin + if Is_Array_Type (Comp_Type) then + Indx := First_Index (Comp_Type); + + while Present (Indx) loop + Ityp := Etype (Indx); + Hi := Type_High_Bound (Ityp); + + if Nkind (Hi) = N_Identifier + and then Ekind (Entity (Hi)) = E_Discriminant + and then Is_Large_Discrete_Type (Ityp) + and then Is_Large_Discrete_Type + (Etype (Entity (Hi))) + then + return True; + end if; + + Next_Index (Indx); + end loop; + end if; + end; Next_Component (Comp); end loop; end; end if; - end Ensure_Minimum_Decoration; + + return False; + end Large_Max_Size_Mutable; + + -- Local declarations + + Typ : constant Entity_Id := Underlying_Type (Id); -- Start of processing for Requires_Transient_Scope begin - if Debug_Flag_QQ then - return Old_Result; - end if; - Ensure_Minimum_Decoration (Id); - declare - New_Result : constant Boolean := New_Requires_Transient_Scope (Id); + -- This is a private type which is not completed yet. This can only + -- happen in a default expression (of a formal parameter or of a + -- record component). Do not expand transient scope in this case. - begin - -- Assert that we're not putting things on the secondary stack if we - -- didn't before; we are trying to AVOID secondary stack when - -- possible. + if No (Typ) then + return False; - if not Old_Result then - pragma Assert (not New_Result); - null; - end if; + -- Do not expand transient scope for non-existent procedure return or + -- string literal types. - if New_Result /= Old_Result then - Results_Differ (Id, Old_Result, New_Result); - end if; + elsif Typ = Standard_Void_Type + or else Ekind (Typ) = E_String_Literal_Subtype + then + return False; - return New_Result; - end; - end Requires_Transient_Scope; + -- If Typ is a generic formal incomplete type, then we want to look at + -- the actual type. - -------------------- - -- Results_Differ -- - -------------------- + elsif Ekind (Typ) = E_Record_Subtype + and then Present (Cloned_Subtype (Typ)) + then + return Requires_Transient_Scope (Cloned_Subtype (Typ)); - procedure Results_Differ - (Id : Entity_Id; - Old_Val : Boolean; - New_Val : Boolean) - is - begin - if False then -- False to disable; True for debugging - Treepr.Print_Tree_Node (Id); + -- Functions returning specific tagged types may dispatch on result, so + -- their returned value is allocated on the secondary stack, even in the + -- definite case. We must treat nondispatching functions the same way, + -- because access-to-function types can point at both, so the calling + -- conventions must be compatible. Is_Tagged_Type includes controlled + -- types and class-wide types. Controlled type temporaries need + -- finalization. - if Old_Val = New_Val then - raise Program_Error; - end if; + -- ???It's not clear why we need to return noncontrolled types with + -- controlled components on the secondary stack. + + elsif Is_Tagged_Type (Typ) or else Has_Controlled_Component (Typ) then + return True; + + -- Untagged definite subtypes are known size. This includes all + -- elementary [sub]types. Tasks are known size even if they have + -- discriminants. So we return False here, with one exception: + -- For a type like: + -- type T (Last : Natural := 0) is + -- X : String (1 .. Last); + -- end record; + -- we return True. That's because for "P(F(...));", where F returns T, + -- we don't know the size of the result at the call site, so if we + -- allocated it on the primary stack, we would have to allocate the + -- maximum size, which is way too big. + + elsif Is_Definite_Subtype (Typ) or else Is_Task_Type (Typ) then + return Large_Max_Size_Mutable (Typ); + + -- Indefinite (discriminated) untagged record or protected type + + elsif Is_Record_Type (Typ) or else Is_Protected_Type (Typ) then + return not Caller_Known_Size_Record (Typ); + + -- Unconstrained array + + else + pragma Assert (Is_Array_Type (Typ) and not Is_Definite_Subtype (Typ)); + return True; end if; - end Results_Differ; + end Requires_Transient_Scope; -------------------------- -- Reset_Analyzed_Flags -- @@ -31238,7 +31061,7 @@ package body Sem_Util is -- -- See Large_Max_Size_Mutable function elsewhere in this -- file (currently declared inside of - -- New_Requires_Transient_Scope, so it would have to be + -- Requires_Transient_Scope, so it would have to be -- moved if we want it to be callable from here). end Indirect_Temp_Needed; -- 2.30.2