-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1992-2001 Free Software Foundation, Inc. --
+-- Copyright (C) 1992-2003 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- --
--------------
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;
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;
Comp : Node_Id;
begin
- -- Check if call is in main unit.
+ -- Check if call is in main unit
while Scope (Scop) /= Standard_Standard
and then not Is_Child_Unit (Scop)
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;
and then Ekind (Pack) = E_Package
then
Set_Is_Called (E);
- Comp_Unit := Parent (Pack);
if Pack = Standard_Standard then
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 numerix suffix generated by gigi
+ -- will be different in the body and the place of the inlined call.
+ --
+ -- 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;
+
+ 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 Is_Always_Inlined (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;
+ 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
+ -- 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;
------------------------
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,
E := First_Entity (P);
while Present (E) loop
- if Has_Pragma_Inline (E) then
+ if Is_Always_Inlined (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 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.
+
+ 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)));
+
+ 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.
+
+ 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);
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.
+
+ Set_Uses_Sec_Stack
+ (Protected_Body_Subprogram (Scop),
+ Uses_Sec_Stack (Scop));
+ Scop := Protected_Body_Subprogram (Scop);
end if;
if Ekind (Scop) = E_Block then
begin
if Serious_Errors_Detected = 0 then
- Expander_Active := (Operating_Mode = Opt.Generate_Code);
+ Expander_Active := (Operating_Mode = Opt.Generate_Code);
New_Scope (Standard_Standard);
To_Clean := New_Elmt_List;
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));
OSDN Git Service
