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-2016, 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 used by the
  40    --  garbage collection of entities. Using a separate array prevents using up
  41    --  any valuable per-node space and possibly results in better locality and
  42    --  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 applies
  70    --  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. All visited
  74    --  entities are marked, as well as entities denoted by a visited identifier
  75    --  or operator. When an entity is first 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       -------------
 140       -- Process --
 141       -------------
 142
 143       function Process (N : Node_Id) return Traverse_Result is
 144       begin
 145          case Nkind (N) is
 146             when N_Entity'Range =>
 147                if Is_Eliminated (N) then
 148                   Set_Is_Public (N, False);
 149                end if;
 150
 151                Set_Marked (Marks, N, Is_Public (N));
 152
 153             when N_Subprogram_Body =>
 154                Traverse (Spec_Of (N));
 155
 156             when N_Package_Body_Stub =>
 157                if Present (Library_Unit (N)) then
 158                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 159                end if;
 160
 161             when N_Package_Body =>
 162                declare
 163                   Elmt : Node_Id := First (Declarations (N));
 164                begin
 165                   while Present (Elmt) loop
 166                      Traverse (Elmt);
 167                      Next (Elmt);
 168                   end loop;
 169                end;
 170
 171             when others =>
 172                null;
 173          end case;
 174
 175          return OK;
 176       end Process;
 177
 178    --  Start of processing for Init_Marked
 179
 180    begin
 181       Marks := (others => False);
 182       Traverse (Root);
 183    end Init_Marked;
 184
 185    ----------
 186    -- Mark --
 187    ----------
 188
 189    procedure Mark (Root : Node_Id; Marks : out Name_Set) is
 190    begin
 191       Init_Marked (Root, Marks);
 192       Trace_Marked (Root, Marks);
 193    end Mark;
 194
 195    ------------
 196    -- Marked --
 197    ------------
 198
 199    function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
 200    begin
 201       return Marks (Name);
 202    end Marked;
 203
 204    ----------------
 205    -- Set_Marked --
 206    ----------------
 207
 208    procedure Set_Marked
 209      (Marks : in out Name_Set;
 210       Name  : Node_Id;
 211       Mark  : Boolean := True)
 212    is
 213    begin
 214       Marks (Name) := Mark;
 215    end Set_Marked;
 216
 217    -------------
 218    -- Spec_Of --
 219    -------------
 220
 221    function Spec_Of (N : Node_Id) return Entity_Id is
 222    begin
 223       if Acts_As_Spec (N) then
 224          return Defining_Entity (N);
 225       else
 226          return Corresponding_Spec (N);
 227       end if;
 228    end Spec_Of;
 229
 230    -----------
 231    -- Sweep --
 232    -----------
 233
 234    procedure Sweep (Root : Node_Id; Marks : Name_Set) is
 235
 236       function Process (N : Node_Id) return Traverse_Result;
 237       procedure Traverse is new Traverse_Proc (Process);
 238
 239       -------------
 240       -- Process --
 241       -------------
 242
 243       function Process (N : Node_Id) return Traverse_Result is
 244       begin
 245          case Nkind (N) is
 246             when N_Entity'Range =>
 247                Set_Is_Eliminated (N, not Marked (Marks, N));
 248
 249             when N_Subprogram_Body =>
 250                Traverse (Spec_Of (N));
 251
 252             when N_Package_Body_Stub =>
 253                if Present (Library_Unit (N)) then
 254                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 255                end if;
 256
 257             when N_Package_Body =>
 258                declare
 259                   Elmt : Node_Id := First (Declarations (N));
 260                begin
 261                   while Present (Elmt) loop
 262                      Traverse (Elmt);
 263                      Next (Elmt);
 264                   end loop;
 265                end;
 266
 267             when others =>
 268                null;
 269          end case;
 270
 271          return OK;
 272       end Process;
 273
 274    --  Start of processing for Sweep
 275
 276    begin
 277       Traverse (Root);
 278    end Sweep;
 279
 280    ------------------
 281    -- Trace_Marked --
 282    ------------------
 283
 284    procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
 285
 286       function  Process (N : Node_Id) return Traverse_Result;
 287       procedure Process (N : Node_Id);
 288       procedure Traverse is new Traverse_Proc (Process);
 289
 290       -------------
 291       -- Process --
 292       -------------
 293
 294       procedure Process (N : Node_Id) is
 295          Result : Traverse_Result;
 296          pragma Warnings (Off, Result);
 297
 298       begin
 299          Result := Process (N);
 300       end Process;
 301
 302       function Process (N : Node_Id) return Traverse_Result is
 303          Result : Traverse_Result := OK;
 304          B      : Node_Id;
 305          E      : Entity_Id;
 306
 307       begin
 308          case Nkind (N) is
 309             when N_Generic_Declaration'Range
 310                | N_Pragma
 311                | N_Subprogram_Body_Stub
 312                | N_Subprogram_Declaration
 313             =>
 314                Result := Skip;
 315
 316             when N_Subprogram_Body =>
 317                if not Marked (Marks, Spec_Of (N)) then
 318                   Result := Skip;
 319                end if;
 320
 321             when N_Package_Body_Stub =>
 322                if Present (Library_Unit (N)) then
 323                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 324                end if;
 325
 326             when N_Expanded_Name
 327                | N_Identifier
 328                | N_Operator_Symbol
 329             =>
 330                E := Entity (N);
 331
 332                if E /= Empty and then not Marked (Marks, E) then
 333                   Process (E);
 334
 335                   if Is_Subprogram (E) then
 336                      B := Body_Of (E);
 337
 338                      if B /= Empty then
 339                         Traverse (B);
 340                      end if;
 341                   end if;
 342                end if;
 343
 344             when N_Entity'Range =>
 345                if (Ekind (N) = E_Component) and then not Marked (Marks, N) then
 346                   if Present (Discriminant_Checking_Func (N)) then
 347                      Process (Discriminant_Checking_Func (N));
 348                   end if;
 349                end if;
 350
 351                Set_Marked (Marks, N);
 352
 353             when others =>
 354                null;
 355          end case;
 356
 357          return Result;
 358       end Process;
 359
 360    --  Start of processing for Trace_Marked
 361
 362    begin
 363       Traverse (Root);
 364    end Trace_Marked;
 365
 366 end Live;