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-2023, 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 Einfo.Entities; use Einfo.Entities;
  29 with Einfo.Utils;    use Einfo.Utils;
  30 with Lib;            use Lib;
  31 with Nlists;         use Nlists;
  32 with Sem_Aux;        use Sem_Aux;
  33 with Sem_Util;       use Sem_Util;
  34 with Sinfo;          use Sinfo;
  35 with Sinfo.Nodes;    use Sinfo.Nodes;
  36 with Sinfo.Utils;    use Sinfo.Utils;
  37 with Types;          use Types;
  38
  39 package body Live is
  40
  41    --  Name_Set
  42
  43    --  The Name_Set type is used to store the temporary mark bits used by the
  44    --  garbage collection of entities. Using a separate array prevents using up
  45    --  any valuable per-node space and possibly results in better locality and
  46    --  cache usage.
  47
  48    type Name_Set is array (Node_Id'Base range <>) of Boolean;
  49    --  We use 'Base here, in case we want to add a predicate to Node_Id
  50    pragma Pack (Name_Set);
  51
  52    function Marked (Marks : Name_Set; Name : Node_Id) return Boolean;
  53    pragma Inline (Marked);
  54
  55    procedure Set_Marked
  56      (Marks : in out Name_Set;
  57       Name  : Node_Id;
  58       Mark  : Boolean := True);
  59    pragma Inline (Set_Marked);
  60
  61    --  Algorithm
  62
  63    --  The problem of finding live entities is solved in two steps:
  64
  65    procedure Mark (Root : Node_Id; Marks : out Name_Set);
  66    --  Mark all live entities in Root as Marked
  67
  68    procedure Sweep (Root : Node_Id; Marks : Name_Set);
  69    --  For all unmarked entities in Root set Is_Eliminated to true
  70
  71    --  The Mark phase is split into two phases:
  72
  73    procedure Init_Marked (Root : Node_Id; Marks : out Name_Set);
  74    --  For all subprograms, reset Is_Public flag if a pragma Eliminate applies
  75    --  to the entity, and set the Marked flag to Is_Public.
  76
  77    procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set);
  78    --  Traverse the tree skipping any unmarked subprogram bodies. All visited
  79    --  entities are marked, as well as entities denoted by a visited identifier
  80    --  or operator. When an entity is first marked it is traced as well.
  81
  82    --  Local functions
  83
  84    function Body_Of (E : Entity_Id) return Node_Id;
  85    --  Returns subprogram body corresponding to entity E
  86
  87    function Spec_Of (N : Node_Id) return Entity_Id;
  88    --  Given a subprogram body N, return defining identifier of its declaration
  89
  90    -------------
  91    -- Body_Of --
  92    -------------
  93
  94    function Body_Of (E : Entity_Id) return Node_Id is
  95       Decl   : constant Node_Id   := Unit_Declaration_Node (E);
  96       Kind   : constant Node_Kind := Nkind (Decl);
  97       Result : Node_Id;
  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       -------------
 142       -- Process --
 143       -------------
 144
 145       function Process (N : Node_Id) return Traverse_Result is
 146       begin
 147          case Nkind (N) is
 148             when N_Entity'Range =>
 149                if Is_Eliminated (N) then
 150                   Set_Is_Public (N, False);
 151                end if;
 152
 153                Set_Marked (Marks, N, Is_Public (N));
 154
 155             when N_Subprogram_Body =>
 156                Traverse (Spec_Of (N));
 157
 158             when N_Package_Body_Stub =>
 159                if Present (Library_Unit (N)) then
 160                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 161                end if;
 162
 163             when N_Package_Body =>
 164                declare
 165                   Elmt : Node_Id := First (Declarations (N));
 166                begin
 167                   while Present (Elmt) loop
 168                      Traverse (Elmt);
 169                      Next (Elmt);
 170                   end loop;
 171                end;
 172
 173             when others =>
 174                null;
 175          end case;
 176
 177          return OK;
 178       end Process;
 179
 180    --  Start of processing for Init_Marked
 181
 182    begin
 183       Marks := (others => False);
 184       Traverse (Root);
 185    end Init_Marked;
 186
 187    ----------
 188    -- Mark --
 189    ----------
 190
 191    procedure Mark (Root : Node_Id; Marks : out Name_Set) is
 192    begin
 193       Init_Marked (Root, Marks);
 194       Trace_Marked (Root, Marks);
 195    end Mark;
 196
 197    ------------
 198    -- Marked --
 199    ------------
 200
 201    function Marked (Marks : Name_Set; Name : Node_Id) return Boolean is
 202    begin
 203       return Marks (Name);
 204    end Marked;
 205
 206    ----------------
 207    -- Set_Marked --
 208    ----------------
 209
 210    procedure Set_Marked
 211      (Marks : in out Name_Set;
 212       Name  : Node_Id;
 213       Mark  : Boolean := True)
 214    is
 215    begin
 216       Marks (Name) := Mark;
 217    end Set_Marked;
 218
 219    -------------
 220    -- Spec_Of --
 221    -------------
 222
 223    function Spec_Of (N : Node_Id) return Entity_Id is
 224    begin
 225       if Acts_As_Spec (N) then
 226          return Defining_Entity (N);
 227       else
 228          return Corresponding_Spec (N);
 229       end if;
 230    end Spec_Of;
 231
 232    -----------
 233    -- Sweep --
 234    -----------
 235
 236    procedure Sweep (Root : Node_Id; Marks : Name_Set) is
 237
 238       function Process (N : Node_Id) return Traverse_Result;
 239       procedure Traverse is new Traverse_Proc (Process);
 240
 241       -------------
 242       -- Process --
 243       -------------
 244
 245       function Process (N : Node_Id) return Traverse_Result is
 246       begin
 247          case Nkind (N) is
 248             when N_Entity'Range =>
 249                Set_Is_Eliminated (N, not Marked (Marks, N));
 250
 251             when N_Subprogram_Body =>
 252                Traverse (Spec_Of (N));
 253
 254             when N_Package_Body_Stub =>
 255                if Present (Library_Unit (N)) then
 256                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 257                end if;
 258
 259             when N_Package_Body =>
 260                declare
 261                   Elmt : Node_Id := First (Declarations (N));
 262                begin
 263                   while Present (Elmt) loop
 264                      Traverse (Elmt);
 265                      Next (Elmt);
 266                   end loop;
 267                end;
 268
 269             when others =>
 270                null;
 271          end case;
 272
 273          return OK;
 274       end Process;
 275
 276    --  Start of processing for Sweep
 277
 278    begin
 279       Traverse (Root);
 280    end Sweep;
 281
 282    ------------------
 283    -- Trace_Marked --
 284    ------------------
 285
 286    procedure Trace_Marked (Root : Node_Id; Marks : in out Name_Set) is
 287
 288       function  Process (N : Node_Id) return Traverse_Result;
 289       procedure Process (N : Node_Id);
 290       procedure Traverse is new Traverse_Proc (Process);
 291
 292       -------------
 293       -- Process --
 294       -------------
 295
 296       procedure Process (N : Node_Id) is
 297          Result : Traverse_Result;
 298          pragma Warnings (Off, Result);
 299
 300       begin
 301          Result := Process (N);
 302       end Process;
 303
 304       function Process (N : Node_Id) return Traverse_Result is
 305          Result : Traverse_Result := OK;
 306          B      : Node_Id;
 307          E      : Entity_Id;
 308
 309       begin
 310          case Nkind (N) is
 311             when N_Generic_Declaration'Range
 312                | N_Pragma
 313                | N_Subprogram_Body_Stub
 314                | N_Subprogram_Declaration
 315             =>
 316                Result := Skip;
 317
 318             when N_Subprogram_Body =>
 319                if not Marked (Marks, Spec_Of (N)) then
 320                   Result := Skip;
 321                end if;
 322
 323             when N_Package_Body_Stub =>
 324                if Present (Library_Unit (N)) then
 325                   Traverse (Proper_Body (Unit (Library_Unit (N))));
 326                end if;
 327
 328             when N_Expanded_Name
 329                | N_Identifier
 330                | N_Operator_Symbol
 331             =>
 332                E := Entity (N);
 333
 334                if E /= Empty and then not Marked (Marks, E) then
 335                   Process (E);
 336
 337                   if Is_Subprogram (E) then
 338                      B := Body_Of (E);
 339
 340                      if B /= Empty then
 341                         Traverse (B);
 342                      end if;
 343                   end if;
 344                end if;
 345
 346             when N_Entity'Range =>
 347                if Ekind (N) = E_Component and then not Marked (Marks, N) then
 348                   if Present (Discriminant_Checking_Func (N)) then
 349                      Process (Discriminant_Checking_Func (N));
 350                   end if;
 351                end if;
 352
 353                Set_Marked (Marks, N);
 354
 355             when others =>
 356                null;
 357          end case;
 358
 359          return Result;
 360       end Process;
 361
 362    --  Start of processing for Trace_Marked
 363
 364    begin
 365       Traverse (Root);
 366    end Trace_Marked;
 367
 368 end Live;