with Atree; use Atree;
with Einfo; use Einfo;
with Lib; use Lib;
with Nlists; use Nlists;
with Sem_Util; use Sem_Util;
with Sinfo; use Sinfo;
with Types; use Types;
package body Live is
type Name_Set is array (Node_Id range <>) of Boolean;
pragma Pack (Name_Set);
function Marked (Marks : Name_Set; Name : Node_Id) return Boolean;
pragma Inline (Marked);
procedure Set_Marked
(Marks : in out Name_Set;
Name : Node_Id;
Mark : Boolean := True);
pragma Inline (Set_Marked);
procedure Mark (Root : Node_Id; Marks : out Name_Set);
procedure Sweep (Root : Node_Id; Marks : Name_Set);
procedure Init_Marked (Root : Node_Id; Marks : out Name_Set);
procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set);
function Body_Of (E : Entity_Id) return Node_Id;
function Spec_Of (N : Node_Id) return Entity_Id;
function Body_Of (E : Entity_Id) return Node_Id is
Decl : constant Node_Id := Unit_Declaration_Node (E);
Kind : constant Node_Kind := Nkind (Decl);
Result : Node_Id;
begin
if Kind = N_Subprogram_Body then
Result := Decl;
elsif Kind /= N_Subprogram_Declaration
and Kind /= N_Subprogram_Body_Stub
then
Result := Empty;
else
Result := Corresponding_Body (Decl);
if Result /= Empty then
Result := Unit_Declaration_Node (Result);
end if;
end if;
return Result;
end Body_Of;
procedure Collect_Garbage_Entities is
Root : constant Node_Id := Cunit (Main_Unit);
Marks : Name_Set (0 .. Last_Node_Id);
begin
Mark (Root, Marks);
Sweep (Root, Marks);
end Collect_Garbage_Entities;
procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is
function Process (N : Node_Id) return Traverse_Result;
procedure Traverse is new Traverse_Proc (Process);
function Process (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
when N_Entity'Range =>
if Is_Eliminated (N) then
Set_Is_Public (N, False);
end if;
Set_Marked (Marks, N, Is_Public (N));
when N_Subprogram_Body =>
Traverse (Spec_Of (N));
when N_Package_Body_Stub =>
if Present (Library_Unit (N)) then
Traverse (Proper_Body (Unit (Library_Unit (N))));
end if;
when N_Package_Body =>
declare
Elmt : Node_Id := First (Declarations (N));
begin
while Present (Elmt) loop
Traverse (Elmt);
Next (Elmt);
end loop;
end;
when others =>
null;
end case;
return OK;
end Process;
begin
Marks := (others => False);
Traverse (Root);
end Init_Marked;
procedure Mark (Root : Node_Id; Marks : out Name_Set) is
begin
Init_Marked (Root, Marks);
Trace_Marked (Root, Marks);
end Mark;
function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
begin
return Marks (Name);
end Marked;
procedure Set_Marked
(Marks : in out Name_Set;
Name : Node_Id;
Mark : Boolean := True)
is
begin
Marks (Name) := Mark;
end Set_Marked;
function Spec_Of (N : Node_Id) return Entity_Id is
begin
if Acts_As_Spec (N) then
return Defining_Entity (N);
else
return Corresponding_Spec (N);
end if;
end Spec_Of;
procedure Sweep (Root : Node_Id; Marks : Name_Set) is
function Process (N : Node_Id) return Traverse_Result;
procedure Traverse is new Traverse_Proc (Process);
function Process (N : Node_Id) return Traverse_Result is
begin
case Nkind (N) is
when N_Entity'Range =>
Set_Is_Eliminated (N, not Marked (Marks, N));
when N_Subprogram_Body =>
Traverse (Spec_Of (N));
when N_Package_Body_Stub =>
if Present (Library_Unit (N)) then
Traverse (Proper_Body (Unit (Library_Unit (N))));
end if;
when N_Package_Body =>
declare
Elmt : Node_Id := First (Declarations (N));
begin
while Present (Elmt) loop
Traverse (Elmt);
Next (Elmt);
end loop;
end;
when others =>
null;
end case;
return OK;
end Process;
begin
Traverse (Root);
end Sweep;
procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
function Process (N : Node_Id) return Traverse_Result;
procedure Process (N : Node_Id);
procedure Traverse is new Traverse_Proc (Process);
procedure Process (N : Node_Id) is
Result : Traverse_Result;
pragma Warnings (Off, Result);
begin
Result := Process (N);
end Process;
function Process (N : Node_Id) return Traverse_Result is
Result : Traverse_Result := OK;
B : Node_Id;
E : Entity_Id;
begin
case Nkind (N) is
when N_Pragma | N_Generic_Declaration'Range |
N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
Result := Skip;
when N_Subprogram_Body =>
if not Marked (Marks, Spec_Of (N)) then
Result := Skip;
end if;
when N_Package_Body_Stub =>
if Present (Library_Unit (N)) then
Traverse (Proper_Body (Unit (Library_Unit (N))));
end if;
when N_Identifier | N_Operator_Symbol | N_Expanded_Name =>
E := Entity (N);
if E /= Empty and then not Marked (Marks, E) then
Process (E);
if Is_Subprogram (E) then
B := Body_Of (E);
if B /= Empty then
Traverse (B);
end if;
end if;
end if;
when N_Entity'Range =>
if (Ekind (N) = E_Component) and then not Marked (Marks, N) then
if Present (Discriminant_Checking_Func (N)) then
Process (Discriminant_Checking_Func (N));
end if;
end if;
Set_Marked (Marks, N);
when others =>
null;
end case;
return Result;
end Process;
begin
Traverse (Root);
end Trace_Marked;
end Live;