with Atree; use Atree;
with Einfo; use Einfo;
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 Nlists; use Nlists;
with Opt; use Opt;
with Sem_Ch8; use Sem_Ch8;
with Sem_Ch10; use Sem_Ch10;
with Sem_Ch12; use Sem_Ch12;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Snames; use Snames;
with Stand; use Stand;
with Uname; use Uname;
package body Inline is
package Inlined_Bodies is new Table.Table (
Table_Component_Type => Entity_Id,
Table_Index_Type => Int,
Table_Low_Bound => 0,
Table_Initial => Alloc.Inlined_Bodies_Initial,
Table_Increment => Alloc.Inlined_Bodies_Increment,
Table_Name => "Inlined_Bodies");
Last_Inlined : Entity_Id := Empty;
type Subp_Index is new Nat;
No_Subp : constant Subp_Index := 0;
Num_Hash_Headers : constant := 512;
Hash_Headers : array (Subp_Index range 0 .. Num_Hash_Headers - 1)
of Subp_Index;
type Succ_Index is new Nat;
No_Succ : constant Succ_Index := 0;
type Succ_Info is record
Subp : Subp_Index;
Next : Succ_Index;
end record;
package Successors is new Table.Table (
Table_Component_Type => Succ_Info,
Table_Index_Type => Succ_Index,
Table_Low_Bound => 1,
Table_Initial => Alloc.Successors_Initial,
Table_Increment => Alloc.Successors_Increment,
Table_Name => "Successors");
type Subp_Info is record
Name : Entity_Id := Empty;
First_Succ : Succ_Index := No_Succ;
Count : Integer := 0;
Listed : Boolean := False;
Main_Call : Boolean := False;
Next : Subp_Index := No_Subp;
Next_Nopred : Subp_Index := No_Subp;
end record;
package Inlined is new Table.Table (
Table_Component_Type => Subp_Info,
Table_Index_Type => Subp_Index,
Table_Low_Bound => 1,
Table_Initial => Alloc.Inlined_Initial,
Table_Increment => Alloc.Inlined_Increment,
Table_Name => "Inlined");
function Scope_In_Main_Unit (Scop : Entity_Id) return Boolean;
procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty);
function Add_Subp (E : Entity_Id) return Subp_Index;
function Has_Initialized_Type (E : Entity_Id) return Boolean;
function Is_Nested (E : Entity_Id) return Boolean;
procedure Add_Inlined_Subprogram (Index : Subp_Index);
To_Clean : Elist_Id;
procedure Add_Scope_To_Clean (Inst : Entity_Id);
procedure Cleanup_Scopes;
procedure Add_Call (Called : Entity_Id; Caller : Entity_Id := Empty) is
P1 : Subp_Index := Add_Subp (Called);
P2 : Subp_Index;
J : Succ_Index;
begin
if Present (Caller) then
P2 := Add_Subp (Caller);
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;
Successors.Increment_Last;
Successors.Table (Successors.Last).Subp := P2;
Successors.Table (Successors.Last).Next :=
Inlined.Table (P1).First_Succ;
Inlined.Table (P1).First_Succ := Successors.Last;
Inlined.Table (P2).Count := Inlined.Table (P2).Count + 1;
else
Inlined.Table (P1).Main_Call := True;
end if;
end Add_Call;
procedure Add_Inlined_Body (E : Entity_Id) is
Pack : Entity_Id;
Comp_Unit : Node_Id;
function Must_Inline return Boolean;
function Must_Inline return Boolean is
Scop : Entity_Id := Current_Scope;
Comp : Node_Id;
begin
while Scope (Scop) /= Standard_Standard
and then not Is_Child_Unit (Scop)
loop
Scop := Scope (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)))
then
Add_Call (E);
return True;
end if;
Scop := Current_Scope;
while Scope (Scop) /= Standard_Standard
and then not Is_Child_Unit (Scop)
loop
if Is_Overloadable (Scop)
and then Is_Inlined (Scop)
then
Add_Call (E, Scop);
return True;
end if;
Scop := Scope (Scop);
end loop;
return False;
end Must_Inline;
begin
if not Is_Abstract (E) and then not Is_Nested (E)
and then Convention (E) /= Convention_Protected
then
Pack := Scope (E);
if Must_Inline
and then Ekind (Pack) = E_Package
then
Set_Is_Called (E);
Comp_Unit := Parent (Pack);
if Pack = Standard_Standard then
Inlined_Bodies.Increment_Last;
Inlined_Bodies.Table (Inlined_Bodies.Last) := E;
elsif Is_Generic_Instance (Pack) then
null;
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;
end if;
end if;
end if;
end Add_Inlined_Body;
procedure Add_Inlined_Subprogram (Index : Subp_Index) is
E : constant Entity_Id := Inlined.Table (Index).Name;
Succ : Succ_Index;
Subp : Subp_Index;
begin
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);
else
Set_Next_Inlined_Subprogram (Last_Inlined, E);
end if;
Last_Inlined := E;
end if;
Inlined.Table (Index).Listed := True;
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
Add_Inlined_Subprogram (Subp);
end if;
Succ := Successors.Table (Succ).Next;
end loop;
end Add_Inlined_Subprogram;
procedure Add_Scope_To_Clean (Inst : Entity_Id) is
Elmt : Elmt_Id;
Scop : Entity_Id := Enclosing_Dynamic_Scope (Inst);
begin
if Scop = Standard_Standard then
return;
end if;
Elmt := First_Elmt (To_Clean);
while Present (Elmt) loop
if Node (Elmt) = Scop then
return;
end if;
Elmt := Next_Elmt (Elmt);
end loop;
Append_Elmt (Scop, To_Clean);
end Add_Scope_To_Clean;
function Add_Subp (E : Entity_Id) return Subp_Index is
Index : Subp_Index := Subp_Index (E) mod Num_Hash_Headers;
J : Subp_Index;
procedure New_Entry;
procedure New_Entry is
begin
Inlined.Increment_Last;
Inlined.Table (Inlined.Last).Name := E;
Inlined.Table (Inlined.Last).First_Succ := No_Succ;
Inlined.Table (Inlined.Last).Count := 0;
Inlined.Table (Inlined.Last).Listed := False;
Inlined.Table (Inlined.Last).Main_Call := False;
Inlined.Table (Inlined.Last).Next := No_Subp;
Inlined.Table (Inlined.Last).Next_Nopred := No_Subp;
end New_Entry;
begin
if Hash_Headers (Index) = No_Subp then
New_Entry;
Hash_Headers (Index) := Inlined.Last;
return Inlined.Last;
else
J := Hash_Headers (Index);
while J /= No_Subp loop
if Inlined.Table (J).Name = E then
return J;
else
Index := J;
J := Inlined.Table (J).Next;
end if;
end loop;
New_Entry;
Inlined.Table (Index).Next := Inlined.Last;
return Inlined.Last;
end if;
end Add_Subp;
procedure Analyze_Inlined_Bodies is
Comp_Unit : Node_Id;
J : Int;
Pack : Entity_Id;
S : Succ_Index;
begin
Analyzing_Inlined_Bodies := False;
if Serious_Errors_Detected = 0 then
New_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)
loop
Pack := Scope (Pack);
end loop;
Comp_Unit := Parent (Pack);
while Present (Comp_Unit)
and then Nkind (Comp_Unit) /= N_Compilation_Unit
loop
Comp_Unit := Parent (Comp_Unit);
end loop;
if Present (Comp_Unit)
and then Comp_Unit /= Cunit (Main_Unit)
and then Body_Required (Comp_Unit)
and then (Nkind (Unit (Comp_Unit)) /= N_Package_Declaration
or else No (Corresponding_Body (Unit (Comp_Unit))))
then
declare
Bname : constant Unit_Name_Type :=
Get_Body_Name (Get_Unit_Name (Unit (Comp_Unit)));
OK : Boolean;
begin
if not Is_Loaded (Bname) then
Load_Needed_Body (Comp_Unit, OK);
if not OK then
Error_Msg_Unit_1 := Bname;
Error_Msg_N
("one or more inlined subprograms accessed in $!",
Comp_Unit);
Error_Msg_Name_1 :=
Get_File_Name (Bname, Subunit => False);
Error_Msg_N ("\but file{ was not found!", Comp_Unit);
raise Unrecoverable_Error;
end if;
end if;
end;
end if;
J := J + 1;
end loop;
Instantiate_Bodies;
for Index in Inlined.First .. Inlined.Last loop
S := Inlined.Table (Index).First_Succ;
if S /= No_Succ
and then not Inlined.Table (Index).Main_Call
then
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
Set_Is_Called (Inlined.Table (Index).Name);
exit;
end if;
S := Successors.Table (S).Next;
end loop;
end if;
end loop;
for Index in Inlined.First .. Inlined.Last loop
if Is_Called (Inlined.Table (Index).Name)
and then Inlined.Table (Index).Count = 0
and then not Inlined.Table (Index).Listed
then
Add_Inlined_Subprogram (Index);
end if;
end loop;
for Index in Inlined.First .. Inlined.Last loop
if Is_Called (Inlined.Table (Index).Name)
and then Inlined.Table (Index).Count /= 0
and then not Is_Predefined_File_Name
(Unit_File_Name
(Get_Source_Unit (Inlined.Table (Index).Name)))
then
Error_Msg_N
("& cannot be inlined?", Inlined.Table (Index).Name);
end if;
end loop;
Pop_Scope;
end if;
end Analyze_Inlined_Bodies;
procedure Check_Body_For_Inlining (N : Node_Id; P : Entity_Id) is
Bname : Unit_Name_Type;
E : Entity_Id;
OK : Boolean;
begin
if Is_Compilation_Unit (P)
and then not Is_Generic_Instance (P)
then
Bname := Get_Body_Name (Get_Unit_Name (Unit (N)));
E := First_Entity (P);
while Present (E) loop
if 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
Error_Msg_Unit_1 := Bname;
Error_Msg_N
("unable to inline subprograms defined in $?", P);
Error_Msg_N ("\body not found?", P);
return;
end if;
end if;
return;
end if;
Next_Entity (E);
end loop;
end if;
end Check_Body_For_Inlining;
procedure Cleanup_Scopes is
Elmt : Elmt_Id;
Decl : Node_Id;
Scop : Entity_Id;
begin
Elmt := First_Elmt (To_Clean);
while Present (Elmt) loop
Scop := Node (Elmt);
if Ekind (Scop) = E_Entry then
Scop := Protected_Body_Subprogram (Scop);
end if;
if Ekind (Scop) = E_Block then
Decl := Parent (Block_Node (Scop));
else
Decl := Unit_Declaration_Node (Scop);
if Nkind (Decl) = N_Subprogram_Declaration
or else Nkind (Decl) = N_Task_Type_Declaration
or else Nkind (Decl) = N_Subprogram_Body_Stub
then
Decl := Unit_Declaration_Node (Corresponding_Body (Decl));
end if;
end if;
New_Scope (Scop);
Expand_Cleanup_Actions (Decl);
End_Scope;
Elmt := Next_Elmt (Elmt);
end loop;
end Cleanup_Scopes;
function Has_Initialized_Type (E : Entity_Id) return Boolean is
E_Body : constant Node_Id := Get_Subprogram_Body (E);
Decl : Node_Id;
begin
if No (E_Body) then return False;
else
Decl := First (Declarations (E_Body));
while Present (Decl) loop
if Nkind (Decl) = N_Full_Type_Declaration
and then Present (Init_Proc (Defining_Identifier (Decl)))
then
return True;
end if;
Next (Decl);
end loop;
end if;
return False;
end Has_Initialized_Type;
procedure Initialize is
begin
Analyzing_Inlined_Bodies := False;
Pending_Descriptor.Init;
Pending_Instantiations.Init;
Inlined_Bodies.Init;
Successors.Init;
Inlined.Init;
for J in Hash_Headers'Range loop
Hash_Headers (J) := No_Subp;
end loop;
end Initialize;
procedure Instantiate_Bodies is
J : Int;
Info : Pending_Body_Info;
begin
if Serious_Errors_Detected = 0 then
Expander_Active := (Operating_Mode = Opt.Generate_Code);
New_Scope (Standard_Standard);
To_Clean := New_Elmt_List;
if Is_Generic_Unit (Cunit_Entity (Main_Unit)) then
Start_Generic;
end if;
J := 0;
while J <= Pending_Instantiations.Last
and then Serious_Errors_Detected = 0
loop
Info := Pending_Instantiations.Table (J);
if No (Info.Inst_Node) then
null;
elsif Nkind (Info. Act_Decl) = N_Package_Declaration then
Instantiate_Package_Body (Info);
Add_Scope_To_Clean (Defining_Entity (Info.Act_Decl));
else
Instantiate_Subprogram_Body (Info);
end if;
J := J + 1;
end loop;
Pending_Instantiations.Init;
if Expander_Active
and then not Is_Generic_Unit (Main_Unit_Entity)
then
Cleanup_Scopes;
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;
Pop_Scope;
end if;
end Instantiate_Bodies;
function Is_Nested (E : Entity_Id) return Boolean is
Scop : Entity_Id := Scope (E);
begin
while Scop /= Standard_Standard loop
if Ekind (Scop) in Subprogram_Kind then
return True;
elsif Ekind (Scop) = E_Task_Type
or else Ekind (Scop) = E_Entry
or else Ekind (Scop) = E_Entry_Family then
return True;
end if;
Scop := Scope (Scop);
end loop;
return False;
end Is_Nested;
procedure Lock is
begin
Pending_Instantiations.Locked := True;
Inlined_Bodies.Locked := True;
Successors.Locked := True;
Inlined.Locked := True;
Pending_Instantiations.Release;
Inlined_Bodies.Release;
Successors.Release;
Inlined.Release;
end Lock;
procedure Remove_Dead_Instance (N : Node_Id) is
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;
end if;
J := J + 1;
end loop;
end Remove_Dead_Instance;
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);
begin
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;
return
Comp = Cunit (Main_Unit)
or else Comp = Library_Unit (Cunit (Main_Unit));
end Scope_In_Main_Unit;
end Inline;