From 5a271a7f3a2983e1529ea5c7f98d6ea5d6b113cf Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Mon, 2 Mar 2015 11:03:29 +0000 Subject: [PATCH] debug.adb: Document new debug flag -gnatd.1. 2015-03-02 Robert Dewar * debug.adb: Document new debug flag -gnatd.1. * einfo.ads, einfo.adb (Has_Nested_Subprogram): New flag. (Has_Uplevel_Reference): New flag (Is_Static_Type): New flag. (Uplevel_Reference_Noted):New flag (Uplevel_References): New field. * elists.ads elists.adb (List_Length): New function. * exp_ch6.adb (Expand_N_Subprogram_Body): Call Unnest_Subprogram when appropriate (Process_Preconditions): Minor code reorganization and reformatting * exp_unst.ads, exp_unst.adb: New files. * gnat1drv.adb (Adjust_Global_Switches): Set Unnest_Subprogram_Mode if -gnatd.1 * namet.ads, namet.adb (Name_Find_Str): New version of Name_Find with string argument. * opt.ads (Unnest_Subprogram_Mode): New flag. * par-ch3.adb (P_Identifier_Declarations): Fixes to -gnatd.2 handling. * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set Has_Nested_Subprogram flag. * sem_ch8.adb (Find_Direct_Name): New calling sequence for Check_Nested_Access. (Find_Selected_Component): Minor comment addition. * sem_util.adb (Check_Nested_Access): New version for use with Exp_Unst. (Note_Possible_Modification): New calling sequence for Check_Nested_Access. * sem_util.ads (Check_Nested_Access): New version for use with Exp_Unst. * gcc-interface/Make-lang.in (GNAT1_OBJS): Add exp_unst.o From-SVN: r221109 --- gcc/ada/ChangeLog | 28 ++ gcc/ada/debug.adb | 7 +- gcc/ada/einfo.adb | 77 ++++- gcc/ada/einfo.ads | 79 ++++- gcc/ada/elists.adb | 21 +- gcc/ada/elists.ads | 5 +- gcc/ada/exp_ch6.adb | 20 +- gcc/ada/exp_unst.adb | 574 +++++++++++++++++++++++++++++++++++++ gcc/ada/exp_unst.ads | 561 ++++++++++++++++++++++++++++++++++++ gcc/ada/gcc-interface/Make-lang.in | 1 + gcc/ada/gnat1drv.adb | 6 + gcc/ada/namet.adb | 11 + gcc/ada/namet.ads | 7 +- gcc/ada/opt.ads | 4 + gcc/ada/par-ch3.adb | 32 ++- gcc/ada/sem_ch6.adb | 25 +- gcc/ada/sem_ch8.adb | 4 +- gcc/ada/sem_util.adb | 42 ++- gcc/ada/sem_util.ads | 8 +- 19 files changed, 1454 insertions(+), 58 deletions(-) create mode 100755 gcc/ada/exp_unst.adb create mode 100644 gcc/ada/exp_unst.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 97c86f3134c..0a4d3f9bf12 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,31 @@ +2015-03-02 Robert Dewar + + * debug.adb: Document new debug flag -gnatd.1. + * einfo.ads, einfo.adb (Has_Nested_Subprogram): New flag. + (Has_Uplevel_Reference): New flag (Is_Static_Type): New flag. + (Uplevel_Reference_Noted):New flag (Uplevel_References): New field. + * elists.ads elists.adb (List_Length): New function. + * exp_ch6.adb (Expand_N_Subprogram_Body): Call Unnest_Subprogram + when appropriate (Process_Preconditions): Minor code + reorganization and reformatting + * exp_unst.ads, exp_unst.adb: New files. + * gnat1drv.adb (Adjust_Global_Switches): Set + Unnest_Subprogram_Mode if -gnatd.1 + * namet.ads, namet.adb (Name_Find_Str): New version of Name_Find with + string argument. + * opt.ads (Unnest_Subprogram_Mode): New flag. + * par-ch3.adb (P_Identifier_Declarations): Fixes to -gnatd.2 handling. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): Set + Has_Nested_Subprogram flag. + * sem_ch8.adb (Find_Direct_Name): New calling sequence for + Check_Nested_Access. + (Find_Selected_Component): Minor comment addition. + * sem_util.adb (Check_Nested_Access): New version for use with Exp_Unst. + (Note_Possible_Modification): New calling sequence for + Check_Nested_Access. + * sem_util.ads (Check_Nested_Access): New version for use with Exp_Unst. + * gcc-interface/Make-lang.in (GNAT1_OBJS): Add exp_unst.o + 2015-03-02 Pierre-Marie de Rodat * gcc-interface/utils.c (gnat_pushdecl): For non-artificial pointer diff --git a/gcc/ada/debug.adb b/gcc/ada/debug.adb index 5869e964463..e04b5b55856 100644 --- a/gcc/ada/debug.adb +++ b/gcc/ada/debug.adb @@ -746,9 +746,10 @@ package body Debug is -- d9 This allows lock free implementation for protected objects -- (see Exp_Ch9). - -- d.1 Enable unnesting of nested procedures. This special pass does not - -- actually unnest things, but it ensures that a nested procedure - -- does not contain any uplevel references. + -- d.1 Sets Opt.Unnest_Subprogram_Mode to enable unnesting of subprograms. + -- This special pass does not actually unnest things, but it ensures + -- that a nested procedure does not contain any uplevel references. + -- See spec of Exp_Unst for full details. -- d.2 Allow statements within declarative parts. This is not usually -- allowed, but in some debugging contexts (e.g. testing the circuit diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb index 794ef19f3d9..c3067b825b0 100644 --- a/gcc/ada/einfo.adb +++ b/gcc/ada/einfo.adb @@ -213,6 +213,7 @@ package body Einfo is -- Stored_Constraint Elist23 -- Related_Expression Node24 + -- Uplevel_References Elist24 -- Interface_Alias Node25 -- Interfaces Elist25 @@ -505,7 +506,7 @@ package body Einfo is -- Has_Pragma_Unreferenced_Objects Flag212 -- Requires_Overriding Flag213 -- Has_RACW Flag214 - -- Has_Up_Level_Access Flag215 + -- Has_Uplevel_Reference Flag215 -- Universal_Aliasing Flag216 -- Suppress_Value_Tracking_On_Call Flag217 -- Is_Primitive Flag218 @@ -578,9 +579,10 @@ package body Einfo is -- Contains_Ignored_Ghost_Code Flag279 -- Partial_View_Has_Unknown_Discr Flag280 - -- (unused) Flag281 - -- (unused) Flag282 - -- (unused) Flag283 + -- Is_Static_Type Flag281 + -- Has_Nested_Subprogram Flag282 + -- Uplevel_Reference_Noted Flag283 + -- (unused) Flag284 -- (unused) Flag285 -- (unused) Flag286 @@ -1544,6 +1546,12 @@ package body Einfo is return Flag101 (Id); end Has_Nested_Block_With_Handler; + function Has_Nested_Subprogram (Id : E) return B is + begin + pragma Assert (Is_Subprogram (Id)); + return Flag282 (Id); + end Has_Nested_Subprogram; + function Has_Non_Standard_Rep (Id : E) return B is begin return Flag75 (Implementation_Base_Type (Id)); @@ -1786,12 +1794,10 @@ package body Einfo is return Flag72 (Id); end Has_Unknown_Discriminants; - function Has_Up_Level_Access (Id : E) return B is + function Has_Uplevel_Reference (Id : E) return B is begin - pragma Assert - (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter)); return Flag215 (Id); - end Has_Up_Level_Access; + end Has_Uplevel_Reference; function Has_Visible_Refinement (Id : E) return B is begin @@ -2376,6 +2382,12 @@ package body Einfo is return Flag60 (Id); end Is_Shared_Passive; + function Is_Static_Type (Id : E) return B is + begin + pragma Assert (Is_Type (Id)); + return Flag281 (Id); + end Is_Static_Type; + function Is_Statically_Allocated (Id : E) return B is begin return Flag28 (Id); @@ -3188,6 +3200,17 @@ package body Einfo is return Node16 (Id); end Unset_Reference; + function Uplevel_Reference_Noted (Id : E) return B is + begin + return Flag283 (Id); + end Uplevel_Reference_Noted; + + function Uplevel_References (Id : E) return L is + begin + pragma Assert (Is_Subprogram (Id)); + return Elist24 (Id); + end Uplevel_References; + function Used_As_Generic_Actual (Id : E) return B is begin return Flag222 (Id); @@ -4371,11 +4394,16 @@ package body Einfo is Set_Flag101 (Id, V); end Set_Has_Nested_Block_With_Handler; - procedure Set_Has_Up_Level_Access (Id : E; V : B := True) is + procedure Set_Has_Nested_Subprogram (Id : E; V : B := True) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Flag282 (Id, V); + end Set_Has_Nested_Subprogram; + + procedure Set_Has_Uplevel_Reference (Id : E; V : B := True) is begin - pragma Assert (Ekind_In (Id, E_Variable, E_Constant, E_Loop_Parameter)); Set_Flag215 (Id, V); - end Set_Has_Up_Level_Access; + end Set_Has_Uplevel_Reference; procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True) is begin @@ -5270,6 +5298,12 @@ package body Einfo is Set_Flag60 (Id, V); end Set_Is_Shared_Passive; + procedure Set_Is_Static_Type (Id : E; V : B := True) is + begin + pragma Assert (Is_Type (Id)); + Set_Flag281 (Id, V); + end Set_Is_Static_Type; + procedure Set_Is_Statically_Allocated (Id : E; V : B := True) is begin pragma Assert @@ -6119,6 +6153,17 @@ package body Einfo is Set_Node16 (Id, V); end Set_Unset_Reference; + procedure Set_Uplevel_Reference_Noted (Id : E; V : B := True) is + begin + Set_Flag283 (Id, V); + end Set_Uplevel_Reference_Noted; + + procedure Set_Uplevel_References (Id : E; V : L) is + begin + pragma Assert (Is_Subprogram (Id)); + Set_Elist24 (Id, V); + end Set_Uplevel_References; + procedure Set_Used_As_Generic_Actual (Id : E; V : B := True) is begin Set_Flag222 (Id, V); @@ -8517,6 +8562,7 @@ package body Einfo is W ("Has_Master_Entity", Flag21 (Id)); W ("Has_Missing_Return", Flag142 (Id)); W ("Has_Nested_Block_With_Handler", Flag101 (Id)); + W ("Has_Nested_Subprogram", Flag282 (Id)); W ("Has_Non_Standard_Rep", Flag75 (Id)); W ("Has_Out_Or_In_Out_Parameter", Flag110 (Id)); W ("Has_Object_Size_Clause", Flag172 (Id)); @@ -8561,7 +8607,7 @@ package body Einfo is W ("Has_Thunks", Flag228 (Id)); W ("Has_Unchecked_Union", Flag123 (Id)); W ("Has_Unknown_Discriminants", Flag72 (Id)); - W ("Has_Up_Level_Access", Flag215 (Id)); + W ("Has_Uplevel_Reference", Flag215 (Id)); W ("Has_Visible_Refinement", Flag263 (Id)); W ("Has_Volatile_Components", Flag87 (Id)); W ("Has_Xref_Entry", Flag182 (Id)); @@ -8662,6 +8708,7 @@ package body Einfo is W ("Is_Return_Object", Flag209 (Id)); W ("Is_Safe_To_Reevaluate", Flag249 (Id)); W ("Is_Shared_Passive", Flag60 (Id)); + W ("Is_Static_Type", Flag281 (Id)); W ("Is_Statically_Allocated", Flag28 (Id)); W ("Is_Tag", Flag78 (Id)); W ("Is_Tagged_Type", Flag55 (Id)); @@ -8728,6 +8775,7 @@ package body Einfo is W ("Suppress_Value_Tracking_On_Call", Flag217 (Id)); W ("Treat_As_Volatile", Flag41 (Id)); W ("Universal_Aliasing", Flag216 (Id)); + W ("Uplevel_Reference_Noted", Flag283 (Id)); W ("Used_As_Generic_Actual", Flag222 (Id)); W ("Uses_Sec_Stack", Flag95 (Id)); W ("Warnings_Off", Flag96 (Id)); @@ -9638,6 +9686,11 @@ package body Einfo is Type_Kind => Write_Str ("Related_Expression"); + when E_Function | + E_Operator | + E_Procedure => + Write_Str ("Uplevel_References"); + when others => Write_Str ("Field24???"); end case; diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 43ae961cc96..08b5319ece6 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -1693,7 +1693,11 @@ package Einfo is -- optimizations to ensure that they are consistent with exceptions. -- See documentation in backend for further details. --- Has_Non_Null_Refinement (synth) +-- Has_Nested_Subprogram (Flag282) +-- Defined in subprogram entities. Set for a subprogram which contains at +-- least one nested subprogram. + + -- Has_Non_Null_Refinement (synth) -- Defined in E_Abstract_State entities. True if the state has at least -- one variable or state constituent in aspect/pragma Refined_State. @@ -1987,12 +1991,15 @@ package Einfo is -- on the partial view, to insure that discriminants are properly -- inherited in certain contexts. --- Has_Up_Level_Access (Flag215) --- Defined in E_Variable and E_Constant entities. Set if the entity --- is a local variable declared in a subprogram p and is accessed in --- a subprogram nested inside p. Currently this flag is only set when --- VM_Target /= No_VM, for efficiency, since only the .NET back-end --- makes use of it to generate proper code for up-level references. +-- Has_Uplevel_Reference (Flag215) +-- Defined in all entities. Indicates that the entity is locally defined +-- within a subprogram P, and there is a reference to the entity within +-- a subprogram nested within P (at any depth). Set only for the VM case +-- (where it is set for variables, constants and loop parameters), and in +-- the case where we are unnesting nested subprograms (in which case it +-- is also set for types and subtypes which are not static types, and +-- that are referenced uplevel, as well as for subprograms that contain +-- uplevel references or call other subprogram, see Exp_unst for details. -- Has_Visible_Refinement (Flag263) -- Defined in E_Abstract_State entities. Set when a state has at least @@ -2966,6 +2973,16 @@ package Einfo is -- type is one of the standard string types (String, Wide_String, or -- Wide_Wide_String). +-- Is_Static_Type (Flag281) +-- Defined in all type and subtype entities. If set, indicates that the +-- type is known to be a static type (defined as a discrete type with +-- static bounds, a record all of whose component types are static types, +-- or an array, all of whose bounds are of a static type, and also have +-- a component type that is a static type. See Set_Uplevel_Type for more +-- information on how this flag is used. Note that if Is_Static_Type is +-- True, then it is never the case that the Has_Uplevel_Reference flag is +-- set for the same type. + -- Is_Statically_Allocated (Flag28) -- Defined in all entities. This can only be set for exception, -- variable, constant, and type/subtype entities. If the flag is set, @@ -4237,6 +4254,17 @@ package Einfo is -- is identified. This field is used to generate a warning message if -- necessary (see Sem_Warn.Check_Unset_Reference). +-- Uplevel_Reference_Noted (Flag283) +-- Defined in all entities, used in Exp_Unst processing to note that an +-- uplevel reference to the entity has been noted (to avoid processing a +-- given entity more than once). + +-- Uplevel_References (Elist24) +-- Defined in subprogram entities. Set only if Has_Uplevel_Reference is +-- set and if we are Unnest_Subprogram_Mode, otherwise undefined. Points +-- to a list of explicit uplevel references to entities declared in +-- the subprogram which need rewriting. See spec of Exp_Unst for details. + -- Used_As_Generic_Actual (Flag222) -- Defined in all entities, set if the entity is used as an argument to -- a generic instantiation. Used to tune certain warning messages. @@ -5269,6 +5297,7 @@ package Einfo is -- Suppress_Elaboration_Warnings (Flag148) -- Suppress_Style_Checks (Flag165) -- Suppress_Value_Tracking_On_Call (Flag217) + -- Uplevel_Reference_Noted (Flag283) -- Used_As_Generic_Actual (Flag222) -- Warnings_Off (Flag96) -- Warnings_Off_Used (Flag236) @@ -5339,6 +5368,7 @@ package Einfo is -- Has_Static_Predicate_Aspect (Flag259) -- Has_Task (Flag30) (base type only) -- Has_Unchecked_Union (Flag123) (base type only) + -- Has_Uplevel_Reference (Flag215) -- Has_Volatile_Components (Flag87) (base type only) -- In_Use (Flag8) -- Is_Abstract_Type (Flag146) @@ -5355,6 +5385,7 @@ package Einfo is -- Is_Non_Static_Subtype (Flag109) -- Is_Packed (Flag51) (base type only) -- Is_Private_Composite (Flag107) + -- Is_Static_Type (Flag281) -- Is_Unsigned_Type (Flag144) -- Is_Volatile (Flag16) -- Itype_Printed (Flag202) (itypes only) @@ -5555,7 +5586,7 @@ package Einfo is -- Has_Independent_Components (Flag34) -- Has_Size_Clause (Flag29) -- Has_Thunks (Flag228) (constants only) - -- Has_Up_Level_Access (Flag215) + -- Has_Uplevel_Reference (Flag215) -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) @@ -5723,6 +5754,7 @@ package Einfo is -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic case only) -- Protection_Object (Node23) (for concurrent kind) + -- Uplevel_References (Elist24) (non-generic case only) -- Interface_Alias (Node25) -- Overridden_Operation (Node26) -- Wrapped_Entity (Node27) (non-generic case only) @@ -5748,6 +5780,7 @@ package Einfo is -- Has_Master_Entity (Flag21) -- Has_Missing_Return (Flag142) -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Nested_Subprogram (Flag282) -- Has_Out_Or_In_Out_Parameter (Flag110) -- Has_Recursive_Call (Flag143) -- Is_Abstract_Subprogram (Flag19) (non-generic case only) @@ -5891,6 +5924,8 @@ package Einfo is -- Alias (Node18) -- Extra_Accessibility_Of_Result (Node19) -- Last_Entity (Node20) + -- Has_Nested_Subprogram (Flag282) + -- Uplevel_References (Elist24) -- Overridden_Operation (Node26) -- Subprograms_For_Type (Node29) -- Linker_Section_Pragma (Node33) @@ -6022,6 +6057,7 @@ package Einfo is -- Generic_Renamings (Elist23) (for an instance) -- Inner_Instances (Elist23) (generic case only) -- Protection_Object (Node23) (for concurrent kind) + -- Uplevel_References (Elist24) (non-generic case only) -- Interface_Alias (Node25) -- Overridden_Operation (Node26) (never for init proc) -- Wrapped_Entity (Node27) (non-generic case only) @@ -6046,6 +6082,7 @@ package Einfo is -- Has_Invariants (Flag232) -- Has_Master_Entity (Flag21) -- Has_Nested_Block_With_Handler (Flag101) + -- Has_Nested_Subprogram (Flag282) -- Is_Abstract_Subprogram (Flag19) (non-generic case only) -- Is_Asynchronous (Flag81) -- Is_Called (Flag102) (non-generic case only) @@ -6274,7 +6311,7 @@ package Einfo is -- Has_Independent_Components (Flag34) -- Has_Initial_Value (Flag219) -- Has_Size_Clause (Flag29) - -- Has_Up_Level_Access (Flag215) + -- Has_Uplevel_Reference (Flag215) -- Has_Volatile_Components (Flag87) -- Is_Atomic (Flag85) -- Is_Eliminated (Flag124) @@ -6676,6 +6713,7 @@ package Einfo is function Has_Master_Entity (Id : E) return B; function Has_Missing_Return (Id : E) return B; function Has_Nested_Block_With_Handler (Id : E) return B; + function Has_Nested_Subprogram (Id : E) return B; function Has_Non_Standard_Rep (Id : E) return B; function Has_Object_Size_Clause (Id : E) return B; function Has_Out_Or_In_Out_Parameter (Id : E) return B; @@ -6720,7 +6758,7 @@ package Einfo is function Has_Thunks (Id : E) return B; function Has_Unchecked_Union (Id : E) return B; function Has_Unknown_Discriminants (Id : E) return B; - function Has_Up_Level_Access (Id : E) return B; + function Has_Uplevel_Reference (Id : E) return B; function Has_Visible_Refinement (Id : E) return B; function Has_Volatile_Components (Id : E) return B; function Has_Xref_Entry (Id : E) return B; @@ -6823,6 +6861,7 @@ package Einfo is function Is_Return_Object (Id : E) return B; function Is_Safe_To_Reevaluate (Id : E) return B; function Is_Shared_Passive (Id : E) return B; + function Is_Static_Type (Id : E) return B; function Is_Statically_Allocated (Id : E) return B; function Is_Tag (Id : E) return B; function Is_Tagged_Type (Id : E) return B; @@ -6959,6 +6998,8 @@ package Einfo is function Underlying_Record_View (Id : E) return E; function Universal_Aliasing (Id : E) return B; function Unset_Reference (Id : E) return N; + function Uplevel_Reference_Noted (Id : E) return B; + function Uplevel_References (Id : E) return L; function Used_As_Generic_Actual (Id : E) return B; function Uses_Lock_Free (Id : E) return B; function Uses_Sec_Stack (Id : E) return B; @@ -7318,6 +7359,7 @@ package Einfo is procedure Set_Has_Master_Entity (Id : E; V : B := True); procedure Set_Has_Missing_Return (Id : E; V : B := True); procedure Set_Has_Nested_Block_With_Handler (Id : E; V : B := True); + procedure Set_Has_Nested_Subprogram (Id : E; V : B := True); procedure Set_Has_Non_Standard_Rep (Id : E; V : B := True); procedure Set_Has_Object_Size_Clause (Id : E; V : B := True); procedure Set_Has_Out_Or_In_Out_Parameter (Id : E; V : B := True); @@ -7362,7 +7404,7 @@ package Einfo is procedure Set_Has_Thunks (Id : E; V : B := True); procedure Set_Has_Unchecked_Union (Id : E; V : B := True); procedure Set_Has_Unknown_Discriminants (Id : E; V : B := True); - procedure Set_Has_Up_Level_Access (Id : E; V : B := True); + procedure Set_Has_Uplevel_Reference (Id : E; V : B := True); procedure Set_Has_Visible_Refinement (Id : E; V : B := True); procedure Set_Has_Volatile_Components (Id : E; V : B := True); procedure Set_Has_Xref_Entry (Id : E; V : B := True); @@ -7471,6 +7513,7 @@ package Einfo is procedure Set_Is_Return_Object (Id : E; V : B := True); procedure Set_Is_Safe_To_Reevaluate (Id : E; V : B := True); procedure Set_Is_Shared_Passive (Id : E; V : B := True); + procedure Set_Is_Static_Type (Id : E; V : B := True); procedure Set_Is_Statically_Allocated (Id : E; V : B := True); procedure Set_Is_Tag (Id : E; V : B := True); procedure Set_Is_Tagged_Type (Id : E; V : B := True); @@ -7607,6 +7650,8 @@ package Einfo is procedure Set_Underlying_Record_View (Id : E; V : E); procedure Set_Universal_Aliasing (Id : E; V : B := True); procedure Set_Unset_Reference (Id : E; V : N); + procedure Set_Uplevel_Reference_Noted (Id : E; V : B := True); + procedure Set_Uplevel_References (Id : E; V : L); procedure Set_Used_As_Generic_Actual (Id : E; V : B := True); procedure Set_Uses_Lock_Free (Id : E; V : B := True); procedure Set_Uses_Sec_Stack (Id : E; V : B := True); @@ -8076,6 +8121,7 @@ package Einfo is pragma Inline (Has_Master_Entity); pragma Inline (Has_Missing_Return); pragma Inline (Has_Nested_Block_With_Handler); + pragma Inline (Has_Nested_Subprogram); pragma Inline (Has_Non_Standard_Rep); pragma Inline (Has_Object_Size_Clause); pragma Inline (Has_Out_Or_In_Out_Parameter); @@ -8120,7 +8166,7 @@ package Einfo is pragma Inline (Has_Thunks); pragma Inline (Has_Unchecked_Union); pragma Inline (Has_Unknown_Discriminants); - pragma Inline (Has_Up_Level_Access); + pragma Inline (Has_Uplevel_Reference); pragma Inline (Has_Visible_Refinement); pragma Inline (Has_Volatile_Components); pragma Inline (Has_Xref_Entry); @@ -8266,6 +8312,7 @@ package Einfo is pragma Inline (Is_Scalar_Type); pragma Inline (Is_Shared_Passive); pragma Inline (Is_Signed_Integer_Type); + pragma Inline (Is_Static_Type); pragma Inline (Is_Statically_Allocated); pragma Inline (Is_Subprogram); pragma Inline (Is_Tag); @@ -8407,6 +8454,8 @@ package Einfo is pragma Inline (Underlying_Record_View); pragma Inline (Universal_Aliasing); pragma Inline (Unset_Reference); + pragma Inline (Uplevel_Reference_Noted); + pragma Inline (Uplevel_References); pragma Inline (Used_As_Generic_Actual); pragma Inline (Uses_Lock_Free); pragma Inline (Uses_Sec_Stack); @@ -8566,6 +8615,7 @@ package Einfo is pragma Inline (Set_Has_Master_Entity); pragma Inline (Set_Has_Missing_Return); pragma Inline (Set_Has_Nested_Block_With_Handler); + pragma Inline (Set_Has_Nested_Subprogram); pragma Inline (Set_Has_Non_Standard_Rep); pragma Inline (Set_Has_Object_Size_Clause); pragma Inline (Set_Has_Out_Or_In_Out_Parameter); @@ -8610,7 +8660,7 @@ package Einfo is pragma Inline (Set_Has_Thunks); pragma Inline (Set_Has_Unchecked_Union); pragma Inline (Set_Has_Unknown_Discriminants); - pragma Inline (Set_Has_Up_Level_Access); + pragma Inline (Set_Has_Uplevel_Reference); pragma Inline (Set_Has_Visible_Refinement); pragma Inline (Set_Has_Volatile_Components); pragma Inline (Set_Has_Xref_Entry); @@ -8718,6 +8768,7 @@ package Einfo is pragma Inline (Set_Is_Return_Object); pragma Inline (Set_Is_Safe_To_Reevaluate); pragma Inline (Set_Is_Shared_Passive); + pragma Inline (Set_Is_Static_Type); pragma Inline (Set_Is_Statically_Allocated); pragma Inline (Set_Is_Tag); pragma Inline (Set_Is_Tagged_Type); @@ -8853,6 +8904,8 @@ package Einfo is pragma Inline (Set_Underlying_Full_View); pragma Inline (Set_Underlying_Record_View); pragma Inline (Set_Universal_Aliasing); + pragma Inline (Set_Uplevel_Reference_Noted); + pragma Inline (Set_Uplevel_References); pragma Inline (Set_Unset_Reference); pragma Inline (Set_Used_As_Generic_Actual); pragma Inline (Set_Uses_Lock_Free); diff --git a/gcc/ada/elists.adb b/gcc/ada/elists.adb index fbfb9e7b46b..4d332644b74 100644 --- a/gcc/ada/elists.adb +++ b/gcc/ada/elists.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -288,6 +288,25 @@ package body Elists is return Elmts.Last; end Last_Elmt_Id; + ----------------- + -- List_Length -- + ----------------- + + function List_Length (List : Elist_Id) return Nat is + Elmt : Elmt_Id; + N : Nat; + begin + N := 0; + Elmt := First_Elmt (List); + loop + if No (Elmt) then + return N; + else + Next_Elmt (Elmt); + end if; + end loop; + end List_Length; + ---------- -- Lock -- ---------- diff --git a/gcc/ada/elists.ads b/gcc/ada/elists.ads index 3353b9cd17f..3daefc07862 100644 --- a/gcc/ada/elists.ads +++ b/gcc/ada/elists.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -107,6 +107,9 @@ package Elists is -- Obtains the last element of the given element list or, if the list has -- no items, then No_Elmt is returned. + function List_Length (List : Elist_Id) return Nat; + -- Returns number of elements in given List + function Next_Elmt (Elmt : Elmt_Id) return Elmt_Id; pragma Inline (Next_Elmt); -- This function returns the next element on an element list. The argument diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 1311615c8a7..370f3e20d44 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -42,6 +42,7 @@ with Exp_Intr; use Exp_Intr; with Exp_Pakd; use Exp_Pakd; with Exp_Prag; use Exp_Prag; with Exp_Tss; use Exp_Tss; +with Exp_Unst; use Exp_Unst; with Exp_Util; use Exp_Util; with Freeze; use Freeze; with Inline; use Inline; @@ -5339,6 +5340,16 @@ package body Exp_Ch6 is -- Set to encode entity names in package body before gigi is called Qualify_Entity_Names (N); + + -- If we are unnesting procedures, and this is an outer level procedure + -- with nested subprograms, do the unnesting operation now. + + if Opt.Unnest_Subprogram_Mode + and then Is_Library_Level_Entity (Spec_Id) + and then Has_Nested_Subprogram (Spec_Id) + then + Unnest_Subprogram (Spec_Id, N); + end if; end Expand_N_Subprogram_Body; ----------------------------------- @@ -7716,14 +7727,9 @@ package body Exp_Ch6 is if Present (Decls) then Decl := First (Decls); - while Present (Decl) loop - if Comes_From_Source (Decl) then - exit; - else - Insert_Node := Decl; - end if; - + exit when Comes_From_Source (Decl); + Insert_Node := Decl; Next (Decl); end loop; end if; diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb new file mode 100755 index 00000000000..fd15cc18926 --- /dev/null +++ b/gcc/ada/exp_unst.adb @@ -0,0 +1,574 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ U N S T -- +-- -- +-- B o d y -- +-- -- +-- Copyright (C) 2015, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +with Atree; use Atree; +with Einfo; use Einfo; +with Elists; use Elists; +with Namet; use Namet; +with Nlists; use Nlists; +with Nmake; use Nmake; +with Rtsfind; use Rtsfind; +with Sem_Aux; use Sem_Aux; +with Sem_Util; use Sem_Util; +with Sinfo; use Sinfo; +with Snames; use Snames; +with Table; +with Tbuild; use Tbuild; + +package body Exp_Unst is + + ------------------------------------- + -- Check_Uplevel_Reference_To_Type -- + ------------------------------------- + + procedure Check_Uplevel_Reference_To_Type (Typ : Entity_Id) is + function Check_Dynamic_Type (T : Entity_Id) return Boolean; + -- This is an internal recursive routine that checks if T or any of + -- its subsdidiary types are dynamic. If so, then the original Typ is + -- marked as having an uplevel reference, as is the subsidiary type in + -- question, and any referenced dynamic bounds are also marked as having + -- an uplevel reference, and True is returned. If the type is a static + -- type, then False is returned; + + ------------------------ + -- Check_Dynamic_Type -- + ------------------------ + + function Check_Dynamic_Type (T : Entity_Id) return Boolean is + DT : Boolean := False; + + begin + -- If it's a static type, nothing to do + + if Is_Static_Type (T) then + return False; + + -- If the type is uplevel referenced, then it must be dynamic + + elsif Has_Uplevel_Reference (T) then + Set_Has_Uplevel_Reference (Typ); + return True; + + -- Otherwise we need to figure out what the story is with this type + + else + DT := False; + + -- For a scalar type, check bounds + + if Is_Scalar_Type (T) then + + -- If both bounds static, then this is a static type + + declare + LB : constant Node_Id := Type_Low_Bound (T); + UB : constant Node_Id := Type_High_Bound (T); + + begin + if not Is_Static_Expression (LB) then + Set_Has_Uplevel_Reference (Entity (LB)); + DT := True; + end if; + + if not Is_Static_Expression (UB) then + Set_Has_Uplevel_Reference (Entity (UB)); + DT := True; + end if; + end; + + -- For record type, check all components + + elsif Is_Record_Type (T) then + declare + C : Entity_Id; + + begin + C := First_Component_Or_Discriminant (T); + while Present (T) loop + if Check_Dynamic_Type (C) then + DT := True; + end if; + + Next_Component_Or_Discriminant (C); + end loop; + end; + + -- For array type, check index types and component type + + elsif Is_Array_Type (T) then + declare + IX : Node_Id; + + begin + if Check_Dynamic_Type (Component_Type (T)) then + DT := True; + end if; + + IX := First_Index (T); + while Present (IX) loop + if Check_Dynamic_Type (Etype (IX)) then + DT := True; + end if; + + Next_Index (IX); + end loop; + end; + + -- For now, ignore other types + + else + return False; + end if; + + -- See if we marked that type as dynamic + + if DT then + Set_Has_Uplevel_Reference (T); + Set_Has_Uplevel_Reference (Typ); + return True; + + -- If not mark it as static + + else + Set_Is_Static_Type (T); + return False; + end if; + end if; + end Check_Dynamic_Type; + + -- Start of processing for Check_Uplevel_Reference_To_Type + + begin + -- Nothing to do if we know this is a static type + + if Is_Static_Type (Typ) then + return; + + -- Nothing to do if already marked as uplevel referenced + + elsif Has_Uplevel_Reference (Typ) then + return; + + -- Otherwise check if we have a dynamic type + + else + if Check_Dynamic_Type (Typ) then + Set_Has_Uplevel_Reference (Typ); + end if; + end if; + + null; + end Check_Uplevel_Reference_To_Type; + + ---------------------------- + -- Note_Uplevel_Reference -- + ---------------------------- + + procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id) is + begin + -- Establish list if first call for Uplevel_References + + if No (Uplevel_References (Subp)) then + Set_Uplevel_References (Subp, New_Elmt_List); + end if; + + -- Add new element to Uplevel_References + + Append_Elmt (N, Uplevel_References (Subp)); + Set_Has_Uplevel_Reference (Entity (N)); + end Note_Uplevel_Reference; + + ----------------------- + -- Unnest_Subprogram -- + ----------------------- + + -- Tables used by Unnest_Subprogram + + type Subp_Entry is record + Ent : Entity_Id; + -- Entity of the subprogram + + Bod : Node_Id; + -- Subprogram_Body node for this subprogram + + Lev : Nat; + -- Subprogram level (1 = outer subprogram (Subp argument), 2 = nested + -- immediately within this outer subprogram etc.) + end record; + + package Subps is new Table.Table ( + Table_Component_Type => Subp_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Subps"); + -- Records the subprograms in the nest whose outer subprogram is Subp + + type Call_Entry is record + N : Node_Id; + -- The actual call + + From : Entity_Id; + -- Entity of the subprogram containing the call + + To : Entity_Id; + -- Entity of the subprogram called + end record; + + package Calls is new Table.Table ( + Table_Component_Type => Call_Entry, + Table_Index_Type => Nat, + Table_Low_Bound => 1, + Table_Initial => 100, + Table_Increment => 200, + Table_Name => "Calls"); + -- Records each call within the outer subprogram and all nested subprograms + -- that are to other subprograms nested within the outer subprogram. These + -- are the calls that may need an additional parameter. + + procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is + + function Get_AREC_String (Lev : Pos) return String; + -- Given a level value, 1, 2, ... returns the string AREC, AREC2, ... + + function Get_Level (Sub : Entity_Id) return Nat; + -- Sub is either Subp itself, or a subprogram nested within Subp. This + -- function returns the level of nesting (Subp = 1, subprograms that + -- are immediately nested within Subp = 2, etc). + + --------------------- + -- Get_AREC_String -- + --------------------- + + function Get_AREC_String (Lev : Pos) return String is + begin + if Lev > 9 then + return + Get_AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48); + else + return + "AREC" & Character'Val (Lev + 48); + end if; + end Get_AREC_String; + + --------------- + -- Get_Level -- + --------------- + + function Get_Level (Sub : Entity_Id) return Nat is + Lev : Nat; + S : Entity_Id; + begin + Lev := 1; + S := Sub; + loop + if S = Subp then + return Lev; + else + S := Enclosing_Dynamic_Scope (S); + Lev := Lev + 1; + end if; + end loop; + end Get_Level; + + -- Start of processing for Unnest_Subprogram + + begin + -- First step, we must mark all nested subprograms that require a static + -- link (activation record) because either they contain explicit uplevel + -- references (as indicated by Has_Uplevel_Reference being set at this + -- point), or they make calls to other subprograms in the same nest that + -- require a static link (in which case we set this flag). + + -- This is a recursive definition, and to implement this, we have to + -- build a call graph for the set of nested subprograms, and then go + -- over this graph to implement recursively the invariant that if a + -- subprogram has a call to a subprogram requiring a static link, then + -- the calling subprogram requires a static link. + + -- First step, populate the above tables + + Subps.Init; + Calls.Init; + + Build_Tables : declare + function Visit_Node (N : Node_Id) return Traverse_Result; + -- Visit a single node in Subp + + ---------------- + -- Visit_Node -- + ---------------- + + function Visit_Node (N : Node_Id) return Traverse_Result is + Ent : Entity_Id; + + function Find_Current_Subprogram return Entity_Id; + -- Finds the current subprogram containing the call N + + ----------------------------- + -- Find_Current_Subprogram -- + ----------------------------- + + function Find_Current_Subprogram return Entity_Id is + Nod : Node_Id; + + begin + Nod := N; + loop + Nod := Parent (Nod); + + if Nkind (Nod) = N_Subprogram_Body then + if Acts_As_Spec (Nod) then + return Defining_Unit_Name (Specification (Nod)); + else + return Corresponding_Spec (Nod); + end if; + end if; + end loop; + end Find_Current_Subprogram; + + -- Start of processing for Visit_Node + + begin + if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then + Ent := Entity (Name (N)); + + if not Is_Library_Level_Entity (Ent) then + Calls.Append ((N, Find_Current_Subprogram, Ent)); + end if; + + elsif Nkind (N) = N_Subprogram_Body and then Acts_As_Spec (N) then + Ent := Defining_Unit_Name (Specification (N)); + Subps.Append + ((Ent => Ent, + Bod => N, + Lev => Get_Level (Ent))); + + elsif Nkind (N) = N_Subprogram_Declaration then + Ent := Defining_Unit_Name (Specification (N)); + Subps.Append + ((Ent => Ent, + Bod => Corresponding_Body (N), + Lev => Get_Level (Ent))); + end if; + + return OK; + end Visit_Node; + + ----------- + -- Visit -- + ----------- + + procedure Visit is new Traverse_Proc (Visit_Node); + -- Used to traverse the body of Subp, populating the tables + + begin + Visit (Subp_Body); + end Build_Tables; + + -- Second step is to do the transitive closure, if any subprogram has + -- a call to a subprogram for which Has_Uplevel_Reference is set, then + -- we set Has_Uplevel_Reference for the calling routine. + + Closure : declare + Modified : Boolean; + + begin + -- We use a simple minded algorithm as follows (obviously this can + -- be done more efficiently, using one of the standard algorithms + -- for efficient transitive closure computation, but this is simple + -- and most likely fast enough that its speed does not matter). + + -- Repeatedly scan the list of calls. Any time we find a call from + -- A to B, where A does not have Has_Uplevel_Reference, and B does + -- have this flag set, then set the flag for A, and note that we + -- have made a change by setting Modified True. We repeat this until + -- we make a pass with no modifications. + + Outer : loop + Modified := False; + Inner : for J in Calls.First .. Calls.Last loop + if not Has_Uplevel_Reference (Calls.Table (J).From) + and then Has_Uplevel_Reference (Calls.Table (J).To) + then + Set_Has_Uplevel_Reference (Calls.Table (J).From); + Modified := True; + end if; + end loop Inner; + + exit Outer when not Modified; + end loop Outer; + end Closure; + + -- Next step, process each subprogram in turn, inserting necessary + -- declarations for ARECxx types and variables for any subprogram + -- that has nested subprograms, and is uplevel referenced. + + Arec_Decls : declare + Addr : constant Entity_Id := RTE (RE_Address); + + begin + for J in Subps.First .. Subps.Last loop + declare + STJ : Subp_Entry renames Subps.Table (J); + + begin + -- We add AREC declarations for any subprogram that has at + -- least one nested subprogram, and has uplevel references. + + if Has_Nested_Subprogram (STJ.Ent) + and then Has_Uplevel_Reference (STJ.Ent) + then + Add_AREC_Declarations : declare + Loc : constant Source_Ptr := Sloc (STJ.Bod); + ARS : constant String := Get_AREC_String (STJ.Lev); + Urefs : constant Elist_Id := + Uplevel_References (STJ.Ent); + Elmt : Elmt_Id; + Ent : Entity_Id; + Clist : List_Id; + + Uplevel_Entities : + array (1 .. List_Length (Urefs)) of Entity_Id; + Num_Uplevel_Entities : Nat; + -- Uplevel_Entities (1 .. Num_Uplevel_Entities) contains + -- a list (with no duplicates) of the entities for this + -- subprogram that are referenced uplevel. The maximum + -- number of entries cannot exceed the total number of + -- uplevel references. + + begin + -- Populate the Uplevel_Entities array, using the flag + -- Uplevel_Reference_Noted to avoid duplicates. + + Num_Uplevel_Entities := 0; + Elmt := First_Elmt (Urefs); + while Present (Elmt) loop + Ent := Entity (Node (Elmt)); + + if not Uplevel_Reference_Noted (Ent) then + Set_Uplevel_Reference_Noted (Ent, True); + Num_Uplevel_Entities := Num_Uplevel_Entities + 1; + Uplevel_Entities (Num_Uplevel_Entities) := Ent; + end if; + + Next_Elmt (Elmt); + end loop; + + -- Build list of component declarations for ARECnT + + Clist := Empty_List; + + -- If not top level, include ARECn : ARECnPT := ARECnP + + if STJ.Lev > 1 then + Append_To (Clist, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Name_Find_Str (ARS)), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + Make_Identifier (Loc, + Chars => Name_Find_Str (ARS & "PT"))), + Expression => + Make_Identifier (Loc, + Chars => Name_Find_Str (ARS & "P")))); + end if; + + -- Add components for uplevel referenced entities + + for J in 1 .. Num_Uplevel_Entities loop + Append_To (Clist, + Make_Component_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Chars (Uplevel_Entities (J))), + Component_Definition => + Make_Component_Definition (Loc, + Subtype_Indication => + New_Occurrence_Of (Addr, Loc)))); + end loop; + + -- Now we can insert the AREC declarations into the body + + Prepend_List_To (Declarations (STJ.Bod), + New_List ( + + -- type ARECT is record .. end record; + + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Name_Find_Str (ARS & "T")), + Type_Definition => + Make_Record_Definition (Loc, + Component_List => + Make_Component_List (Loc, + Component_Items => Clist))), + + -- type ARECPT is access all ARECT; + + Make_Full_Type_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Name_Find_Str (ARS & "PT")), + Type_Definition => + Make_Access_To_Object_Definition (Loc, + All_Present => True, + Subtype_Indication => + Make_Identifier (Loc, + Chars => Name_Find_Str (ARS & "T")))), + + -- ARECP : constant ARECPT := AREC'Access; + + Make_Object_Declaration (Loc, + Defining_Identifier => + Make_Defining_Identifier (Loc, + Chars => Name_Find_Str (ARS & "P")), + Constant_Present => True, + Object_Definition => + Make_Identifier (Loc, Name_Find_Str (ARS & "PT")), + Expression => + Make_Attribute_Reference (Loc, + Prefix => + Make_Identifier (Loc, Name_Find_Str (ARS)), + Attribute_Name => Name_Access)))); + end Add_AREC_Declarations; + end if; + end; + end loop; + end Arec_Decls; + + -- Next step, for each uplevel referenced entity, add assignment + -- operations to set the corresponding AREC fields, and define + -- the PTR types. + + return; + end Unnest_Subprogram; + +end Exp_Unst; diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads new file mode 100644 index 00000000000..9e48a66d57f --- /dev/null +++ b/gcc/ada/exp_unst.ads @@ -0,0 +1,561 @@ +------------------------------------------------------------------------------ +-- -- +-- GNAT COMPILER COMPONENTS -- +-- -- +-- E X P _ U N S T -- +-- -- +-- S p e c -- +-- -- +-- Copyright (C) 2015, Free Software Foundation, Inc. -- +-- -- +-- GNAT is free software; you can redistribute it and/or modify it under -- +-- terms of the GNU General Public License as published by the Free Soft- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- +-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- +-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- +-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- +-- for more details. You should have received a copy of the GNU General -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- +-- -- +-- GNAT was originally developed by the GNAT team at New York University. -- +-- Extensive contributions were provided by Ada Core Technologies Inc. -- +-- -- +------------------------------------------------------------------------------ + +-- Expand routines for unnesting subprograms + +with Types; use Types; + +package Exp_Unst is + + -- ----------------- + -- -- The Problem -- + -- ----------------- + + -- Normally, nested subprograms in the source result in corresponding + -- nested subprograms in the resulting tree. We then expect the back end + -- to handle such nested subprograms, including all cases of uplevel + -- references. For example, the GCC back end can do this relatively easily + -- since GNU C (as an extension) allows nested functions with uplevel + -- references, and implements an appropriate static chain approach to + -- dealing with such uplevel references. + + -- However, we also want to be able to interface with back ends that do + -- not easily handle such uplevel references. One example is the back end + -- that translates the tree into standard C source code. In the future, + -- other back ends might need the same capability (e.g. a back end that + -- generated LLVM intermediate code). + + -- We could imagine simply handling such references in the appropriate + -- back end. For example the back end that generates C could recognize + -- nested subprograms and rig up some way of translating them, e.g. by + -- making a static-link source level visible. + + -- Rather than take that approach, we prefer to do a semantics-preserving + -- transformation on the GNAT tree, that eliminates the problem before we + -- hand the tree over to the back end. There are two reasons for preferring + -- this approach: + + -- First: the work needs only to be done once for all affected back ends + -- and we can remain within the semantics of the tree. The front end is + -- full of tree transformations, so we have all the infrastructure for + -- doing transformations of this type. + + -- Second: given that the transformation will be semantics-preserving, + -- we can still used the standard GCC back end to build code from it. + -- This means we can easily run our full test suite to verify that the + -- transformations are indeed semantics preserving. It is a lot more + -- work to thoroughly test the output of specialized back ends. + + -- Looking at the problem, we have three situations to deal with. Note + -- that in these examples, we use all lower case, since that is the way + -- the internal tree is cased. + + -- First, cases where there are no uplevel references, for example + + -- procedure case1 is + -- function max (m, n : Integer) return integer is + -- begin + -- return integer'max (m, n); + -- end max; + -- ... + -- end case1; + + -- Second, cases where there are explicit uplevel references. + + -- procedure case2 (b : integer) is + -- procedure Inner (bb : integer); + -- + -- procedure inner2 is + -- begin + -- inner(5); + -- end; + -- + -- x : integer := 77; + -- y : constant integer := 15 * 16; + -- rv : integer := 10; + -- + -- procedure inner (bb : integer) is + -- begin + -- x := rv + y + bb + b; + -- end; + -- + -- begin + -- inner2; + -- end case2; + + -- In this second example, B, X, RV are uplevel referenced. Y is not + -- considered as an uplevel reference since it is a static constant + -- where references are replaced by the value at compile time. + + -- Third, cases where there are implicit uplevel references via types + -- whose bounds depend on locally declared constants or variables: + + -- function case3 (x, y : integer) return boolean is + -- subtype dynam is integer range x .. y + 3; + -- subtype static is integer range 42 .. 73; + -- xx : dynam := y; + -- + -- type darr is array (dynam) of Integer; + -- type darec is record + -- A : darr; + -- B : integer; + -- end record; + -- darecv : darec; + -- + -- function inner (b : integer) return boolean is + -- begin + -- return b in dynam and then darecv.b in static; + -- end inner; + -- + -- begin + -- return inner (42) and then inner (xx * 3 - y * 2); + -- end case3; + -- + -- In this third example, the membership test implicitly references the + -- the bounds of Dynam, which both involve uplevel references. + + -- ------------------ + -- -- The Solution -- + -- ------------------ + + -- Looking at the three cases above, the first case poses no problem at + -- all. Indeed the subprogram could have been declared at the outer level + -- (perhaps changing the name). But this style is quite common as a way + -- of limiting the scope of a local procedure called only within the outer + -- procedure. We could move it to the outer level (with a name change if + -- needed), but we don't bother. We leave it nested, and the back end just + -- translates it as though it were not nested. + + -- In general we leave nested procedures nested, rather than trying to move + -- them to the outer level (the back end may do that, e.g. as part of the + -- translation to C, but we don't do it in the tree itself). This saves a + -- LOT of trouble in terms of visibility and semantics. + + -- But of course we have to deal with the uplevel references. The idea is + -- to rewrite these nested subprograms so that they no longer have any such + -- uplevel references, so by the time they reach the back end, they all are + -- case 1 (no uplevel references) and thus easily handled. + + -- To deal with explicit uplevel references (case 2 above), we proceed with + -- the following steps: + + -- All entities marked as being uplevel referenced are marked as aliased + -- since they will be accessed indirectly via an activation record as + -- described below. + + -- For each such entity xxx we create an access type xxxPTR (forced to + -- single length in the unconstrained case). + + -- An activation record is created containing system address values + -- for each uplevel referenced entity in a given scope. In the example + -- given before, we would have: + + -- type AREC1T is record + -- b : Address; + -- x : Address; + -- rv : Address; + -- end record; + -- type AREC1P is access all AREC1T; + -- AREC1 : AREC1T; + + -- The fields of AREC1 are set at the point the corresponding entity + -- is declared (immediately for parameters). + + -- Note: the 1 in all these names represents the fact that we are at the + -- outer level of nesting. As we will see later, deeper levels of nesting + -- will use AREC2, AREC3, ... + + -- For all subprograms nested immediately within the corresponding scope, + -- a parameter AREC1P is passed, and all calls to these routines have + -- AREC1 added as an additional formal. + + -- Now within the nested procedures, any reference to an uplevel entity + -- xxx is replaced by Tnn!(AREC1.xxx).all (where ! represents a call + -- to unchecked conversion to convert the address to the access type + -- and Tnn is a locally declared type that is "access all t", where t + -- is the type of the reference. + + -- Note: the reason that we use Address as the component type in the + -- declaration of AREC1T is that we may create this type before we see + -- the declaration of this type. + + -- The following shows example 2 above after this translation: + + -- procedure case2x (b : aliased Integer) is + -- type AREC1T is record + -- b : Address; + -- x : Address; + -- rv : Address; + -- end record; + -- + -- AREC1 : aliased AREC1T; + -- type AREC1PT is access all AREC1T; + -- AREC1P : constant AREC1PT := AREC1'Access; + -- + -- AREC1.b := b'Address; + -- + -- procedure inner (bb : integer; AREC1P : AREC1PT); + -- + -- procedure inner2 (AREC1P : AREC1PT) is + -- begin + -- inner(5, AREC1P); + -- end; + -- + -- x : aliased integer := 77; + -- AREC1.x := X'Address; + -- + -- y : constant Integer := 15 * 16; + -- + -- rv : aliased Integer; + -- AREC1.rv := rv'Address; + -- + -- procedure inner (bb : integer; AREC1P : AREC1PT) is + -- begin + -- type Tnn1 is access all Integer; + -- type Tnn2 is access all Integer; + -- type Tnn3 is access all Integer; + -- Tnn1!(AREC1P.x).all := + -- Tnn2!(AREC1P.rv).all + y + b + Tnn3!(AREC1P.b).all; + -- end; + -- + -- begin + -- inner2 (AREC1P); + -- end case2x; + + -- And now the inner procedures INNER2 and INNER have no uplevel references + -- so they have been reduced to case 1, which is the case easily handled by + -- the back end. Note that the generated code is not strictly legal Ada + -- because of the assignments to AREC1 in the declarative sequence, but the + -- GNAT tree always allows such mixing of declarations and statements, so + -- the back end must be prepared to handle this in any case. + + -- Case 3 where we have uplevel references to types is a bit more complex. + -- That would especially be the case if we did a full transformation that + -- completely eliminated such uplevel references as we did for case 2. But + -- instead of trying to do that, we rewrite the subprogram so that the code + -- generator can easily detect and deal with these uplevel type references. + + -- First we distinguish two cases + + -- Static types are one of the two following cases: + + -- Discrete types whose bounds are known at compile time. This is not + -- quite the same as what is tested by Is_OK_Static_Subtype, in that + -- it allows compile time known values that are not static expressions. + + -- Composite types, whose components are (recursively) static types. + + -- Dynamic types are one of the two following cases: + + -- Discrete types with at least one bound not known at compile time. + + -- Composite types with at least one component that is (recursively) + -- a dynamic type. + + -- Uplevel references to static types are not a problem, the front end + -- or the code generator fetches the bounds as required, and since they + -- are compile time known values, this value can just be extracted and + -- no actual uplevel reference is required. + + -- Uplevel references to dynamic types are a potential problem, since + -- such references may involve an implicit access to a dynamic bound, + -- and this reference is an implicit uplevel access. + + -- To fully unnest such references would be messy, since we would have + -- to create local copies of the dynamic types involved, so that the + -- front end or code generator could generate an explicit uplevel + -- reference to the bound involved. Rather than do that, we set things + -- up so that this situation can be easily detected and dealt with when + -- there is an implicit reference to the bounds. + + -- What we do is to always generate a local constant for any dynamic + -- bound in a dynamic subtype xx with name xx_FIRST or xx_LAST. The one + -- case where we can skip this is where the bound is For + -- example in the third example above, subtype dynam is expanded as + + -- dynam_LAST : constant Integer := y + 3; + -- subtype dynam is integer range x .. dynam_LAST; + + -- Now if type dynam is uplevel referenced (as it is this case), then + -- the bounds x and dynam_LAST are marked as uplevel references + -- so that appropriate entries are made in the activation record. Any + -- explicit reference to such a bound in the front end generated code + -- will be handled by the normal uplevel reference mechanism which we + -- described above for case 2. For implicit references by a back end + -- that needs to unnest things, any such implicit reference to one of + -- these bounds can be replaced by an appropriate reference to the entry + -- in the activation record for xx_FIRST or xx_LAST. Thus the back end + -- can eliminate the problematical uplevel reference without the need to + -- do the heavy tree modification to do that at the code expansion level + + -- Looking at case 3 again, here is the normal -gnatG expanded code + + -- function case3 (x : integer; y : integer) return boolean is + -- dynam_LAST : constant integer := y {+} 3; + -- subtype dynam is integer range x .. dynam_LAST; + -- subtype static is integer range 42 .. 73; + -- + -- [constraint_error when + -- not (y in x .. dynam_LAST) + -- "range check failed"] + -- + -- xx : dynam := y; + -- + -- type darr is array (x .. dynam_LAST) of integer; + -- type darec is record + -- a : darr; + -- b : integer; + -- end record; + -- [type TdarrB is array (x .. dynam_LAST range <>) of integer] + -- freeze TdarrB [] + -- darecv : darec; + -- + -- function inner (b : integer) return boolean is + -- begin + -- return b in x .. dynam_LAST and then darecv.b in 42 .. 73; + -- end inner; + -- begin + -- return inner (42) and then inner (xx {*} 3 {-} y {*} 2); + -- end case3; + + -- Note: the actual expanded code has fully qualified names so for + -- example function inner is actually function case3__inner. For now + -- we ignore that detail to clarify the examples. + + -- Here we see that some of the bounds references are expanded by the + -- front end, so that we get explicit references to y or dynamLast. These + -- cases are handled by the normal uplevel reference mechanism described + -- above for case 2. This is the case for the constraint check for the + -- initialization of xx, and the range check in function inner. + + -- But the reference darecv.b in the return statement of function + -- inner has an implicit reference to the bounds of dynam, since to + -- compute the location of b in the record, we need the length of a. + + -- Here is the full translation of the third example: + + -- function case3x (x, y : integer) return boolean is + -- type AREC1T is record + -- x : Address; + -- dynam_LAST : Address; + -- end record; + -- + -- AREC1 : aliased AREC1T; + -- type AREC1PT is access all AREC1T; + -- AREC1P : constant AREC1PT := AREC1'Access; + -- + -- AREC1.x := x'Address; + -- + -- dynam_LAST : constant integer := y {+} 3; + -- AREC1.dynam_LAST := dynam_LAST'Address; + -- subtype dynam is integer range x .. dynam_LAST; + -- xx : dynam := y; + -- + -- [constraint_error when + -- not (y in x .. dynam_LAST) + -- "range check failed"] + -- + -- subtype static is integer range 42 .. 73; + -- + -- type darr is array (x .. dynam_LAST) of Integer; + -- type darec is record + -- A : darr; + -- B : integer; + -- end record; + -- darecv : darec; + -- + -- function inner (b : integer; AREC1P : AREC1PT) return boolean is + -- begin + -- type Tnn is access all Integer + -- return b in x .. Tnn!(AREC1P.dynam_LAST).all + -- and then darecv.b in 42 .. 73; + -- end inner; + -- + -- begin + -- return inner (42, AREC1P) and then inner (xx * 3, AREC1P); + -- end case3x; + + -- And now the back end when it processes darecv.b will access the bounds + -- of darecv.a by referencing the d and dynam_LAST fields of AREC1P. + + ----------------------------- + -- Multiple Nesting Levels -- + ----------------------------- + + -- In our examples so far, we have only nested to a single level, but the + -- scheme generalizes to multiple levels of nesting and in this section we + -- discuss how this generalization works. + + -- Consider this example with two nesting levels + + -- To deal with elimination of uplevel references, we follow the same basic + -- approach described above for case 2, except that we need an activation + -- record at each nested level. Basically the rule is that any procedure + -- that has nested procedures needs an activation record. When we do this, + -- the inner activation records have a pointer to the immediately enclosing + -- activation record, the normal arrangement of static links. The following + -- shows the full translation of this fourth case. + + -- function case4x (x : integer) return integer is + -- type AREC1T is record + -- v1 : Address; + -- end record; + -- + -- AREC1 : aliased AREC1T; + -- type AREC1PT is access all AREC1T; + -- AREC1P : constant AREC1PT := AREC1'Access; + -- + -- v1 : integer := x; + -- AREC1.v1 := v1'Address; + -- + -- function inner1 (y : integer; AREC1P : ARECPT) return integer is + -- type AREC2T is record + -- AREC1 : AREC1PT := AREC1P; + -- v2 : Address; + -- end record; + -- + -- AREC2 : aliased AREC2T; + -- type AREC2PT is access all AREC2T; + -- AREC2P : constant AREC2PT := AREC2'Access; + -- + -- type Tnn1 is access all Integer; + -- v2 : integer := Tnn1!(AREC1P.v1).all {+} 1; + -- AREC2.v2 := v2'Address; + -- + -- function inner2 + -- (z : integer; AREC2P : AREC2PT) return integer + -- is + -- begin + -- type Tnn1 is access all Integer; + -- type Tnn2 is access all Integer; + -- return integer(z {+} + -- Tnn1!(AREC2P.AREC1.v1).all {+} + -- Tnn2!(AREC2P.v2).all); + -- end inner2; + -- begin + -- type Tnn is access all Integer; + -- return integer(y {+} inner2 (Tnn!(AREC1P.v1).all, AREC2P)); + -- end inner1; + -- begin + -- return inner1 (x, AREC1P); + -- end case4x; + + -- As can be seen in this example, the level number following AREC in the + -- names avoids any confusion between AREC names at different levels. + + ------------------------- + -- Name Disambiguation -- + ------------------------- + + -- As described above, the translation scheme would raise issues when the + -- code generator did the actual unnesting if identically named nested + -- subprograms exist. Similarly overloading would cause a naming issue. + + -- In fact, the expanded code includes qualified names which eliminate this + -- problem. We omitted the qualification from the exapnded examples above + -- for simplicity. But to see this in action, consider this example: + + -- function Mnames return Boolean is + -- procedure Inner is + -- procedure Inner is + -- begin + -- null; + -- end; + -- begin + -- Inner; + -- end; + -- function F (A : Boolean) return Boolean is + -- begin + -- return not A; + -- end; + -- function F (A : Integer) return Boolean is + -- begin + -- return A > 42; + -- end; + -- begin + -- Inner; + -- return F (42) or F (True); + -- end; + + -- The expanded code actually looks like: + + -- function mnames return boolean is + -- procedure mnames__inner is + -- procedure mnames__inner__inner is + -- begin + -- null; + -- return; + -- end mnames__inner__inner; + -- begin + -- mnames__inner__inner; + -- return; + -- end mnames__inner; + -- function mnames__f (a : boolean) return boolean is + -- begin + -- return not a; + -- end mnames__f; + -- function mnames__f__2 (a : integer) return boolean is + -- begin + -- return a > 42; + -- end mnames__f__2; + -- begin + -- mnames__inner; + -- return mnames__f__2 (42) or mnames__f (true); + -- end mnames; + + -- As can be seen from studying this example, the qualification deals both + -- with the issue of clashing names (mnames__inner, mnames__inner__inner), + -- and with overloading (mnames__f, mnames__f__2). + + ----------------- + -- Subprograms -- + ----------------- + + procedure Check_Uplevel_Reference_To_Type (Typ : Entity_Id); + -- This procedure is called if Sem_Util.Check_Nested_Access detects an + -- uplevel reference to a type or subtype entity Typ. On return there are + -- two cases, if Typ is a static type (defined as a discrete type with + -- static bounds, or a record all of whose components are of a static type, + -- or an array whose index and component types are all static types), then + -- the flag Is_Static_Type (Typ) will be set True, and in this case the + -- flag Has_Uplevel_Reference is not set since we don't need to worry about + -- uplevel references to static types. If on the other hand Typ is not a + -- static type, then the flag Has_Uplevel_Reference will be set, and any + -- non-static bounds referenced by the type will also be marked as having + -- uplevel references (by setting Has_Uplevel_Reference for these bounds). + + procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id); + -- Called in Unnest_Subprogram_Mode when we detect an explicit uplevel + -- reference (node N) to an enclosing subprogram Subp. + + procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id); + -- Subp is a library level subprogram which has nested subprograms, and + -- Subp_Body is the corresponding N_Subprogram_Body node. This procedure + -- declares the AREC types and objects, adds assignments to the AREC record + -- as required, defines the xxxPTR types for uplevel referenced objects, + -- adds the ARECP parameter to all nested subprograms which need it, and + -- modifies all uplevel references appropriately. + +end Exp_Unst; diff --git a/gcc/ada/gcc-interface/Make-lang.in b/gcc/ada/gcc-interface/Make-lang.in index 4696203ddaf..80d0a4e7b1f 100644 --- a/gcc/ada/gcc-interface/Make-lang.in +++ b/gcc/ada/gcc-interface/Make-lang.in @@ -282,6 +282,7 @@ GNAT_ADA_OBJS = \ ada/exp_smem.o \ ada/exp_strm.o \ ada/exp_tss.o \ + ada/exp_unst.o \ ada/exp_util.o \ ada/expander.o \ ada/fmap.o \ diff --git a/gcc/ada/gnat1drv.adb b/gcc/ada/gnat1drv.adb index f210fcbb289..83979d7d058 100644 --- a/gcc/ada/gnat1drv.adb +++ b/gcc/ada/gnat1drv.adb @@ -130,6 +130,12 @@ procedure Gnat1drv is Relaxed_RM_Semantics := True; end if; + -- -gnatd.1 enables unnesting of subprograms + + if Debug_Flag_Dot_1 then + Unnest_Subprogram_Mode := True; + end if; + -- -gnatd.V or -gnatd.u enables special C expansion mode if Debug_Flag_Dot_VV or Debug_Flag_Dot_U then diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 9de0feca058..6def9f273b7 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -1104,6 +1104,17 @@ package body Namet is end if; end Name_Find; + ------------------- + -- Name_Find_Str -- + ------------------- + + function Name_Find_Str (S : String) return Name_Id is + begin + Name_Len := S'Length; + Name_Buffer (1 .. Name_Len) := S; + return Name_Find; + end Name_Find_Str; + ------------- -- Nam_In -- ------------- diff --git a/gcc/ada/namet.ads b/gcc/ada/namet.ads index 6074575070c..2e2e95daa95 100644 --- a/gcc/ada/namet.ads +++ b/gcc/ada/namet.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -422,6 +422,11 @@ package Namet is -- not modified by this call. Note that it is permissible for Name_Len to -- be set to zero to lookup the null name string. + function Name_Find_Str (S : String) return Name_Id; + -- Similar to Name_Find, except that the string is provided as an argument. + -- This call destroys the contents of Name_Buffer and Name_Len (by storing + -- the given string there. + function Name_Enter return Name_Id; -- Name_Enter has the same calling interface as Name_Find. The difference -- is that it does not search the table for an existing match, and also diff --git a/gcc/ada/opt.ads b/gcc/ada/opt.ads index 499cc15b94c..7fd019a86f8 100644 --- a/gcc/ada/opt.ads +++ b/gcc/ada/opt.ads @@ -1533,6 +1533,10 @@ package Opt is -- Indicates if error messages are to be prefixed by the string error: -- Initialized from Tag_Errors, can be forced on with the -gnatU switch. + Unnest_Subprogram_Mode : Boolean := False; + -- If true, activates the circuitry for unnesting subprograms (see the spec + -- of Exp_Unst for full details). Currently set only by use of -gnatd.1. + Universal_Addressing_On_AAMP : Boolean := False; -- GNAAMP -- Indicates if library-level objects should be accessed and updated using diff --git a/gcc/ada/par-ch3.adb b/gcc/ada/par-ch3.adb index 4a393bdd6ae..0be12177513 100644 --- a/gcc/ada/par-ch3.adb +++ b/gcc/ada/par-ch3.adb @@ -1514,14 +1514,34 @@ package body Ch3 is return; -- Otherwise we definitely have an ordinary identifier with a junk - -- token after it. Just complain that we expect a declaration, and - -- skip to a semicolon + -- token after it. else - Set_Declaration_Expected; - Resync_Past_Semicolon; - Done := False; - return; + -- If in -gnatd.2 mode, try for statements + + if Debug_Flag_Dot_2 then + Restore_Scan_State (Scan_State); + + -- Reset Token_Node, because it already got changed from an + -- Identifier to a Defining_Identifier, and we don't want that + -- for a statement! + + Token_Node := + Make_Identifier (Sloc (Token_Node), Chars (Token_Node)); + + -- And now scan out one or more statements + + Statement_When_Declaration_Expected (Decls, Done, In_Spec); + return; + + -- Normal case, just complain and skip to semicolon + + else + Set_Declaration_Expected; + Resync_Past_Semicolon; + Done := False; + return; + end if; end if; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 9ac8a6ba18b..dccecc34be0 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -3223,8 +3223,7 @@ package body Sem_Ch6 is -- We make two copies of the given spec, one for the new -- declaration, and one for the body. - if No (Spec_Id) - and then GNATprove_Mode + if No (Spec_Id) and then GNATprove_Mode -- Inlining does not apply during pre-analysis of code @@ -4157,6 +4156,28 @@ package body Sem_Ch6 is Check_References (Body_Id); end; + + -- Check for nested subprogram, and mark outer level subprogram if so + + declare + Ent : Entity_Id; + + begin + if Present (Spec_Id) then + Ent := Spec_Id; + else + Ent := Body_Id; + end if; + + loop + Ent := Enclosing_Subprogram (Ent); + exit when No (Ent) or else Is_Subprogram (Ent); + end loop; + + if Present (Ent) then + Set_Has_Nested_Subprogram (Ent); + end if; + end; end Analyze_Subprogram_Body_Helper; --------------------------------- diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index 3e7d5ab70a7..5695033171d 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -5623,7 +5623,7 @@ package body Sem_Ch8 is end if; end if; - Check_Nested_Access (E); + Check_Nested_Access (N, E); end if; Set_Entity_Or_Discriminal (N, E); @@ -6593,6 +6593,8 @@ package body Sem_Ch8 is and then (not Is_Entity_Name (P) or else Chars (Entity (P)) /= Name_uInit) then + -- Check if we already have an available subtype we can use + if Ekind (Etype (P)) = E_Record_Subtype and then Nkind (Parent (Etype (P))) = N_Subtype_Declaration and then Is_Array_Type (Etype (Selector)) diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 2ea04d700b9..ee5db001761 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -32,6 +32,7 @@ with Elists; use Elists; with Errout; use Errout; with Exp_Ch11; use Exp_Ch11; with Exp_Disp; use Exp_Disp; +with Exp_Unst; use Exp_Unst; with Exp_Util; use Exp_Util; with Fname; use Fname; with Freeze; use Freeze; @@ -2863,23 +2864,37 @@ package body Sem_Util is -- Check_Nested_Access -- ------------------------- - procedure Check_Nested_Access (Ent : Entity_Id) is + procedure Check_Nested_Access (N : Node_Id; Ent : Entity_Id) is Scop : constant Entity_Id := Current_Scope; Current_Subp : Entity_Id; Enclosing : Entity_Id; begin -- Currently only enabled for VM back-ends for efficiency, should we - -- enable it more systematically ??? + -- enable it more systematically? Probably not unless someone actually + -- needs it. It will be needed for C generation and is activated if the + -- Opt.Unnest_Subprogram_Mode flag is set True. - -- Check for Is_Imported needs commenting below ??? - - if VM_Target /= No_VM - and then Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter) + if (VM_Target /= No_VM or else Unnest_Subprogram_Mode) and then Scope (Ent) /= Empty and then not Is_Library_Level_Entity (Ent) + + -- Comment the exclusion of imported entities ??? + and then not Is_Imported (Ent) then + -- For VM case, we are only interested in variables, constants, + -- and loop parameters. For general nested procedure usage, we + -- allow types as well. + + if Ekind_In (Ent, E_Variable, E_Constant, E_Loop_Parameter) then + null; + elsif not (Unnest_Subprogram_Mode and then Is_Type (Ent)) then + return; + end if; + + -- Get current subprogram that is relevant + if Is_Subprogram (Scop) or else Is_Generic_Subprogram (Scop) or else Is_Entry (Scop) @@ -2891,8 +2906,19 @@ package body Sem_Util is Enclosing := Enclosing_Subprogram (Ent); + -- Set flag if uplevel reference + if Enclosing /= Empty and then Enclosing /= Current_Subp then - Set_Has_Up_Level_Access (Ent, True); + if Is_Type (Ent) then + Check_Uplevel_Reference_To_Type (Ent); + else + Set_Has_Uplevel_Reference (Ent, True); + + if Unnest_Subprogram_Mode then + Set_Has_Uplevel_Reference (Current_Subp, True); + Note_Uplevel_Reference (N, Enclosing); + end if; + end if; end if; end if; end Check_Nested_Access; @@ -15168,7 +15194,7 @@ package body Sem_Util is end if; end if; - Check_Nested_Access (Ent); + Check_Nested_Access (N, Ent); end if; Kill_Checks (Ent); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e0781ab9372..ca31b297e0e 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -308,10 +308,12 @@ package Sem_Util is -- remains in the Examiner (JB01-005). Note that the Examiner does not -- count package declarations in later declarative items. - procedure Check_Nested_Access (Ent : Entity_Id); + procedure Check_Nested_Access (N : Node_Id; Ent : Entity_Id); -- Check whether Ent denotes an entity declared in an uplevel scope, which - -- is accessed inside a nested procedure, and set Has_Up_Level_Access flag - -- accordingly. This is currently only enabled for VM_Target /= No_VM. + -- is accessed inside a nested procedure, and set the Has_Uplevel_Reference + -- flag accordingly. This is currently only enabled for if on a VM target, + -- or if Opt.Unnest_Subprogram_Mode is active. N is the node for the + -- possible uplevel reference. procedure Check_No_Hidden_State (Id : Entity_Id); -- Determine whether object or state Id introduces a hidden state. If this -- 2.11.4.GIT