gcc/ada/live.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                 L I V E                                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                             $Revision: 1.1 $
  10 --                                                                          --
  11 --          Copyright (C) 2000-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- GNAT was originally developed  by the GNAT team at  New York University. --
  25 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  26 --                                                                          --
  27 ------------------------------------------------------------------------------
  28
  29 with Atree;    use Atree;
  30 with Einfo;    use Einfo;
  31 with Lib;      use Lib;
  32 with Nlists;   use Nlists;
  33 with Sem_Util; use Sem_Util;
  34 with Sinfo;    use Sinfo;
  35 with Types;    use Types;
  36
  37 package body Live is
  38
  39    --  Name_Set
  40
  41    --  The Name_Set type is used to store the temporary mark bits
  42    --  used by the garbage collection of entities. Using a separate
  43    --  array prevents using up any valuable per-node space and possibly
  44    --  results in better locality and cache usage.
  45
  46    type Name_Set is array (Node_Id range <>) of Boolean;
  47    pragma Pack (Name_Set);
  48
  49    function Marked (Marks : Name_Set; Name : Node_Id) return Boolean;
  50    pragma Inline (Marked);
  51
  52    procedure Set_Marked
  53      (Marks : in out Name_Set;
  54       Name  : Node_Id;
  55       Mark  : Boolean := True);
  56    pragma Inline (Set_Marked);
  57
  58    --  Algorithm
  59
  60    --  The problem of finding live entities is solved in two steps:
  61
  62    procedure Mark (Root : Node_Id; Marks : out Name_Set);
  63    --  Mark all live entities in Root as Marked.
  64
  65    procedure Sweep (Root : Node_Id; Marks : Name_Set);
  66    --  For all unmarked entities in Root set Is_Eliminated to true
  67
  68    --  The Mark phase is split into two phases:
  69
  70    procedure Init_Marked (Root : Node_Id; Marks : out Name_Set);
  71    --  For all subprograms, reset Is_Public flag if a pragma Eliminate
  72    --  applies to the entity, and set the Marked flag to Is_Public
  73
  74    procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set);
  75    --  Traverse the tree skipping any unmarked subprogram bodies.
  76    --  All visited entities are marked, as well as entities denoted
  77    --  by a visited identifier or operator. When an entity is first
  78    --  marked it is traced as well.
  79
  80    --  Local functions
  81
  82    function Body_Of (E : Entity_Id) return Node_Id;
  83    --  Returns subprogram body corresponding to entity E
  84
  85    function Spec_Of (N : Node_Id) return Entity_Id;
  86    --  Given a subprogram body N, return defining identifier of its declaration
  87
  88    --  ??? the body of this package contains no comments at all, this
  89    --  should be fixed!
  90
  91    -------------
  92    -- Body_Of --
  93    -------------
  94
  95    function Body_Of (E : Entity_Id) return Node_Id is
  96       Decl    : Node_Id := Unit_Declaration_Node (E);
  97       Result  : Node_Id;
  98       Kind    : Node_Kind := Nkind (Decl);
  99
 100    begin
 101       if Kind = N_Subprogram_Body then
 102          Result := Decl;
 103
 104       elsif Kind /= N_Subprogram_Declaration
 105         and  Kind /= N_Subprogram_Body_Stub
 106       then
 107          Result := Empty;
 108
 109       else
 110          Result := Corresponding_Body (Decl);
 111
 112          if Result /= Empty then
 113             Result := Unit_Declaration_Node (Result);
 114          end if;
 115       end if;
 116
 117       return Result;
 118    end Body_Of;
 119
 120    ------------------------------
 121    -- Collect_Garbage_Entities --
 122    ------------------------------
 123
 124    procedure Collect_Garbage_Entities is
 125       Root  : constant Node_Id := Cunit (Main_Unit);
 126       Marks : Name_Set (0 .. Last_Node_Id);
 127
 128    begin
 129       Mark (Root, Marks);
 130       Sweep (Root, Marks);
 131    end Collect_Garbage_Entities;
 132
 133    -----------------
 134    -- Init_Marked --
 135    -----------------
 136
 137    procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is
 138
 139       function Process (N : Node_Id) return Traverse_Result;
 140       procedure Traverse is new Traverse_Proc (Process);
 141
 142       function Process (N : Node_Id) return Traverse_Result is
 143       begin
 144          case Nkind (N) is
 145             when N_Entity'Range =>
 146                if Is_Eliminated (N) then
 147                   Set_Is_Public (N, False);
 148                end if;
 149
 150                Set_Marked (Marks, N, Is_Public (N));
 151
 152             when N_Subprogram_Body =>
 153                Traverse (Spec_Of (N));
 154
 155             when N_Package_Body_Stub =>
 156                if Present (Library_Unit (N)) then
 157                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 158                end if;
 159
 160             when N_Package_Body =>
 161                declare
 162                   Elmt : Node_Id := First (Declarations (N));
 163                begin
 164                   while Present (Elmt) loop
 165                      Traverse (Elmt);
 166                      Next (Elmt);
 167                   end loop;
 168                end;
 169
 170             when others =>
 171                null;
 172          end case;
 173
 174          return OK;
 175       end Process;
 176
 177    --  Start of processing for Init_Marked
 178
 179    begin
 180       Marks := (others => False);
 181       Traverse (Root);
 182    end Init_Marked;
 183
 184    ----------
 185    -- Mark --
 186    ----------
 187
 188    procedure Mark (Root : Node_Id; Marks : out Name_Set) is
 189    begin
 190       Init_Marked (Root, Marks);
 191       Trace_Marked (Root, Marks);
 192    end Mark;
 193
 194    ------------
 195    -- Marked --
 196    ------------
 197
 198    function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
 199    begin
 200       return Marks (Name);
 201    end Marked;
 202
 203    ----------------
 204    -- Set_Marked --
 205    ----------------
 206
 207    procedure Set_Marked
 208      (Marks : in out Name_Set;
 209       Name  : Node_Id;
 210       Mark  : Boolean := True)
 211    is
 212    begin
 213       Marks (Name) := Mark;
 214    end Set_Marked;
 215
 216    -------------
 217    -- Spec_Of --
 218    -------------
 219
 220    function Spec_Of (N : Node_Id) return Entity_Id is
 221    begin
 222       if Acts_As_Spec (N) then
 223          return Defining_Entity (N);
 224       else
 225          return Corresponding_Spec (N);
 226       end if;
 227    end Spec_Of;
 228
 229    -----------
 230    -- Sweep --
 231    -----------
 232
 233    procedure Sweep (Root : Node_Id; Marks : Name_Set) is
 234
 235       function Process (N : Node_Id) return Traverse_Result;
 236       procedure Traverse is new Traverse_Proc (Process);
 237
 238       function Process (N : Node_Id) return Traverse_Result is
 239       begin
 240          case Nkind (N) is
 241             when N_Entity'Range =>
 242                Set_Is_Eliminated (N, not Marked (Marks, N));
 243
 244             when N_Subprogram_Body =>
 245                Traverse (Spec_Of (N));
 246
 247             when N_Package_Body_Stub =>
 248                if Present (Library_Unit (N)) then
 249                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 250                end if;
 251
 252             when N_Package_Body =>
 253                declare
 254                   Elmt : Node_Id := First (Declarations (N));
 255                begin
 256                   while Present (Elmt) loop
 257                      Traverse (Elmt);
 258                      Next (Elmt);
 259                   end loop;
 260                end;
 261
 262             when others =>
 263                null;
 264          end case;
 265          return OK;
 266       end Process;
 267
 268    begin
 269       Traverse (Root);
 270    end Sweep;
 271
 272    ------------------
 273    -- Trace_Marked --
 274    ------------------
 275
 276    procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
 277
 278       function  Process (N : Node_Id) return Traverse_Result;
 279       procedure Process (N : Node_Id);
 280       procedure Traverse is new Traverse_Proc (Process);
 281
 282       procedure Process (N : Node_Id) is
 283          Result : Traverse_Result;
 284       begin
 285          Result := Process (N);
 286       end Process;
 287
 288       function Process (N : Node_Id) return Traverse_Result is
 289          Result : Traverse_Result := OK;
 290          B      : Node_Id;
 291          E      : Entity_Id;
 292
 293       begin
 294          case Nkind (N) is
 295             when N_Pragma | N_Generic_Declaration'Range |
 296                  N_Subprogram_Declaration | N_Subprogram_Body_Stub =>
 297                Result := Skip;
 298
 299             when N_Subprogram_Body =>
 300                if not Marked (Marks, Spec_Of (N)) then
 301                   Result := Skip;
 302                end if;
 303
 304             when N_Package_Body_Stub =>
 305                if Present (Library_Unit (N)) then
 306                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 307                end if;
 308
 309             when N_Identifier | N_Operator_Symbol | N_Expanded_Name =>
 310                E := Entity (N);
 311
 312                if E /= Empty and then not Marked (Marks, E) then
 313                   Process (E);
 314
 315                   if Is_Subprogram (E) then
 316                      B := Body_Of (E);
 317
 318                      if B /= Empty then
 319                         Traverse (B);
 320                      end if;
 321                   end if;
 322                end if;
 323
 324             when N_Entity'Range =>
 325                if (Ekind (N) = E_Component) and then not Marked (Marks, N) then
 326                   if Present (Discriminant_Checking_Func (N)) then
 327                      Process (Discriminant_Checking_Func (N));
 328                   end if;
 329                end if;
 330
 331                Set_Marked (Marks, N);
 332
 333             when others =>
 334                null;
 335          end case;
 336
 337          return Result;
 338       end Process;
 339
 340    --  Start of processing for Trace_Marked
 341
 342    begin
 343       Traverse (Root);
 344    end Trace_Marked;
 345
 346 end Live;