-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2009, 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 2, or (at your option) any later ver- --
+-- 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 COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- 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. --
--- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
+-- Extensive contributions were provided by Ada Core Technologies Inc. --
-- --
------------------------------------------------------------------------------
with Elists; use Elists;
with Errout; use Errout;
with Exp_Ch7; use Exp_Ch7;
-with Exp_Ch11; use Exp_Ch11;
with Exp_Tss; use Exp_Tss;
with Fname; use Fname;
with Fname.UF; use Fname.UF;
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;
type Subp_Index is new Nat;
No_Subp : constant Subp_Index := 0;
- -- The subprogram entities are hashed into the Inlined table.
+ -- The subprogram entities are hashed into the Inlined table
Num_Hash_Headers : constant := 512;
To_Clean : Elist_Id;
procedure Add_Scope_To_Clean (Inst : Entity_Id);
- -- Build set of scopes on which cleanup actions must be performed.
+ -- Build set of scopes on which cleanup actions must be performed
procedure Cleanup_Scopes;
- -- Complete cleanup actions on scopes that need it.
+ -- Complete cleanup actions on scopes that need it
--------------
-- Add_Call --
--------------
procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
- P1 : Subp_Index := Add_Subp (Called);
+ P1 : constant Subp_Index := Add_Subp (Called);
P2 : Subp_Index;
J : Succ_Index;
-- 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;
J := Successors.Table (J).Next;
end loop;
- -- On exit, make a successor entry for P2.
+ -- On exit, make a successor entry for P2
Successors.Increment_Last;
Successors.Table (Successors.Last).Subp := P2;
procedure Add_Inlined_Body (E : Entity_Id) is
Pack : Entity_Id;
- Comp_Unit : Node_Id;
function Must_Inline return Boolean;
-- Inlining is only done if the call statement N is in the main unit,
-- or within the body of another inlined subprogram.
+ -----------------
+ -- Must_Inline --
+ -----------------
+
function Must_Inline return Boolean is
- Scop : Entity_Id := Current_Scope;
+ Scop : Entity_Id;
Comp : Node_Id;
begin
- -- Check if call is in main unit.
+ -- Check if call is in main unit
+
+ Scop := Current_Scope;
+
+ -- Do not try to inline if scope is standard. This could happen, for
+ -- example, for a call to Add_Global_Declaration, and it causes
+ -- trouble to try to inline at this level.
+
+ if Scop = Standard_Standard then
+ return False;
+ end if;
+
+ -- Otherwise lookup scope stack to outer scope
while Scope (Scop) /= Standard_Standard
and then not Is_Child_Unit (Scop)
end loop;
Comp := Parent (Scop);
-
while Nkind (Comp) /= N_Compilation_Unit loop
Comp := Parent (Comp);
end loop;
- if (Comp = Cunit (Main_Unit)
- or else Comp = Library_Unit (Cunit (Main_Unit)))
+ if Comp = Cunit (Main_Unit)
+ or else Comp = Library_Unit (Cunit (Main_Unit))
then
Add_Call (E);
return True;
end if;
- -- Call is not in main unit. See if it's in some inlined
- -- subprogram.
+ -- Call is not in main unit. See if it's in some inlined subprogram
Scop := Current_Scope;
while Scope (Scop) /= Standard_Standard
end loop;
return False;
-
end Must_Inline;
-- Start of processing for Add_Inlined_Body
-- 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 (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
then
Pack := Scope (E);
and then Ekind (Pack) = E_Package
then
Set_Is_Called (E);
- Comp_Unit := Parent (Pack);
if Pack = Standard_Standard then
- -- Library-level inlined function. Add function iself to
+ -- Library-level inlined function. Add function itself to
-- list of needed units.
Inlined_Bodies.Increment_Last;
Succ : Succ_Index;
Subp : Subp_Index;
+ function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean;
+ -- There are various conditions under which back-end inlining cannot
+ -- be done reliably:
+ --
+ -- a) If a body has handlers, it must not be inlined, because this
+ -- may violate program semantics, and because in zero-cost exception
+ -- mode it will lead to undefined symbols at link time.
+ --
+ -- b) If a body contains inlined function instances, it cannot be
+ -- 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.
+
+ ----------------------------
+ -- Back_End_Cannot_Inline --
+ ----------------------------
+
+ function Back_End_Cannot_Inline (Subp : Entity_Id) return Boolean is
+ 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 Comes_From_Source (Entity (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
+ and then Present (Corresponding_Body (Decl))
+ then
+ Body_Ent := Corresponding_Body (Decl);
+ else
+ return False;
+ end if;
+
+ -- If subprogram is marked Inline_Always, inlining is mandatory
+
+ if Has_Pragma_Inline_Always (Subp) then
+ return False;
+ end if;
+
+ if Present
+ (Exception_Handlers
+ (Handled_Statement_Sequence
+ (Unit_Declaration_Node (Corresponding_Body (Decl)))))
+ then
+ return True;
+ end if;
+
+ Ent := First_Entity (Body_Ent);
+ while Present (Ent) loop
+ if Is_Subprogram (Ent)
+ and then Is_Generic_Instance (Ent)
+ then
+ return True;
+ end if;
+
+ 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;
+ end Back_End_Cannot_Inline;
+
+ -- Start of processing for Add_Inlined_Subprogram
+
begin
- -- Insert the current subprogram in the list of inlined subprograms
+ -- 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)
and then not Is_Nested (E)
and then not Has_Initialized_Type (E)
then
- if No (Last_Inlined) then
- Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
+ if Back_End_Cannot_Inline (E) then
+ Set_Is_Inlined (E, False);
+
else
- Set_Next_Inlined_Subprogram (Last_Inlined, E);
- end if;
+ if No (Last_Inlined) then
+ Set_First_Inlined_Subprogram (Cunit (Main_Unit), E);
+ else
+ Set_Next_Inlined_Subprogram (Last_Inlined, E);
+ end if;
- Last_Inlined := E;
+ Last_Inlined := E;
+ end if;
end if;
Inlined.Table (Index).Listed := True;
- Succ := Inlined.Table (Index).First_Succ;
+ -- 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;
------------------------
procedure Add_Scope_To_Clean (Inst : Entity_Id) is
+ Scop : constant Entity_Id := Enclosing_Dynamic_Scope (Inst);
Elmt : Elmt_Id;
- Scop : Entity_Id := Enclosing_Dynamic_Scope (Inst);
begin
-- If the instance appears in a library-level package declaration,
return;
end if;
- Elmt := First_Elmt (To_Clean);
+ -- If the instance appears within a generic subprogram there is nothing
+ -- to finalize either.
- while Present (Elmt) loop
+ declare
+ S : Entity_Id;
+
+ begin
+ S := Scope (Inst);
+ while Present (S) and then S /= Standard_Standard loop
+ if Is_Generic_Subprogram (S) then
+ return;
+ end if;
+
+ S := Scope (S);
+ end loop;
+ end;
+ Elmt := First_Elmt (To_Clean);
+ while Present (Elmt) loop
if Node (Elmt) = Scop then
return;
end if;
J : Subp_Index;
procedure New_Entry;
- -- Initialize entry in Inlined table.
+ -- Initialize entry in Inlined table
procedure New_Entry is
begin
else
J := Hash_Headers (Index);
-
while J /= No_Subp loop
-
if Inlined.Table (J).Name = E then
return J;
else
Analyzing_Inlined_Bodies := False;
if Serious_Errors_Detected = 0 then
- New_Scope (Standard_Standard);
+ Push_Scope (Standard_Standard);
J := 0;
while J <= Inlined_Bodies.Last
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)
end loop;
Comp_Unit := Parent (Pack);
-
while Present (Comp_Unit)
and then Nkind (Comp_Unit) /= N_Compilation_Unit
loop
Load_Needed_Body (Comp_Unit, OK);
if not OK then
+
+ -- Warn that a body was not available for inlining
+ -- by the back-end.
+
Error_Msg_Unit_1 := Bname;
Error_Msg_N
- ("one or more inlined subprograms accessed in $!",
+ ("one or more inlined subprograms accessed in $!?",
Comp_Unit);
- Error_Msg_Name_1 :=
+ Error_Msg_File_1 :=
Get_File_Name (Bname, Subunit => False);
- Error_Msg_N ("\but file{ was not found!", Comp_Unit);
- raise Unrecoverable_Error;
+ Error_Msg_N ("\but file{ was not found!?", Comp_Unit);
end if;
end if;
end;
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
then
Error_Msg_N
("& cannot be inlined?", Inlined.Table (Index).Name);
- -- A warning on the first one might be sufficient.
+
+ -- A warning on the first one might be sufficient ???
end if;
end loop;
end if;
end Analyze_Inlined_Bodies;
- --------------------------------
- -- Check_Body_For_Inlining --
- --------------------------------
+ -----------------------------
+ -- Check_Body_For_Inlining --
+ -----------------------------
procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
Bname : Unit_Name_Type;
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 (E) then
+ if Has_Pragma_Inline_Always (E)
+ or else (Front_End_Inlining and then Has_Pragma_Inline (E))
+ then
if not Is_Loaded (Bname) then
Load_Needed_Body (N, OK);
- if not OK
- and then Ineffective_Inline_Warnings
- then
+ if OK then
+
+ -- 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
+ Child_Spec : Entity_Id; -- Spec of main unit
+ Ent : Entity_Id; -- For iteration
+ With_Clause : Node_Id; -- Context of body.
+
+ begin
+ if Nkind (Unit (Cunit (Main_Unit))) = N_Package_Body
+ and then Present (Body_Entity (P))
+ then
+ Child_Spec :=
+ Defining_Entity
+ ((Unit (Library_Unit (Cunit (Main_Unit)))));
+
+ Comp :=
+ Parent (Unit_Declaration_Node (Body_Entity (P)));
+
+ -- 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
+ Scope (Entity (Name (With_Clause))) = P
+ and then
+ Entity (Name (With_Clause)) = Child_Spec
+ then
+ Error_Msg_Node_2 := Child_Spec;
+ Error_Msg_NE
+ ("body of & depends on child unit&?",
+ With_Clause, P);
+ Error_Msg_N
+ ("\subprograms in body cannot be inlined?",
+ With_Clause);
+
+ -- Disable further inlining from this unit,
+ -- 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)
+ then
+ Set_Full_View (Ent, Empty);
+
+ elsif Is_Subprogram (Ent) then
+ Set_Is_Inlined (Ent, False);
+ end if;
+
+ Next_Entity (Ent);
+ end loop;
+
+ return;
+ end if;
+
+ Next (With_Clause);
+ end loop;
+ end if;
+ end;
+
+ elsif Ineffective_Inline_Warnings then
Error_Msg_Unit_1 := Bname;
Error_Msg_N
("unable to inline subprograms defined in $?", P);
begin
Elmt := First_Elmt (To_Clean);
-
while Present (Elmt) loop
Scop := Node (Elmt);
if Ekind (Scop) = E_Entry then
Scop := Protected_Body_Subprogram (Scop);
+
+ elsif Is_Subprogram (Scop)
+ and then Is_Protected_Type (Scope (Scop))
+ and then Present (Protected_Body_Subprogram (Scop))
+ then
+ -- If a protected operation contains an instance, its
+ -- cleanup operations have been delayed, and the subprogram
+ -- has been rewritten in the expansion of the enclosing
+ -- protected body. It is the corresponding subprogram that
+ -- may require the cleanup operations, so propagate the
+ -- information that triggers cleanup activity.
+
+ 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;
if Ekind (Scop) = E_Block then
end if;
end if;
- New_Scope (Scop);
+ Push_Scope (Scop);
Expand_Cleanup_Actions (Decl);
End_Scope;
else
Decl := First (Declarations (E_Body));
-
while Present (Decl) loop
if Nkind (Decl) = N_Full_Type_Declaration
begin
if Serious_Errors_Detected = 0 then
- Expander_Active := (Operating_Mode = Opt.Generate_Code);
- New_Scope (Standard_Standard);
+ Expander_Active := (Operating_Mode = Opt.Generate_Code);
+ Push_Scope (Standard_Standard);
To_Clean := New_Elmt_List;
if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
-- set (that's why we can't simply use a FOR loop here).
J := 0;
-
while J <= Pending_Instantiations.Last
and then Serious_Errors_Detected = 0
loop
-
Info := Pending_Instantiations.Table (J);
- -- If the instantiation node is absent, it has been removed
+ -- If the instantiation node is absent, it has been removed
-- as part of unreachable code.
if No (Info.Inst_Node) then
null;
- elsif Nkind (Info. Act_Decl) = N_Package_Declaration then
+ elsif Nkind (Info.Act_Decl) = N_Package_Declaration then
Instantiate_Package_Body (Info);
Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
and then not Is_Generic_Unit (Main_Unit_Entity)
then
Cleanup_Scopes;
-
- -- Also generate subprogram descriptors that were delayed
-
- for J in Pending_Descriptor.First .. Pending_Descriptor.Last loop
- declare
- Ent : constant Entity_Id := Pending_Descriptor.Table (J);
-
- begin
- if Is_Subprogram (Ent) then
- Generate_Subprogram_Descriptor_For_Subprogram
- (Get_Subprogram_Body (Ent), Ent);
-
- elsif Ekind (Ent) = E_Package then
- Generate_Subprogram_Descriptor_For_Package
- (Parent (Declaration_Node (Ent)), Ent);
-
- elsif Ekind (Ent) = E_Package_Body then
- Generate_Subprogram_Descriptor_For_Package
- (Declaration_Node (Ent), Ent);
- end if;
- end;
- end loop;
-
elsif Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
End_Generic;
end if;
---------------
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;
+ S : Entity_Id;
Ent : Entity_Id := Cunit_Entity (Main_Unit);
begin
-- the second case, this may lead to circularities if a parent body
-- depends on a child spec, and we are analyzing the child.
+ S := Scop;
while Scope (S) /= Standard_Standard
and then not Is_Child_Unit (S)
loop
end loop;
Comp := Parent (S);
-
while Present (Comp)
and then Nkind (Comp) /= N_Compilation_Unit
loop
end loop;
if Is_Child_Unit (Ent) then
-
while Present (Ent)
and then Is_Child_Unit (Ent)
loop
OSDN Git Service
