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-2011, 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_Aux;  use Sem_Aux;
  31 with Sem_Util; use Sem_Util;
  32 with Sinfo;    use Sinfo;
  33 with Types;    use Types;
  34
  35 package body Live is
  36
  37    --  Name_Set
  38
  39    --  The Name_Set type is used to store the temporary mark bits
  40    --  used by the garbage collection of entities. Using a separate
  41    --  array prevents using up any valuable per-node space and possibly
  42    --  results in better locality and cache usage.
  43
  44    type Name_Set is array (Node_Id range <>) of Boolean;
  45    pragma Pack (Name_Set);
  46
  47    function Marked (Marks : Name_Set; Name : Node_Id) return Boolean;
  48    pragma Inline (Marked);
  49
  50    procedure Set_Marked
  51      (Marks : in out Name_Set;
  52       Name  : Node_Id;
  53       Mark  : Boolean := True);
  54    pragma Inline (Set_Marked);
  55
  56    --  Algorithm
  57
  58    --  The problem of finding live entities is solved in two steps:
  59
  60    procedure Mark (Root : Node_Id; Marks : out Name_Set);
  61    --  Mark all live entities in Root as Marked
  62
  63    procedure Sweep (Root : Node_Id; Marks : Name_Set);
  64    --  For all unmarked entities in Root set Is_Eliminated to true
  65
  66    --  The Mark phase is split into two phases:
  67
  68    procedure Init_Marked (Root : Node_Id; Marks : out Name_Set);
  69    --  For all subprograms, reset Is_Public flag if a pragma Eliminate
  70    --  applies to the entity, and set the Marked flag to Is_Public
  71
  72    procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set);
  73    --  Traverse the tree skipping any unmarked subprogram bodies.
  74    --  All visited entities are marked, as well as entities denoted
  75    --  by a visited identifier or operator. When an entity is first
  76    --  marked it is traced as well.
  77
  78    --  Local functions
  79
  80    function Body_Of (E : Entity_Id) return Node_Id;
  81    --  Returns subprogram body corresponding to entity E
  82
  83    function Spec_Of (N : Node_Id) return Entity_Id;
  84    --  Given a subprogram body N, return defining identifier of its declaration
  85
  86    --  ??? the body of this package contains no comments at all, this
  87    --  should be fixed!
  88
  89    -------------
  90    -- Body_Of --
  91    -------------
  92
  93    function Body_Of (E : Entity_Id) return Node_Id is
  94       Decl   : constant Node_Id   := Unit_Declaration_Node (E);
  95       Kind   : constant Node_Kind := Nkind (Decl);
  96       Result : Node_Id;
  97
  98    begin
  99       if Kind = N_Subprogram_Body then
 100          Result := Decl;
 101
 102       elsif Kind /= N_Subprogram_Declaration
 103         and  Kind /= N_Subprogram_Body_Stub
 104       then
 105          Result := Empty;
 106
 107       else
 108          Result := Corresponding_Body (Decl);
 109
 110          if Result /= Empty then
 111             Result := Unit_Declaration_Node (Result);
 112          end if;
 113       end if;
 114
 115       return Result;
 116    end Body_Of;
 117
 118    ------------------------------
 119    -- Collect_Garbage_Entities --
 120    ------------------------------
 121
 122    procedure Collect_Garbage_Entities is
 123       Root  : constant Node_Id := Cunit (Main_Unit);
 124       Marks : Name_Set (0 .. Last_Node_Id);
 125
 126    begin
 127       Mark (Root, Marks);
 128       Sweep (Root, Marks);
 129    end Collect_Garbage_Entities;
 130
 131    -----------------
 132    -- Init_Marked --
 133    -----------------
 134
 135    procedure Init_Marked (Root : Node_Id; Marks : out Name_Set) is
 136
 137       function Process (N : Node_Id) return Traverse_Result;
 138       procedure Traverse is new Traverse_Proc (Process);
 139
 140       function Process (N : Node_Id) return Traverse_Result is
 141       begin
 142          case Nkind (N) is
 143             when N_Entity'Range =>
 144                if Is_Eliminated (N) then
 145                   Set_Is_Public (N, False);
 146                end if;
 147
 148                Set_Marked (Marks, N, Is_Public (N));
 149
 150             when N_Subprogram_Body =>
 151                Traverse (Spec_Of (N));
 152
 153             when N_Package_Body_Stub =>
 154                if Present (Library_Unit (N)) then
 155                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 156                end if;
 157
 158             when N_Package_Body =>
 159                declare
 160                   Elmt : Node_Id := First (Declarations (N));
 161                begin
 162                   while Present (Elmt) loop
 163                      Traverse (Elmt);
 164                      Next (Elmt);
 165                   end loop;
 166                end;
 167
 168             when others =>
 169                null;
 170          end case;
 171
 172          return OK;
 173       end Process;
 174
 175    --  Start of processing for Init_Marked
 176
 177    begin
 178       Marks := (others => False);
 179       Traverse (Root);
 180    end Init_Marked;
 181
 182    ----------
 183    -- Mark --
 184    ----------
 185
 186    procedure Mark (Root : Node_Id; Marks : out Name_Set) is
 187    begin
 188       Init_Marked (Root, Marks);
 189       Trace_Marked (Root, Marks);
 190    end Mark;
 191
 192    ------------
 193    -- Marked --
 194    ------------
 195
 196    function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
 197    begin
 198       return Marks (Name);
 199    end Marked;
 200
 201    ----------------
 202    -- Set_Marked --
 203    ----------------
 204
 205    procedure Set_Marked
 206      (Marks : in out Name_Set;
 207       Name  : Node_Id;
 208       Mark  : Boolean := True)
 209    is
 210    begin
 211       Marks (Name) := Mark;
 212    end Set_Marked;
 213
 214    -------------
 215    -- Spec_Of --
 216    -------------
 217
 218    function Spec_Of (N : Node_Id) return Entity_Id is
 219    begin
 220       if Acts_As_Spec (N) then
 221          return Defining_Entity (N);
 222       else
 223          return Corresponding_Spec (N);
 224       end if;
 225    end Spec_Of;
 226
 227    -----------
 228    -- Sweep --
 229    -----------
 230
 231    procedure Sweep (Root : Node_Id; Marks : Name_Set) is
 232
 233       function Process (N : Node_Id) return Traverse_Result;
 234       procedure Traverse is new Traverse_Proc (Process);
 235
 236       function Process (N : Node_Id) return Traverse_Result is
 237       begin
 238          case Nkind (N) is
 239             when N_Entity'Range =>
 240                Set_Is_Eliminated (N, not Marked (Marks, N));
 241
 242             when N_Subprogram_Body =>
 243                Traverse (Spec_Of (N));
 244
 245             when N_Package_Body_Stub =>
 246                if Present (Library_Unit (N)) then
 247                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 248                end if;
 249
 250             when N_Package_Body =>
 251                declare
 252                   Elmt : Node_Id := First (Declarations (N));
 253                begin
 254                   while Present (Elmt) loop
 255                      Traverse (Elmt);
 256                      Next (Elmt);
 257                   end loop;
 258                end;
 259
 260             when others =>
 261                null;
 262          end case;
 263          return OK;
 264       end Process;
 265
 266    begin
 267       Traverse (Root);
 268    end Sweep;
 269
 270    ------------------
 271    -- Trace_Marked --
 272    ------------------
 273
 274    procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
 275
 276       function  Process (N : Node_Id) return Traverse_Result;
 277       procedure Process (N : Node_Id);
 278       procedure Traverse is new Traverse_Proc (Process);
 279
 280       procedure Process (N : Node_Id) is
 281          Result : Traverse_Result;
 282          pragma Warnings (Off, Result);
 283
 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;