+2015-05-22 Robert Dewar <dewar@adacore.com>
+
+ * 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 <duff@adacore.com>
+
+ * 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 <ebotcazou@adacore.com>
* einfo.ads (Is_Atomic_Or_VFA): Move to XEINFO INLINES section.
-- --
-- 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- --
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 --
-----------------
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 --
-------------------
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);
-- --
-- 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- --
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 --
-----------------
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 --
-------------------
-- 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 ("=");
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);
-- --
-- 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- --
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 --
-----------------
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 --
-------------------
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);
-- --
-- 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- --
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 --
-----------------
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 --
-------------------
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);
-- --
-- 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- --
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 --
-----------------
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 --
-------------------
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,
-- --
-- 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- --
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 --
-----------------
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 --
-------------------
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,
-- 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
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
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
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
- -- <original loop statements>
- -- 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
- -- <original loop statements>
- -- 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
- -- <Stats>
- -- 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;
-------------------------------------
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
+ -- <Stats>
+ -- 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 --
-----------------------------
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;
-- 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;
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
function Get_Level (Sub : Entity_Id) return Nat is
Lev : Nat;
S : Entity_Id;
-
begin
Lev := 1;
S := Sub;
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;
-- First populate the above tables
- Subps.Init;
+ Subps_First := Subps.Last + 1;
Calls.Init;
Urefs.Init;
Uplevel_Ref => L,
Declares_AREC => False,
Uents => No_Elist,
+ Last => 0,
ARECnF => Empty,
ARECn => Empty,
ARECnT => Empty,
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;
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);
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);
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,
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;
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;
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;
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
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
-- (((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)
-- Expand routines for unnesting subprograms
+with Table;
with Types; use Types;
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
-- 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;
-- 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;
-- v1 : Address;
-- end record;
--
- -- AREC1 : aliased AREC1T;
-- type AREC1PT is access all AREC1T;
+ --
+ -- AREC1 : aliased AREC1T;
-- AREC1P : constant AREC1PT := AREC1'Access;
--
-- v1 : integer := x;
--
-- 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;
--
-- 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 --
-----------------
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;
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
projects / gcc.git / commitdiff