blob: fd4c543ddfcbc4fd269e56d1f38a0a14281fdab5 [file] [log] [blame]
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
-- E X P _ U N S T --
-- --
-- B o d y --
-- --
-- Copyright (C) 2014-2022, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
-- ware Foundation; either version 3, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING3. If not, go to --
-- http://www.gnu.org/licenses for a complete copy of the license. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Atree; use Atree;
with Debug; use Debug;
with Einfo; use Einfo;
with Einfo.Entities; use Einfo.Entities;
with Einfo.Utils; use Einfo.Utils;
with Elists; use Elists;
with Exp_Util; use Exp_Util;
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
with Nmake; use Nmake;
with Opt;
with Output; use Output;
with Rtsfind; use Rtsfind;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Mech; use Sem_Mech;
with Sem_Res; use Sem_Res;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Sinput; use Sinput;
with Snames; use Snames;
with Stand; use Stand;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
package body Exp_Unst is
-----------------------
-- Local Subprograms --
-----------------------
procedure Unnest_Subprogram
(Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False);
-- Subp is a library-level subprogram which has nested subprograms, and
-- Subp_Body is the corresponding N_Subprogram_Body node. This procedure
-- declares the AREC types and objects, adds assignments to the AREC record
-- as required, defines the xxxPTR types for uplevel referenced objects,
-- adds the ARECP parameter to all nested subprograms which need it, and
-- modifies all uplevel references appropriately. If For_Inline is True,
-- we're unnesting this subprogram because it's on the list of inlined
-- subprograms and should unnest it despite it not being part of the main
-- unit.
-----------
-- Calls --
-----------
-- Table to record calls within the nest being analyzed. These are the
-- 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;
-- The actual call
Caller : Entity_Id;
-- Entity of the subprogram containing the call (can be at any level)
Callee : Entity_Id;
-- Entity of the subprogram called (always at level 2 or higher). Note
-- that in accordance with the basic rules of nesting, the level of To
-- is either less than or equal to the level of From, or one greater.
end record;
package Calls is new Table.Table (
Table_Component_Type => Call_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Unnest_Calls");
-- Records each call within the outer subprogram and all nested subprograms
-- that are to other subprograms nested within the outer subprogram. These
-- are the calls that may need an additional parameter.
procedure Append_Unique_Call (Call : Call_Entry);
-- Append a call entry to the Calls table. A check is made to see if the
-- table already contains this entry and if so it has no effect.
----------------------------------
-- Subprograms For Fat Pointers --
----------------------------------
function Build_Access_Type_Decl
(E : Entity_Id;
Scop : Entity_Id) return Node_Id;
-- For an uplevel reference that involves an unconstrained array type,
-- build an access type declaration for the corresponding activation
-- record component. The relevant attributes of the access type are
-- set here to avoid a full analysis that would require a scope stack.
function Needs_Fat_Pointer (E : Entity_Id) return Boolean;
-- A formal parameter of an unconstrained array type that appears in an
-- uplevel reference requires the construction of an access type, to be
-- used in the corresponding component declaration.
-----------
-- Urefs --
-----------
-- Table to record explicit uplevel references to objects (variables,
-- 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. 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;
-- The reference itself. For objects this is always an entity reference
-- and the referenced entity will have its Is_Uplevel_Referenced_Entity
-- flag set and will appear in the Uplevel_Referenced_Entities list of
-- the subprogram declaring this entity.
Ent : Entity_Id;
-- The Entity_Id of the uplevel referenced object or type
Caller : Entity_Id;
-- The entity for the subprogram immediately containing this entity
Callee : Entity_Id;
-- The entity for the subprogram containing the referenced entity. Note
-- that the level of Callee must be less than the level of Caller, since
-- this is an uplevel reference.
end record;
package Urefs is new Table.Table (
Table_Component_Type => Uref_Entry,
Table_Index_Type => Nat,
Table_Low_Bound => 1,
Table_Initial => 100,
Table_Increment => 200,
Table_Name => "Unnest_Urefs");
------------------------
-- Append_Unique_Call --
------------------------
procedure Append_Unique_Call (Call : Call_Entry) is
begin
for J in Calls.First .. Calls.Last loop
if Calls.Table (J) = Call then
return;
end if;
end loop;
Calls.Append (Call);
end Append_Unique_Call;
-----------------------------
-- Build_Access_Type_Decl --
-----------------------------
function Build_Access_Type_Decl
(E : Entity_Id;
Scop : Entity_Id) return Node_Id
is
Loc : constant Source_Ptr := Sloc (E);
Typ : Entity_Id;
begin
Typ := Make_Temporary (Loc, 'S');
Mutate_Ekind (Typ, E_General_Access_Type);
Set_Etype (Typ, Typ);
Set_Scope (Typ, Scop);
Set_Directly_Designated_Type (Typ, Etype (E));
return
Make_Full_Type_Declaration (Loc,
Defining_Identifier => Typ,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
Subtype_Indication => New_Occurrence_Of (Etype (E), Loc)));
end Build_Access_Type_Decl;
---------------
-- Get_Level --
---------------
function Get_Level (Subp : Entity_Id; Sub : Entity_Id) return Nat is
Lev : Nat;
S : Entity_Id;
begin
Lev := 1;
S := Sub;
loop
if S = Subp then
return Lev;
else
Lev := Lev + 1;
S := Enclosing_Subprogram (S);
end if;
end loop;
end Get_Level;
--------------------------
-- In_Synchronized_Unit --
--------------------------
function In_Synchronized_Unit (Subp : Entity_Id) return Boolean is
S : Entity_Id := Scope (Subp);
begin
while Present (S) and then S /= Standard_Standard loop
if Is_Concurrent_Type (S) then
return True;
elsif Is_Private_Type (S)
and then Present (Full_View (S))
and then Is_Concurrent_Type (Full_View (S))
then
return True;
end if;
S := Scope (S);
end loop;
return False;
end In_Synchronized_Unit;
-----------------------
-- Needs_Fat_Pointer --
-----------------------
function Needs_Fat_Pointer (E : Entity_Id) return Boolean is
Typ : constant Entity_Id := Get_Fullest_View (Etype (E));
begin
return Is_Array_Type (Typ) and then not Is_Constrained (Typ);
end Needs_Fat_Pointer;
----------------
-- Subp_Index --
----------------
function Subp_Index (Sub : Entity_Id) return SI_Type is
E : Entity_Id := Sub;
begin
pragma Assert (Is_Subprogram (E));
if Field_Is_Initial_Zero (E, F_Subps_Index)
or else Subps_Index (E) = Uint_0
then
E := Ultimate_Alias (E);
-- The body of a protected operation has a different name and
-- has been scanned at this point, and thus has an entry in the
-- subprogram table.
if E = Sub and then Present (Protected_Body_Subprogram (E)) then
E := Protected_Body_Subprogram (E);
end if;
if Ekind (E) = E_Function
and then Rewritten_For_C (E)
and then Present (Corresponding_Procedure (E))
then
E := Corresponding_Procedure (E);
end if;
end if;
pragma Assert (Subps_Index (E) /= Uint_0);
return SI_Type (UI_To_Int (Subps_Index (E)));
end Subp_Index;
-----------------------
-- Unnest_Subprogram --
-----------------------
procedure Unnest_Subprogram
(Subp : Entity_Id; Subp_Body : Node_Id; For_Inline : Boolean := False) is
function AREC_Name (J : Pos; S : String) return Name_Id;
-- Returns name for string ARECjS, where j is the decimal value of j
function Enclosing_Subp (Subp : SI_Type) return SI_Type;
-- Subp is the index of a subprogram which has a Lev greater than 1.
-- This function returns the index of the enclosing subprogram which
-- will have a Lev value one less than this.
function Img_Pos (N : Pos) return String;
-- Return image of N without leading blank
function Upref_Name
(Ent : Entity_Id;
Index : Pos;
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
-- have been created in the activation record so far. Normally the name
-- is just a copy of the Chars field of the entity. The exception is
-- when the name has already been used, in which case we suffix the name
-- with the index value Index to avoid duplication. This happens with
-- declare blocks and generic parameters at least.
---------------
-- AREC_Name --
---------------
function AREC_Name (J : Pos; S : String) return Name_Id is
begin
return Name_Find ("AREC" & Img_Pos (J) & S);
end AREC_Name;
--------------------
-- Enclosing_Subp --
--------------------
function Enclosing_Subp (Subp : SI_Type) return SI_Type is
STJ : Subp_Entry renames Subps.Table (Subp);
Ret : constant SI_Type := Subp_Index (Enclosing_Subprogram (STJ.Ent));
begin
pragma Assert (STJ.Lev > 1);
pragma Assert (Subps.Table (Ret).Lev = STJ.Lev - 1);
return Ret;
end Enclosing_Subp;
-------------
-- Img_Pos --
-------------
function Img_Pos (N : Pos) return String is
Buf : String (1 .. 20);
Ptr : Natural;
NV : Nat;
begin
Ptr := Buf'Last;
NV := N;
while NV /= 0 loop
Buf (Ptr) := Character'Val (48 + NV mod 10);
Ptr := Ptr - 1;
NV := NV / 10;
end loop;
return Buf (Ptr + 1 .. Buf'Last);
end Img_Pos;
----------------
-- Upref_Name --
----------------
function Upref_Name
(Ent : Entity_Id;
Index : Pos;
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
return
Name_Find (Get_Name_String (Chars (Ent)) & Img_Pos (Index));
else
Next (C);
end if;
end loop;
end Upref_Name;
-- Start of processing for Unnest_Subprogram
begin
-- Nothing to do inside a generic (all processing is for instance)
if Inside_A_Generic then
return;
end if;
-- If the main unit is a package body then we need to examine the spec
-- to determine whether the main unit is generic (the scope stack is not
-- present when this is called on the main unit).
if not For_Inline
and then Ekind (Cunit_Entity (Main_Unit)) = E_Package_Body
and then Is_Generic_Unit (Spec_Entity (Cunit_Entity (Main_Unit)))
then
return;
-- Only unnest when generating code for the main source unit or if
-- we're unnesting for inline. But in some Annex E cases the Sloc
-- points to a different unit, so also make sure that the Parent
-- isn't in something that we know we're generating code for.
elsif not For_Inline
and then not In_Extended_Main_Code_Unit (Subp_Body)
and then not In_Extended_Main_Code_Unit (Parent (Subp_Body))
then
return;
end if;
-- This routine is called late, after the scope stack is gone. The
-- following creates a suitable dummy scope stack to be used for the
-- analyze/expand calls made from this routine.
Push_Scope (Subp);
-- First step, we must mark all nested subprograms that require a static
-- link (activation record) because either they contain explicit uplevel
-- references (as indicated by Is_Uplevel_Referenced_Entity being set at
-- this point), or they make calls to other subprograms in the same nest
-- that require a static link (in which case we set this flag).
-- This is a recursive definition, and to implement this, we have to
-- build a call graph for the set of nested subprograms, and then go
-- over this graph to implement recursively the invariant that if a
-- subprogram has a call to a subprogram requiring a static link, then
-- the calling subprogram requires a static link.
-- First populate the above tables
Subps_First := Subps.Last + 1;
Calls.Init;
Urefs.Init;
Build_Tables : declare
Current_Subprogram : Entity_Id := Empty;
-- When we scan a subprogram body, we set Current_Subprogram to the
-- corresponding entity. This gets recursively saved and restored.
function Visit_Node (N : Node_Id) return Traverse_Result;
-- Visit a single node in Subp
-----------
-- Visit --
-----------
procedure Visit is new Traverse_Proc (Visit_Node);
-- Used to traverse the body of Subp, populating the tables
----------------
-- Visit_Node --
----------------
function Visit_Node (N : Node_Id) return Traverse_Result is
Ent : Entity_Id;
Caller : Entity_Id;
Callee : Entity_Id;
procedure Check_Static_Type
(In_T : Entity_Id;
N : Node_Id;
DT : in out Boolean;
Check_Designated : Boolean := False);
-- Given a type In_T, checks if it is a static type defined as
-- a type with no dynamic bounds in sight. If so, the only
-- action is to set Is_Static_Type True for In_T. If In_T is
-- not a static type, then all types with dynamic bounds
-- associated with In_T are detected, and their bounds are
-- marked as uplevel referenced if not at the library level,
-- and DT is set True. If N is specified, it's the node that
-- will need to be replaced. If not specified, it means we
-- can't do a replacement because the bound is implicit.
-- If Check_Designated is True and In_T or its full view
-- is an access type, check whether the designated type
-- has dynamic bounds.
procedure Note_Uplevel_Ref
(E : Entity_Id;
N : Node_Id;
Caller : Entity_Id;
Callee : Entity_Id);
-- Called when we detect an explicit or implicit uplevel reference
-- from within Caller to entity E declared in Callee. E can be a
-- an object or a type.
procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id);
-- Enter a subprogram whose body is visible or which is a
-- subprogram instance into the subprogram table.
-----------------------
-- Check_Static_Type --
-----------------------
procedure Check_Static_Type
(In_T : Entity_Id;
N : Node_Id;
DT : in out Boolean;
Check_Designated : Boolean := False)
is
T : constant Entity_Id := Get_Fullest_View (In_T);
procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id);
-- N is the bound of a dynamic type. This procedure notes that
-- this bound is uplevel referenced, it can handle references
-- to entities (typically _FIRST and _LAST entities), and also
-- attribute references of the form T'name (name is typically
-- FIRST or LAST) where T is the uplevel referenced bound.
-- Ref, if Present, is the location of the reference to
-- replace.
------------------------
-- Note_Uplevel_Bound --
------------------------
procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id) is
begin
-- Entity name case. Make sure that the entity is declared
-- in a subprogram. This may not be the case for a type in a
-- loop appearing in a precondition.
-- Exclude explicitly discriminants (that can appear
-- in bounds of discriminated components) and enumeration
-- literals.
if Is_Entity_Name (N) then
if Present (Entity (N))
and then not Is_Type (Entity (N))
and then Present (Enclosing_Subprogram (Entity (N)))
and then
Ekind (Entity (N))
not in E_Discriminant | E_Enumeration_Literal
then
Note_Uplevel_Ref
(E => Entity (N),
N => Empty,
Caller => Current_Subprogram,
Callee => Enclosing_Subprogram (Entity (N)));
end if;
-- Attribute or indexed component case
elsif Nkind (N) in
N_Attribute_Reference | N_Indexed_Component
then
Note_Uplevel_Bound (Prefix (N), Ref);
-- The indices of the indexed components, or the
-- associated expressions of an attribute reference,
-- may also involve uplevel references.
declare
Expr : Node_Id;
begin
Expr := First (Expressions (N));
while Present (Expr) loop
Note_Uplevel_Bound (Expr, Ref);
Next (Expr);
end loop;
end;
-- The type of the prefix may be have an uplevel
-- reference if this needs bounds.
if Nkind (N) = N_Attribute_Reference then
declare
Attr : constant Attribute_Id :=
Get_Attribute_Id (Attribute_Name (N));
DT : Boolean := False;
begin
if (Attr = Attribute_First
or else Attr = Attribute_Last
or else Attr = Attribute_Length)
and then Is_Constrained (Etype (Prefix (N)))
then
Check_Static_Type
(Etype (Prefix (N)), Empty, DT);
end if;
end;
end if;
-- Binary operator cases. These can apply to arrays for
-- which we may need bounds.
elsif Nkind (N) in N_Binary_Op then
Note_Uplevel_Bound (Left_Opnd (N), Ref);
Note_Uplevel_Bound (Right_Opnd (N), Ref);
-- Unary operator case
elsif Nkind (N) in N_Unary_Op then
Note_Uplevel_Bound (Right_Opnd (N), Ref);
-- Explicit dereference and selected component case
elsif Nkind (N) in
N_Explicit_Dereference | N_Selected_Component
then
Note_Uplevel_Bound (Prefix (N), Ref);
-- Conditional expressions
elsif Nkind (N) = N_If_Expression then
declare
Expr : Node_Id;
begin
Expr := First (Expressions (N));
while Present (Expr) loop
Note_Uplevel_Bound (Expr, Ref);
Next (Expr);
end loop;
end;
elsif Nkind (N) = N_Case_Expression then
declare
Alternative : Node_Id;
begin
Note_Uplevel_Bound (Expression (N), Ref);
Alternative := First (Alternatives (N));
while Present (Alternative) loop
Note_Uplevel_Bound (Expression (Alternative), Ref);
end loop;
end;
-- Conversion case
elsif Nkind (N) = N_Type_Conversion then
Note_Uplevel_Bound (Expression (N), Ref);
end if;
end Note_Uplevel_Bound;
-- Start of processing for Check_Static_Type
begin
-- If already marked static, immediate return
if Is_Static_Type (T) and then not Check_Designated then
return;
end if;
-- If the type is at library level, always consider it static,
-- since such uplevel references are irrelevant.
if Is_Library_Level_Entity (T) then
Set_Is_Static_Type (T);
return;
end if;
-- Otherwise figure out what the story is with this type
-- For a scalar type, check bounds
if Is_Scalar_Type (T) then
-- If both bounds static, then this is a static type
declare
LB : constant Node_Id := Type_Low_Bound (T);
UB : constant Node_Id := Type_High_Bound (T);
begin
if not Is_Static_Expression (LB) then
Note_Uplevel_Bound (LB, N);
DT := True;
end if;
if not Is_Static_Expression (UB) then
Note_Uplevel_Bound (UB, N);
DT := True;
end if;
end;
-- For record type, check all components and discriminant
-- constraints if present.
elsif Is_Record_Type (T) then
declare
C : Entity_Id;
D : Elmt_Id;
begin
C := First_Component_Or_Discriminant (T);
while Present (C) loop
Check_Static_Type (Etype (C), N, DT);
Next_Component_Or_Discriminant (C);
end loop;
if Has_Discriminants (T)
and then Present (Discriminant_Constraint (T))
then
D := First_Elmt (Discriminant_Constraint (T));
while Present (D) loop
if not Is_Static_Expression (Node (D)) then
Note_Uplevel_Bound (Node (D), N);
DT := True;
end if;
Next_Elmt (D);
end loop;
end if;
end;
-- For array type, check index types and component type
elsif Is_Array_Type (T) then
declare
IX : Node_Id;
begin
Check_Static_Type (Component_Type (T), N, DT);
IX := First_Index (T);
while Present (IX) loop
Check_Static_Type (Etype (IX), N, DT);
Next_Index (IX);
end loop;
end;
-- For private type, examine whether full view is static
elsif Is_Incomplete_Or_Private_Type (T)
and then Present (Full_View (T))
then
Check_Static_Type (Full_View (T), N, DT, Check_Designated);
if Is_Static_Type (Full_View (T)) then
Set_Is_Static_Type (T);
end if;
-- For access types, check designated type when required
elsif Is_Access_Type (T) and then Check_Designated then
Check_Static_Type (Directly_Designated_Type (T), N, DT);
-- For now, ignore other types
else
return;
end if;
if not DT then
Set_Is_Static_Type (T);
end if;
end Check_Static_Type;
----------------------
-- Note_Uplevel_Ref --
----------------------
procedure Note_Uplevel_Ref
(E : Entity_Id;
N : Node_Id;
Caller : Entity_Id;
Callee : Entity_Id)
is
Full_E : Entity_Id := E;
begin
-- Nothing to do for static type
if Is_Static_Type (E) then
return;
end if;
-- Nothing to do if Caller and Callee are the same
if Caller = Callee then
return;
-- Callee may be a function that returns an array, and that has
-- been rewritten as a procedure. If caller is that procedure,
-- nothing to do either.
elsif Ekind (Callee) = E_Function
and then Rewritten_For_C (Callee)
and then Corresponding_Procedure (Callee) = Caller
then
return;
elsif Ekind (Callee) in E_Entry | E_Entry_Family then
return;
end if;
-- We have a new uplevel referenced entity
if Ekind (E) = E_Constant and then Present (Full_View (E)) then
Full_E := Full_View (E);
end if;
-- All we do at this stage is to add the uplevel reference to
-- the table. It's too early to do anything else, since this
-- uplevel reference may come from an unreachable subprogram
-- in which case the entry will be deleted.
Urefs.Append ((N, Full_E, Caller, Callee));
end Note_Uplevel_Ref;
-------------------------
-- Register_Subprogram --
-------------------------
procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is
L : constant Nat := Get_Level (Subp, E);
begin
-- Subprograms declared in tasks and protected types cannot be
-- eliminated because calls to them may be in other units, so
-- they must be treated as reachable.
Subps.Append
((Ent => E,
Bod => Bod,
Lev => L,
Reachable => In_Synchronized_Unit (E)
or else Address_Taken (E),
Uplevel_Ref => L,
Declares_AREC => False,
Uents => No_Elist,
Last => 0,
ARECnF => Empty,
ARECn => Empty,
ARECnT => Empty,
ARECnPT => Empty,
ARECnP => Empty,
ARECnU => Empty));
Set_Subps_Index (E, UI_From_Int (Subps.Last));
-- If we marked this reachable because it's in a synchronized
-- unit, we have to mark all enclosing subprograms as reachable
-- as well. We do the same for subprograms with Address_Taken,
-- because otherwise we can run into problems with looking at
-- enclosing subprograms in Subps.Table due to their being
-- unreachable (the Subp_Index of unreachable subps is later
-- set to zero and their entry in Subps.Table is removed).
if In_Synchronized_Unit (E) or else Address_Taken (E) then
declare
S : Entity_Id := E;
begin
for J in reverse 1 .. L - 1 loop
S := Enclosing_Subprogram (S);
Subps.Table (Subp_Index (S)).Reachable := True;
end loop;
end;
end if;
end Register_Subprogram;
-- Start of processing for Visit_Node
begin
case Nkind (N) is
-- Record a subprogram call
when N_Function_Call
| N_Procedure_Call_Statement
=>
-- We are only interested in direct calls, not indirect
-- calls (where Name (N) is an explicit dereference) at
-- least for now!
if Nkind (Name (N)) in N_Has_Entity then
Ent := Entity (Name (N));
-- We are only interested in calls to subprograms nested
-- within Subp. Calls to Subp itself or to subprograms
-- outside the nested structure do not affect us.
if Is_Subprogram (Ent)
and then not Is_Generic_Subprogram (Ent)
and then not Is_Imported (Ent)
and then not Is_Intrinsic_Subprogram (Ent)
and then Scope_Within (Ultimate_Alias (Ent), Subp)
then
Append_Unique_Call ((N, Current_Subprogram, Ent));
end if;
end if;
-- For all calls where the formal is an unconstrained array
-- and the actual is constrained we need to check the bounds
-- for uplevel references.
declare
Actual : Entity_Id;
DT : Boolean := False;
Formal : Node_Id;
Subp : Entity_Id;
F_Type : Entity_Id;
A_Type : Entity_Id;
begin
if Nkind (Name (N)) = N_Explicit_Dereference then
Subp := Etype (Name (N));
else
Subp := Entity (Name (N));
end if;
Actual := First_Actual (N);
Formal := First_Formal_With_Extras (Subp);
while Present (Actual) loop
F_Type := Get_Fullest_View (Etype (Formal));
A_Type := Get_Fullest_View (Etype (Actual));
if Is_Array_Type (F_Type)
and then not Is_Constrained (F_Type)
and then Is_Constrained (A_Type)
then
Check_Static_Type (A_Type, Empty, DT);
end if;
Next_Actual (Actual);
Next_Formal_With_Extras (Formal);
end loop;
end;
-- An At_End_Proc in a statement sequence indicates that there
-- is a call from the enclosing construct or block to that
-- subprogram. As above, the called entity must be local and
-- not imported.
when N_Handled_Sequence_Of_Statements | N_Block_Statement =>
if Present (At_End_Proc (N))
and then Scope_Within (Entity (At_End_Proc (N)), Subp)
and then not Is_Imported (Entity (At_End_Proc (N)))
then
Append_Unique_Call
((N, Current_Subprogram, Entity (At_End_Proc (N))));
end if;
-- Similarly, the following constructs include a semantic
-- attribute Procedure_To_Call that must be handled like
-- other calls. Likewise for attribute Storage_Pool.
when N_Allocator
| N_Extended_Return_Statement
| N_Free_Statement
| N_Simple_Return_Statement
=>
declare
Pool : constant Entity_Id := Storage_Pool (N);
Proc : constant Entity_Id := Procedure_To_Call (N);
begin
if Present (Proc)
and then Scope_Within (Proc, Subp)
and then not Is_Imported (Proc)
then
Append_Unique_Call ((N, Current_Subprogram, Proc));
end if;
if Present (Pool)
and then not Is_Library_Level_Entity (Pool)
and then Scope_Within_Or_Same (Scope (Pool), Subp)
then
Caller := Current_Subprogram;
Callee := Enclosing_Subprogram (Pool);
if Callee /= Caller then
Note_Uplevel_Ref (Pool, Empty, Caller, Callee);
end if;
end if;
end;
-- For an allocator with a qualified expression, check type
-- of expression being qualified. The explicit type name is
-- handled as an entity reference.
if Nkind (N) = N_Allocator
and then Nkind (Expression (N)) = N_Qualified_Expression
then
declare
DT : Boolean := False;
begin
Check_Static_Type
(Etype (Expression (Expression (N))), Empty, DT);
end;
-- For a Return or Free (all other nodes we handle here),
-- we usually need the size of the object, so we need to be
-- sure that any nonstatic bounds of the expression's type
-- that are uplevel are handled.
elsif Nkind (N) /= N_Allocator
and then Present (Expression (N))
then
declare
DT : Boolean := False;
begin
Check_Static_Type
(Etype (Expression (N)),
Empty,
DT,
Check_Designated => Nkind (N) = N_Free_Statement);
end;
end if;
-- A 'Access reference is a (potential) call. So is 'Address,
-- in particular on imported subprograms. Other attributes
-- require special handling.
when N_Attribute_Reference =>
declare
Attr : constant Attribute_Id :=
Get_Attribute_Id (Attribute_Name (N));
begin
case Attr is
when Attribute_Access
| Attribute_Unchecked_Access
| Attribute_Unrestricted_Access
| Attribute_Address
=>
if Nkind (Prefix (N)) in N_Has_Entity then
Ent := Entity (Prefix (N));
-- We only need to examine calls to subprograms
-- nested within current Subp.
if Scope_Within (Ent, Subp) then
if Is_Imported (Ent) then
null;
elsif Is_Subprogram (Ent) then
Append_Unique_Call
((N, Current_Subprogram, Ent));
end if;
end if;
end if;
-- References to bounds can be uplevel references if
-- the type isn't static.
when Attribute_First
| Attribute_Last
| Attribute_Length
=>
-- Special-case attributes of objects whose bounds
-- may be uplevel references. More complex prefixes
-- handled during full traversal. Note that if the
-- nominal subtype of the prefix is unconstrained,
-- the bound must be obtained from the object, not
-- from the (possibly) uplevel reference. We call
-- Get_Referenced_Object to deal with prefixes that
-- are object renamings (prefixes that are types
-- can be passed and will simply be returned). But
-- it's also legal to get the bounds from the type
-- of the prefix, so we have to handle both cases.
declare
DT : Boolean := False;
begin
if Is_Constrained
(Etype (Get_Referenced_Object (Prefix (N))))
then
Check_Static_Type
(Etype (Get_Referenced_Object (Prefix (N))),
Empty, DT);
end if;
if Is_Constrained (Etype (Prefix (N))) then
Check_Static_Type
(Etype (Prefix (N)), Empty, DT);
end if;
end;
when others =>
null;
end case;
end;
-- Component associations in aggregates are either static or
-- else the aggregate will be expanded into assignments, in
-- which case the expression is analyzed later and provides
-- no relevant code generation.
when N_Component_Association =>
if No (Expression (N))
or else No (Etype (Expression (N)))
then
return Skip;
end if;
-- Generic associations are not analyzed: the actuals are
-- transferred to renaming and subtype declarations that
-- are the ones that must be examined.
when N_Generic_Association =>
return Skip;
-- Indexed references can be uplevel if the type isn't static
-- and if the lower bound (or an inner bound for a multi-
-- dimensional array) is uplevel.
when N_Indexed_Component
| N_Slice
=>
if Is_Constrained (Etype (Prefix (N))) then
declare
DT : Boolean := False;
begin
Check_Static_Type (Etype (Prefix (N)), Empty, DT);
end;
end if;
-- A selected component can have an implicit up-level
-- reference due to the bounds of previous fields in the
-- record. We simplify the processing here by examining
-- all components of the record.
-- Selected components appear as unit names and end labels
-- for child units. Prefixes of these nodes denote parent
-- units and carry no type information so they are skipped.
when N_Selected_Component =>
if Present (Etype (Prefix (N))) then
declare
DT : Boolean := False;
begin
Check_Static_Type (Etype (Prefix (N)), Empty, DT);
end;
end if;
-- For EQ/NE comparisons, we need the type of the operands
-- in order to do the comparison, which means we need the
-- bounds.
when N_Op_Eq
| N_Op_Ne
=>
declare
DT : Boolean := False;
begin
Check_Static_Type (Etype (Left_Opnd (N)), Empty, DT);
Check_Static_Type (Etype (Right_Opnd (N)), Empty, DT);
end;
-- Likewise we need the sizes to compute how much to move in
-- an assignment.
when N_Assignment_Statement =>
declare
DT : Boolean := False;
begin
Check_Static_Type (Etype (Name (N)), Empty, DT);
Check_Static_Type (Etype (Expression (N)), Empty, DT);
end;
-- Record a subprogram. We record a subprogram body that acts
-- as a spec. Otherwise we record a subprogram declaration,
-- providing that it has a corresponding body we can get hold
-- of. The case of no corresponding body being available is
-- ignored for now.
when N_Subprogram_Body =>
Ent := Unique_Defining_Entity (N);
-- Ignore generic subprogram
if Is_Generic_Subprogram (Ent) then
return Skip;
end if;
-- Make new entry in subprogram table if not already made
Register_Subprogram (Ent, N);
-- Record a call from an At_End_Proc
if Present (At_End_Proc (N))
and then Scope_Within (Entity (At_End_Proc (N)), Subp)
and then not Is_Imported (Entity (At_End_Proc (N)))
then
Append_Unique_Call ((N, Ent, Entity (At_End_Proc (N))));
end if;
-- We make a recursive call to scan the subprogram body, so
-- that we can save and restore Current_Subprogram.
declare
Save_CS : constant Entity_Id := Current_Subprogram;
Decl : Node_Id;
begin
Current_Subprogram := Ent;
-- Scan declarations
Decl := First (Declarations (N));
while Present (Decl) loop
Visit (Decl);
Next (Decl);
end loop;
-- Scan statements
Visit (Handled_Statement_Sequence (N));
-- Restore current subprogram setting
Current_Subprogram := Save_CS;
end;
-- Now at this level, return skipping the subprogram body
-- descendants, since we already took care of them!
return Skip;
-- If we have a body stub, visit the associated subunit, which
-- is a semantic descendant of the stub.
when N_Body_Stub =>
Visit (Library_Unit (N));
-- A declaration of a wrapper package indicates a subprogram
-- instance for which there is no explicit body. Enter the
-- subprogram instance in the table.
when N_Package_Declaration =>
if Is_Wrapper_Package (Defining_Entity (N)) then
Register_Subprogram
(Related_Instance (Defining_Entity (N)), Empty);
end if;
-- Skip generic declarations
when N_Generic_Declaration =>
return Skip;
-- Skip generic package body
when N_Package_Body =>
if Present (Corresponding_Spec (N))
and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
then
return Skip;
end if;
-- Pragmas and component declarations are ignored. Quantified
-- expressions are expanded into explicit loops and the
-- original epression must be ignored.
when N_Component_Declaration
| N_Pragma
| N_Quantified_Expression
=>
return Skip;
-- We want to skip the function spec for a generic function
-- to avoid looking at any generic types that might be in
-- its formals.
when N_Function_Specification =>
if Is_Generic_Subprogram (Unique_Defining_Entity (N)) then
return Skip;
end if;
-- Otherwise record an uplevel reference in a local identifier
when others =>
if Nkind (N) in N_Has_Entity
and then Present (Entity (N))
then
Ent := Entity (N);
-- Only interested in entities declared within our nest
if not Is_Library_Level_Entity (Ent)
and then Scope_Within_Or_Same (Scope (Ent), Subp)
-- Skip entities defined in inlined subprograms
and then
Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
-- Constants and variables are potentially uplevel
-- references to global declarations.
and then
(Ekind (Ent) in E_Constant
| E_Loop_Parameter
| E_Variable
-- Formals are interesting, but not if being used
-- as mere names of parameters for name notation
-- calls.
or else
(Is_Formal (Ent)
and then not
(Nkind (Parent (N)) = N_Parameter_Association
and then Selector_Name (Parent (N)) = N))
-- Types other than known Is_Static types are
-- potentially interesting.
or else
(Is_Type (Ent) and then not Is_Static_Type (Ent)))
then
-- Here we have a potentially interesting uplevel
-- reference to examine.
if Is_Type (Ent) then
declare
DT : Boolean := False;
begin
Check_Static_Type (Ent, N, DT);
return OK;
end;
end if;
Caller := Current_Subprogram;
Callee := Enclosing_Subprogram (Ent);
if Callee /= Caller
and then (not Is_Static_Type (Ent)
or else Needs_Fat_Pointer (Ent))
then
Note_Uplevel_Ref (Ent, N, Caller, Callee);
-- Check the type of a formal parameter of the current
-- subprogram, whose formal type may be an uplevel
-- reference.
elsif Is_Formal (Ent)
and then Scope (Ent) = Current_Subprogram
then
declare
DT : Boolean := False;
begin
Check_Static_Type (Etype (Ent), Empty, DT);
end;
end if;
end if;
end if;
end case;
-- Fall through to continue scanning children of this node
return OK;
end Visit_Node;
-- Start of processing for Build_Tables
begin
-- Traverse the body to get subprograms, calls and uplevel references
Visit (Subp_Body);
end Build_Tables;
-- Now do the first transitive closure which determines which
-- subprograms in the nest are actually reachable.
Reachable_Closure : declare
Modified : Boolean;
begin
Subps.Table (Subps_First).Reachable := True;
-- We use a simple minded algorithm as follows (obviously this can
-- be done more efficiently, using one of the standard algorithms
-- for efficient transitive closure computation, but this is simple
-- and most likely fast enough that its speed does not matter).
-- Repeatedly scan the list of calls. Any time we find a call from
-- A to B, where A is reachable, but B is not, then B is reachable,
-- and note that we have made a change by setting Modified True. We
-- repeat this until we make a pass with no modifications.
Outer : loop
Modified := False;
Inner : for J in Calls.First .. Calls.Last loop
declare
CTJ : Call_Entry renames Calls.Table (J);
SINF : constant SI_Type := Subp_Index (CTJ.Caller);
SINT : constant SI_Type := Subp_Index (CTJ.Callee);
SUBF : Subp_Entry renames Subps.Table (SINF);
SUBT : Subp_Entry renames Subps.Table (SINT);
begin
if SUBF.Reachable and then not SUBT.Reachable then
SUBT.Reachable := True;
Modified := True;
end if;
end;
end loop Inner;
exit Outer when not Modified;
end loop Outer;
end Reachable_Closure;
-- Remove calls from unreachable subprograms
declare
New_Index : Nat;
begin
New_Index := 0;
for J in Calls.First .. Calls.Last loop
declare
CTJ : Call_Entry renames Calls.Table (J);
SINF : constant SI_Type := Subp_Index (CTJ.Caller);
SINT : constant SI_Type := Subp_Index (CTJ.Callee);
SUBF : Subp_Entry renames Subps.Table (SINF);
SUBT : Subp_Entry renames Subps.Table (SINT);
begin
if SUBF.Reachable then
pragma Assert (SUBT.Reachable);
New_Index := New_Index + 1;
Calls.Table (New_Index) := Calls.Table (J);
end if;
end;
end loop;
Calls.Set_Last (New_Index);
end;
-- Remove uplevel references from unreachable subprograms
declare
New_Index : Nat;
begin
New_Index := 0;
for J in Urefs.First .. Urefs.Last loop
declare
URJ : Uref_Entry renames Urefs.Table (J);
SINF : constant SI_Type := Subp_Index (URJ.Caller);
SINT : constant SI_Type := Subp_Index (URJ.Callee);
SUBF : Subp_Entry renames Subps.Table (SINF);
SUBT : Subp_Entry renames Subps.Table (SINT);
S : Entity_Id;
begin
-- Keep reachable reference
if SUBF.Reachable then
New_Index := New_Index + 1;
Urefs.Table (New_Index) := Urefs.Table (J);
-- And since we know we are keeping this one, this is a good
-- place to fill in information for a good reference.
-- Mark all enclosing subprograms need to declare AREC
S := URJ.Caller;
loop
S := Enclosing_Subprogram (S);
-- If we are at the top level, as can happen with
-- references to formals in aspects of nested subprogram
-- declarations, there are no further subprograms to mark
-- as requiring activation records.
exit when No (S);
declare
SUBI : Subp_Entry renames Subps.Table (Subp_Index (S));
begin
SUBI.Declares_AREC := True;
-- If this entity was marked reachable because it is
-- in a task or protected type, there may not appear
-- to be any calls to it, which would normally adjust
-- the levels of the parent subprograms. So we need to
-- be sure that the uplevel reference of that entity
-- takes into account possible calls.
if In_Synchronized_Unit (SUBF.Ent)
and then SUBT.Lev < SUBI.Uplevel_Ref
then
SUBI.Uplevel_Ref := SUBT.Lev;
end if;
end;
exit when S = URJ.Callee;
end loop;
-- Add to list of uplevel referenced entities for Callee.
-- We do not add types to this list, only actual references
-- to objects that will be referenced uplevel, and we use
-- the flag Is_Uplevel_Referenced_Entity to avoid making
-- duplicate entries in the list. Discriminants are also
-- excluded, only the enclosing object can appear in the
-- list.
if not Is_Uplevel_Referenced_Entity (URJ.Ent)
and then Ekind (URJ.Ent) /= E_Discriminant
then
Set_Is_Uplevel_Referenced_Entity (URJ.Ent);
Append_New_Elmt (URJ.Ent, SUBT.Uents);
end if;
-- And set uplevel indication for caller
if SUBT.Lev < SUBF.Uplevel_Ref then
SUBF.Uplevel_Ref := SUBT.Lev;
end if;
end if;
end;
end loop;
Urefs.Set_Last (New_Index);
end;
-- Remove unreachable subprograms from Subps table. Note that we do
-- this after eliminating entries from the other two tables, since
-- those elimination steps depend on referencing the Subps table.
declare
New_SI : SI_Type;
begin
New_SI := Subps_First - 1;
for J in Subps_First .. Subps.Last loop
declare
STJ : Subp_Entry renames Subps.Table (J);
Spec : Node_Id;
Decl : Node_Id;
begin
-- Subprogram is reachable, copy and reset index
if STJ.Reachable then
New_SI := New_SI + 1;
Subps.Table (New_SI) := STJ;
Set_Subps_Index (STJ.Ent, UI_From_Int (New_SI));
-- Subprogram is not reachable
else
-- Clear index, since no longer active
Set_Subps_Index (Subps.Table (J).Ent, Uint_0);
-- Output debug information if -gnatd.3 set
if Debug_Flag_Dot_3 then
Write_Str ("Eliminate ");
Write_Name (Chars (Subps.Table (J).Ent));
Write_Str (" at ");
Write_Location (Sloc (Subps.Table (J).Ent));
Write_Str (" (not referenced)");
Write_Eol;
end if;
-- Rewrite declaration, body, and corresponding freeze node
-- to null statements.
-- A subprogram instantiation does not have an explicit
-- body. If unused, we could remove the corresponding
-- wrapper package and its body.
if Present (STJ.Bod) then
Spec := Corresponding_Spec (STJ.Bod);
if Present (Spec) then
Decl := Parent (Declaration_Node (Spec));
Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
if Present (Freeze_Node (Spec)) then
Rewrite (Freeze_Node (Spec),
Make_Null_Statement (Sloc (Decl)));
end if;
end if;
Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
end if;
end if;
end;
end loop;
Subps.Set_Last (New_SI);
end;
-- Now it is time for the second transitive closure, which follows calls
-- and makes sure that A calls B, and B has uplevel references, then A
-- is also marked as having uplevel references.
Closure_Uplevel : declare
Modified : Boolean;
begin
-- We use a simple minded algorithm as follows (obviously this can
-- be done more efficiently, using one of the standard algorithms
-- for efficient transitive closure computation, but this is simple
-- and most likely fast enough that its speed does not matter).
-- Repeatedly scan the list of calls. Any time we find a call from
-- A to B, where B has uplevel references, make sure that A is marked
-- as having at least the same level of uplevel referencing.
Outer2 : loop
Modified := False;
Inner2 : for J in Calls.First .. Calls.Last loop
declare
CTJ : Call_Entry renames Calls.Table (J);
SINF : constant SI_Type := Subp_Index (CTJ.Caller);
SINT : constant SI_Type := Subp_Index (CTJ.Callee);
SUBF : Subp_Entry renames Subps.Table (SINF);
SUBT : Subp_Entry renames Subps.Table (SINT);
begin
if SUBT.Lev > SUBT.Uplevel_Ref
and then SUBF.Uplevel_Ref > SUBT.Uplevel_Ref
then
SUBF.Uplevel_Ref := SUBT.Uplevel_Ref;
Modified := True;
end if;
end;
end loop Inner2;
exit Outer2 when not Modified;
end loop Outer2;
end Closure_Uplevel;
-- We have one more step before the tables are complete. An uplevel
-- call from subprogram A to subprogram B where subprogram B has uplevel
-- references is in effect an uplevel reference, and must arrange for
-- the proper activation link to be passed.
for J in Calls.First .. Calls.Last loop
declare
CTJ : Call_Entry renames Calls.Table (J);
SINF : constant SI_Type := Subp_Index (CTJ.Caller);
SINT : constant SI_Type := Subp_Index (CTJ.Callee);
SUBF : Subp_Entry renames Subps.Table (SINF);
SUBT : Subp_Entry renames Subps.Table (SINT);
A : Entity_Id;
begin
-- If callee has uplevel references
if SUBT.Uplevel_Ref < SUBT.Lev
-- And this is an uplevel call
and then SUBT.Lev < SUBF.Lev
then
-- We need to arrange for finding the uplink
A := CTJ.Caller;
loop
A := Enclosing_Subprogram (A);
Subps.Table (Subp_Index (A)).Declares_AREC := True;
exit when A = CTJ.Callee;
-- In any case exit when we get to the outer level. This
-- happens in some odd cases with generics (in particular
-- sem_ch3.adb does not compile without this kludge ???).
exit when A = Subp;
end loop;
end if;
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
declare
STJ : Subp_Entry renames Subps.Table (J);
Loc : constant Source_Ptr := Sloc (STJ.Bod);
begin
-- First we create the ARECnF entity for the additional formal for
-- all subprograms which need an activation record passed.
if STJ.Uplevel_Ref < STJ.Lev then
STJ.ARECnF :=
Make_Defining_Identifier (Loc, Chars => AREC_Name (J, "F"));
end if;
-- Define the AREC entities for the activation record if needed
if STJ.Declares_AREC then
STJ.ARECn :=
Make_Defining_Identifier (Loc, AREC_Name (J, ""));
STJ.ARECnT :=
Make_Defining_Identifier (Loc, AREC_Name (J, "T"));
STJ.ARECnPT :=
Make_Defining_Identifier (Loc, AREC_Name (J, "PT"));
STJ.ARECnP :=
Make_Defining_Identifier (Loc, AREC_Name (J, "P"));
-- Define uplink component entity if inner nesting case
if Present (STJ.ARECnF) then
STJ.ARECnU :=
Make_Defining_Identifier (Loc, AREC_Name (J, "U"));
end if;
end if;
end;
end loop Create_Entities;
-- Loop through subprograms
Subp_Loop : declare
Addr : Entity_Id := Empty;
begin
for J in Subps_First .. Subps.Last loop
declare
STJ : Subp_Entry renames Subps.Table (J);
begin
-- First add the extra formal if needed. This applies to all
-- nested subprograms that require an activation record to be
-- passed, as indicated by ARECnF being defined.
if Present (STJ.ARECnF) then
-- Here we need the extra formal. We do the expansion and
-- analysis of this manually, since it is fairly simple,
-- and it is not obvious how we can get what we want if we
-- try to use the normal Analyze circuit.
Add_Extra_Formal : declare
Encl : constant SI_Type := Enclosing_Subp (J);
STJE : Subp_Entry renames Subps.Table (Encl);
-- Index and Subp_Entry for enclosing routine
Form : constant Entity_Id := STJ.ARECnF;
-- The formal to be added. Note that n here is one less
-- than the level of the subprogram itself (STJ.Ent).
procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id);
-- S is an N_Function/Procedure_Specification node, and F
-- is the new entity to add to this subprogram spec as
-- the last Extra_Formal.
----------------------
-- Add_Form_To_Spec --
----------------------
procedure Add_Form_To_Spec (F : Entity_Id; S : Node_Id) is
Sub : constant Entity_Id := Defining_Entity (S);
Ent : Entity_Id;
begin
-- Case of at least one Extra_Formal is present, set
-- ARECnF as the new last entry in the list.
if Present (Extra_Formals (Sub)) then
Ent := Extra_Formals (Sub);
while Present (Extra_Formal (Ent)) loop
Ent := Extra_Formal (Ent);
end loop;
Set_Extra_Formal (Ent, F);
-- No Extra formals present
else
Set_Extra_Formals (Sub, F);
Ent := Last_Formal (Sub);
if Present (Ent) then
Set_Extra_Formal (Ent, F);
end if;
end if;
end Add_Form_To_Spec;
-- Start of processing for Add_Extra_Formal
begin
-- Decorate the new formal entity
Set_Scope (Form, STJ.Ent);
Mutate_Ekind (Form, E_In_Parameter);
Set_Etype (Form, STJE.ARECnPT);
Set_Mechanism (Form, By_Copy);
Set_Never_Set_In_Source (Form, True);
Set_Analyzed (Form, True);
Set_Comes_From_Source (Form, False);
Set_Is_Activation_Record (Form, True);
-- Case of only body present
if Acts_As_Spec (STJ.Bod) then
Add_Form_To_Spec (Form, Specification (STJ.Bod));
-- Case of separate spec
else
Add_Form_To_Spec (Form, Parent (STJ.Ent));
end if;
end Add_Extra_Formal;
end if;
-- Processing for subprograms that declare an activation record
if Present (STJ.ARECn) then
-- Local declarations for one such subprogram
declare
Loc : constant Source_Ptr := Sloc (STJ.Bod);
Decls : constant List_Id := New_List;
-- List of new declarations we create
Clist : List_Id;
Comp : Entity_Id;
Decl_Assign : Node_Id;
-- Assignment to set uplink, Empty if none
Decl_ARECnT : Node_Id;
Decl_ARECnPT : Node_Id;
Decl_ARECn : Node_Id;
Decl_ARECnP : Node_Id;
-- Declaration nodes for the AREC entities we build
begin
-- Build list of component declarations for ARECnT and
-- load System.Address.
Clist := Empty_List;
if No (Addr) then
Addr := RTE (RE_Address);
end if;
-- If we are in a subprogram that has a static link that
-- is passed in (as indicated by ARECnF being defined),
-- then include ARECnU : ARECmPT where ARECmPT comes from
-- the level one higher 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,
Defining_Identifier => STJ.ARECnU,
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (STJE.ARECnPT, Loc))));
end;
end if;
-- Add components for uplevel referenced entities
if Present (STJ.Uents) then
declare
Elmt : Elmt_Id;
Ptr_Decl : Node_Id;
Uent : Entity_Id;
Indx : Nat;
-- 1's origin of index in list of elements. This is
-- used to uniquify names if needed in Upref_Name.
begin
Elmt := First_Elmt (STJ.Uents);
Indx := 0;
while Present (Elmt) loop
Uent := Node (Elmt);
Indx := Indx + 1;
Comp :=
Make_Defining_Identifier (Loc,
Chars => Upref_Name (Uent, Indx, Clist));
Set_Activation_Record_Component
(Uent, Comp);
if Needs_Fat_Pointer (Uent) then
-- Build corresponding access type
Ptr_Decl :=
Build_Access_Type_Decl
(Etype (Uent), STJ.Ent);
Append_To (Decls, Ptr_Decl);
-- And use its type in the corresponding
-- component.
Append_To (Clist,
Make_Component_Declaration (Loc,
Defining_Identifier => Comp,
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of
(Defining_Identifier (Ptr_Decl),
Loc))));
else
Append_To (Clist,
Make_Component_Declaration (Loc,
Defining_Identifier => Comp,
Component_Definition =>
Make_Component_Definition (Loc,
Subtype_Indication =>
New_Occurrence_Of (Addr, Loc))));
end if;
Next_Elmt (Elmt);
end loop;
end;
end if;
-- Now we can insert the AREC declarations into the body
-- type ARECnT is record .. end record;
-- pragma Suppress_Initialization (ARECnT);
-- Note that we need to set the Suppress_Initialization
-- flag after Decl_ARECnT has been analyzed.
Decl_ARECnT :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => STJ.ARECnT,
Type_Definition =>
Make_Record_Definition (Loc,
Component_List =>
Make_Component_List (Loc,
Component_Items => Clist)));
Append_To (Decls, Decl_ARECnT);
-- type ARECnPT is access all ARECnT;
Decl_ARECnPT :=
Make_Full_Type_Declaration (Loc,
Defining_Identifier => STJ.ARECnPT,
Type_Definition =>
Make_Access_To_Object_Definition (Loc,
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;
Decl_ARECnP :=
Make_Object_Declaration (Loc,
Defining_Identifier => STJ.ARECnP,
Constant_Present => True,
Object_Definition =>
New_Occurrence_Of (STJ.ARECnPT, Loc),
Expression =>
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (STJ.ARECn, Loc),
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);
else
Decl_Assign := Empty;
end if;
if No (Declarations (STJ.Bod)) then
Set_Declarations (STJ.Bod, Decls);
else
Prepend_List_To (Declarations (STJ.Bod), Decls);
end if;
-- Analyze the newly inserted declarations. Note that we
-- do not need to establish the whole scope stack, since
-- we have already set all entity fields (so there will
-- be no searching of upper scopes to resolve names). But
-- we do set the scope of the current subprogram, so that
-- newly created entities go in the right entity chain.
-- We analyze with all checks suppressed (since we do
-- not expect any exceptions).
Push_Scope (STJ.Ent);
Analyze (Decl_ARECnT, Suppress => All_Checks);
-- Note that we need to call Set_Suppress_Initialization
-- after Decl_ARECnT has been analyzed, but before
-- analyzing Decl_ARECnP so that the flag is properly
-- taking into account.
Set_Suppress_Initialization (STJ.ARECnT);
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;
-- Next step, for each uplevel referenced entity, add
-- assignment operations to set the component in the
-- activation record.
if Present (STJ.Uents) then
declare
Elmt : Elmt_Id;
begin
Elmt := First_Elmt (STJ.Uents);
while Present (Elmt) loop
declare
Ent : constant Entity_Id := Node (Elmt);
Loc : constant Source_Ptr := Sloc (Ent);
Dec : constant Node_Id :=
Declaration_Node (Ent);
Asn : Node_Id;
Attr : Name_Id;
Comp : Entity_Id;
Ins : Node_Id;
Rhs : Node_Id;
begin
-- For parameters, we insert the assignment
-- right after the declaration of ARECnP.
-- For all other entities, we insert the
-- assignment immediately after the
-- declaration of the entity or after the
-- freeze node if present.
-- Note: we don't need to mark the entity
-- as being aliased, because the address
-- attribute will mark it as Address_Taken,
-- and that is good enough.
if Is_Formal (Ent) then
Ins := Decl_ARECnP;
elsif Has_Delayed_Freeze (Ent) then
Ins := Freeze_Node (Ent);
else
Ins := Dec;
end if;
-- Build and insert the assignment:
-- ARECn.nam := nam'Address
-- or else 'Unchecked_Access for
-- unconstrained array.
if Needs_Fat_Pointer (Ent) then
Attr := Name_Unchecked_Access;
else
Attr := Name_Address;
end if;
Rhs :=
Make_Attribute_Reference (Loc,
Prefix =>
New_Occurrence_Of (Ent, Loc),
Attribute_Name => Attr);
-- If the entity is an unconstrained formal
-- we wrap the attribute reference in an
-- unchecked conversion to the type of the
-- activation record component, to prevent
-- spurious subtype conformance errors within
-- instances.
if Is_Formal (Ent)
and then not Is_Constrained (Etype (Ent))
then
-- Find target component and its type
Comp := First_Component (STJ.ARECnT);
while Chars (Comp) /= Chars (Ent) loop
Next_Component (Comp);
end loop;
Rhs :=
Unchecked_Convert_To (Etype (Comp), Rhs);
end if;
Asn :=
Make_Assignment_Statement (Loc,
Name =>
Make_Selected_Component (Loc,
Prefix =>
New_Occurrence_Of (STJ.ARECn, Loc),
Selector_Name =>
New_Occurrence_Of
(Activation_Record_Component
(Ent),
Loc)),
Expression => Rhs);
-- If we have a loop parameter, we have
-- to insert before the first statement
-- of the loop. Ins points to the
-- N_Loop_Parameter_Specification or to
-- an N_Iterator_Specification.
if Nkind (Ins) in
N_Iterator_Specification |
N_Loop_Parameter_Specification
then
-- Quantified expression are rewritten as
-- loops during expansion.
if Nkind (Parent (Ins)) =
N_Quantified_Expression
then
null;
else
Ins :=
First
(Statements
(Parent (Parent (Ins))));
Insert_Before (Ins, Asn);
end if;
else
Insert_After (Ins, Asn);
end if;
-- Analyze the assignment statement. We do
-- not need to establish the relevant scope
-- stack entries here, because we have
-- already set the correct entity references,
-- so no name resolution is required, and no
-- new entities are created, so we don't even
-- need to set the current scope.
-- We analyze with all checks suppressed
-- (since we do not expect any exceptions).
Analyze (Asn, Suppress => All_Checks);
end;
Next_Elmt (Elmt);
end loop;
end;
end if;
end;
end if;
end;
end loop;
end Subp_Loop;
-- Next step, process uplevel references. This has to be done in a
-- separate pass, after completing the processing in Sub_Loop because we
-- need all the AREC declarations generated, inserted, and analyzed so
-- that the uplevel references can be successfully analyzed.
Uplev_Refs : for J in Urefs.First .. Urefs.Last loop
declare
UPJ : Uref_Entry renames Urefs.Table (J);
begin
-- Ignore type references, these are implicit references that do
-- not need rewriting (e.g. the appearance in a conversion).
-- Also ignore if no reference was specified or if the rewriting
-- has already been done (this can happen if the N_Identifier
-- occurs more than one time in the tree). Also ignore references
-- when not generating C code (in particular for the case of LLVM,
-- since GNAT-LLVM will handle the processing for up-level refs).
if No (UPJ.Ref)
or else not Is_Entity_Name (UPJ.Ref)
or else No (Entity (UPJ.Ref))
or else not Opt.Generate_C_Code
then
goto Continue;
end if;
-- Rewrite one reference
Rewrite_One_Ref : declare
Loc : constant Source_Ptr := Sloc (UPJ.Ref);
-- Source location for the reference
Typ : constant Entity_Id := Etype (UPJ.Ent);
-- The type of the referenced entity
Atyp : Entity_Id;
-- The actual subtype of the reference
RS_Caller : constant SI_Type := Subp_Index (UPJ.Caller);
-- Subp_Index for caller containing reference
STJR : Subp_Entry renames Subps.Table (RS_Caller);
-- Subp_Entry for subprogram containing reference
RS_Callee : constant SI_Type := Subp_Index (UPJ.Callee);
-- Subp_Index for subprogram containing referenced entity
STJE : Subp_Entry renames Subps.Table (RS_Callee);
-- Subp_Entry for subprogram containing referenced entity
Pfx : Node_Id;
Comp : Entity_Id;
SI : SI_Type;
begin
Atyp := Etype (UPJ.Ref);
if Ekind (Atyp) /= E_Record_Subtype then
Atyp := Get_Actual_Subtype (UPJ.Ref);
end if;
-- Ignore if no ARECnF entity for enclosing subprogram which
-- probably happens as a result of not properly treating
-- instance bodies. To be examined ???
-- If this test is omitted, then the compilation of freeze.adb
-- and inline.adb fail in unnesting mode.
if No (STJR.ARECnF) then
goto Continue;
end if;
-- If this is a reference to a global constant, use its value
-- rather than create a reference. It is more efficient and
-- furthermore indispensable if the context requires a
-- constant, such as a branch of a case statement.
if Ekind (UPJ.Ent) = E_Constant
and then Is_True_Constant (UPJ.Ent)
and then Present (Constant_Value (UPJ.Ent))
and then Is_Static_Expression (Constant_Value (UPJ.Ent))
then
Rewrite (UPJ.Ref, New_Copy_Tree (Constant_Value (UPJ.Ent)));
goto Continue;
end if;
-- Push the current scope, so that the pointer type Tnn, and
-- any subsidiary entities resulting from the analysis of the
-- rewritten reference, go in the right entity chain.
Push_Scope (STJR.Ent);
-- Now we need to rewrite the reference. We have a reference
-- from level STJR.Lev to level STJE.Lev. The general form of
-- the rewritten reference for entity X is:
-- Typ'Deref (ARECaF.ARECbU.ARECcU.ARECdU....ARECmU.X)
-- where a,b,c,d .. m =
-- STJR.Lev - 1, STJR.Lev - 2, .. STJE.Lev
pragma Assert (STJR.Lev > STJE.Lev);
-- Compute the prefix of X. Here are examples to make things
-- clear (with parens to show groupings, the prefix is
-- everything except the .X at the end).
-- level 2 to level 1
-- AREC1F.X
-- level 3 to level 1
-- (AREC2F.AREC1U).X
-- level 4 to level 1
-- ((AREC3F.AREC2U).AREC1U).X
-- level 6 to level 2
-- (((AREC5F.AREC4U).AREC3U).AREC2U).X
-- 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_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)
Comp := Activation_Record_Component (UPJ.Ent);
pragma Assert (Present (Comp));
-- Do the replacement. If the component type is an access type,
-- this is an uplevel reference for an entity that requires a
-- fat pointer, so dereference the component.
if Is_Access_Type (Etype (Comp)) then
Rewrite (UPJ.Ref,
Make_Explicit_Dereference (Loc,
Prefix =>
Make_Selected_Component (Loc,
Prefix => Pfx,
Selector_Name =>
New_Occurrence_Of (Comp, Loc))));
else
Rewrite (UPJ.Ref,
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Atyp, Loc),
Attribute_Name => Name_Deref,
Expressions => New_List (
Make_Selected_Component (Loc,
Prefix => Pfx,
Selector_Name =>
New_Occurrence_Of (Comp, Loc)))));
end if;
-- Analyze and resolve the new expression. We do not need to
-- establish the relevant scope stack entries here, because we
-- have already set all the correct entity references, so no
-- name resolution is needed. We have already set the current
-- scope, so that any new entities created will be in the right
-- scope.
-- We analyze with all checks suppressed (since we do not
-- expect any exceptions)
Analyze_And_Resolve (UPJ.Ref, Typ, Suppress => All_Checks);
-- Generate an extra temporary to facilitate the C backend
-- processing this dereference
if Opt.Modify_Tree_For_C
and then Nkind (Parent (UPJ.Ref)) in
N_Type_Conversion | N_Unchecked_Type_Conversion
then
Force_Evaluation (UPJ.Ref, Mode => Strict);
end if;
Pop_Scope;
end Rewrite_One_Ref;
end;
<<Continue>>
null;
end loop Uplev_Refs;
-- Finally, loop through all calls adding extra actual for the
-- activation record where it is required.
Adjust_Calls : for J in Calls.First .. Calls.Last loop
-- Process a single call, we are only interested in a call to a
-- subprogram that actually needs a pointer to an activation record,
-- as indicated by the ARECnF entity being set. This excludes the
-- top level subprogram, and any subprogram not having uplevel refs.
Adjust_One_Call : declare
CTJ : Call_Entry renames Calls.Table (J);
STF : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Caller));
STT : Subp_Entry renames Subps.Table (Subp_Index (CTJ.Callee));
Loc : constant Source_Ptr := Sloc (CTJ.N);
Extra : Node_Id;
ExtraP : Node_Id;
SubX : SI_Type;
Act : Node_Id;
begin
if Present (STT.ARECnF)
and then Nkind (CTJ.N) in N_Subprogram_Call
then
-- CTJ.N is a call to a subprogram which may require a pointer
-- to an activation record. The subprogram containing the call
-- is CTJ.From and the subprogram being called is CTJ.To, so we
-- have a call from level STF.Lev to level STT.Lev.
-- There are three possibilities:
-- For a call to the same level, we just pass the activation
-- record passed to the calling subprogram.
if STF.Lev = STT.Lev then
Extra := New_Occurrence_Of (STF.ARECnF, Loc);
-- For a call that goes down a level, we pass a pointer to the
-- activation record constructed within the caller (which may
-- be the outer-level subprogram, but also may be a more deeply
-- nested caller).
elsif STT.Lev = STF.Lev + 1 then
Extra := New_Occurrence_Of (STF.ARECnP, Loc);
-- Otherwise we must have an upcall (STT.Lev < STF.LEV),
-- since it is not possible to do a downcall of more than
-- one level.
-- For a call from level STF.Lev to level STT.Lev, we
-- have to find the activation record needed by the
-- callee. This is as follows:
-- ARECaF.ARECbU.ARECcU....ARECmU
-- where a,b,c .. m =
-- STF.Lev - 1, STF.Lev - 2, STF.Lev - 3 .. STT.Lev
else
pragma Assert (STT.Lev < STF.Lev);
Extra := New_Occurrence_Of (STF.ARECnF, Loc);
SubX := Subp_Index (CTJ.Caller);
for K in reverse STT.Lev .. STF.Lev - 1 loop
SubX := Enclosing_Subp (SubX);
Extra :=
Make_Selected_Component (Loc,
Prefix => Extra,
Selector_Name =>
New_Occurrence_Of
(Subps.Table (SubX).ARECnU, Loc));
end loop;
end if;
-- Extra is the additional parameter to be added. Build a
-- parameter association that we can append to the actuals.
ExtraP :=
Make_Parameter_Association (Loc,
Selector_Name =>
New_Occurrence_Of (STT.ARECnF, Loc),
Explicit_Actual_Parameter => Extra);
if No (Parameter_Associations (CTJ.N)) then
Set_Parameter_Associations (CTJ.N, Empty_List);
end if;
Append (ExtraP, Parameter_Associations (CTJ.N));
-- We need to deal with the actual parameter chain as well. The
-- newly added parameter is always the last actual.
Act := First_Named_Actual (CTJ.N);
if No (Act) then
Set_First_Named_Actual (CTJ.N, Extra);
-- If call has been relocated (as with an expression in
-- an aggregate), set First_Named pointer in original node
-- as well, because that's the parent of the parameter list.
Set_First_Named_Actual
(Parent (List_Containing (ExtraP)), Extra);
-- Here we must follow the chain and append the new entry
else
loop
declare
PAN : Node_Id;
NNA : Node_Id;
begin
PAN := Parent (Act);
pragma Assert (Nkind (PAN) = N_Parameter_Association);
NNA := Next_Named_Actual (PAN);
if No (NNA) then
Set_Next_Named_Actual (PAN, Extra);
exit;
end if;
Act := NNA;
end;
end loop;
end if;
-- Analyze and resolve the new actual. We do not need to
-- establish the relevant scope stack entries here, because
-- we have already set all the correct entity references, so
-- no name resolution is needed.
-- We analyze with all checks suppressed (since we do not
-- expect any exceptions, and also we temporarily turn off
-- Unested_Subprogram_Mode to avoid trying to mark uplevel
-- references (not needed at this stage, and in fact causes
-- a bit of recursive chaos).
Opt.Unnest_Subprogram_Mode := False;
Analyze_And_Resolve
(Extra, Etype (STT.ARECnF), Suppress => All_Checks);
Opt.Unnest_Subprogram_Mode := True;
end if;
end Adjust_One_Call;
end loop Adjust_Calls;
return;
end Unnest_Subprogram;
------------------------
-- Unnest_Subprograms --
------------------------
procedure Unnest_Subprograms (N : Node_Id) is
function Search_Subprograms (N : Node_Id) return Traverse_Result;
-- Tree visitor that search for outer level procedures with nested
-- subprograms and invokes Unnest_Subprogram()
---------------
-- Do_Search --
---------------
procedure Do_Search is new Traverse_Proc (Search_Subprograms);
-- Subtree visitor instantiation
------------------------
-- Search_Subprograms --
------------------------
function Search_Subprograms (N : Node_Id) return Traverse_Result is
begin
if Nkind (N) in N_Subprogram_Body | N_Subprogram_Body_Stub then
declare
Spec_Id : constant Entity_Id := Unique_Defining_Entity (N);
begin
-- We are only interested in subprograms (not generic
-- subprograms), that have nested subprograms.
if Is_Subprogram (Spec_Id)
and then Has_Nested_Subprogram (Spec_Id)
and then Is_Library_Level_Entity (Spec_Id)
then
Unnest_Subprogram (Spec_Id, N);
else
return Skip;
end if;
end;
-- The proper body of a stub may contain nested subprograms, and
-- therefore must be visited explicitly. Nested stubs are examined
-- recursively in Visit_Node.
elsif Nkind (N) in N_Body_Stub then
Do_Search (Library_Unit (N));
-- Skip generic packages
elsif Nkind (N) = N_Package_Body
and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
then
return Skip;
end if;
return OK;
end Search_Subprograms;
Subp : Entity_Id;
Subp_Body : Node_Id;
-- Start of processing for Unnest_Subprograms
begin
if not Opt.Unnest_Subprogram_Mode or not Opt.Expander_Active then
return;
end if;
-- A specification will contain bodies if it contains instantiations so
-- examine package or subprogram declaration of the main unit, when it
-- is present.
if Nkind (Unit (N)) = N_Package_Body
or else (Nkind (Unit (N)) = N_Subprogram_Body
and then not Acts_As_Spec (N))
then
Do_Search (Library_Unit (N));
end if;
Do_Search (N);
-- Unnest any subprograms passed on the list of inlined subprograms
Subp := First_Inlined_Subprogram (N);
while Present (Subp) loop
Subp_Body := Parent (Declaration_Node (Subp));
if Nkind (Subp_Body) = N_Subprogram_Declaration
and then Present (Corresponding_Body (Subp_Body))
then
Subp_Body := Parent (Declaration_Node
(Corresponding_Body (Subp_Body)));
end if;
Unnest_Subprogram (Subp, Subp_Body, For_Inline => True);
Next_Inlined_Subprogram (Subp);
end loop;
end Unnest_Subprograms;
end Exp_Unst;