Skip to content

R
riscv-gcc-1
Commit 5d514884 by Ed Schonberg Committed by Pierre-Marie de Rodat
Options

[Ada] Unnesting: properly handle subprogram instantiations 

2018-05-30  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* exp_unst.adb (Visit_Node): Handle properly subprogram instantiations
	that have no corresponding body and appear as attributes of the
	corresponding wrapper package declaration.
	(Register_Subprogram): New subprogram, used for subprogram bodies and
	for subprogram instantiations to enter callable entity into Subp table.

From-SVN: r260925
parent 1df65b89
Showing with 293 additions and 254 deletions
gcc/ada/ChangeLog
2018-05-30 Ed Schonberg <schonberg@adacore.com>
* exp_unst.adb (Visit_Node): Handle properly subprogram instantiations
that have no corresponding body and appear as attributes of the
corresponding wrapper package declaration.
(Register_Subprogram): New subprogram, used for subprogram bodies and
for subprogram instantiations to enter callable entity into Subp table.
2018-05-30 Hristian Kirtchev <kirtchev@adacore.com> 2018-05-30 Hristian Kirtchev <kirtchev@adacore.com>
* libgnat/s-secsta.adb: Reimplement the secondary stack support. * libgnat/s-secsta.adb: Reimplement the secondary stack support.
......
gcc/ada/exp_unst.adb
...@@ -367,9 +367,7 @@ package body Exp_Unst is ...@@ -367,9 +367,7 @@ package body Exp_Unst is
Callee : Entity_Id; Callee : Entity_Id;
procedure Check_Static_Type procedure Check_Static_Type
(T : Entity_Id; (T : Entity_Id; N : Node_Id; DT : in out Boolean);
N : Node_Id;
DT : in out Boolean);
-- Given a type T, checks if it is a static type defined as a type -- Given a type 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 -- with no dynamic bounds in sight. If so, the only action is to
-- set Is_Static_Type True for T. If T is not a static type, then -- set Is_Static_Type True for T. If T is not a static type, then
...@@ -388,14 +386,16 @@ package body Exp_Unst is ...@@ -388,14 +386,16 @@ package body Exp_Unst is
-- from within Caller to entity E declared in Callee. E can be a -- from within Caller to entity E declared in Callee. E can be a
-- an object or a type. -- 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 -- -- Check_Static_Type --
----------------------- -----------------------
procedure Check_Static_Type procedure Check_Static_Type
(T : Entity_Id; (T : Entity_Id; N : Node_Id; DT : in out Boolean)
N : Node_Id;
DT : in out Boolean)
is is
procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id); procedure Note_Uplevel_Bound (N : Node_Id; Ref : Node_Id);
-- N is the bound of a dynamic type. This procedure notes that -- N is the bound of a dynamic type. This procedure notes that
...@@ -414,9 +414,9 @@ package body Exp_Unst is ...@@ -414,9 +414,9 @@ package body Exp_Unst is
begin begin
-- Entity name case. Make sure that the entity is declared -- Entity name case. Make sure that the entity is declared
-- in a subprogram. This may not be the case for for a type -- in a subprogram. This may not be the case for for a type
-- in a loop appearing in a precondition. Exclude explicitly -- in a loop appearing in a precondition.
-- discriminants (that can appear in bounds of discriminated -- Exclude explicitly discriminants (that can appear
-- components). -- in bounds of discriminated components).
if Is_Entity_Name (N) then if Is_Entity_Name (N) then
if Present (Entity (N)) if Present (Entity (N))
...@@ -613,316 +613,341 @@ package body Exp_Unst is ...@@ -613,316 +613,341 @@ package body Exp_Unst is
Urefs.Append ((N, Full_E, Caller, Callee)); Urefs.Append ((N, Full_E, Caller, Callee));
end Note_Uplevel_Ref; end Note_Uplevel_Ref;
-------------------------
-- Register_Subprogram --
-------------------------
procedure Register_Subprogram (E : Entity_Id; Bod : Node_Id) is
L : constant Nat := Get_Level (Subp, E);
begin
Subps.Append
((Ent => E,
Bod => Bod,
Lev => L,
Reachable => False,
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));
end Register_Subprogram;
-- Start of processing for Visit_Node -- Start of processing for Visit_Node
begin begin
-- Record a call case Nkind (N) is
if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then -- Record a subprogram call
-- We are only interested in direct calls, not indirect calls when N_Procedure_Call_Statement | N_Function_Call =>
-- (where Name (N) is an explicit dereference) at least for now! -- 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 if Nkind (Name (N)) in N_Has_Entity then
Ent := Entity (Name (N)); Ent := Entity (Name (N));
-- We are only interested in calls to subprograms nested -- We are only interested in calls to subprograms nested
-- within Subp. Calls to Subp itself or to subprograms -- within Subp. Calls to Subp itself or to subprograms
-- that are outside the nested structure do not affect us. -- outside the nested structure do not affect us.
if Scope_Within (Ent, Subp) then if Scope_Within (Ent, Subp)
and then Is_Subprogram (Ent)
-- Ignore calls to imported routines and then not Is_Imported (Ent)
then
Append_Unique_Call ((N, Current_Subprogram, Ent));
end if;
end if;
if Is_Imported (Ent) then -- For all calls where the formal is an unconstrained array
null; -- and the actual is constrained we need to check the bounds
-- for uplevel references.
-- Here we have a call to keep and analyze declare
Subp : Entity_Id;
Actual : Entity_Id;
Formal : Node_Id;
DT : Boolean := False;
begin
if Nkind (Name (N)) = N_Explicit_Dereference then
Subp := Etype (Name (N));
else else
-- Both caller and callee must be subprograms Subp := Entity (Name (N));
end if;
if Is_Subprogram (Ent) then Actual := First_Actual (N);
Append_Unique_Call ((N, Current_Subprogram, Ent)); Formal := First_Formal_With_Extras (Subp);
while Present (Actual) loop
if Is_Array_Type (Etype (Formal))
and then not Is_Constrained (Etype (Formal))
and then Is_Constrained (Etype (Actual))
then
Check_Static_Type (Etype (Actual), Empty, DT);
end if; end if;
end if;
end if;
end if;
-- for all calls where the formal is an unconstrained array and Next_Actual (Actual);
-- the actual is constrained we need to check the bounds. Next_Formal_With_Extras (Formal);
end loop;
end;
declare -- An At_End_Proc in a statement sequence indicates that
Actual : Entity_Id; -- there's a call from the enclosing construct or block
DT : Boolean := False; -- to that subprogram. As above, the called entity must
Formal : Node_Id; -- be local and not imported.
Subp : Entity_Id;
begin when N_Handled_Sequence_Of_Statements =>
if Nkind (Name (N)) = N_Explicit_Dereference then if Present (At_End_Proc (N))
Subp := Etype (Name (N)); and then Scope_Within (Entity (At_End_Proc (N)), Subp)
else and then not Is_Imported (Entity (At_End_Proc (N)))
Subp := Entity (Name (N)); then
Append_Unique_Call ((N, Current_Subprogram,
Entity (At_End_Proc (N))));
end if; end if;
Actual := First_Actual (N); -- A 'Access reference is a (potential) call.
Formal := First_Formal_With_Extras (Subp); -- Other attributes require special handling.
while Present (Actual) loop
if Is_Array_Type (Etype (Formal))
and then not Is_Constrained (Etype (Formal))
and then Is_Constrained (Etype (Actual))
then
Check_Static_Type (Etype (Actual), Empty, DT);
end if;
Next_Actual (Actual); when N_Attribute_Reference =>
Next_Formal_With_Extras (Formal); declare
end loop; Attr : constant Attribute_Id :=
end; Get_Attribute_Id (Attribute_Name (N));
begin
case Attr is
when Attribute_Access
| Attribute_Unchecked_Access
| Attribute_Unrestricted_Access
=>
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;
elsif Nkind (N) = N_Handled_Sequence_Of_Statements -- References to bounds can be uplevel references if
and then Present (At_End_Proc (N)) -- the type isn't static.
then
-- An At_End_Proc means there's a call from this block to that when Attribute_First
-- subprogram. | 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.
if Is_Constrained (Etype (Prefix (N))) then
declare
DT : Boolean := False;
begin
Check_Static_Type (Etype (Prefix (N)),
Empty, DT);
end;
Append_Unique_Call return OK;
((N, Current_Subprogram, Entity (At_End_Proc (N)))); end if;
-- Handle a 'Access as a (potential) call when others =>
null;
end case;
end;
elsif Nkind (N) = N_Attribute_Reference then -- Indexed references can be uplevel if the type isn't static
declare -- and if the lower bound (or an inner bound for a multi-
Attr : constant Attribute_Id := -- dimensional array) is uplevel.
Get_Attribute_Id (Attribute_Name (N));
begin when N_Indexed_Component | N_Slice =>
case Attr is if Is_Constrained (Etype (Prefix (N))) then
when Attribute_Access declare
| Attribute_Unchecked_Access DT : Boolean := False;
| Attribute_Unrestricted_Access begin
=> Check_Static_Type (Etype (Prefix (N)), Empty, DT);
if Nkind (Prefix (N)) in N_Has_Entity then end;
Ent := Entity (Prefix (N)); end if;
-- We are only interested in calls to subprograms
-- nested within 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 -- A selected component can have an implicit up-level
-- type isn't static. -- reference due to the bounds of previous fields in the
-- record. We simplify the processing here by examining
when Attribute_First -- all components of the record.
| 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.
if Is_Constrained (Etype (Prefix (N))) then
declare
DT : Boolean := False;
begin
Check_Static_Type
(Etype (Prefix (N)), Empty, DT);
end;
return OK; -- Selected components appear as unit names and end labels
end if; -- for child units. Prefixes of these nodes denote parent
-- units and carry no type information so they are skipped.
when others => when N_Selected_Component =>
null; if Present (Etype (Prefix (N))) then
end case; declare
end; DT : Boolean := False;
begin
Check_Static_Type (Etype (Prefix (N)), Empty, DT);
end;
end if;
-- Indexed references can be uplevel if the type isn't static and -- Record a subprogram. We record a subprogram body that acts
-- if the lower bound (or an inner bound for a multidimensional -- as a spec. Otherwise we record a subprogram declaration,
-- array) is uplevel. -- providing that it has a corresponding body we can get hold
-- of. The case of no corresponding body being available is
-- ignored for now.
elsif Nkind_In (N, N_Indexed_Component, N_Slice) when N_Subprogram_Body =>
and then Is_Constrained (Etype (Prefix (N))) Ent := Unique_Defining_Entity (N);
then
declare
DT : Boolean := False;
begin
Check_Static_Type (Etype (Prefix (N)), Empty, DT);
end;
-- A selected component can have an implicit up-level reference -- Ignore generic subprogram
-- 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 if Is_Generic_Subprogram (Ent) then
-- child units. The prefixes of these nodes denote parent units return Skip;
-- and carry no type information so they are skipped. end if;
elsif Nkind (N) = N_Selected_Component -- Make new entry in subprogram table if not already made
and then Present (Etype (Prefix (N))) Register_Subprogram (Ent, N);
then
declare
DT : Boolean := False;
begin
Check_Static_Type (Etype (Prefix (N)), Empty, DT);
end;
-- Record a subprogram. We record a subprogram body that acts as a -- We make a recursive call to scan the subprogram body, so
-- spec. Otherwise we record a subprogram declaration, providing -- that we can save and restore Current_Subprogram.
-- that it has a corresponding body we can get hold of. The case
-- of no corresponding body being available is ignored for now.
elsif Nkind (N) = N_Subprogram_Body then declare
Ent := Unique_Defining_Entity (N); Save_CS : constant Entity_Id := Current_Subprogram;
Decl : Node_Id;
-- Ignore generic subprogram begin
Current_Subprogram := Ent;
if Is_Generic_Subprogram (Ent) then -- Scan declarations
return Skip;
end if;
-- Make new entry in subprogram table if not already made Decl := First (Declarations (N));
while Present (Decl) loop
Visit (Decl);
Next (Decl);
end loop;
declare -- Scan statements
L : constant Nat := Get_Level (Subp, Ent);
begin
Subps.Append
((Ent => Ent,
Bod => N,
Lev => L,
Reachable => False,
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 (Ent, UI_From_Int (Subps.Last));
end;
-- We make a recursive call to scan the subprogram body, so Visit (Handled_Statement_Sequence (N));
-- that we can save and restore Current_Subprogram.
declare -- Restore current subprogram setting
Save_CS : constant Entity_Id := Current_Subprogram;
Decl : Node_Id;
begin Current_Subprogram := Save_CS;
Current_Subprogram := Ent; end;
-- Scan declarations -- Now at this level, return skipping the subprogram body
-- descendants, since we already took care of them!
Decl := First (Declarations (N)); return Skip;
while Present (Decl) loop
Visit (Decl);
Next (Decl);
end loop;
-- Scan statements -- If we have a body stub, visit the associated subunit,
-- which is a semantic descendant of the stub.
Visit (Handled_Statement_Sequence (N)); when N_Body_Stub =>
Visit (Library_Unit (N));
-- Restore current subprogram setting -- A declaration of a wrapper package indicates a subprogram
-- instance for which there is no explicit body. Enter the
-- subprogram instance in the table.
Current_Subprogram := Save_CS; when N_Package_Declaration =>
end; if Is_Wrapper_Package (Defining_Entity (N)) then
Register_Subprogram
(Related_Instance (Defining_Entity (N)), Empty);
end if;
-- Now at this level, return skipping the subprogram body -- Skip generic declarations
-- descendants, since we already took care of them!
when N_Generic_Declaration =>
return Skip;
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;
-- Record an uplevel reference -- Otherwise record an uplevel reference
elsif Nkind (N) in N_Has_Entity and then Present (Entity (N)) then when others =>
Ent := Entity (N); if
Nkind (N) in N_Has_Entity and then Present (Entity (N))
then
Ent := Entity (N);
-- Only interested in entities declared within our nest -- Only interested in entities declared within our nest
if not Is_Library_Level_Entity (Ent) if not Is_Library_Level_Entity (Ent)
and then Scope_Within_Or_Same (Scope (Ent), Subp) and then Scope_Within_Or_Same (Scope (Ent), Subp)
-- Skip entities defined in inlined subprograms -- Skip entities defined in inlined subprograms
and then Chars (Enclosing_Subprogram (Ent)) /= Name_uParent and then
and then Chars (Enclosing_Subprogram (Ent)) /= Name_uParent
-- Constants and variables are potentially -- Constants and variables are potentially
-- uplevel references to global declarations. -- uplevel references to global declarations.
(Ekind_In (Ent, E_Constant, E_Variable) and then
(Ekind_In (Ent, E_Constant, E_Variable)
-- Formals are interesting, but not if being used as mere -- Formals are interesting, but not if being used as mere
-- names of parameters for name notation calls. -- names of parameters for name notation calls.
or else or else
(Is_Formal (Ent) (Is_Formal (Ent)
and then not and then not
(Nkind (Parent (N)) = N_Parameter_Association (Nkind (Parent (N)) = N_Parameter_Association
and then Selector_Name (Parent (N)) = N)) and then Selector_Name (Parent (N)) = N))
-- Types other than known Is_Static types are interesting -- Types other than known Is_Static types are
-- potentially interesting
or else (Is_Type (Ent) or else (Is_Type (Ent)
and then not Is_Static_Type (Ent))) and then not Is_Static_Type (Ent)))
then then
-- Here we have a possible interesting uplevel reference -- Here we have a potentially interesting uplevel
-- reference to examine.
if Is_Type (Ent) then if Is_Type (Ent) then
declare declare
DT : Boolean := False; DT : Boolean := False;
begin begin
Check_Static_Type (Ent, N, DT); Check_Static_Type (Ent, N, DT);
if Is_Static_Type (Ent) then if Is_Static_Type (Ent) then
return OK; return OK;
end if;
end;
end if; end if;
end;
end if;
Caller := Current_Subprogram; Caller := Current_Subprogram;
Callee := Enclosing_Subprogram (Ent); Callee := Enclosing_Subprogram (Ent);
if Callee /= Caller and then not Is_Static_Type (Ent) then if Callee /= Caller
Note_Uplevel_Ref (Ent, N, Caller, Callee); and then not Is_Static_Type (Ent)
then
Note_Uplevel_Ref (Ent, N, Caller, Callee);
end if;
end if;
end if; end if;
end if; end case;
-- If we have a body stub, visit the associated subunit
elsif Nkind (N) in N_Body_Stub then
Visit (Library_Unit (N));
-- Skip generic declarations
elsif Nkind (N) in N_Generic_Declaration then
return Skip;
-- Skip generic package body
elsif Nkind (N) = N_Package_Body
and then Present (Corresponding_Spec (N))
and then Ekind (Corresponding_Spec (N)) = E_Generic_Package
then
return Skip;
end if;
-- Fall through to continue scanning children of this node -- Fall through to continue scanning children of this node
...@@ -1127,14 +1152,20 @@ package body Exp_Unst is ...@@ -1127,14 +1152,20 @@ package body Exp_Unst is
-- Rewrite declaration and body to null statements -- Rewrite declaration and body to null statements
Spec := Corresponding_Spec (STJ.Bod); -- A subprogram instantiation does not have an explicit
-- body. If unused, we could remove the corresponding
-- wrapper package and its body (TBD).
if Present (Spec) then if Present (STJ.Bod) then
Decl := Parent (Declaration_Node (Spec)); Spec := Corresponding_Spec (STJ.Bod);
Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
end if;
Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod))); if Present (Spec) then
Decl := Parent (Declaration_Node (Spec));
Rewrite (Decl, Make_Null_Statement (Sloc (Decl)));
end if;
Rewrite (STJ.Bod, Make_Null_Statement (Sloc (STJ.Bod)));
end if;
end if; end if;
end; end;
end loop; end loop;
......
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