gcc/ada/live.adb

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