Skip to content

R
riscv-gcc-1
Commit ee935273 by Arnaud Charlet
Options

[multiple changes] 

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
parent 5c0c1090
Showing with 1030 additions and 474 deletions
gcc/ada/ChangeLog
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> 2015-05-22 Eric Botcazou <ebotcazou@adacore.com>
* einfo.ads (Is_Atomic_Or_VFA): Move to XEINFO INLINES section. * einfo.ads (Is_Atomic_Or_VFA): Move to XEINFO INLINES section.
......
gcc/ada/a-cdlili.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- 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 ...@@ -923,6 +923,16 @@ package body Ada.Containers.Doubly_Linked_Lists is
end Generic_Sorting; 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 -- -- Has_Element --
----------------- -----------------
...@@ -1384,6 +1394,25 @@ package body Ada.Containers.Doubly_Linked_Lists is ...@@ -1384,6 +1394,25 @@ package body Ada.Containers.Doubly_Linked_Lists is
end if; end if;
end Previous; 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 -- -- Query_Element --
------------------- -------------------
......
gcc/ada/a-cdlili.ads
...@@ -362,6 +362,24 @@ private ...@@ -362,6 +362,24 @@ private
for Reference_Type'Read use Read; 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); Empty_List : constant List := (Controlled with null, null, 0, 0, 0);
No_Element : constant Cursor := Cursor'(null, null); No_Element : constant Cursor := Cursor'(null, null);
......
gcc/ada/a-cohama.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -555,6 +555,16 @@ package body Ada.Containers.Hashed_Maps is ...@@ -555,6 +555,16 @@ package body Ada.Containers.Hashed_Maps is
end if; end if;
end Free; 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 -- -- Has_Element --
----------------- -----------------
...@@ -858,6 +868,25 @@ package body Ada.Containers.Hashed_Maps is ...@@ -858,6 +868,25 @@ package body Ada.Containers.Hashed_Maps is
return Next (Position); return Next (Position);
end Next; 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 -- -- Query_Element --
------------------- -------------------
......
gcc/ada/a-cohama.ads
...@@ -300,7 +300,7 @@ package Ada.Containers.Hashed_Maps is ...@@ -300,7 +300,7 @@ package Ada.Containers.Hashed_Maps is
-- Calls Process for each node in the map -- Calls Process for each node in the map
function Iterate function Iterate
(Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'class; (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class;
private private
pragma Inline ("="); pragma Inline ("=");
...@@ -428,6 +428,24 @@ private ...@@ -428,6 +428,24 @@ private
for Reference_Type'Read use Read; 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)); Empty_Map : constant Map := (Controlled with HT => (null, 0, 0, 0));
No_Element : constant Cursor := (Container => null, Node => null); No_Element : constant Cursor := (Container => null, Node => null);
......
gcc/ada/a-cohase.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -722,6 +722,16 @@ package body Ada.Containers.Hashed_Sets is ...@@ -722,6 +722,16 @@ package body Ada.Containers.Hashed_Sets is
end if; end if;
end Free; 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 -- -- Has_Element --
----------------- -----------------
...@@ -1154,6 +1164,25 @@ package body Ada.Containers.Hashed_Sets is ...@@ -1154,6 +1164,25 @@ package body Ada.Containers.Hashed_Sets is
return False; return False;
end Overlap; 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 -- -- Query_Element --
------------------- -------------------
......
gcc/ada/a-cohase.ads
...@@ -573,6 +573,24 @@ private ...@@ -573,6 +573,24 @@ private
for Constant_Reference_Type'Write use Write; 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)); Empty_Set : constant Set := (Controlled with HT => (null, 0, 0, 0));
No_Element : constant Cursor := (Container => null, Node => null); No_Element : constant Cursor := (Container => null, Node => null);
......
gcc/ada/a-convec.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1269,6 +1269,16 @@ package body Ada.Containers.Vectors is ...@@ -1269,6 +1269,16 @@ package body Ada.Containers.Vectors is
end Generic_Sorting; 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 -- -- Has_Element --
----------------- -----------------
...@@ -2673,6 +2683,25 @@ package body Ada.Containers.Vectors is ...@@ -2673,6 +2683,25 @@ package body Ada.Containers.Vectors is
end if; end if;
end Previous; 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 -- -- Query_Element --
------------------- -------------------
......
gcc/ada/a-convec.ads
...@@ -475,6 +475,24 @@ private ...@@ -475,6 +475,24 @@ private
for Reference_Type'Read use Read; 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); No_Element : constant Cursor := Cursor'(null, Index_Type'First);
Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0); Empty_Vector : constant Vector := (Controlled with null, No_Index, 0, 0);
......
gcc/ada/a-coorma.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -677,6 +677,16 @@ package body Ada.Containers.Ordered_Maps is ...@@ -677,6 +677,16 @@ package body Ada.Containers.Ordered_Maps is
Deallocate (X); Deallocate (X);
end Free; 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 -- -- Has_Element --
----------------- -----------------
...@@ -1198,6 +1208,25 @@ package body Ada.Containers.Ordered_Maps is ...@@ -1198,6 +1208,25 @@ package body Ada.Containers.Ordered_Maps is
return Previous (Position); return Previous (Position);
end Previous; 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 -- -- Query_Element --
------------------- -------------------
......
gcc/ada/a-coorma.ads
...@@ -352,6 +352,24 @@ private ...@@ -352,6 +352,24 @@ private
for Reference_Type'Write use Write; 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 := Empty_Map : constant Map :=
(Controlled with Tree => (First => null, (Controlled with Tree => (First => null,
Last => null, Last => null,
......
gcc/ada/a-coorse.adb
...@@ -6,7 +6,7 @@ ...@@ -6,7 +6,7 @@
-- -- -- --
-- B o d y -- -- 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 -- -- 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- -- -- terms of the GNU General Public License as published by the Free Soft- --
...@@ -1087,6 +1087,16 @@ package body Ada.Containers.Ordered_Sets is ...@@ -1087,6 +1087,16 @@ package body Ada.Containers.Ordered_Sets is
end Generic_Keys; 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 -- -- Has_Element --
----------------- -----------------
...@@ -1616,6 +1626,25 @@ package body Ada.Containers.Ordered_Sets is ...@@ -1616,6 +1626,25 @@ package body Ada.Containers.Ordered_Sets is
return Previous (Position); return Previous (Position);
end Previous; 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 -- -- Query_Element --
------------------- -------------------
......
gcc/ada/a-coorse.ads
...@@ -413,6 +413,24 @@ private ...@@ -413,6 +413,24 @@ private
for Constant_Reference_Type'Read use Read; 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 := Empty_Set : constant Set :=
(Controlled with Tree => (First => null, (Controlled with Tree => (First => null,
Last => null, Last => null,
......
gcc/ada/einfo.ads
...@@ -4201,8 +4201,11 @@ package Einfo is ...@@ -4201,8 +4201,11 @@ package Einfo is
-- names to access entries in this list. -- names to access entries in this list.
-- Subps_Index (Uint24) -- Subps_Index (Uint24)
-- Used during Exp_Inst.Unnest_Subprogram to hold the index in the Subps -- Present in subprogram entries. Set if the subprogram contains nested
-- table for a subprogram. See processing in this procedure for details. -- 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) -- Suppress_Elaboration_Warnings (Flag148)
-- Defined in all entities, can be set only for subprogram entities and -- Defined in all entities, can be set only for subprogram entities and
......
gcc/ada/exp_ch5.adb
...@@ -132,6 +132,17 @@ package body Exp_Ch5 is ...@@ -132,6 +132,17 @@ package body Exp_Ch5 is
procedure Expand_Iterator_Loop_Over_Array (N : Node_Id); procedure Expand_Iterator_Loop_Over_Array (N : Node_Id);
-- Expand loop over arrays that uses the form "for X of C" -- 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); procedure Expand_Predicated_Loop (N : Node_Id);
-- Expand for loop over predicated subtype -- Expand for loop over predicated subtype
...@@ -3231,23 +3242,16 @@ package body Exp_Ch5 is ...@@ -3231,23 +3242,16 @@ package body Exp_Ch5 is
procedure Expand_Iterator_Loop (N : Node_Id) is procedure Expand_Iterator_Loop (N : Node_Id) is
Isc : constant Node_Id := Iteration_Scheme (N); Isc : constant Node_Id := Iteration_Scheme (N);
I_Spec : constant Node_Id := Iterator_Specification (Isc); 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 : constant Node_Id := Name (I_Spec);
Container_Typ : constant Entity_Id := Base_Type (Etype (Container)); 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 begin
-- Processing for arrays -- Processing for arrays
if Is_Array_Type (Container_Typ) then if Is_Array_Type (Container_Typ) then
pragma Assert (Of_Present (I_Spec));
Expand_Iterator_Loop_Over_Array (N); Expand_Iterator_Loop_Over_Array (N);
return;
elsif Has_Aspect (Container_Typ, Aspect_Iterable) then elsif Has_Aspect (Container_Typ, Aspect_Iterable) then
if Of_Present (I_Spec) then if Of_Present (I_Spec) then
...@@ -3256,43 +3260,313 @@ package body Exp_Ch5 is ...@@ -3256,43 +3260,313 @@ package body Exp_Ch5 is
Expand_Formal_Container_Loop (N); Expand_Formal_Container_Loop (N);
end if; end if;
return; -- Processing for containers
else
Expand_Iterator_Loop_Over_Container
(N, Isc, I_Spec, Container, Container_Typ);
end if; end if;
end Expand_Iterator_Loop;
-- Processing for containers -------------------------------------
-- Expand_Iterator_Loop_Over_Array --
-------------------------------------
procedure Expand_Iterator_Loop_Over_Array (N : Node_Id) is
Isc : constant Node_Id := Iteration_Scheme (N);
I_Spec : constant Node_Id := Iterator_Specification (Isc);
Array_Node : constant Node_Id := Name (I_Spec);
Array_Typ : constant Entity_Id := Base_Type (Etype (Array_Node));
Array_Dim : constant Pos := Number_Dimensions (Array_Typ);
Id : constant Entity_Id := Defining_Identifier (I_Spec);
Loc : constant Source_Ptr := Sloc (N);
Stats : constant List_Id := Statements (N);
Core_Loop : Node_Id;
Dim1 : Int;
Ind_Comp : Node_Id;
Iterator : Entity_Id;
-- For an "of" iterator the name is a container expression, which -- Start of processing for Expand_Iterator_Loop_Over_Array
-- is transformed into a call to the default iterator.
-- For an iterator of the form "in" the name is a function call begin
-- that delivers an iterator type. -- for Element of Array loop
-- In both cases, analysis of the iterator has introduced an object -- This case requires an internally generated cursor to iterate over
-- declaration to capture the domain, so that Container is an entity. -- the array.
-- The for loop is expanded into a while loop which uses a container if Of_Present (I_Spec) then
-- specific cursor to desgnate each element. Iterator := Make_Temporary (Loc, 'C');
-- Iter : Iterator_Type := Container.Iterate; -- Generate:
-- Cursor : Cursor_type := First (Iter); -- Element : Component_Type renames Array (Iterator);
-- while Has_Element (Iter) loop -- Iterator is the index value, or a list of index values
-- declare -- in the case of a multidimensional array.
-- -- The block is added when Element_Type is controlled
-- Obj : Pack.Element_Type := Element (Cursor); Ind_Comp :=
-- -- for the "of" loop form Make_Indexed_Component (Loc,
-- begin Prefix => Relocate_Node (Array_Node),
Expressions => New_List (New_Occurrence_Of (Iterator, Loc)));
Prepend_To (Stats,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
Subtype_Mark =>
New_Occurrence_Of (Component_Type (Array_Typ), Loc),
Name => Ind_Comp));
-- Mark the loop variable as needing debug info, so that expansion
-- of the renaming will result in Materialize_Entity getting set via
-- Debug_Renaming_Declaration. (This setting is needed here because
-- the setting in Freeze_Entity comes after the expansion, which is
-- too late. ???)
Set_Debug_Info_Needed (Id);
-- for Index in Array loop
-- This case utilizes the already given iterator name
else
Iterator := Id;
end if;
-- Generate:
-- for Iterator in [reverse] Array'Range (Array_Dim) loop
-- Element : Component_Type renames Array (Iterator);
-- <original loop statements> -- <original loop statements>
-- end loop;
-- If this is an iteration over a multidimensional array, the
-- innermost loop is over the last dimension in Ada, and over
-- the first dimension in Fortran.
if Convention (Array_Typ) = Convention_Fortran then
Dim1 := 1;
else
Dim1 := Array_Dim;
end if;
Core_Loop :=
Make_Loop_Statement (Loc,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Array_Node),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim1))),
Reverse_Present => Reverse_Present (I_Spec))),
Statements => Stats,
End_Label => Empty);
-- Processing for multidimensional array. The body of each loop is
-- a loop over a previous dimension, going in decreasing order in Ada
-- and in increasing order in Fortran.
if Array_Dim > 1 then
for Dim in 1 .. Array_Dim - 1 loop
if Convention (Array_Typ) = Convention_Fortran then
Dim1 := Dim + 1;
else
Dim1 := Array_Dim - Dim;
end if;
Iterator := Make_Temporary (Loc, 'C');
-- Generate the dimension loops starting from the innermost one
-- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
-- <core loop>
-- end loop;
Core_Loop :=
Make_Loop_Statement (Loc,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Array_Node),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim1))),
Reverse_Present => Reverse_Present (I_Spec))),
Statements => New_List (Core_Loop),
End_Label => Empty);
-- Update the previously created object renaming declaration with
-- the new iterator, by adding the index of the next loop to the
-- indexed component, in the order that corresponds to the
-- convention.
if Convention (Array_Typ) = Convention_Fortran then
Append_To (Expressions (Ind_Comp),
New_Occurrence_Of (Iterator, Loc));
else
Prepend_To (Expressions (Ind_Comp),
New_Occurrence_Of (Iterator, Loc));
end if;
end loop;
end if;
-- Inherit the loop identifier from the original loop. This ensures that
-- the scope stack is consistent after the rewriting.
if Present (Identifier (N)) then
Set_Identifier (Core_Loop, Relocate_Node (Identifier (N)));
end if;
Rewrite (N, Core_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; -- 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.)
-- Cursor := Iter.Next (Cursor); -- Source:
-- for X of My_Vector loop
-- X.Count := X.Count + 1;
-- ...
-- end loop; -- end loop;
-- If "reverse" is present, then the initialization of the cursor -- The compiler will generate:
-- uses Last and the step becomes Prev. Pack is the name of the
-- scope where the container package is instantiated. -- 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);
declare
Element_Type : constant Entity_Id := Etype (Id); Element_Type : constant Entity_Id := Etype (Id);
Iter_Type : Entity_Id; Iter_Type : Entity_Id;
Pack : Entity_Id; Pack : Entity_Id;
...@@ -3300,20 +3574,36 @@ package body Exp_Ch5 is ...@@ -3300,20 +3574,36 @@ package body Exp_Ch5 is
Name_Init : Name_Id; Name_Init : Name_Id;
Name_Step : Name_Id; Name_Step : Name_Id;
Fast_Element_Access_Op, Fast_Step_Op : Entity_Id := Empty;
-- Only for optimized version of "for ... of"
begin begin
-- The type of the iterator is the return type of the Iterate -- Determine the advancement and initialization steps for the cursor.
-- function used. For the "of" form this is the default iterator -- Analysis of the expanded loop will verify that the container has a
-- for the type, otherwise it is the type of the explicit -- reverse iterator.
-- function used in the iterator specification. The most common
-- case will be an Iterate function in the container package. 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 primitive operations of the container type may not be -- The Iterator type is declared in an instance within the container
-- use-visible, so we introduce the name of the enclosing package -- package itself, for example:
-- 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 -- package Vector_Iterator_Interfaces is new
-- found in the package of the parent type. -- 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 if Is_Derived_Type (Container_Typ) then
Pack := Scope (Root_Type (Container_Typ)); Pack := Scope (Root_Type (Container_Typ));
...@@ -3323,24 +3613,15 @@ package body Exp_Ch5 is ...@@ -3323,24 +3613,15 @@ package body Exp_Ch5 is
Iter_Type := Etype (Name (I_Spec)); 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 if Of_Present (I_Spec) then
Handle_Of : declare Handle_Of : declare
Default_Iter : Entity_Id;
Container_Arg : Node_Id; Container_Arg : Node_Id;
Ent : Entity_Id;
function Get_Default_Iterator function Get_Default_Iterator
(T : Entity_Id) return Entity_Id; (T : Entity_Id) return Entity_Id;
-- If the container is a derived type, the aspect holds the -- If the container is a derived type, the aspect holds the parent
-- parent operation. The required one is a primitive of the -- operation. The required one is a primitive of the derived type
-- derived type and is either inherited or overridden. -- and is either inherited or overridden. Also sets Container_Arg.
-------------------------- --------------------------
-- Get_Default_Iterator -- -- Get_Default_Iterator --
...@@ -3359,7 +3640,7 @@ package body Exp_Ch5 is ...@@ -3359,7 +3640,7 @@ package body Exp_Ch5 is
-- A previous version of GNAT allowed indexing aspects to -- A previous version of GNAT allowed indexing aspects to
-- be redefined on derived container types, while the -- be redefined on derived container types, while the
-- default iterator was inherited from the aprent type. -- default iterator was inherited from the parent type.
-- This non-standard extension is preserved temporarily for -- This non-standard extension is preserved temporarily for
-- use by the modelling project under debug flag d.X. -- use by the modelling project under debug flag d.X.
...@@ -3379,8 +3660,8 @@ package body Exp_Ch5 is ...@@ -3379,8 +3660,8 @@ package body Exp_Ch5 is
elsif Is_Derived_Type (T) then elsif Is_Derived_Type (T) then
-- The default iterator must be a primitive operation -- The default iterator must be a primitive operation of the
-- of the type, at the same dispatch slot position. -- type, at the same dispatch slot position.
Prim := First_Elmt (Primitive_Operations (T)); Prim := First_Elmt (Primitive_Operations (T));
while Present (Prim) loop while Present (Prim) loop
...@@ -3399,46 +3680,93 @@ package body Exp_Ch5 is ...@@ -3399,46 +3680,93 @@ package body Exp_Ch5 is
pragma Assert (False); pragma Assert (False);
else -- not a derived type -- Otherwise not a derived type
else
return Iter; return Iter;
end if; end if;
end Get_Default_Iterator; 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 -- Start of processing for Handle_Of
begin begin
if Is_Class_Wide_Type (Container_Typ) then if Is_Class_Wide_Type (Container_Typ) then
Default_Iter := Default_Iter :=
Get_Default_Iterator (Etype (Base_Type (Container_Typ))); Get_Default_Iterator (Etype (Base_Type (Container_Typ)));
else else
Default_Iter := Get_Default_Iterator (Etype (Container)); Default_Iter := Get_Default_Iterator (Etype (Container));
end if; end if;
Cursor := Make_Temporary (Loc, 'C'); Cursor := Make_Temporary (Loc, 'C');
-- For an container element iterator, the iterator type -- For a container element iterator, the iterator type is obtained
-- is obtained from the corresponding aspect, whose return -- from the corresponding aspect, whose return type is descended
-- type is descended from the corresponding interface type -- from the corresponding interface type in some instance of
-- in some instance of Ada.Iterator_Interfaces. The actuals -- Ada.Iterator_Interfaces. The actuals of that instantiation
-- of that instantiation are Cursor and Has_Element. -- are Cursor and Has_Element.
Iter_Type := Etype (Default_Iter); Iter_Type := Etype (Default_Iter);
-- The iterator type, which is a class_wide type, may itself -- Find declarations needed for "for ... of" optimization
-- be derived locally, so the desired instantiation is the
-- scope of the root type of the iterator type. 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))); Pack := Scope (Root_Type (Etype (Iter_Type)));
-- Rewrite domain of iteration as a call to the default -- Rewrite domain of iteration as a call to the default iterator
-- iterator for the container type. -- for the container type.
Rewrite (Name (I_Spec), Rewrite (Name (I_Spec),
Make_Function_Call (Loc, Make_Function_Call (Loc,
Name => New_Occurrence_Of (Default_Iter, Loc), Name =>
Parameter_Associations => New_Occurrence_Of (Default_Iter, Loc),
New_List (Container_Arg))); Parameter_Associations => New_List (Container_Arg)));
Analyze_And_Resolve (Name (I_Spec)); Analyze_And_Resolve (Name (I_Spec));
-- Find cursor type in proper iterator package, which is an -- Find cursor type in proper iterator package, which is an
...@@ -3450,15 +3778,26 @@ package body Exp_Ch5 is ...@@ -3450,15 +3778,26 @@ package body Exp_Ch5 is
Set_Etype (Cursor, Etype (Ent)); Set_Etype (Cursor, Etype (Ent));
exit; exit;
end if; end if;
Next_Entity (Ent); Next_Entity (Ent);
end loop; end loop;
-- Generate: if Present (Fast_Element_Access_Op) then
-- Id : Element_Type renames Container (Cursor); Decl :=
-- This assumes that the container type has an indexing Make_Object_Renaming_Declaration (Loc,
-- operation with Cursor. The check that this operation Defining_Identifier => Id,
-- exists is performed in Check_Container_Indexing. 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 := Decl :=
Make_Object_Renaming_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id, Defining_Identifier => Id,
...@@ -3469,6 +3808,7 @@ package body Exp_Ch5 is ...@@ -3469,6 +3808,7 @@ package body Exp_Ch5 is
Prefix => Relocate_Node (Container_Arg), Prefix => Relocate_Node (Container_Arg),
Expressions => Expressions =>
New_List (New_Occurrence_Of (Cursor, Loc)))); New_List (New_Occurrence_Of (Cursor, Loc))));
end if;
-- The defining identifier in the iterator is user-visible -- The defining identifier in the iterator is user-visible
-- and must be visible in the debugger. -- and must be visible in the debugger.
...@@ -3484,32 +3824,7 @@ package body Exp_Ch5 is ...@@ -3484,32 +3824,7 @@ package body Exp_Ch5 is
Set_Ekind (Id, E_Constant); Set_Ekind (Id, E_Constant);
end if; 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); Prepend_To (Stats, Decl);
end if;
end Handle_Of; end Handle_Of;
-- X in Iterate (S) : type of iterator is type of explicitly -- X in Iterate (S) : type of iterator is type of explicitly
...@@ -3522,21 +3837,6 @@ package body Exp_Ch5 is ...@@ -3522,21 +3837,6 @@ package body Exp_Ch5 is
Iterator := Make_Temporary (Loc, 'I'); 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 -- For both iterator forms, add a call to the step operation to
-- advance the cursor. Generate: -- advance the cursor. Generate:
...@@ -3546,6 +3846,22 @@ package body Exp_Ch5 is ...@@ -3546,6 +3846,22 @@ package body Exp_Ch5 is
-- Cursor := Next (Cursor); -- 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 declare
Rhs : Node_Id; Rhs : Node_Id;
...@@ -3565,9 +3881,10 @@ package body Exp_Ch5 is ...@@ -3565,9 +3881,10 @@ package body Exp_Ch5 is
Expression => Rhs)); Expression => Rhs));
Set_Assignment_OK (Name (Last (Stats))); Set_Assignment_OK (Name (Last (Stats)));
end; end;
end if;
-- Generate: -- Generate:
-- while Iterator.Has_Element loop -- while Has_Element (Cursor) loop
-- <Stats> -- <Stats>
-- end loop; -- end loop;
...@@ -3596,13 +3913,9 @@ package body Exp_Ch5 is ...@@ -3596,13 +3913,9 @@ package body Exp_Ch5 is
end if; end if;
-- Create the declarations for Iterator and cursor and insert them -- Create the declarations for Iterator and cursor and insert them
-- before the source loop. Given that the domain of iteration is -- before the source loop. Given that the domain of iteration is already
-- already an entity, the iterator is just a renaming of that -- an entity, the iterator is just a renaming of that entity. Possible
-- entity. Possible optimization ??? -- optimization ???
-- Generate:
-- I : Iterator_Type renames Container;
-- C : Cursor_Type := Container.[First | Last];
Insert_Action (N, Insert_Action (N,
Make_Object_Renaming_Declaration (Loc, Make_Object_Renaming_Declaration (Loc,
...@@ -3613,10 +3926,7 @@ package body Exp_Ch5 is ...@@ -3613,10 +3926,7 @@ package body Exp_Ch5 is
-- Create declaration for cursor -- Create declaration for cursor
declare declare
Decl : Node_Id; Cursor_Decl : constant Node_Id :=
begin
Decl :=
Make_Object_Declaration (Loc, Make_Object_Declaration (Loc,
Defining_Identifier => Cursor, Defining_Identifier => Cursor,
Object_Definition => Object_Definition =>
...@@ -3627,191 +3937,32 @@ package body Exp_Ch5 is ...@@ -3627,191 +3937,32 @@ package body Exp_Ch5 is
Selector_Name => Selector_Name =>
Make_Identifier (Loc, Name_Init))); Make_Identifier (Loc, Name_Init)));
begin
-- The cursor is only modified in expanded code, so it appears -- The cursor is only modified in expanded code, so it appears
-- as unassigned to the warning machinery. We must suppress -- as unassigned to the warning machinery. We must suppress this
-- this spurious warning explicitly. The cursor's kind is that of -- spurious warning explicitly. The cursor's kind is that of the
-- the original loop parameter (it is a constant if the domain of -- original loop parameter (it is a constant if the domain of
-- iteration is constant). -- iteration is constant).
Set_Warnings_Off (Cursor); Set_Warnings_Off (Cursor);
Set_Assignment_OK (Decl); Set_Assignment_OK (Cursor_Decl);
Insert_Action (N, Decl); Insert_Action (N, Cursor_Decl);
Set_Ekind (Cursor, I_Kind); Set_Ekind (Cursor, I_Kind);
end; end;
-- If the range of iteration is given by a function call that -- If the range of iteration is given by a function call that returns
-- returns a container, the finalization actions have been saved -- a container, the finalization actions have been saved in the
-- in the Condition_Actions of the iterator. Insert them now at -- Condition_Actions of the iterator. Insert them now at the head of
-- the head of the loop. -- the loop.
if Present (Condition_Actions (Isc)) then if Present (Condition_Actions (Isc)) then
Insert_List_Before (N, Condition_Actions (Isc)); Insert_List_Before (N, Condition_Actions (Isc));
end if; end if;
end;
Rewrite (N, New_Loop); Rewrite (N, New_Loop);
Analyze (N); Analyze (N);
end Expand_Iterator_Loop; end Expand_Iterator_Loop_Over_Container;
-------------------------------------
-- Expand_Iterator_Loop_Over_Array --
-------------------------------------
procedure Expand_Iterator_Loop_Over_Array (N : Node_Id) is
Isc : constant Node_Id := Iteration_Scheme (N);
I_Spec : constant Node_Id := Iterator_Specification (Isc);
Array_Node : constant Node_Id := Name (I_Spec);
Array_Typ : constant Entity_Id := Base_Type (Etype (Array_Node));
Array_Dim : constant Pos := Number_Dimensions (Array_Typ);
Id : constant Entity_Id := Defining_Identifier (I_Spec);
Loc : constant Source_Ptr := Sloc (N);
Stats : constant List_Id := Statements (N);
Core_Loop : Node_Id;
Dim1 : Int;
Ind_Comp : Node_Id;
Iterator : Entity_Id;
-- Start of processing for Expand_Iterator_Loop_Over_Array
begin
-- for Element of Array loop
-- This case requires an internally generated cursor to iterate over
-- the array.
if Of_Present (I_Spec) then
Iterator := Make_Temporary (Loc, 'C');
-- Generate:
-- Element : Component_Type renames Array (Iterator);
-- Iterator is the index value, or a list of index values
-- in the case of a multidimensional array.
Ind_Comp :=
Make_Indexed_Component (Loc,
Prefix => Relocate_Node (Array_Node),
Expressions => New_List (New_Occurrence_Of (Iterator, Loc)));
Prepend_To (Stats,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Id,
Subtype_Mark =>
New_Occurrence_Of (Component_Type (Array_Typ), Loc),
Name => Ind_Comp));
-- Mark the loop variable as needing debug info, so that expansion
-- of the renaming will result in Materialize_Entity getting set via
-- Debug_Renaming_Declaration. (This setting is needed here because
-- the setting in Freeze_Entity comes after the expansion, which is
-- too late. ???)
Set_Debug_Info_Needed (Id);
-- for Index in Array loop
-- This case utilizes the already given iterator name
else
Iterator := Id;
end if;
-- Generate:
-- for Iterator in [reverse] Array'Range (Array_Dim) loop
-- Element : Component_Type renames Array (Iterator);
-- <original loop statements>
-- end loop;
-- If this is an iteration over a multidimensional array, the
-- innermost loop is over the last dimension in Ada, and over
-- the first dimension in Fortran.
if Convention (Array_Typ) = Convention_Fortran then
Dim1 := 1;
else
Dim1 := Array_Dim;
end if;
Core_Loop :=
Make_Loop_Statement (Loc,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Array_Node),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim1))),
Reverse_Present => Reverse_Present (I_Spec))),
Statements => Stats,
End_Label => Empty);
-- Processing for multidimensional array. The body of each loop is
-- a loop over a previous dimension, going in decreasing order in Ada
-- and in increasing order in Fortran.
if Array_Dim > 1 then
for Dim in 1 .. Array_Dim - 1 loop
if Convention (Array_Typ) = Convention_Fortran then
Dim1 := Dim + 1;
else
Dim1 := Array_Dim - Dim;
end if;
Iterator := Make_Temporary (Loc, 'C');
-- Generate the dimension loops starting from the innermost one
-- for Iterator in [reverse] Array'Range (Array_Dim - Dim) loop
-- <core loop>
-- end loop;
Core_Loop :=
Make_Loop_Statement (Loc,
Iteration_Scheme =>
Make_Iteration_Scheme (Loc,
Loop_Parameter_Specification =>
Make_Loop_Parameter_Specification (Loc,
Defining_Identifier => Iterator,
Discrete_Subtype_Definition =>
Make_Attribute_Reference (Loc,
Prefix => Relocate_Node (Array_Node),
Attribute_Name => Name_Range,
Expressions => New_List (
Make_Integer_Literal (Loc, Dim1))),
Reverse_Present => Reverse_Present (I_Spec))),
Statements => New_List (Core_Loop),
End_Label => Empty);
-- Update the previously created object renaming declaration with
-- the new iterator, by adding the index of the next loop to the
-- indexed component, in the order that corresponds to the
-- convention.
if Convention (Array_Typ) = Convention_Fortran then
Append_To (Expressions (Ind_Comp),
New_Occurrence_Of (Iterator, Loc));
else
Prepend_To (Expressions (Ind_Comp),
New_Occurrence_Of (Iterator, Loc));
end if;
end loop;
end if;
-- Inherit the loop identifier from the original loop. This ensures that
-- the scope stack is consistent after the rewriting.
if Present (Identifier (N)) then
Set_Identifier (Core_Loop, Relocate_Node (Identifier (N)));
end if;
Rewrite (N, Core_Loop);
Analyze (N);
end Expand_Iterator_Loop_Over_Array;
----------------------------- -----------------------------
-- Expand_N_Loop_Statement -- -- Expand_N_Loop_Statement --
......
gcc/ada/exp_unst.adb
...@@ -42,138 +42,19 @@ with Sem_Util; use Sem_Util; ...@@ -42,138 +42,19 @@ with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo; with Sinfo; use Sinfo;
with Sinput; use Sinput; with Sinput; use Sinput;
with Snames; use Snames; with Snames; use Snames;
with Table;
with Tbuild; use Tbuild; with Tbuild; use Tbuild;
with Uintp; use Uintp; with Uintp; use Uintp;
package body Exp_Unst is 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 -- -- Calls --
----------- -----------
-- Table to record calls within the nest being analyzed. These are the -- 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 type Call_Entry is record
N : Node_Id; N : Node_Id;
...@@ -207,7 +88,9 @@ package body Exp_Unst is ...@@ -207,7 +88,9 @@ package body Exp_Unst is
-- constants, formal parameters). These are the references that will -- constants, formal parameters). These are the references that will
-- need rewriting to use the activation table (AREC) pointers. Also -- need rewriting to use the activation table (AREC) pointers. Also
-- included are implicit and explicit uplevel references to types, but -- 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 type Uref_Entry is record
Ref : Node_Id; Ref : Node_Id;
...@@ -257,6 +140,10 @@ package body Exp_Unst is ...@@ -257,6 +140,10 @@ package body Exp_Unst is
function Subp_Index (Sub : Entity_Id) return SI_Type; function Subp_Index (Sub : Entity_Id) return SI_Type;
-- Given the entity for a subprogram, return corresponding Subps index -- 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; 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 -- This function returns the name to be used in the activation record to
-- reference the variable uplevel. Clist is the list of components that -- reference the variable uplevel. Clist is the list of components that
...@@ -299,7 +186,6 @@ package body Exp_Unst is ...@@ -299,7 +186,6 @@ package body Exp_Unst is
function Get_Level (Sub : Entity_Id) return Nat is function Get_Level (Sub : Entity_Id) return Nat is
Lev : Nat; Lev : Nat;
S : Entity_Id; S : Entity_Id;
begin begin
Lev := 1; Lev := 1;
S := Sub; S := Sub;
...@@ -323,25 +209,31 @@ package body Exp_Unst is ...@@ -323,25 +209,31 @@ package body Exp_Unst is
return SI_Type (UI_To_Int (Subps_Index (Sub))); return SI_Type (UI_To_Int (Subps_Index (Sub)));
end Subp_Index; 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 -- -- Upref_Name --
---------------- ----------------
function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id is function Upref_Name (Ent : Entity_Id; Clist : List_Id) return Name_Id is
C : Node_Id; C : Node_Id;
begin begin
C := First (Clist); C := First (Clist);
loop loop
if No (C) then if No (C) then
return Chars (Ent); return Chars (Ent);
elsif Chars (Defining_Identifier (C)) = Chars (Ent) then elsif Chars (Defining_Identifier (C)) = Chars (Ent) then
Get_Name_String (Chars (Ent)); return Suffixed_Name (Ent);
Add_Str_To_Name_Buffer ("__");
Add_Nat_To_Name_Buffer (Nat (Ent));
return Name_Enter;
else else
Next (C); Next (C);
end if; end if;
...@@ -383,7 +275,7 @@ package body Exp_Unst is ...@@ -383,7 +275,7 @@ package body Exp_Unst is
-- First populate the above tables -- First populate the above tables
Subps.Init; Subps_First := Subps.Last + 1;
Calls.Init; Calls.Init;
Urefs.Init; Urefs.Init;
...@@ -637,6 +529,7 @@ package body Exp_Unst is ...@@ -637,6 +529,7 @@ package body Exp_Unst is
Uplevel_Ref => L, Uplevel_Ref => L,
Declares_AREC => False, Declares_AREC => False,
Uents => No_Elist, Uents => No_Elist,
Last => 0,
ARECnF => Empty, ARECnF => Empty,
ARECn => Empty, ARECn => Empty,
ARECnT => Empty, ARECnT => Empty,
...@@ -907,7 +800,7 @@ package body Exp_Unst is ...@@ -907,7 +800,7 @@ package body Exp_Unst is
begin begin
New_SI := 0; New_SI := 0;
for J in Subps.First .. Subps.Last loop for J in Subps_First .. Subps.Last loop
declare declare
STJ : Subp_Entry renames Subps.Table (J); STJ : Subp_Entry renames Subps.Table (J);
Spec : Node_Id; Spec : Node_Id;
...@@ -1040,11 +933,16 @@ package body Exp_Unst is ...@@ -1040,11 +933,16 @@ package body Exp_Unst is
end; end;
end loop; 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 -- 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 -- at the start so that all the entities are defined, regardless of the
-- order in which we do the code insertions. -- 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 declare
STJ : Subp_Entry renames Subps.Table (J); STJ : Subp_Entry renames Subps.Table (J);
Loc : constant Source_Ptr := Sloc (STJ.Bod); Loc : constant Source_Ptr := Sloc (STJ.Bod);
...@@ -1093,7 +991,7 @@ package body Exp_Unst is ...@@ -1093,7 +991,7 @@ package body Exp_Unst is
Addr : constant Entity_Id := RTE (RE_Address); Addr : constant Entity_Id := RTE (RE_Address);
begin begin
for J in Subps.First .. Subps.Last loop for J in Subps_First .. Subps.Last loop
declare declare
STJ : Subp_Entry renames Subps.Table (J); STJ : Subp_Entry renames Subps.Table (J);
...@@ -1193,27 +1091,39 @@ package body Exp_Unst is ...@@ -1193,27 +1091,39 @@ package body Exp_Unst is
Comp : Entity_Id; Comp : Entity_Id;
Decl_ARECnT : Node_Id; Decl_ARECnT : Node_Id;
Decl_ARECn : Node_Id;
Decl_ARECnPT : Node_Id; Decl_ARECnPT : Node_Id;
Decl_ARECn : Node_Id;
Decl_ARECnP : Node_Id; Decl_ARECnP : Node_Id;
-- Declaration nodes for the AREC entities we build -- 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 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 -- Build list of component declarations for ARECnT
Clist := Empty_List; Clist := Empty_List;
-- If we are in a subprogram that has a static link that -- If we are in a subprogram that has a static link that
-- is passed in (as indicated by ARECnF being defined), -- is passed in (as indicated by ARECnF being defined),
-- then include ARECnU : ARECnPT := ARECnF where n is -- then include ARECnU : ARECmPT where m is one less than
-- one less than the current level and the entity ARECnPT -- the current level and the entity ARECnPT comes from
-- comes from the enclosing subprogram. -- the enclosing subprogram.
if Present (STJ.ARECnF) then if Present (STJ.ARECnF) then
declare declare
STJE : Subp_Entry STJE : Subp_Entry
renames Subps.Table (Enclosing_Subp (J)); renames Subps.Table (Enclosing_Subp (J));
begin begin
Append_To (Clist, Append_To (Clist,
Make_Component_Declaration (Loc, Make_Component_Declaration (Loc,
...@@ -1221,9 +1131,7 @@ package body Exp_Unst is ...@@ -1221,9 +1131,7 @@ package body Exp_Unst is
Component_Definition => Component_Definition =>
Make_Component_Definition (Loc, Make_Component_Definition (Loc,
Subtype_Indication => Subtype_Indication =>
New_Occurrence_Of (STJE.ARECnPT, Loc)), New_Occurrence_Of (STJE.ARECnPT, Loc))));
Expression =>
New_Occurrence_Of (STJ.ARECnF, Loc)));
end; end;
end if; end if;
...@@ -1271,15 +1179,7 @@ package body Exp_Unst is ...@@ -1271,15 +1179,7 @@ package body Exp_Unst is
Component_List => Component_List =>
Make_Component_List (Loc, Make_Component_List (Loc,
Component_Items => Clist))); Component_Items => Clist)));
Decls := New_List (Decl_ARECnT);
-- ARECn : aliased ARECnT;
Decl_ARECn :=
Make_Object_Declaration (Loc,
Defining_Identifier => STJ.ARECn,
Aliased_Present => True,
Object_Definition =>
New_Occurrence_Of (STJ.ARECnT, Loc));
-- type ARECnPT is access all ARECnT; -- type ARECnPT is access all ARECnT;
...@@ -1291,6 +1191,17 @@ package body Exp_Unst is ...@@ -1291,6 +1191,17 @@ package body Exp_Unst is
All_Present => True, All_Present => True,
Subtype_Indication => Subtype_Indication =>
New_Occurrence_Of (STJ.ARECnT, Loc))); 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; -- ARECnP : constant ARECnPT := ARECn'Access;
...@@ -1305,10 +1216,31 @@ package body Exp_Unst is ...@@ -1305,10 +1216,31 @@ package body Exp_Unst is
Prefix => Prefix =>
New_Occurrence_Of (STJ.ARECn, Loc), New_Occurrence_Of (STJ.ARECn, Loc),
Attribute_Name => Name_Access)); Attribute_Name => Name_Access));
Append_To (Decls, 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);
Prepend_List_To (Declarations (STJ.Bod), else
New_List Decl_Assign := Empty;
(Decl_ARECnT, Decl_ARECn, Decl_ARECnPT, Decl_ARECnP)); end if;
Prepend_List_To (Declarations (STJ.Bod), Decls);
-- Analyze the newly inserted declarations. Note that we -- Analyze the newly inserted declarations. Note that we
-- do not need to establish the whole scope stack, since -- do not need to establish the whole scope stack, since
...@@ -1322,9 +1254,14 @@ package body Exp_Unst is ...@@ -1322,9 +1254,14 @@ package body Exp_Unst is
Push_Scope (STJ.Ent); Push_Scope (STJ.Ent);
Analyze (Decl_ARECnT, Suppress => All_Checks); Analyze (Decl_ARECnT, Suppress => All_Checks);
Analyze (Decl_ARECn, Suppress => All_Checks);
Analyze (Decl_ARECnPT, Suppress => All_Checks); Analyze (Decl_ARECnPT, Suppress => All_Checks);
Analyze (Decl_ARECn, Suppress => All_Checks);
Analyze (Decl_ARECnP, Suppress => All_Checks); Analyze (Decl_ARECnP, Suppress => All_Checks);
if Present (Decl_Assign) then
Analyze (Decl_Assign, Suppress => All_Checks);
end if;
Pop_Scope; Pop_Scope;
-- Mark the types as needing typedefs -- Mark the types as needing typedefs
...@@ -1521,15 +1458,22 @@ package body Exp_Unst is ...@@ -1521,15 +1458,22 @@ package body Exp_Unst is
-- (((AREC5F.AREC4U).AREC3U).AREC2U).X -- (((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; SI := RS_Caller;
for L in STJE.Lev .. STJR.Lev - 2 loop for L in STJE.Lev .. STJR.Lev - 2 loop
SI := Enclosing_Subp (SI); SI := Enclosing_Subp (SI);
Pfx := Pfx :=
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Selected_Component (Loc, Make_Selected_Component (Loc,
Prefix => Pfx, Prefix => Pfx,
Selector_Name => Selector_Name =>
New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)); New_Occurrence_Of (Subps.Table (SI).ARECnU, Loc)));
end loop; end loop;
-- Get activation record component (must exist) -- Get activation record component (must exist)
......
gcc/ada/exp_unst.ads
...@@ -25,6 +25,7 @@ ...@@ -25,6 +25,7 @@
-- Expand routines for unnesting subprograms -- Expand routines for unnesting subprograms
with Table;
with Types; use Types; with Types; use Types;
package Exp_Unst is package Exp_Unst is
...@@ -175,9 +176,9 @@ package Exp_Unst is ...@@ -175,9 +176,9 @@ package Exp_Unst is
-- rv : Address; -- rv : Address;
-- end record; -- end record;
-- AREC1 : aliased AREC1T;
-- type AREC1PT is access all AREC1T; -- type AREC1PT is access all AREC1T;
-- AREC1 : aliased AREC1T;
-- AREC1P : constant AREC1PT := AREC1'Access; -- AREC1P : constant AREC1PT := AREC1'Access;
-- The fields of AREC1 are set at the point the corresponding entity -- The fields of AREC1 are set at the point the corresponding entity
...@@ -213,8 +214,9 @@ package Exp_Unst is ...@@ -213,8 +214,9 @@ package Exp_Unst is
-- rv : Address; -- rv : Address;
-- end record; -- end record;
-- --
-- AREC1 : aliased AREC1T;
-- type AREC1PT is access all AREC1T; -- type AREC1PT is access all AREC1T;
--
-- AREC1 : aliased AREC1T;
-- AREC1P : constant AREC1PT := AREC1'Access; -- AREC1P : constant AREC1PT := AREC1'Access;
-- --
-- AREC1.b := b'Address; -- AREC1.b := b'Address;
...@@ -362,8 +364,9 @@ package Exp_Unst is ...@@ -362,8 +364,9 @@ package Exp_Unst is
-- dynam_LAST : Address; -- dynam_LAST : Address;
-- end record; -- end record;
-- --
-- AREC1 : aliased AREC1T;
-- type AREC1PT is access all AREC1T; -- type AREC1PT is access all AREC1T;
--
-- AREC1 : aliased AREC1T;
-- AREC1P : constant AREC1PT := AREC1'Access; -- AREC1P : constant AREC1PT := AREC1'Access;
-- --
-- AREC1.x := x'Address; -- AREC1.x := x'Address;
...@@ -422,8 +425,9 @@ package Exp_Unst is ...@@ -422,8 +425,9 @@ package Exp_Unst is
-- v1 : Address; -- v1 : Address;
-- end record; -- end record;
-- --
-- AREC1 : aliased AREC1T;
-- type AREC1PT is access all AREC1T; -- type AREC1PT is access all AREC1T;
--
-- AREC1 : aliased AREC1T;
-- AREC1P : constant AREC1PT := AREC1'Access; -- AREC1P : constant AREC1PT := AREC1'Access;
-- --
-- v1 : integer := x; -- v1 : integer := x;
...@@ -431,14 +435,17 @@ package Exp_Unst is ...@@ -431,14 +435,17 @@ package Exp_Unst is
-- --
-- function inner1 (y : integer; AREC1F : AREC1PT) return integer is -- function inner1 (y : integer; AREC1F : AREC1PT) return integer is
-- type AREC2T is record -- type AREC2T is record
-- AREC1U : AREC1PT := AREC1F; -- AREC1U : AREC1PT;
-- v2 : Address; -- v2 : Address;
-- end record; -- end record;
-- --
-- AREC2 : aliased AREC2T;
-- type AREC2PT is access all AREC2T; -- type AREC2PT is access all AREC2T;
--
-- AREC2 : aliased AREC2T;
-- AREC2P : constant AREC2PT := AREC2'Access; -- AREC2P : constant AREC2PT := AREC2'Access;
-- --
-- AREC2.AREC1U := AREC1F;
--
-- v2 : integer := Integer'Deref (AREC1F.v1) {+} 1; -- v2 : integer := Integer'Deref (AREC1F.v1) {+} 1;
-- AREC2.v2 := v2'Address; -- AREC2.v2 := v2'Address;
-- --
...@@ -525,6 +532,148 @@ package Exp_Unst is ...@@ -525,6 +532,148 @@ package Exp_Unst is
-- with the issue of clashing names (mnames__inner, mnames__inner__inner), -- with the issue of clashing names (mnames__inner, mnames__inner__inner),
-- and with overloading (mnames__f, mnames__f__2). -- 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 -- -- Subprograms --
----------------- -----------------
......
gcc/ada/snames.ads-tmpl
...@@ -120,7 +120,7 @@ package Snames is ...@@ -120,7 +120,7 @@ package Snames is
Name_uY : constant Name_Id := First_Name_Id + Character'Pos ('Y'); Name_uY : constant Name_Id := First_Name_Id + Character'Pos ('Y');
Name_uZ : constant Name_Id := First_Name_Id + Character'Pos ('Z'); 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. -- its format should not be changed without coordinating with this program.
N : constant Name_Id := First_Name_Id + 256; N : constant Name_Id := First_Name_Id + 256;
...@@ -1411,6 +1411,9 @@ package Snames is ...@@ -1411,6 +1411,9 @@ package Snames is
Name_Forward_Iterator : constant Name_Id := N + $; Name_Forward_Iterator : constant Name_Id := N + $;
Name_Reversible_Iterator : constant Name_Id := N + $; Name_Reversible_Iterator : constant Name_Id := N + $;
Name_Previous : 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 -- Ada 2005 reserved words
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment