mirror/gcc
2
0
Fork 0
mirror of git://gcc.gnu.org/git/gcc.git synced 2025-04-05 10:50:51 +08:00
Code Issues Packages Projects Releases Wiki Activity

[multiple changes]

Browse Source 
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.

From-SVN: r223563
This commit is contained in:
Arnaud Charlet 2015-05-22 15:01:37 +02:00
parent 5c0c1090a7
commit ee93527368
18 changed files with 1136 additions and 580 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
gcc/ada/ChangeLog
View File

@ -1,3 +1,27 @@
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.

31
gcc/ada/a-cdlili.adb
View File

@ -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 --
-------------------

18
gcc/ada/a-cdlili.ads
View File

@ -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);

31
gcc/ada/a-cohama.adb
View File

@ -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 --
-------------------

20
gcc/ada/a-cohama.ads
View File

@ -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);

31
gcc/ada/a-cohase.adb
View File

@ -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 --
-------------------

18
gcc/ada/a-cohase.ads
View File

@ -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);

31
gcc/ada/a-convec.adb
View File

@ -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 --
-------------------

18
gcc/ada/a-convec.ads
View File

@ -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);

31
gcc/ada/a-coorma.adb
View File

@ -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 --
-------------------

18
gcc/ada/a-coorma.ads
View File

@ -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,

31
gcc/ada/a-coorse.adb
View File

@ -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 --
-------------------

18
gcc/ada/a-coorse.ads
View File

@ -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,

7
gcc/ada/einfo.ads
View File

@ -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

955
gcc/ada/exp_ch5.adb
View File

@ -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
-- <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;
-------------------------------------
@ -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
-- <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 --
-----------------------------

266
gcc/ada/exp_unst.adb
View File

@ -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)

163
gcc/ada/exp_unst.ads
View File

@ -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 --
-----------------

5
gcc/ada/snames.ads-tmpl
View File

@ -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