gcc/ada/live.adb

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