From: Arnaud Charlet Date: Fri, 22 May 2015 13:01:37 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=ee93527368e112d1f2a9b0e739fc513eff3e048e;p=gcc.git [multiple changes] 2015-05-22 Robert Dewar * einfo.ads: Minor comment updates. * exp_unst.adb: Move Subps table to spec Don't remove old entries from table Add Last field to record last entry used. * exp_unst.ads: Move Subps table here from body So that Cprint can access saved values. 2015-05-22 Bob Duff * a-cdlili.adb, a-cdlili.ads, a-cohama.adb, a-cohama.ads, * a-cohase.adb, a-cohase.ads, a-convec.adb, a-convec.ads, * a-coorma.adb, a-coorma.ads, a-coorse.adb, a-coorse.ads: (Pseudo_Reference, Element_Access, Get_Element_Access): New declarations added for use by performance improvements in exp_ch5.adb. * snames.ads-tmpl: New names referenced by exp_ch5.adb. * exp_ch5.adb: Speed up "for ... of" loops for predefined containers. Instead of doing literally what the RM calls for, we do something equivalent that avoids expensive operations inside the loop. If the container package has appropriate Next, Pseudo_Reference, Element_Access, Get_Element_Access declarations, we invoke the optimization. * snames.ads-tmpl: Note speed improvement. From-SVN: r223563 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index fe2dbad0f34..863e3d9d26e 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,27 @@ +2015-05-22 Robert Dewar + + * einfo.ads: Minor comment updates. + * exp_unst.adb: Move Subps table to spec Don't remove old entries + from table Add Last field to record last entry used. + * exp_unst.ads: Move Subps table here from body So that Cprint + can access saved values. + +2015-05-22 Bob Duff + + * a-cdlili.adb, a-cdlili.ads, a-cohama.adb, a-cohama.ads, + * a-cohase.adb, a-cohase.ads, a-convec.adb, a-convec.ads, + * a-coorma.adb, a-coorma.ads, a-coorse.adb, a-coorse.ads: + (Pseudo_Reference, Element_Access, Get_Element_Access): New + declarations added for use by performance improvements in exp_ch5.adb. + * snames.ads-tmpl: New names referenced by exp_ch5.adb. + * exp_ch5.adb: Speed up "for ... of" loops for predefined containers. + Instead of doing literally what the RM calls for, we do something + equivalent that avoids expensive operations inside the loop. If the + container package has appropriate Next, Pseudo_Reference, + Element_Access, Get_Element_Access declarations, we invoke the + optimization. + * snames.ads-tmpl: Note speed improvement. + 2015-05-22 Eric Botcazou * einfo.ads (Is_Atomic_Or_VFA): Move to XEINFO INLINES section. diff --git a/gcc/ada/a-cdlili.adb b/gcc/ada/a-cdlili.adb index 02a4c3903ea..e003cfc7c3d 100644 --- a/gcc/ada/a-cdlili.adb +++ b/gcc/ada/a-cdlili.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -923,6 +923,16 @@ package body Ada.Containers.Doubly_Linked_Lists is end Generic_Sorting; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1384,6 +1394,25 @@ package body Ada.Containers.Doubly_Linked_Lists is end if; end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type + is + C : constant List_Access := Container'Unrestricted_Access; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Control_Type := + (Controlled with C) + do + B := B + 1; + L := L + 1; + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- diff --git a/gcc/ada/a-cdlili.ads b/gcc/ada/a-cdlili.ads index 7740566af6d..35aaf9f6099 100644 --- a/gcc/ada/a-cdlili.ads +++ b/gcc/ada/a-cdlili.ads @@ -362,6 +362,24 @@ private for Reference_Type'Read use Read; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased List'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_List : constant List := (Controlled with null, null, 0, 0, 0); No_Element : constant Cursor := Cursor'(null, null); diff --git a/gcc/ada/a-cohama.adb b/gcc/ada/a-cohama.adb index ba6b998ba12..6fe9bfd576b 100644 --- a/gcc/ada/a-cohama.adb +++ b/gcc/ada/a-cohama.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -555,6 +555,16 @@ package body Ada.Containers.Hashed_Maps is end if; end Free; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -858,6 +868,25 @@ package body Ada.Containers.Hashed_Maps is return Next (Position); end Next; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + C : constant Map_Access := Container'Unrestricted_Access; + B : Natural renames C.HT.Busy; + L : Natural renames C.HT.Lock; + begin + return R : constant Reference_Control_Type := + (Controlled with C) + do + B := B + 1; + L := L + 1; + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- diff --git a/gcc/ada/a-cohama.ads b/gcc/ada/a-cohama.ads index 049ec448c10..12c352962de 100644 --- a/gcc/ada/a-cohama.ads +++ b/gcc/ada/a-cohama.ads @@ -300,7 +300,7 @@ package Ada.Containers.Hashed_Maps is -- Calls Process for each node in the map function Iterate - (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class; + (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class; private pragma Inline ("="); @@ -428,6 +428,24 @@ private for Reference_Type'Read use Read; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0)); No_Element : constant Cursor := (Container => null, Node => null); diff --git a/gcc/ada/a-cohase.adb b/gcc/ada/a-cohase.adb index 56376e18092..1ce5c4a50b9 100644 --- a/gcc/ada/a-cohase.adb +++ b/gcc/ada/a-cohase.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -722,6 +722,16 @@ package body Ada.Containers.Hashed_Sets is end if; end Free; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1154,6 +1164,25 @@ package body Ada.Containers.Hashed_Sets is return False; end Overlap; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + C : constant Set_Access := Container'Unrestricted_Access; + B : Natural renames C.HT.Busy; + L : Natural renames C.HT.Lock; + begin + return R : constant Reference_Control_Type := + (Controlled with C) + do + B := B + 1; + L := L + 1; + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- diff --git a/gcc/ada/a-cohase.ads b/gcc/ada/a-cohase.ads index b80907802a3..7e5671edfb4 100644 --- a/gcc/ada/a-cohase.ads +++ b/gcc/ada/a-cohase.ads @@ -573,6 +573,24 @@ private for Constant_Reference_Type'Write use Write; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0)); No_Element : constant Cursor := (Container => null, Node => null); diff --git a/gcc/ada/a-convec.adb b/gcc/ada/a-convec.adb index 8731060fbe3..5eb82fe739d 100644 --- a/gcc/ada/a-convec.adb +++ b/gcc/ada/a-convec.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -1269,6 +1269,16 @@ package body Ada.Containers.Vectors is end Generic_Sorting; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Container.Elements.EA (Position.Index)'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -2673,6 +2683,25 @@ package body Ada.Containers.Vectors is end if; end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type + is + C : constant Vector_Access := Container'Unrestricted_Access; + B : Natural renames C.Busy; + L : Natural renames C.Lock; + begin + return R : constant Reference_Control_Type := + (Controlled with C) + do + B := B + 1; + L := L + 1; + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- diff --git a/gcc/ada/a-convec.ads b/gcc/ada/a-convec.ads index 00dfda2adeb..cb1bce17507 100644 --- a/gcc/ada/a-convec.ads +++ b/gcc/ada/a-convec.ads @@ -475,6 +475,24 @@ private for Reference_Type'Read use Read; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Vector'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + No_Element : constant Cursor := Cursor'(null, Index_Type'First); Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0); diff --git a/gcc/ada/a-coorma.adb b/gcc/ada/a-coorma.adb index 0794ba3f62b..c217a4f6d68 100644 --- a/gcc/ada/a-coorma.adb +++ b/gcc/ada/a-coorma.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -677,6 +677,16 @@ package body Ada.Containers.Ordered_Maps is Deallocate (X); end Free; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1198,6 +1208,25 @@ package body Ada.Containers.Ordered_Maps is return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type + is + C : constant Map_Access := Container'Unrestricted_Access; + B : Natural renames C.Tree.Busy; + L : Natural renames C.Tree.Lock; + begin + return R : constant Reference_Control_Type := + (Controlled with C) + do + B := B + 1; + L := L + 1; + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- diff --git a/gcc/ada/a-coorma.ads b/gcc/ada/a-coorma.ads index c30520f33da..56a98fbc0e4 100644 --- a/gcc/ada/a-coorma.ads +++ b/gcc/ada/a-coorma.ads @@ -352,6 +352,24 @@ private for Reference_Type'Write use Write; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Map'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Map : constant Map := (Controlled with Tree => (First => null, Last => null, diff --git a/gcc/ada/a-coorse.adb b/gcc/ada/a-coorse.adb index 34e562ec733..fde98bf5f2d 100644 --- a/gcc/ada/a-coorse.adb +++ b/gcc/ada/a-coorse.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 2004-2014, Free Software Foundation, Inc. -- +-- Copyright (C) 2004-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- -- @@ -1087,6 +1087,16 @@ package body Ada.Containers.Ordered_Sets is end Generic_Keys; + ------------------------ + -- Get_Element_Access -- + ------------------------ + + function Get_Element_Access + (Position : Cursor) return not null Element_Access is + begin + return Position.Node.Element'Access; + end Get_Element_Access; + ----------------- -- Has_Element -- ----------------- @@ -1616,6 +1626,25 @@ package body Ada.Containers.Ordered_Sets is return Previous (Position); end Previous; + ---------------------- + -- Pseudo_Reference -- + ---------------------- + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type + is + C : constant Set_Access := Container'Unrestricted_Access; + B : Natural renames C.Tree.Busy; + L : Natural renames C.Tree.Lock; + begin + return R : constant Reference_Control_Type := + (Controlled with C) + do + B := B + 1; + L := L + 1; + end return; + end Pseudo_Reference; + ------------------- -- Query_Element -- ------------------- diff --git a/gcc/ada/a-coorse.ads b/gcc/ada/a-coorse.ads index 3e16c944fb0..f574f3c92ca 100644 --- a/gcc/ada/a-coorse.ads +++ b/gcc/ada/a-coorse.ads @@ -413,6 +413,24 @@ private for Constant_Reference_Type'Read use Read; + -- Three operations are used to optimize in the expansion of "for ... of" + -- loops: the Next(Cursor) procedure in the visible part, and the following + -- Pseudo_Reference and Get_Element_Access functions. See Sem_Ch5 for + -- details. + + function Pseudo_Reference + (Container : aliased Set'Class) return Reference_Control_Type; + pragma Inline (Pseudo_Reference); + -- Creates an object of type Reference_Control_Type pointing to the + -- container, and increments the Lock. Finalization of this object will + -- decrement the Lock. + + type Element_Access is access all Element_Type; + + function Get_Element_Access + (Position : Cursor) return not null Element_Access; + -- Returns a pointer to the element designated by Position. + Empty_Set : constant Set := (Controlled with Tree => (First => null, Last => null, diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads index 4f54106cbb1..5d876551f1e 100644 --- a/gcc/ada/einfo.ads +++ b/gcc/ada/einfo.ads @@ -4201,8 +4201,11 @@ package Einfo is -- names to access entries in this list. -- Subps_Index (Uint24) --- Used during Exp_Inst.Unnest_Subprogram to hold the index in the Subps --- table for a subprogram. See processing in this procedure for details. +-- Present in subprogram entries. Set if the subprogram contains nested +-- subprograms, or is a subprogram nested within such a subprogram. Holds +-- the index in the Exp_Unst.Subps table for the subprogram. Note that +-- for the outer level subprogram, this is the starting index in the Subp +-- table for the entries for this subprogram. -- Suppress_Elaboration_Warnings (Flag148) -- Defined in all entities, can be set only for subprogram entities and diff --git a/gcc/ada/exp_ch5.adb b/gcc/ada/exp_ch5.adb index 145da2cf977..a27fc2cae3d 100644 --- a/gcc/ada/exp_ch5.adb +++ b/gcc/ada/exp_ch5.adb @@ -132,6 +132,17 @@ package body Exp_Ch5 is procedure Expand_Iterator_Loop_Over_Array (N : Node_Id); -- Expand loop over arrays that uses the form "for X of C" + procedure Expand_Iterator_Loop_Over_Container + (N : Node_Id; + Isc : Node_Id; + I_Spec : Node_Id; + Container : Node_Id; + Container_Typ : Entity_Id); + -- Expand loop over containers that uses the form "for X of C" with an + -- optional subtype mark, or "for Y in C". Isc is the iteration scheme. + -- I_Spec is the iterator specification and Container is either the + -- Container (for OF) or the iterator (for IN). + procedure Expand_Predicated_Loop (N : Node_Id); -- Expand for loop over predicated subtype @@ -3231,23 +3242,16 @@ package body Exp_Ch5 is procedure Expand_Iterator_Loop (N : Node_Id) is Isc : constant Node_Id := Iteration_Scheme (N); I_Spec : constant Node_Id := Iterator_Specification (Isc); - Id : constant Entity_Id := Defining_Identifier (I_Spec); - Loc : constant Source_Ptr := Sloc (N); Container : constant Node_Id := Name (I_Spec); Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); - I_Kind : constant Entity_Kind := Ekind (Id); - Cursor : Entity_Id; - Iterator : Entity_Id; - New_Loop : Node_Id; - Stats : List_Id := Statements (N); begin -- Processing for arrays if Is_Array_Type (Container_Typ) then + pragma Assert (Of_Present (I_Spec)); Expand_Iterator_Loop_Over_Array (N); - return; elsif Has_Aspect (Container_Typ, Aspect_Iterable) then if Of_Present (I_Spec) then @@ -3256,402 +3260,12 @@ package body Exp_Ch5 is Expand_Formal_Container_Loop (N); end if; - return; - end if; - -- Processing for containers - -- For an "of" iterator the name is a container expression, which - -- is transformed into a call to the default iterator. - - -- For an iterator of the form "in" the name is a function call - -- that delivers an iterator type. - - -- In both cases, analysis of the iterator has introduced an object - -- declaration to capture the domain, so that Container is an entity. - - -- The for loop is expanded into a while loop which uses a container - -- specific cursor to desgnate each element. - - -- Iter : Iterator_Type := Container.Iterate; - -- Cursor : Cursor_type := First (Iter); - -- while Has_Element (Iter) loop - -- declare - -- -- The block is added when Element_Type is controlled - - -- Obj : Pack.Element_Type := Element (Cursor); - -- -- for the "of" loop form - -- begin - -- - -- end; - - -- Cursor := Iter.Next (Cursor); - -- end loop; - - -- If "reverse" is present, then the initialization of the cursor - -- uses Last and the step becomes Prev. Pack is the name of the - -- scope where the container package is instantiated. - - declare - Element_Type : constant Entity_Id := Etype (Id); - Iter_Type : Entity_Id; - Pack : Entity_Id; - Decl : Node_Id; - Name_Init : Name_Id; - Name_Step : Name_Id; - - begin - -- The type of the iterator is the return type of the Iterate - -- function used. For the "of" form this is the default iterator - -- for the type, otherwise it is the type of the explicit - -- function used in the iterator specification. The most common - -- case will be an Iterate function in the container package. - - -- The primitive operations of the container type may not be - -- use-visible, so we introduce the name of the enclosing package - -- in the declarations below. The Iterator type is declared in a - -- an instance within the container package itself. - - -- If the container type is a derived type, the cursor type is - -- found in the package of the parent type. - - if Is_Derived_Type (Container_Typ) then - Pack := Scope (Root_Type (Container_Typ)); - else - Pack := Scope (Container_Typ); - end if; - - Iter_Type := Etype (Name (I_Spec)); - - -- The "of" case uses an internally generated cursor whose type - -- is found in the container package. The domain of iteration - -- is expanded into a call to the default Iterator function, but - -- this expansion does not take place in quantified expressions - -- that are analyzed with expansion disabled, and in that case the - -- type of the iterator must be obtained from the aspect. - - if Of_Present (I_Spec) then - Handle_Of : declare - Default_Iter : Entity_Id; - Container_Arg : Node_Id; - Ent : Entity_Id; - - function Get_Default_Iterator - (T : Entity_Id) return Entity_Id; - -- If the container is a derived type, the aspect holds the - -- parent operation. The required one is a primitive of the - -- derived type and is either inherited or overridden. - - -------------------------- - -- Get_Default_Iterator -- - -------------------------- - - function Get_Default_Iterator - (T : Entity_Id) return Entity_Id - is - Iter : constant Entity_Id := - Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator)); - Prim : Elmt_Id; - Op : Entity_Id; - - begin - Container_Arg := New_Copy_Tree (Container); - - -- A previous version of GNAT allowed indexing aspects to - -- be redefined on derived container types, while the - -- default iterator was inherited from the aprent type. - -- This non-standard extension is preserved temporarily for - -- use by the modelling project under debug flag d.X. - - if Debug_Flag_Dot_XX then - if Base_Type (Etype (Container)) /= - Base_Type (Etype (First_Formal (Iter))) - then - Container_Arg := - Make_Type_Conversion (Loc, - Subtype_Mark => - New_Occurrence_Of - (Etype (First_Formal (Iter)), Loc), - Expression => Container_Arg); - end if; - - return Iter; - - elsif Is_Derived_Type (T) then - - -- The default iterator must be a primitive operation - -- of the type, at the same dispatch slot position. - - Prim := First_Elmt (Primitive_Operations (T)); - while Present (Prim) loop - Op := Node (Prim); - - if Chars (Op) = Chars (Iter) - and then DT_Position (Op) = DT_Position (Iter) - then - return Op; - end if; - - Next_Elmt (Prim); - end loop; - - -- Default iterator must exist - - pragma Assert (False); - - else -- not a derived type - return Iter; - end if; - end Get_Default_Iterator; - - -- Start of processing for Handle_Of - - begin - if Is_Class_Wide_Type (Container_Typ) then - Default_Iter := - Get_Default_Iterator (Etype (Base_Type (Container_Typ))); - - else - Default_Iter := Get_Default_Iterator (Etype (Container)); - end if; - - Cursor := Make_Temporary (Loc, 'C'); - - -- For an container element iterator, the iterator type - -- is obtained from the corresponding aspect, whose return - -- type is descended from the corresponding interface type - -- in some instance of Ada.Iterator_Interfaces. The actuals - -- of that instantiation are Cursor and Has_Element. - - Iter_Type := Etype (Default_Iter); - - -- The iterator type, which is a class_wide type, may itself - -- be derived locally, so the desired instantiation is the - -- scope of the root type of the iterator type. - - Pack := Scope (Root_Type (Etype (Iter_Type))); - - -- Rewrite domain of iteration as a call to the default - -- iterator for the container type. - - Rewrite (Name (I_Spec), - Make_Function_Call (Loc, - Name => New_Occurrence_Of (Default_Iter, Loc), - Parameter_Associations => - New_List (Container_Arg))); - Analyze_And_Resolve (Name (I_Spec)); - - -- Find cursor type in proper iterator package, which is an - -- instantiation of Iterator_Interfaces. - - Ent := First_Entity (Pack); - while Present (Ent) loop - if Chars (Ent) = Name_Cursor then - Set_Etype (Cursor, Etype (Ent)); - exit; - end if; - Next_Entity (Ent); - end loop; - - -- Generate: - -- Id : Element_Type renames Container (Cursor); - -- This assumes that the container type has an indexing - -- operation with Cursor. The check that this operation - -- exists is performed in Check_Container_Indexing. - - Decl := - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Id, - Subtype_Mark => - New_Occurrence_Of (Element_Type, Loc), - Name => - Make_Indexed_Component (Loc, - Prefix => Relocate_Node (Container_Arg), - Expressions => - New_List (New_Occurrence_Of (Cursor, Loc)))); - - -- The defining identifier in the iterator is user-visible - -- and must be visible in the debugger. - - Set_Debug_Info_Needed (Id); - - -- If the container does not have a variable indexing aspect, - -- the element is a constant in the loop. - - if No (Find_Value_Of_Aspect - (Container_Typ, Aspect_Variable_Indexing)) - then - Set_Ekind (Id, E_Constant); - end if; - - -- If the container holds controlled objects, wrap the loop - -- statements and element renaming declaration with a block. - -- This ensures that the result of Element (Cusor) is - -- cleaned up after each iteration of the loop. - - if Needs_Finalization (Element_Type) then - - -- Generate: - -- declare - -- Id : Element_Type := Element (curosr); - -- begin - -- - -- end; - - Stats := New_List ( - Make_Block_Statement (Loc, - Declarations => New_List (Decl), - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => Stats))); - - -- Elements do not need finalization - - else - Prepend_To (Stats, Decl); - end if; - end Handle_Of; - - -- X in Iterate (S) : type of iterator is type of explicitly - -- given Iterate function, and the loop variable is the cursor. - -- It will be assigned in the loop and must be a variable. - - else - Cursor := Id; - end if; - - Iterator := Make_Temporary (Loc, 'I'); - - -- Determine the advancement and initialization steps for the - -- cursor. - - -- Analysis of the expanded loop will verify that the container - -- has a reverse iterator. - - if Reverse_Present (I_Spec) then - Name_Init := Name_Last; - Name_Step := Name_Previous; - - else - Name_Init := Name_First; - Name_Step := Name_Next; - end if; - - -- For both iterator forms, add a call to the step operation to - -- advance the cursor. Generate: - - -- Cursor := Iterator.Next (Cursor); - - -- or else - - -- Cursor := Next (Cursor); - - declare - Rhs : Node_Id; - - begin - Rhs := - Make_Function_Call (Loc, - Name => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Iterator, Loc), - Selector_Name => Make_Identifier (Loc, Name_Step)), - Parameter_Associations => New_List ( - New_Occurrence_Of (Cursor, Loc))); - - Append_To (Stats, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of (Cursor, Loc), - Expression => Rhs)); - Set_Assignment_OK (Name (Last (Stats))); - end; - - -- Generate: - -- while Iterator.Has_Element loop - -- - -- end loop; - - -- Has_Element is the second actual in the iterator package - - New_Loop := - Make_Loop_Statement (Loc, - Iteration_Scheme => - Make_Iteration_Scheme (Loc, - Condition => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of ( - Next_Entity (First_Entity (Pack)), Loc), - Parameter_Associations => - New_List (New_Occurrence_Of (Cursor, Loc)))), - - Statements => Stats, - End_Label => Empty); - - -- If present, preserve identifier of loop, which can be used in - -- an exit statement in the body. - - if Present (Identifier (N)) then - Set_Identifier (New_Loop, Relocate_Node (Identifier (N))); - end if; - - -- Create the declarations for Iterator and cursor and insert them - -- before the source loop. Given that the domain of iteration is - -- already an entity, the iterator is just a renaming of that - -- entity. Possible optimization ??? - -- Generate: - - -- I : Iterator_Type renames Container; - -- C : Cursor_Type := Container.[First | Last]; - - Insert_Action (N, - Make_Object_Renaming_Declaration (Loc, - Defining_Identifier => Iterator, - Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), - Name => Relocate_Node (Name (I_Spec)))); - - -- Create declaration for cursor - - declare - Decl : Node_Id; - - begin - Decl := - Make_Object_Declaration (Loc, - Defining_Identifier => Cursor, - Object_Definition => - New_Occurrence_Of (Etype (Cursor), Loc), - Expression => - Make_Selected_Component (Loc, - Prefix => New_Occurrence_Of (Iterator, Loc), - Selector_Name => - Make_Identifier (Loc, Name_Init))); - - -- The cursor is only modified in expanded code, so it appears - -- as unassigned to the warning machinery. We must suppress - -- this spurious warning explicitly. The cursor's kind is that of - -- the original loop parameter (it is a constant if the domain of - -- iteration is constant). - - Set_Warnings_Off (Cursor); - Set_Assignment_OK (Decl); - - Insert_Action (N, Decl); - Set_Ekind (Cursor, I_Kind); - end; - - -- If the range of iteration is given by a function call that - -- returns a container, the finalization actions have been saved - -- in the Condition_Actions of the iterator. Insert them now at - -- the head of the loop. - - if Present (Condition_Actions (Isc)) then - Insert_List_Before (N, Condition_Actions (Isc)); - end if; - end; - - Rewrite (N, New_Loop); - Analyze (N); + else + Expand_Iterator_Loop_Over_Container + (N, Isc, I_Spec, Container, Container_Typ); + end if; end Expand_Iterator_Loop; ------------------------------------- @@ -3813,6 +3427,543 @@ package body Exp_Ch5 is Analyze (N); end Expand_Iterator_Loop_Over_Array; + ----------------------------------------- + -- Expand_Iterator_Loop_Over_Container -- + ----------------------------------------- + + -- For a 'for ... in' loop, such as: + + -- for Cursor in Iterator_Function (...) loop + -- ... + -- end loop; + + -- we generate: + + -- Iter : Iterator_Type := Iterator_Function (...); + -- Cursor : Cursor_type := First (Iter); -- or Last for "reverse" + -- while Has_Element (Cursor) loop + -- ... + -- + -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse" + -- end loop; + + -- For a 'for ... of' loop, such as: + + -- for X of Container loop + -- ... + -- end loop; + + -- the RM implies the generation of: + + -- Iter : Iterator_Type := Container.Iterate; -- the Default_Iterator + -- Cursor : Cursor_Type := First (Iter); -- or Last for "reverse" + -- while Has_Element (Cursor) loop + -- declare + -- X : Element_Type renames Element (Cursor).Element.all; + -- -- or Constant_Element + -- begin + -- ... + -- end; + -- Cursor := Iter.Next (Cursor); -- or Prev for "reverse" + -- end loop; + + -- In the general case, we do what the RM says. However, the operations + -- Element and Iter.Next are slow, which is bad inside a loop, because they + -- involve dispatching via interfaces, secondary stack manipulation, + -- Busy/Lock incr/decr, and adjust/finalization/at-end handling. So for the + -- predefined containers, we use an equivalent but optimized expansion. + + -- In the optimized case, we make use of these: + + -- procedure Next (Position : in out Cursor); -- instead of Iter.Next + + -- function Pseudo_Reference + -- (Container : aliased Vector'Class) return Reference_Control_Type; + + -- type Element_Access is access all Element_Type; + + -- function Get_Element_Access + -- (Position : Cursor) return not null Element_Access; + + -- Next is declared in the visible part of the container packages. + -- The other three are added in the private part. (We're not supposed to + -- pollute the namespace for clients. The compiler has no trouble breaking + -- privacy to call things in the private part of an instance.) + + -- Source: + + -- for X of My_Vector loop + -- X.Count := X.Count + 1; + -- ... + -- end loop; + + -- The compiler will generate: + + -- Iter : Reversible_Iterator'Class := Iterate (My_Vector); + -- -- Reversible_Iterator is an interface. Iterate is the + -- -- Default_Iterator aspect of Vector. This increments Lock, + -- -- disallowing tampering with cursors. Unfortunately, it does not + -- -- increment Busy. The result of Iterate is Limited_Controlled; + -- -- finalization will decrement Lock. This is a build-in-place + -- -- dispatching call to Iterate. + + -- Cur : Cursor := First (Iter); -- or Last + -- -- Dispatching call via interface. + + -- Control : Reference_Control_Type := Pseudo_Reference (My_Vector); + -- -- Pseudo_Reference increments Busy, to detect tampering with + -- -- elements, as required by RM. Also redundantly increment + -- -- Lock. Finalization of Control will decrement both Busy and + -- -- Lock. Pseudo_Reference returns a record containing a pointer to + -- -- My_Vector, used by Finalize. + -- -- + -- -- Control is not used below, except to finalize it -- it's purely + -- -- an RAII thing. This is needed because we are eliminating the + -- -- call to Reference within the loop. + + -- while Has_Element (Cur) loop + -- declare + -- X : My_Element renames Get_Element_Access (Cur).all; + -- -- Get_Element_Access returns a pointer to the element + -- -- designated by Cur. No dispatching here, and no horsing + -- -- around with access discriminants. This is instead of the + -- -- existing + -- -- + -- -- X : My_Element renames Reference (Cur).Element.all; + -- -- + -- -- which creates a controlled object. + -- begin + -- -- Any attempt to tamper with My_Vector here in the loop + -- -- will correctly raise Program_Error, because of the + -- -- Control. + -- + -- X.Count := X.Count + 1; + -- ... + -- + -- Next (Cur); -- or Prev + -- -- This is instead of "Cur := Next (Iter, Cur);" + -- end; + -- -- No finalization here + -- end loop; + -- Finalize Iter and Control here, decrementing Lock twice and Busy + -- once. + + -- This optimization makes "for ... of" loops over 30 times faster in cases + -- measured. + + procedure Expand_Iterator_Loop_Over_Container + (N : Node_Id; + Isc : Node_Id; + I_Spec : Node_Id; + Container : Node_Id; + Container_Typ : Entity_Id) + is + Id : constant Entity_Id := Defining_Identifier (I_Spec); + Loc : constant Source_Ptr := Sloc (N); + + I_Kind : constant Entity_Kind := Ekind (Id); + Cursor : Entity_Id; + Iterator : Entity_Id; + New_Loop : Node_Id; + Stats : constant List_Id := Statements (N); + + Element_Type : constant Entity_Id := Etype (Id); + Iter_Type : Entity_Id; + Pack : Entity_Id; + Decl : Node_Id; + Name_Init : Name_Id; + Name_Step : Name_Id; + + Fast_Element_Access_Op, Fast_Step_Op : Entity_Id := Empty; + -- Only for optimized version of "for ... of" + + begin + -- Determine the advancement and initialization steps for the cursor. + -- Analysis of the expanded loop will verify that the container has a + -- reverse iterator. + + if Reverse_Present (I_Spec) then + Name_Init := Name_Last; + Name_Step := Name_Previous; + else + Name_Init := Name_First; + Name_Step := Name_Next; + end if; + + -- The type of the iterator is the return type of the Iterate function + -- used. For the "of" form this is the default iterator for the type, + -- otherwise it is the type of the explicit function used in the + -- iterator specification. The most common case will be an Iterate + -- function in the container package. + + -- The Iterator type is declared in an instance within the container + -- package itself, for example: + + -- package Vector_Iterator_Interfaces is new + -- Ada.Iterator_Interfaces (Cursor, Has_Element); + + -- If the container type is a derived type, the cursor type is found in + -- the package of the ultimate ancestor type. + + if Is_Derived_Type (Container_Typ) then + Pack := Scope (Root_Type (Container_Typ)); + else + Pack := Scope (Container_Typ); + end if; + + Iter_Type := Etype (Name (I_Spec)); + + if Of_Present (I_Spec) then + Handle_Of : declare + Container_Arg : Node_Id; + + function Get_Default_Iterator + (T : Entity_Id) return Entity_Id; + -- If the container is a derived type, the aspect holds the parent + -- operation. The required one is a primitive of the derived type + -- and is either inherited or overridden. Also sets Container_Arg. + + -------------------------- + -- Get_Default_Iterator -- + -------------------------- + + function Get_Default_Iterator + (T : Entity_Id) return Entity_Id + is + Iter : constant Entity_Id := + Entity (Find_Value_Of_Aspect (T, Aspect_Default_Iterator)); + Prim : Elmt_Id; + Op : Entity_Id; + + begin + Container_Arg := New_Copy_Tree (Container); + + -- A previous version of GNAT allowed indexing aspects to + -- be redefined on derived container types, while the + -- default iterator was inherited from the parent type. + -- This non-standard extension is preserved temporarily for + -- use by the modelling project under debug flag d.X. + + if Debug_Flag_Dot_XX then + if Base_Type (Etype (Container)) /= + Base_Type (Etype (First_Formal (Iter))) + then + Container_Arg := + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of + (Etype (First_Formal (Iter)), Loc), + Expression => Container_Arg); + end if; + + return Iter; + + elsif Is_Derived_Type (T) then + + -- The default iterator must be a primitive operation of the + -- type, at the same dispatch slot position. + + Prim := First_Elmt (Primitive_Operations (T)); + while Present (Prim) loop + Op := Node (Prim); + + if Chars (Op) = Chars (Iter) + and then DT_Position (Op) = DT_Position (Iter) + then + return Op; + end if; + + Next_Elmt (Prim); + end loop; + + -- Default iterator must exist + + pragma Assert (False); + + -- Otherwise not a derived type + + else + return Iter; + end if; + end Get_Default_Iterator; + + Default_Iter : Entity_Id; + Ent : Entity_Id; + + Reference_Control_Type : Entity_Id := Empty; + Pseudo_Reference : Entity_Id := Empty; + + -- Start of processing for Handle_Of + + begin + if Is_Class_Wide_Type (Container_Typ) then + Default_Iter := + Get_Default_Iterator (Etype (Base_Type (Container_Typ))); + else + Default_Iter := Get_Default_Iterator (Etype (Container)); + end if; + + Cursor := Make_Temporary (Loc, 'C'); + + -- For a container element iterator, the iterator type is obtained + -- from the corresponding aspect, whose return type is descended + -- from the corresponding interface type in some instance of + -- Ada.Iterator_Interfaces. The actuals of that instantiation + -- are Cursor and Has_Element. + + Iter_Type := Etype (Default_Iter); + + -- Find declarations needed for "for ... of" optimization + + Ent := First_Entity (Pack); + while Present (Ent) loop + if Chars (Ent) = Name_Get_Element_Access then + Fast_Element_Access_Op := Ent; + + elsif Chars (Ent) = Name_Step + and then Ekind (Ent) = E_Procedure + then + Fast_Step_Op := Ent; + + elsif Chars (Ent) = Name_Reference_Control_Type then + Reference_Control_Type := Ent; + + elsif Chars (Ent) = Name_Pseudo_Reference then + Pseudo_Reference := Ent; + end if; + + Next_Entity (Ent); + end loop; + + if Present (Reference_Control_Type) + and then Present (Pseudo_Reference) + then + Insert_Action (N, + Make_Object_Declaration (Loc, + Defining_Identifier => Make_Temporary (Loc, 'D'), + Object_Definition => + New_Occurrence_Of (Reference_Control_Type, Loc), + Expression => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Pseudo_Reference, Loc), + Parameter_Associations => + New_List (New_Copy_Tree (Container_Arg))))); + end if; + + -- The iterator type, which is a class-wide type, may itself be + -- derived locally, so the desired instantiation is the scope of + -- the root type of the iterator type. Currently, Pack is the + -- container instance; this overwrites it with the iterator + -- package. + + Pack := Scope (Root_Type (Etype (Iter_Type))); + + -- Rewrite domain of iteration as a call to the default iterator + -- for the container type. + + Rewrite (Name (I_Spec), + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Default_Iter, Loc), + Parameter_Associations => New_List (Container_Arg))); + Analyze_And_Resolve (Name (I_Spec)); + + -- Find cursor type in proper iterator package, which is an + -- instantiation of Iterator_Interfaces. + + Ent := First_Entity (Pack); + while Present (Ent) loop + if Chars (Ent) = Name_Cursor then + Set_Etype (Cursor, Etype (Ent)); + exit; + end if; + + Next_Entity (Ent); + end loop; + + if Present (Fast_Element_Access_Op) then + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Id, + Subtype_Mark => + New_Occurrence_Of (Element_Type, Loc), + Name => + Make_Explicit_Dereference (Loc, + Prefix => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of (Fast_Element_Access_Op, Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Cursor, Loc))))); + + else + Decl := + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Id, + Subtype_Mark => + New_Occurrence_Of (Element_Type, Loc), + Name => + Make_Indexed_Component (Loc, + Prefix => Relocate_Node (Container_Arg), + Expressions => + New_List (New_Occurrence_Of (Cursor, Loc)))); + end if; + + -- The defining identifier in the iterator is user-visible + -- and must be visible in the debugger. + + Set_Debug_Info_Needed (Id); + + -- If the container does not have a variable indexing aspect, + -- the element is a constant in the loop. + + if No (Find_Value_Of_Aspect + (Container_Typ, Aspect_Variable_Indexing)) + then + Set_Ekind (Id, E_Constant); + end if; + + Prepend_To (Stats, Decl); + end Handle_Of; + + -- X in Iterate (S) : type of iterator is type of explicitly + -- given Iterate function, and the loop variable is the cursor. + -- It will be assigned in the loop and must be a variable. + + else + Cursor := Id; + end if; + + Iterator := Make_Temporary (Loc, 'I'); + + -- For both iterator forms, add a call to the step operation to + -- advance the cursor. Generate: + + -- Cursor := Iterator.Next (Cursor); + + -- or else + + -- Cursor := Next (Cursor); + + if Present (Fast_Element_Access_Op) and then Present (Fast_Step_Op) then + declare + Step_Call : Node_Id; + Curs_Name : constant Node_Id := New_Occurrence_Of (Cursor, Loc); + begin + Step_Call := + Make_Procedure_Call_Statement (Loc, + Name => + New_Occurrence_Of (Fast_Step_Op, Loc), + Parameter_Associations => New_List (Curs_Name)); + + Append_To (Stats, Step_Call); + Set_Assignment_OK (Curs_Name); + end; + + else + declare + Rhs : Node_Id; + + begin + Rhs := + Make_Function_Call (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Iterator, Loc), + Selector_Name => Make_Identifier (Loc, Name_Step)), + Parameter_Associations => New_List ( + New_Occurrence_Of (Cursor, Loc))); + + Append_To (Stats, + Make_Assignment_Statement (Loc, + Name => New_Occurrence_Of (Cursor, Loc), + Expression => Rhs)); + Set_Assignment_OK (Name (Last (Stats))); + end; + end if; + + -- Generate: + -- while Has_Element (Cursor) loop + -- + -- end loop; + + -- Has_Element is the second actual in the iterator package + + New_Loop := + Make_Loop_Statement (Loc, + Iteration_Scheme => + Make_Iteration_Scheme (Loc, + Condition => + Make_Function_Call (Loc, + Name => + New_Occurrence_Of ( + Next_Entity (First_Entity (Pack)), Loc), + Parameter_Associations => + New_List (New_Occurrence_Of (Cursor, Loc)))), + + Statements => Stats, + End_Label => Empty); + + -- If present, preserve identifier of loop, which can be used in + -- an exit statement in the body. + + if Present (Identifier (N)) then + Set_Identifier (New_Loop, Relocate_Node (Identifier (N))); + end if; + + -- Create the declarations for Iterator and cursor and insert them + -- before the source loop. Given that the domain of iteration is already + -- an entity, the iterator is just a renaming of that entity. Possible + -- optimization ??? + + Insert_Action (N, + Make_Object_Renaming_Declaration (Loc, + Defining_Identifier => Iterator, + Subtype_Mark => New_Occurrence_Of (Iter_Type, Loc), + Name => Relocate_Node (Name (I_Spec)))); + + -- Create declaration for cursor + + declare + Cursor_Decl : constant Node_Id := + Make_Object_Declaration (Loc, + Defining_Identifier => Cursor, + Object_Definition => + New_Occurrence_Of (Etype (Cursor), Loc), + Expression => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Iterator, Loc), + Selector_Name => + Make_Identifier (Loc, Name_Init))); + + begin + -- The cursor is only modified in expanded code, so it appears + -- as unassigned to the warning machinery. We must suppress this + -- spurious warning explicitly. The cursor's kind is that of the + -- original loop parameter (it is a constant if the domain of + -- iteration is constant). + + Set_Warnings_Off (Cursor); + Set_Assignment_OK (Cursor_Decl); + + Insert_Action (N, Cursor_Decl); + Set_Ekind (Cursor, I_Kind); + end; + + -- If the range of iteration is given by a function call that returns + -- a container, the finalization actions have been saved in the + -- Condition_Actions of the iterator. Insert them now at the head of + -- the loop. + + if Present (Condition_Actions (Isc)) then + Insert_List_Before (N, Condition_Actions (Isc)); + end if; + + Rewrite (N, New_Loop); + Analyze (N); + end Expand_Iterator_Loop_Over_Container; + ----------------------------- -- Expand_N_Loop_Statement -- ----------------------------- diff --git a/gcc/ada/exp_unst.adb b/gcc/ada/exp_unst.adb index 94f2969bf7a..872a35fda67 100644 --- a/gcc/ada/exp_unst.adb +++ b/gcc/ada/exp_unst.adb @@ -42,138 +42,19 @@ with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; with Snames; use Snames; -with Table; with Tbuild; use Tbuild; with Uintp; use Uintp; package body Exp_Unst is - --------------------------- - -- Terminology for Calls -- - --------------------------- - - -- The level of a subprogram in the nest being analyzed is defined to be - -- the level of nesting, so the outer level subprogram (the one passed to - -- Unnest_Subprogram) is 1, subprograms immediately nested within this - -- outer level subprogram have a level of 2, etc. - - -- Calls within the nest being analyzed are of three types: - - -- Downward call: this is a call from a subprogram to a subprogram that - -- is immediately nested with in the caller, and thus has a level that - -- is one greater than the caller. It is a fundamental property of the - -- nesting structure and visibility that it is not possible to make a - -- call from level N to level M, where M is greater than N + 1. - - -- Parallel call: this is a call from a nested subprogram to another - -- nested subprogram that is at the same level. - - -- Upward call: this is a call from a subprogram to a subprogram that - -- encloses the caller. The level of the callee is less than the level - -- of the caller, and there is no limit on the difference, e.g. for an - -- uplevel call, a subprogram at level 5 can call one at level 2 or even - -- the outer level subprogram at level 1. - - ----------- - -- Subps -- - ----------- - - -- Table to record subprograms within the nest being currently analyzed - - 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.) - - Reachable : Boolean; - -- This flag is set True if there is a call path from the outer level - -- subprogram to this subprogram. If Reachable is False, it means that - -- the subprogram is declared but not actually referenced. We remove - -- such subprograms from the tree, which simplifies our task, because - -- we don't have to worry about e.g. uplevel references from such an - -- unreferenced subpogram, which might require (useless) activation - -- records to be created. This is computed by setting the outer level - -- subprogram (Subp itself) as reachable, and then doing a transitive - -- closure following all calls. - - Uplevel_Ref : Nat; - -- The outermost level which defines entities which this subprogram - -- references either directly or indirectly via a call. This cannot - -- be greater than Lev. If it is equal to Lev, then it means that the - -- subprogram does not make any uplevel references and that thus it - -- does not need an activation record pointer passed. If it is less than - -- Lev, then an activation record pointer is needed, since there is at - -- least one uplevel reference. This is computed by initially setting - -- Uplevel_Ref to Lev for all subprograms. Then on the initial tree - -- traversal, decreasing Uplevel_Ref for an explicit uplevel reference, - -- and finally by doing a transitive closure that follows calls (if A - -- calls B and B has an uplevel reference to level X, then A references - -- level X indirectly). - - Declares_AREC : Boolean; - -- This is set True for a subprogram which include the declarations - -- for a local activation record to be passed on downward calls. It - -- is set True for the target level of an uplevel reference, and for - -- all intervening nested subprograms. For example, if a subprogram X - -- at level 5 makes an uplevel reference to an entity declared in a - -- level 2 subprogram, then the subprograms at levels 4,3,2 enclosing - -- the level 5 subprogram will have this flag set True. - - Uents : Elist_Id; - -- This is a list of entities declared in this subprogram which are - -- uplevel referenced. It contains both objects (which will be put in - -- the corresponding AREC activation record), and types. The types are - -- not put in the AREC activation record, but referenced bounds (i.e. - -- generated _FIRST and _LAST entites, and formal parameters) will be - -- in the list in their own right. - - ARECnF : Entity_Id; - -- This entity is defined for all subprograms which need an extra formal - -- that contains a pointer to the activation record needed for uplevel - -- references. ARECnF must be defined for any subprogram which has a - -- direct or indirect uplevel reference (i.e. Reference_Level < Lev). - - ARECn : Entity_Id; - ARECnT : Entity_Id; - ARECnPT : Entity_Id; - ARECnP : Entity_Id; - -- These AREC entities are defined only for subprograms for which we - -- generate an activation record declaration, i.e. for subprograms for - -- which the Declares_AREC flag is set True. - - ARECnU : Entity_Id; - -- This AREC entity is the uplink component. It is other than Empty only - -- for nested subprograms that declare an activation record as indicated - -- by Declares_AREC being Ture, and which have uplevel references (Lev - -- greater than Uplevel_Ref). It is the additional component in the - -- activation record that references the ARECnF pointer (which points - -- the activation record one level higher, thus forming the chain). - - end record; - - subtype SI_Type is Nat; - - package Subps is new Table.Table ( - Table_Component_Type => Subp_Entry, - Table_Index_Type => SI_Type, - Table_Low_Bound => 1, - Table_Initial => 100, - Table_Increment => 200, - Table_Name => "Unnest_Subps"); - -- Records the subprograms in the nest whose outer subprogram is Subp - ----------- -- Calls -- ----------- -- Table to record calls within the nest being analyzed. These are the - -- calls which may need to have an AREC actual added. + -- calls which may need to have an AREC actual added. This table is built + -- new for each subprogram nest and cleared at the end of processing each + -- subprogram nest. type Call_Entry is record N : Node_Id; @@ -207,7 +88,9 @@ package body Exp_Unst is -- constants, formal parameters). These are the references that will -- need rewriting to use the activation table (AREC) pointers. Also -- included are implicit and explicit uplevel references to types, but - -- these do not get rewritten by the front end. + -- these do not get rewritten by the front end. This table is built new + -- for each subprogram nest and cleared at the end of processing each + -- subprogram nest. type Uref_Entry is record Ref : Node_Id; @@ -257,6 +140,10 @@ package body Exp_Unst is function Subp_Index (Sub : Entity_Id) return SI_Type; -- Given the entity for a subprogram, return corresponding Subps index + function Suffixed_Name (Ent : Entity_Id) return Name_Id; + -- Given an entity Ent, return its name (Char (Ent)) suffixed with + -- two underscores and the entity number, to ensure a unique name. + function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id; -- This function returns the name to be used in the activation record to -- reference the variable uplevel. Clist is the list of components that @@ -299,7 +186,6 @@ package body Exp_Unst is function Get_Level (Sub : Entity_Id) return Nat is Lev : Nat; S : Entity_Id; - begin Lev := 1; S := Sub; @@ -323,25 +209,31 @@ package body Exp_Unst is return SI_Type (UI_To_Int (Subps_Index (Sub))); end Subp_Index; + ------------------- + -- Suffixed_Name -- + ------------------- + + function Suffixed_Name (Ent : Entity_Id) return Name_Id is + begin + Get_Name_String (Chars (Ent)); + Add_Str_To_Name_Buffer ("__"); + Add_Nat_To_Name_Buffer (Nat (Ent)); + return Name_Enter; + end Suffixed_Name; + ---------------- -- Upref_Name -- ---------------- function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id is C : Node_Id; - begin C := First (Clist); loop if No (C) then return Chars (Ent); - elsif Chars (Defining_Identifier (C)) = Chars (Ent) then - Get_Name_String (Chars (Ent)); - Add_Str_To_Name_Buffer ("__"); - Add_Nat_To_Name_Buffer (Nat (Ent)); - return Name_Enter; - + return Suffixed_Name (Ent); else Next (C); end if; @@ -383,7 +275,7 @@ package body Exp_Unst is -- First populate the above tables - Subps.Init; + Subps_First := Subps.Last + 1; Calls.Init; Urefs.Init; @@ -637,6 +529,7 @@ package body Exp_Unst is Uplevel_Ref => L, Declares_AREC => False, Uents => No_Elist, + Last => 0, ARECnF => Empty, ARECn => Empty, ARECnT => Empty, @@ -907,7 +800,7 @@ package body Exp_Unst is begin New_SI := 0; - for J in Subps.First .. Subps.Last loop + for J in Subps_First .. Subps.Last loop declare STJ : Subp_Entry renames Subps.Table (J); Spec : Node_Id; @@ -1040,11 +933,16 @@ package body Exp_Unst is end; end loop; + -- The tables are now complete, so we can record the last index in the + -- Subps table for later reference in Cprint. + + Subps.Table (Subps_First).Last := Subps.Last; + -- Next step, create the entities for code we will insert. We do this -- at the start so that all the entities are defined, regardless of the -- order in which we do the code insertions. - Create_Entities : for J in Subps.First .. Subps.Last loop + Create_Entities : for J in Subps_First .. Subps.Last loop declare STJ : Subp_Entry renames Subps.Table (J); Loc : constant Source_Ptr := Sloc (STJ.Bod); @@ -1093,7 +991,7 @@ package body Exp_Unst is Addr : constant Entity_Id := RTE (RE_Address); begin - for J in Subps.First .. Subps.Last loop + for J in Subps_First .. Subps.Last loop declare STJ : Subp_Entry renames Subps.Table (J); @@ -1193,27 +1091,39 @@ package body Exp_Unst is Comp : Entity_Id; Decl_ARECnT : Node_Id; - Decl_ARECn : Node_Id; Decl_ARECnPT : Node_Id; + Decl_ARECn : Node_Id; Decl_ARECnP : Node_Id; -- Declaration nodes for the AREC entities we build + Decl_Assign : Node_Id; + -- Assigment to set uplink, Empty if none + + Decls : List_Id; + -- List of new declarations we create + begin + -- Suffix the ARECnT and ARECnPT names to make sure that + -- they are unique when Cprint moves the declarations to + -- the outer level. + + Set_Chars (STJ.ARECnT, Suffixed_Name (STJ.ARECnT)); + Set_Chars (STJ.ARECnPT, Suffixed_Name (STJ.ARECnPT)); + -- Build list of component declarations for ARECnT Clist := Empty_List; -- If we are in a subprogram that has a static link that -- is passed in (as indicated by ARECnF being defined), - -- then include ARECnU : ARECnPT := ARECnF where n is - -- one less than the current level and the entity ARECnPT - -- comes from the enclosing subprogram. + -- then include ARECnU : ARECmPT where m is one less than + -- the current level and the entity ARECnPT comes from + -- the enclosing subprogram. if Present (STJ.ARECnF) then declare STJE : Subp_Entry renames Subps.Table (Enclosing_Subp (J)); - begin Append_To (Clist, Make_Component_Declaration (Loc, @@ -1221,9 +1131,7 @@ package body Exp_Unst is Component_Definition => Make_Component_Definition (Loc, Subtype_Indication => - New_Occurrence_Of (STJE.ARECnPT, Loc)), - Expression => - New_Occurrence_Of (STJ.ARECnF, Loc))); + New_Occurrence_Of (STJE.ARECnPT, Loc)))); end; end if; @@ -1271,15 +1179,7 @@ package body Exp_Unst is Component_List => Make_Component_List (Loc, Component_Items => Clist))); - - -- ARECn : aliased ARECnT; - - Decl_ARECn := - Make_Object_Declaration (Loc, - Defining_Identifier => STJ.ARECn, - Aliased_Present => True, - Object_Definition => - New_Occurrence_Of (STJ.ARECnT, Loc)); + Decls := New_List (Decl_ARECnT); -- type ARECnPT is access all ARECnT; @@ -1291,6 +1191,17 @@ package body Exp_Unst is All_Present => True, Subtype_Indication => New_Occurrence_Of (STJ.ARECnT, Loc))); + Append_To (Decls, Decl_ARECnPT); + + -- ARECn : aliased ARECnT; + + Decl_ARECn := + Make_Object_Declaration (Loc, + Defining_Identifier => STJ.ARECn, + Aliased_Present => True, + Object_Definition => + New_Occurrence_Of (STJ.ARECnT, Loc)); + Append_To (Decls, Decl_ARECn); -- ARECnP : constant ARECnPT := ARECn'Access; @@ -1305,10 +1216,31 @@ package body Exp_Unst is Prefix => New_Occurrence_Of (STJ.ARECn, Loc), Attribute_Name => Name_Access)); + Append_To (Decls, Decl_ARECnP); - Prepend_List_To (Declarations (STJ.Bod), - New_List - (Decl_ARECnT, Decl_ARECn, Decl_ARECnPT, Decl_ARECnP)); + -- If we are in a subprogram that has a static link that + -- is passed in (as indicated by ARECnF being defined), + -- then generate ARECn.ARECmU := ARECmF where m is + -- one less than the current level to set the uplink. + + if Present (STJ.ARECnF) then + Decl_Assign := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => + New_Occurrence_Of (STJ.ARECn, Loc), + Selector_Name => + New_Occurrence_Of (STJ.ARECnU, Loc)), + Expression => + New_Occurrence_Of (STJ.ARECnF, Loc)); + Append_To (Decls, Decl_Assign); + + else + Decl_Assign := Empty; + end if; + + Prepend_List_To (Declarations (STJ.Bod), Decls); -- Analyze the newly inserted declarations. Note that we -- do not need to establish the whole scope stack, since @@ -1322,9 +1254,14 @@ package body Exp_Unst is Push_Scope (STJ.Ent); Analyze (Decl_ARECnT, Suppress => All_Checks); - Analyze (Decl_ARECn, Suppress => All_Checks); Analyze (Decl_ARECnPT, Suppress => All_Checks); + Analyze (Decl_ARECn, Suppress => All_Checks); Analyze (Decl_ARECnP, Suppress => All_Checks); + + if Present (Decl_Assign) then + Analyze (Decl_Assign, Suppress => All_Checks); + end if; + Pop_Scope; -- Mark the types as needing typedefs @@ -1521,15 +1458,22 @@ package body Exp_Unst is -- (((AREC5F.AREC4U).AREC3U).AREC2U).X - Pfx := New_Occurrence_Of (STJR.ARECnF, Loc); + -- In the above, ARECnF and ARECnU are pointers, so there are + -- explicit dereferences required for these occurrences. + + Pfx := + Make_Explicit_Dereference (Loc, + Prefix => New_Occurrence_Of (STJR.ARECnF, Loc)); SI := RS_Caller; for L in STJE.Lev .. STJR.Lev - 2 loop SI := Enclosing_Subp (SI); Pfx := - Make_Selected_Component (Loc, - Prefix => Pfx, - Selector_Name => - New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)); + Make_Explicit_Dereference (Loc, + Prefix => + Make_Selected_Component (Loc, + Prefix => Pfx, + Selector_Name => + New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc))); end loop; -- Get activation record component (must exist) diff --git a/gcc/ada/exp_unst.ads b/gcc/ada/exp_unst.ads index 9a6393c6473..7b92dcd4b09 100644 --- a/gcc/ada/exp_unst.ads +++ b/gcc/ada/exp_unst.ads @@ -25,6 +25,7 @@ -- Expand routines for unnesting subprograms +with Table; with Types; use Types; package Exp_Unst is @@ -175,9 +176,9 @@ package Exp_Unst is -- rv : Address; -- end record; - -- AREC1 : aliased AREC1T; - -- type AREC1PT is access all AREC1T; + + -- AREC1 : aliased AREC1T; -- AREC1P : constant AREC1PT := AREC1'Access; -- The fields of AREC1 are set at the point the corresponding entity @@ -213,8 +214,9 @@ package Exp_Unst is -- rv : Address; -- end record; -- - -- AREC1 : aliased AREC1T; -- type AREC1PT is access all AREC1T; + -- + -- AREC1 : aliased AREC1T; -- AREC1P : constant AREC1PT := AREC1'Access; -- -- AREC1.b := b'Address; @@ -362,8 +364,9 @@ package Exp_Unst is -- dynam_LAST : Address; -- end record; -- - -- AREC1 : aliased AREC1T; -- type AREC1PT is access all AREC1T; + -- + -- AREC1 : aliased AREC1T; -- AREC1P : constant AREC1PT := AREC1'Access; -- -- AREC1.x := x'Address; @@ -422,8 +425,9 @@ package Exp_Unst is -- v1 : Address; -- end record; -- - -- AREC1 : aliased AREC1T; -- type AREC1PT is access all AREC1T; + -- + -- AREC1 : aliased AREC1T; -- AREC1P : constant AREC1PT := AREC1'Access; -- -- v1 : integer := x; @@ -431,14 +435,17 @@ package Exp_Unst is -- -- function inner1 (y : integer; AREC1F : AREC1PT) return integer is -- type AREC2T is record - -- AREC1U : AREC1PT := AREC1F; + -- AREC1U : AREC1PT; -- v2 : Address; -- end record; -- - -- AREC2 : aliased AREC2T; -- type AREC2PT is access all AREC2T; + -- + -- AREC2 : aliased AREC2T; -- AREC2P : constant AREC2PT := AREC2'Access; -- + -- AREC2.AREC1U := AREC1F; + -- -- v2 : integer := Integer'Deref (AREC1F.v1) {+} 1; -- AREC2.v2 := v2'Address; -- @@ -525,6 +532,148 @@ package Exp_Unst is -- with the issue of clashing names (mnames__inner, mnames__inner__inner), -- and with overloading (mnames__f, mnames__f__2). + -- In addition, the declarations of ARECnT and ARECnPT get moved to the + -- outer level when we actually generate C code, so we suffix these names + -- with the corresponding entity name to make sure they are unique. + + --------------------------- + -- Terminology for Calls -- + --------------------------- + + -- The level of a subprogram in the nest being analyzed is defined to be + -- the level of nesting, so the outer level subprogram (the one passed to + -- Unnest_Subprogram) is 1, subprograms immediately nested within this + -- outer level subprogram have a level of 2, etc. + + -- Calls within the nest being analyzed are of three types: + + -- Downward call: this is a call from a subprogram to a subprogram that + -- is immediately nested with in the caller, and thus has a level that + -- is one greater than the caller. It is a fundamental property of the + -- nesting structure and visibility that it is not possible to make a + -- call from level N to level M, where M is greater than N + 1. + + -- Parallel call: this is a call from a nested subprogram to another + -- nested subprogram that is at the same level. + + -- Upward call: this is a call from a subprogram to a subprogram that + -- encloses the caller. The level of the callee is less than the level + -- of the caller, and there is no limit on the difference, e.g. for an + -- uplevel call, a subprogram at level 5 can call one at level 2 or even + -- the outer level subprogram at level 1. + + ----------- + -- Subps -- + ----------- + + -- Table to record subprograms within the nest being currently analyzed. + -- Entries in this table are made for each subprogram expanded, and do not + -- get cleared as we complete the expansion, since we want the table info + -- around in Cprint for the actual unnesting operation. Subps_First in this + -- unit records the starting entry in the table for the entries for Subp + -- and this is also recorded in the Subps_Index field of the outer level + -- subprogram in the nest. The last subps index for the nest can be found + -- in the Subp_Entry Last field of this first entry. + + subtype SI_Type is Nat; + -- Index type for the table + + Subps_First : SI_Type; + -- Record starting index for entries in the current nest (this is the table + -- index of the entry for Subp itself, and is recorded in the Subps_Index + -- field of the entity for this 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.) + + Reachable : Boolean; + -- This flag is set True if there is a call path from the outer level + -- subprogram to this subprogram. If Reachable is False, it means that + -- the subprogram is declared but not actually referenced. We remove + -- such subprograms from the tree, which simplifies our task, because + -- we don't have to worry about e.g. uplevel references from such an + -- unreferenced subpogram, which might require (useless) activation + -- records to be created. This is computed by setting the outer level + -- subprogram (Subp itself) as reachable, and then doing a transitive + -- closure following all calls. + + Uplevel_Ref : Nat; + -- The outermost level which defines entities which this subprogram + -- references either directly or indirectly via a call. This cannot + -- be greater than Lev. If it is equal to Lev, then it means that the + -- subprogram does not make any uplevel references and that thus it + -- does not need an activation record pointer passed. If it is less than + -- Lev, then an activation record pointer is needed, since there is at + -- least one uplevel reference. This is computed by initially setting + -- Uplevel_Ref to Lev for all subprograms. Then on the initial tree + -- traversal, decreasing Uplevel_Ref for an explicit uplevel reference, + -- and finally by doing a transitive closure that follows calls (if A + -- calls B and B has an uplevel reference to level X, then A references + -- level X indirectly). + + Declares_AREC : Boolean; + -- This is set True for a subprogram which include the declarations + -- for a local activation record to be passed on downward calls. It + -- is set True for the target level of an uplevel reference, and for + -- all intervening nested subprograms. For example, if a subprogram X + -- at level 5 makes an uplevel reference to an entity declared in a + -- level 2 subprogram, then the subprograms at levels 4,3,2 enclosing + -- the level 5 subprogram will have this flag set True. + + Uents : Elist_Id; + -- This is a list of entities declared in this subprogram which are + -- uplevel referenced. It contains both objects (which will be put in + -- the corresponding AREC activation record), and types. The types are + -- not put in the AREC activation record, but referenced bounds (i.e. + -- generated _FIRST and _LAST entites, and formal parameters) will be + -- in the list in their own right. + + Last : SI_Type; + -- This field is set only in the entry for the outer level subprogram + -- in a nest, and records the last index in the Subp table for all the + -- entries for subprograms in this nest. + + ARECnF : Entity_Id; + -- This entity is defined for all subprograms which need an extra formal + -- that contains a pointer to the activation record needed for uplevel + -- references. ARECnF must be defined for any subprogram which has a + -- direct or indirect uplevel reference (i.e. Reference_Level < Lev). + + ARECn : Entity_Id; + ARECnT : Entity_Id; + ARECnPT : Entity_Id; + ARECnP : Entity_Id; + -- These AREC entities are defined only for subprograms for which we + -- generate an activation record declaration, i.e. for subprograms for + -- which the Declares_AREC flag is set True. + + ARECnU : Entity_Id; + -- This AREC entity is the uplink component. It is other than Empty only + -- for nested subprograms that declare an activation record as indicated + -- by Declares_AREC being Ture, and which have uplevel references (Lev + -- greater than Uplevel_Ref). It is the additional component in the + -- activation record that references the ARECnF pointer (which points + -- the activation record one level higher, thus forming the chain). + + end record; + + package Subps is new Table.Table ( + Table_Component_Type => Subp_Entry, + Table_Index_Type => SI_Type, + Table_Low_Bound => 1, + Table_Initial => 1000, + Table_Increment => 200, + Table_Name => "Unnest_Subps"); + -- Records the subprograms in the nest whose outer subprogram is Subp + ----------------- -- Subprograms -- ----------------- diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 6dc7c00de9d..90745527853 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -120,7 +120,7 @@ package Snames is Name_uY : constant Name_Id := First_Name_Id + Character'Pos ('Y'); Name_uZ : constant Name_Id := First_Name_Id + Character'Pos ('Z'); - -- Note: the following table is read by the utility program XSNAMES, and + -- Note: the following table is read by the utility program 'xsnamest', and -- its format should not be changed without coordinating with this program. N : constant Name_Id := First_Name_Id + 256; @@ -1411,6 +1411,9 @@ package Snames is Name_Forward_Iterator : constant Name_Id := N + $; Name_Reversible_Iterator : constant Name_Id := N + $; Name_Previous : constant Name_Id := N + $; + Name_Pseudo_Reference : constant Name_Id := N + $; + Name_Reference_Control_Type : constant Name_Id := N + $; + Name_Get_Element_Access : constant Name_Id := N + $; -- Ada 2005 reserved words