-- --
-- B o d y --
-- --
--- Copyright (C) 1992-2008, Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2011, 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- --
with Lib; use Lib;
with Namet; use Namet;
with Nlists; use Nlists;
-with Opt; use Opt;
+with Sem_Aux; use Sem_Aux;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
-- Local Subprograms --
-----------------------
+ function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id;
+ pragma Inline (Get_Code_Unit_Entity);
+ -- Return the entity node for the unit containing E
+
function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean;
- -- Return True if Scop is in the main unit or its spec, or in a
- -- parent of the main unit if it is a child unit.
+ -- Return True if Scop is in the main unit or its spec
procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty);
-- Make two entries in Inlined table, for an inlined subprogram being
-- one needs to be recorded.
J := Inlined.Table (P1).First_Succ;
-
while J /= No_Succ loop
-
if Successors.Table (J).Subp = P2 then
return;
end if;
----------------------
procedure Add_Inlined_Body (E : Entity_Id) is
- Pack : Entity_Id;
function Must_Inline return Boolean;
-- Inlining is only done if the call statement N is in the main unit,
-- no enclosing package to retrieve. In this case, it is the body of
-- the function that will have to be loaded.
- if not Is_Abstract_Subprogram (E) and then not Is_Nested (E)
+ if not Is_Abstract_Subprogram (E)
+ and then not Is_Nested (E)
and then Convention (E) /= Convention_Protected
+ and then Must_Inline
then
- Pack := Scope (E);
+ declare
+ Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
- if Must_Inline
- and then Ekind (Pack) = E_Package
- then
- Set_Is_Called (E);
-
- if Pack = Standard_Standard then
+ begin
+ if Pack = E then
-- Library-level inlined function. Add function itself to
-- list of needed units.
+ Set_Is_Called (E);
Inlined_Bodies.Increment_Last;
Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
- elsif Is_Generic_Instance (Pack) then
- null;
+ elsif Ekind (Pack) = E_Package then
+ Set_Is_Called (E);
- elsif not Is_Inlined (Pack)
- and then not Has_Completion (E)
- and then not Scope_In_Main_Unit (Pack)
- then
- Set_Is_Inlined (Pack);
- Inlined_Bodies.Increment_Last;
- Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
+ if Is_Generic_Instance (Pack) then
+ null;
+
+ -- Do not inline the package if the subprogram is an init proc
+ -- or other internally generated subprogram, because in that
+ -- case the subprogram body appears in the same unit that
+ -- declares the type, and that body is visible to the back end.
+
+ elsif not Is_Inlined (Pack)
+ and then Comes_From_Source (E)
+ then
+ Set_Is_Inlined (Pack);
+ Inlined_Bodies.Increment_Last;
+ Inlined_Bodies.Table (Inlined_Bodies.Last) := Pack;
+ end if;
end if;
- end if;
+ end;
end if;
end Add_Inlined_Body;
procedure Add_Inlined_Subprogram (Index : Subp_Index) is
E : constant Entity_Id := Inlined.Table (Index).Name;
+ Pack : constant Entity_Id := Get_Code_Unit_Entity (E);
Succ : Succ_Index;
Subp : Subp_Index;
-- inlined under ZCX because the numeric suffix generated by gigi
-- will be different in the body and the place of the inlined call.
--
- -- If the body to be inlined contains calls to subprograms declared
- -- in the same body that have no previous spec, the back-end cannot
- -- inline either because the bodies to be inlined are processed before
- -- the rest of the enclosing package body, and gigi will then find
- -- references to entities that have not been elaborated yet.
- --
-- This procedure must be carefully coordinated with the back end.
----------------------------
Decl : constant Node_Id := Unit_Declaration_Node (Subp);
Body_Ent : Entity_Id;
Ent : Entity_Id;
- Bad_Call : Node_Id;
-
- function Process (N : Node_Id) return Traverse_Result;
- -- Look for calls to subprograms with no previous spec, declared
- -- in the same enclosiong package body.
-
- -------------
- -- Process --
- -------------
-
- function Process (N : Node_Id) return Traverse_Result is
- begin
- if Nkind (N) = N_Procedure_Call_Statement
- or else Nkind (N) = N_Function_Call
- then
- if Is_Entity_Name (Name (N))
- and then
- Nkind (Unit_Declaration_Node (Entity (Name (N))))
- = N_Subprogram_Body
- and then In_Same_Extended_Unit (Subp, Entity (Name (N)))
- then
- Bad_Call := N;
- return Abandon;
- else
- return OK;
- end if;
- else
- return OK;
- end if;
- end Process;
-
- function Has_Exposed_Call is new Traverse_Func (Process);
-
- -- Start of processing for Back_End_Cannot_Inline
begin
if Nkind (Decl) = N_Subprogram_Declaration
Next_Entity (Ent);
end loop;
- if Has_Exposed_Call
- (Unit_Declaration_Node (Corresponding_Body (Decl))) = Abandon
- then
- if Ineffective_Inline_Warnings then
- Error_Msg_N
- ("?call to subprogram with no separate spec"
- & " prevents inlining!!", Bad_Call);
- end if;
-
- return True;
- else
- return False;
- end if;
+ return False;
end Back_End_Cannot_Inline;
-- Start of processing for Add_Inlined_Subprogram
begin
- -- Insert the current subprogram in the list of inlined subprograms,
- -- if it can actually be inlined by the back-end.
-
- if not Scope_In_Main_Unit (E)
- and then Is_Inlined (E)
+ -- If the subprogram is to be inlined, and if its unit is known to be
+ -- inlined or is an instance whose body will be analyzed anyway or the
+ -- subprogram has been generated by the compiler, and if it is declared
+ -- at the library level not in the main unit, and if it can be inlined
+ -- by the back-end, then insert it in the list of inlined subprograms.
+
+ if Is_Inlined (E)
+ and then (Is_Inlined (Pack)
+ or else Is_Generic_Instance (Pack)
+ or else Is_Internal (E))
+ and then not Scope_In_Main_Unit (E)
and then not Is_Nested (E)
and then not Has_Initialized_Type (E)
then
Inlined.Table (Index).Listed := True;
+ -- Now add to the list those callers of the current subprogram that
+ -- are themselves called. They may appear on the graph as callers
+ -- of the current one, even if they are themselves not called, and
+ -- there is no point in including them in the list for the backend.
+ -- Furthermore, they might not even be public, in which case the
+ -- back-end cannot handle them at all.
+
Succ := Inlined.Table (Index).First_Succ;
while Succ /= No_Succ loop
Subp := Successors.Table (Succ).Subp;
Inlined.Table (Subp).Count := Inlined.Table (Subp).Count - 1;
- if Inlined.Table (Subp).Count = 0 then
+ if Inlined.Table (Subp).Count = 0
+ and then Is_Called (Inlined.Table (Subp).Name)
+ then
Add_Inlined_Subprogram (Subp);
end if;
return;
end if;
- -- If the instance appears within a generic subprogram there is nothing
- -- to finalize either.
+ -- If the instance is within a generic unit, no finalization code
+ -- can be generated. Note that at this point all bodies have been
+ -- analyzed, and the scope stack itself is not present, and the flag
+ -- Inside_A_Generic is not set.
declare
S : Entity_Id;
+
begin
S := Scope (Inst);
while Present (S) and then S /= Standard_Standard loop
- if Is_Generic_Subprogram (S) then
+ if Is_Generic_Unit (S) then
return;
end if;
end;
Elmt := First_Elmt (To_Clean);
-
while Present (Elmt) loop
-
if Node (Elmt) = Scop then
return;
end if;
else
J := Hash_Headers (Index);
-
while J /= No_Subp loop
-
if Inlined.Table (J).Name = E then
return J;
else
Pack : Entity_Id;
S : Succ_Index;
+ function Is_Ancestor_Of_Main
+ (U_Name : Entity_Id;
+ Nam : Node_Id) return Boolean;
+ -- Determine whether the unit whose body is loaded is an ancestor of
+ -- the main unit, and has a with_clause on it. The body is not
+ -- analyzed yet, so the check is purely lexical: the name of the with
+ -- clause is a selected component, and names of ancestors must match.
+
+ -------------------------
+ -- Is_Ancestor_Of_Main --
+ -------------------------
+
+ function Is_Ancestor_Of_Main
+ (U_Name : Entity_Id;
+ Nam : Node_Id) return Boolean
+ is
+ Pref : Node_Id;
+
+ begin
+ if Nkind (Nam) /= N_Selected_Component then
+ return False;
+
+ else
+ if Chars (Selector_Name (Nam)) /=
+ Chars (Cunit_Entity (Main_Unit))
+ then
+ return False;
+ end if;
+
+ Pref := Prefix (Nam);
+ if Nkind (Pref) = N_Identifier then
+
+ -- Par is an ancestor of Par.Child.
+
+ return Chars (Pref) = Chars (U_Name);
+
+ elsif Nkind (Pref) = N_Selected_Component
+ and then Chars (Selector_Name (Pref)) = Chars (U_Name)
+ then
+ -- Par.Child is an ancestor of Par.Child.Grand.
+
+ return True; -- should check that ancestor match
+
+ else
+ -- A is an ancestor of A.B.C if it is an ancestor of A.B
+
+ return Is_Ancestor_Of_Main (U_Name, Pref);
+ end if;
+ end if;
+ end Is_Ancestor_Of_Main;
+
+ -- Start of processing for Analyze_Inlined_Bodies
+
begin
Analyzing_Inlined_Bodies := False;
and then Serious_Errors_Detected = 0
loop
Pack := Inlined_Bodies.Table (J);
-
while Present (Pack)
and then Scope (Pack) /= Standard_Standard
and then not Is_Child_Unit (Pack)
Comp_Unit := Parent (Comp_Unit);
end loop;
- -- Load the body, unless it the main unit, or is an instance
- -- whose body has already been analyzed.
+ -- Load the body, unless it the main unit, or is an instance whose
+ -- body has already been analyzed.
if Present (Comp_Unit)
and then Comp_Unit /= Cunit (Main_Unit)
begin
if not Is_Loaded (Bname) then
- Load_Needed_Body (Comp_Unit, OK);
+ Style_Check := False;
+ Load_Needed_Body (Comp_Unit, OK, Do_Analyze => False);
if not OK then
Error_Msg_File_1 :=
Get_File_Name (Bname, Subunit => False);
Error_Msg_N ("\but file{ was not found!?", Comp_Unit);
+
+ else
+ -- If the package to be inlined is an ancestor unit of
+ -- the main unit, and it has a semantic dependence on
+ -- it, the inlining cannot take place to prevent an
+ -- elaboration circularity. The desired body is not
+ -- analyzed yet, to prevent the completion of Taft
+ -- amendment types that would lead to elaboration
+ -- circularities in gigi.
+
+ declare
+ U_Id : constant Entity_Id :=
+ Defining_Entity (Unit (Comp_Unit));
+ Body_Unit : constant Node_Id :=
+ Library_Unit (Comp_Unit);
+ Item : Node_Id;
+
+ begin
+ Item := First (Context_Items (Body_Unit));
+ while Present (Item) loop
+ if Nkind (Item) = N_With_Clause
+ and then
+ Is_Ancestor_Of_Main (U_Id, Name (Item))
+ then
+ Set_Is_Inlined (U_Id, False);
+ exit;
+ end if;
+
+ Next (Item);
+ end loop;
+
+ -- If no suspicious with_clauses, analyze the body.
+
+ if Is_Inlined (U_Id) then
+ Semantics (Body_Unit);
+ end if;
+ end;
end if;
end if;
end;
Instantiate_Bodies;
- -- The list of inlined subprograms is an overestimate, because
- -- it includes inlined functions called from functions that are
- -- compiled as part of an inlined package, but are not themselves
- -- called. An accurate computation of just those subprograms that
- -- are needed requires that we perform a transitive closure over
- -- the call graph, starting from calls in the main program. Here
- -- we do one step of the inverse transitive closure, and reset
- -- the Is_Called flag on subprograms all of whose callers are not.
+ -- The list of inlined subprograms is an overestimate, because it
+ -- includes inlined functions called from functions that are compiled
+ -- as part of an inlined package, but are not themselves called. An
+ -- accurate computation of just those subprograms that are needed
+ -- requires that we perform a transitive closure over the call graph,
+ -- starting from calls in the main program. Here we do one step of
+ -- the inverse transitive closure, and reset the Is_Called flag on
+ -- subprograms all of whose callers are not.
for Index in Inlined.First .. Inlined.Last loop
S := Inlined.Table (Index).First_Succ;
Set_Is_Called (Inlined.Table (Index).Name, False);
while S /= No_Succ loop
-
if Is_Called
(Inlined.Table (Successors.Table (S).Subp).Name)
or else Inlined.Table (Successors.Table (S).Subp).Main_Call
and then not Is_Generic_Instance (P)
then
Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
- E := First_Entity (P);
+ E := First_Entity (P);
while Present (E) loop
if Has_Pragma_Inline_Always (E)
or else (Front_End_Inlining and then Has_Pragma_Inline (E))
if OK then
- -- Check that we are not trying to inline a parent
- -- whose body depends on a child, when we are compiling
- -- the body of the child. Otherwise we have a potential
- -- elaboration circularity with inlined subprograms and
- -- with Taft-Amendment types.
+ -- Check we are not trying to inline a parent whose body
+ -- depends on a child, when we are compiling the body of
+ -- the child. Otherwise we have a potential elaboration
+ -- circularity with inlined subprograms and with
+ -- Taft-Amendment types.
declare
Comp : Node_Id; -- Body just compiled
and then Present (Body_Entity (P))
then
Child_Spec :=
- Defining_Entity (
- (Unit (Library_Unit (Cunit (Main_Unit)))));
+ Defining_Entity
+ ((Unit (Library_Unit (Cunit (Main_Unit)))));
Comp :=
Parent (Unit_Declaration_Node (Body_Entity (P)));
- With_Clause := First (Context_Items (Comp));
-
-- Check whether the context of the body just
-- compiled includes a child of itself, and that
-- child is the spec of the main compilation.
+ With_Clause := First (Context_Items (Comp));
while Present (With_Clause) loop
if Nkind (With_Clause) = N_With_Clause
and then
-- and keep Taft-amendment types incomplete.
Ent := First_Entity (P);
-
while Present (Ent) loop
if Is_Type (Ent)
and then Has_Completion_In_Body (Ent)
begin
Elmt := First_Elmt (To_Clean);
-
while Present (Elmt) loop
Scop := Node (Elmt);
Set_Uses_Sec_Stack
(Protected_Body_Subprogram (Scop),
Uses_Sec_Stack (Scop));
- Set_Finalization_Chain_Entity
- (Protected_Body_Subprogram (Scop),
- Finalization_Chain_Entity (Scop));
+
Scop := Protected_Body_Subprogram (Scop);
end if;
end Cleanup_Scopes;
--------------------------
+ -- Get_Code_Unit_Entity --
+ --------------------------
+
+ function Get_Code_Unit_Entity (E : Entity_Id) return Entity_Id is
+ begin
+ return Cunit_Entity (Get_Code_Unit (E));
+ end Get_Code_Unit_Entity;
+
+ --------------------------
-- Has_Initialized_Type --
--------------------------
else
Decl := First (Declarations (E_Body));
-
while Present (Decl) loop
if Nkind (Decl) = N_Full_Type_Declaration
---------------
function Is_Nested (E : Entity_Id) return Boolean is
- Scop : Entity_Id := Scope (E);
+ Scop : Entity_Id;
begin
+ Scop := Scope (E);
while Scop /= Standard_Standard loop
if Ekind (Scop) in Subprogram_Kind then
return True;
--------------------------
procedure Remove_Dead_Instance (N : Node_Id) is
- J : Int;
+ J : Int;
begin
J := 0;
-
while J <= Pending_Instantiations.Last loop
-
if Pending_Instantiations.Table (J).Inst_Node = N then
Pending_Instantiations.Table (J).Inst_Node := Empty;
return;
------------------------
function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean is
- Comp : Node_Id;
- S : Entity_Id := Scop;
- Ent : Entity_Id := Cunit_Entity (Main_Unit);
+ Comp : constant Node_Id := Cunit (Get_Code_Unit (Scop));
begin
- -- The scope may be within the main unit, or it may be an ancestor
- -- of the main unit, if the main unit is a child unit. In both cases
- -- it makes no sense to process the body before the main unit. In
- -- the second case, this may lead to circularities if a parent body
- -- depends on a child spec, and we are analyzing the child.
-
- while Scope (S) /= Standard_Standard
- and then not Is_Child_Unit (S)
- loop
- S := Scope (S);
- end loop;
-
- Comp := Parent (S);
-
- while Present (Comp)
- and then Nkind (Comp) /= N_Compilation_Unit
- loop
- Comp := Parent (Comp);
- end loop;
-
- if Is_Child_Unit (Ent) then
-
- while Present (Ent)
- and then Is_Child_Unit (Ent)
- loop
- if Scope (Ent) = S then
- return True;
- end if;
-
- Ent := Scope (Ent);
- end loop;
- end if;
+ -- Check whether the scope of the subprogram to inline is within the
+ -- main unit or within its spec. In either case there are no additional
+ -- bodies to process. If the subprogram appears in a parent of the
+ -- current unit, the check on whether inlining is possible is done in
+ -- Analyze_Inlined_Bodies.
return
Comp = Cunit (Main_Unit)
OSDN Git Service
