gcc/ada/exp_unst.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ U N S T                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --            Copyright (C) 2015, 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 Elists;   use Elists;
  29 with Namet;    use Namet;
  30 with Nlists;   use Nlists;
  31 with Nmake;    use Nmake;
  32 with Rtsfind;  use Rtsfind;
  33 with Sem_Aux;  use Sem_Aux;
  34 with Sem_Util; use Sem_Util;
  35 with Sinfo;    use Sinfo;
  36 with Snames;   use Snames;
  37 with Table;
  38 with Tbuild;   use Tbuild;
  39
  40 package body Exp_Unst is
  41
  42    -------------------------------------
  43    -- Check_Uplevel_Reference_To_Type --
  44    -------------------------------------
  45
  46    procedure Check_Uplevel_Reference_To_Type (Typ : Entity_Id) is
  47       function Check_Dynamic_Type (T : Entity_Id) return Boolean;
  48       --  This is an internal recursive routine that checks if T or any of
  49       --  its subsdidiary types are dynamic. If so, then the original Typ is
  50       --  marked as having an uplevel reference, as is the subsidiary type in
  51       --  question, and any referenced dynamic bounds are also marked as having
  52       --  an uplevel reference, and True is returned. If the type is a static
  53       --  type, then False is returned;
  54
  55       ------------------------
  56       -- Check_Dynamic_Type --
  57       ------------------------
  58
  59       function Check_Dynamic_Type (T : Entity_Id) return Boolean is
  60          DT : Boolean := False;
  61
  62       begin
  63          --  If it's a static type, nothing to do
  64
  65          if Is_Static_Type (T) then
  66             return False;
  67
  68          --  If the type is uplevel referenced, then it must be dynamic
  69
  70          elsif Has_Uplevel_Reference (T) then
  71             Set_Has_Uplevel_Reference (Typ);
  72             return True;
  73
  74          --  Otherwise we need to figure out what the story is with this type
  75
  76          else
  77             DT := False;
  78
  79          --  For a scalar type, check bounds
  80
  81             if Is_Scalar_Type (T) then
  82
  83                --  If both bounds static, then this is a static type
  84
  85                declare
  86                   LB : constant Node_Id := Type_Low_Bound (T);
  87                   UB : constant Node_Id := Type_High_Bound (T);
  88
  89                begin
  90                   if not Is_Static_Expression (LB) then
  91                      Set_Has_Uplevel_Reference (Entity (LB));
  92                      DT := True;
  93                   end if;
  94
  95                   if not Is_Static_Expression (UB) then
  96                      Set_Has_Uplevel_Reference (Entity (UB));
  97                      DT := True;
  98                   end if;
  99                end;
 100
 101             --  For record type, check all components
 102
 103             elsif Is_Record_Type (T) then
 104                declare
 105                   C : Entity_Id;
 106
 107                begin
 108                   C := First_Component_Or_Discriminant (T);
 109                   while Present (T) loop
 110                      if Check_Dynamic_Type (C) then
 111                         DT := True;
 112                      end if;
 113
 114                      Next_Component_Or_Discriminant (C);
 115                   end loop;
 116                end;
 117
 118             --  For array type, check index types and component type
 119
 120             elsif Is_Array_Type (T) then
 121                declare
 122                   IX : Node_Id;
 123
 124                begin
 125                   if Check_Dynamic_Type (Component_Type (T)) then
 126                      DT := True;
 127                   end if;
 128
 129                   IX := First_Index (T);
 130                   while Present (IX) loop
 131                      if Check_Dynamic_Type (Etype (IX)) then
 132                         DT := True;
 133                      end if;
 134
 135                      Next_Index (IX);
 136                   end loop;
 137                end;
 138
 139             --  For now, ignore other types
 140
 141             else
 142                return False;
 143             end if;
 144
 145             --  See if we marked that type as dynamic
 146
 147             if DT then
 148                Set_Has_Uplevel_Reference (T);
 149                Set_Has_Uplevel_Reference (Typ);
 150                return True;
 151
 152             --  If not mark it as static
 153
 154             else
 155                Set_Is_Static_Type (T);
 156                return False;
 157             end if;
 158          end if;
 159       end Check_Dynamic_Type;
 160
 161    --  Start of processing for Check_Uplevel_Reference_To_Type
 162
 163    begin
 164       --  Nothing to do if we know this is a static type
 165
 166       if Is_Static_Type (Typ) then
 167          return;
 168
 169       --  Nothing to do if already marked as uplevel referenced
 170
 171       elsif Has_Uplevel_Reference (Typ) then
 172          return;
 173
 174       --  Otherwise check if we have a dynamic type
 175
 176       else
 177          if Check_Dynamic_Type (Typ) then
 178             Set_Has_Uplevel_Reference (Typ);
 179          end if;
 180       end if;
 181
 182       null;
 183    end Check_Uplevel_Reference_To_Type;
 184
 185    ----------------------------
 186    -- Note_Uplevel_Reference --
 187    ----------------------------
 188
 189    procedure Note_Uplevel_Reference (N : Node_Id; Subp : Entity_Id) is
 190    begin
 191       --  Establish list if first call for Uplevel_References
 192
 193       if No (Uplevel_References (Subp)) then
 194          Set_Uplevel_References (Subp, New_Elmt_List);
 195       end if;
 196
 197       --  Add new element to Uplevel_References
 198
 199       Append_Elmt (N, Uplevel_References (Subp));
 200       Set_Has_Uplevel_Reference (Entity (N));
 201    end Note_Uplevel_Reference;
 202
 203    -----------------------
 204    -- Unnest_Subprogram --
 205    -----------------------
 206
 207    --  Tables used by Unnest_Subprogram
 208
 209    type Subp_Entry is record
 210       Ent : Entity_Id;
 211       --  Entity of the subprogram
 212
 213       Bod : Node_Id;
 214       --  Subprogram_Body node for this subprogram
 215
 216       Lev : Nat;
 217       --  Subprogram level (1 = outer subprogram (Subp argument), 2 = nested
 218       --  immediately within this outer subprogram etc.)
 219    end record;
 220
 221    package Subps is new Table.Table (
 222      Table_Component_Type => Subp_Entry,
 223      Table_Index_Type     => Nat,
 224      Table_Low_Bound      => 1,
 225      Table_Initial        => 100,
 226      Table_Increment      => 200,
 227      Table_Name           => "Subps");
 228    --  Records the subprograms in the nest whose outer subprogram is Subp
 229
 230    type Call_Entry is record
 231       N   : Node_Id;
 232       --  The actual call
 233
 234       From : Entity_Id;
 235       --  Entity of the subprogram containing the call
 236
 237       To : Entity_Id;
 238       --  Entity of the subprogram called
 239    end record;
 240
 241    package Calls is new Table.Table (
 242      Table_Component_Type => Call_Entry,
 243      Table_Index_Type     => Nat,
 244      Table_Low_Bound      => 1,
 245      Table_Initial        => 100,
 246      Table_Increment      => 200,
 247      Table_Name           => "Calls");
 248    --  Records each call within the outer subprogram and all nested subprograms
 249    --  that are to other subprograms nested within the outer subprogram. These
 250    --  are the calls that may need an additional parameter.
 251
 252    procedure Unnest_Subprogram (Subp : Entity_Id; Subp_Body : Node_Id) is
 253
 254       function Get_AREC_String (Lev : Pos) return String;
 255       --  Given a level value, 1, 2, ... returns the string AREC, AREC2, ...
 256
 257       function Get_Level (Sub : Entity_Id) return Nat;
 258       --  Sub is either Subp itself, or a subprogram nested within Subp. This
 259       --  function returns the level of nesting (Subp = 1, subprograms that
 260       --  are immediately nested within Subp = 2, etc).
 261
 262       ---------------------
 263       -- Get_AREC_String --
 264       ---------------------
 265
 266       function Get_AREC_String (Lev : Pos) return String is
 267       begin
 268          if Lev > 9 then
 269             return
 270               Get_AREC_String (Lev / 10) & Character'Val (Lev mod 10 + 48);
 271          else
 272             return
 273               "AREC" & Character'Val (Lev + 48);
 274          end if;
 275       end Get_AREC_String;
 276
 277       ---------------
 278       -- Get_Level --
 279       ---------------
 280
 281       function Get_Level (Sub : Entity_Id) return Nat is
 282          Lev : Nat;
 283          S   : Entity_Id;
 284       begin
 285          Lev := 1;
 286          S   := Sub;
 287          loop
 288             if S = Subp then
 289                return Lev;
 290             else
 291                S := Enclosing_Dynamic_Scope (S);
 292                Lev := Lev + 1;
 293             end if;
 294          end loop;
 295       end Get_Level;
 296
 297    --  Start of processing for Unnest_Subprogram
 298
 299    begin
 300       --  First step, we must mark all nested subprograms that require a static
 301       --  link (activation record) because either they contain explicit uplevel
 302       --  references (as indicated by Has_Uplevel_Reference being set at this
 303       --  point), or they make calls to other subprograms in the same nest that
 304       --  require a static link (in which case we set this flag).
 305
 306       --  This is a recursive definition, and to implement this, we have to
 307       --  build a call graph for the set of nested subprograms, and then go
 308       --  over this graph to implement recursively the invariant that if a
 309       --  subprogram has a call to a subprogram requiring a static link, then
 310       --  the calling subprogram requires a static link.
 311
 312       --  First step, populate the above tables
 313
 314       Subps.Init;
 315       Calls.Init;
 316
 317       Build_Tables : declare
 318          function Visit_Node (N : Node_Id) return Traverse_Result;
 319          --  Visit a single node in Subp
 320
 321          ----------------
 322          -- Visit_Node --
 323          ----------------
 324
 325          function Visit_Node (N : Node_Id) return Traverse_Result is
 326             Ent : Entity_Id;
 327
 328             function Find_Current_Subprogram return Entity_Id;
 329             --  Finds the current subprogram containing the call N
 330
 331             -----------------------------
 332             -- Find_Current_Subprogram --
 333             -----------------------------
 334
 335             function Find_Current_Subprogram return Entity_Id is
 336                Nod : Node_Id;
 337
 338             begin
 339                Nod := N;
 340                loop
 341                   Nod := Parent (Nod);
 342
 343                   if Nkind (Nod) = N_Subprogram_Body then
 344                      if Acts_As_Spec (Nod) then
 345                         return Defining_Unit_Name (Specification (Nod));
 346                      else
 347                         return Corresponding_Spec (Nod);
 348                      end if;
 349                   end if;
 350                end loop;
 351             end Find_Current_Subprogram;
 352
 353          --  Start of processing for Visit_Node
 354
 355          begin
 356             if Nkind_In (N, N_Procedure_Call_Statement, N_Function_Call) then
 357                Ent := Entity (Name (N));
 358
 359                if not Is_Library_Level_Entity (Ent) then
 360                   Calls.Append ((N, Find_Current_Subprogram, Ent));
 361                end if;
 362
 363             elsif Nkind (N) = N_Subprogram_Body and then Acts_As_Spec (N) then
 364                Ent := Defining_Unit_Name (Specification (N));
 365                Subps.Append
 366                  ((Ent => Ent,
 367                    Bod => N,
 368                    Lev => Get_Level (Ent)));
 369
 370             elsif Nkind (N) = N_Subprogram_Declaration then
 371                Ent := Defining_Unit_Name (Specification (N));
 372                Subps.Append
 373                  ((Ent => Ent,
 374                    Bod => Corresponding_Body (N),
 375                    Lev => Get_Level (Ent)));
 376             end if;
 377
 378             return OK;
 379          end Visit_Node;
 380
 381          -----------
 382          -- Visit --
 383          -----------
 384
 385          procedure Visit is new Traverse_Proc (Visit_Node);
 386          --  Used to traverse the body of Subp, populating the tables
 387
 388       begin
 389          Visit (Subp_Body);
 390       end Build_Tables;
 391
 392       --  Second step is to do the transitive closure, if any subprogram has
 393       --  a call to a subprogram for which Has_Uplevel_Reference is set, then
 394       --  we set Has_Uplevel_Reference for the calling routine.
 395
 396       Closure : declare
 397          Modified : Boolean;
 398
 399       begin
 400          --  We use a simple minded algorithm as follows (obviously this can
 401          --  be done more efficiently, using one of the standard algorithms
 402          --  for efficient transitive closure computation, but this is simple
 403          --  and most likely fast enough that its speed does not matter).
 404
 405          --  Repeatedly scan the list of calls. Any time we find a call from
 406          --  A to B, where A does not have Has_Uplevel_Reference, and B does
 407          --  have this flag set, then set the flag for A, and note that we
 408          --  have made a change by setting Modified True. We repeat this until
 409          --  we make a pass with no modifications.
 410
 411          Outer : loop
 412             Modified := False;
 413             Inner : for J in Calls.First .. Calls.Last loop
 414                if not Has_Uplevel_Reference (Calls.Table (J).From)
 415                  and then Has_Uplevel_Reference (Calls.Table (J).To)
 416                then
 417                   Set_Has_Uplevel_Reference (Calls.Table (J).From);
 418                   Modified := True;
 419                end if;
 420             end loop Inner;
 421
 422             exit Outer when not Modified;
 423          end loop Outer;
 424       end Closure;
 425
 426       --  Next step, process each subprogram in turn, inserting necessary
 427       --  declarations for ARECxx types and variables for any subprogram
 428       --  that has nested subprograms, and is uplevel referenced.
 429
 430       Arec_Decls : declare
 431          Addr : constant Entity_Id := RTE (RE_Address);
 432
 433       begin
 434          for J in Subps.First .. Subps.Last loop
 435             declare
 436                STJ : Subp_Entry renames Subps.Table (J);
 437
 438             begin
 439                --  We add AREC declarations for any subprogram that has at
 440                --  least one nested subprogram, and has uplevel references.
 441
 442                if Has_Nested_Subprogram (STJ.Ent)
 443                  and then Has_Uplevel_Reference (STJ.Ent)
 444                then
 445                   Add_AREC_Declarations : declare
 446                      Loc   : constant Source_Ptr := Sloc (STJ.Bod);
 447                      ARS   : constant String     := Get_AREC_String (STJ.Lev);
 448                      Urefs : constant Elist_Id   :=
 449                                Uplevel_References (STJ.Ent);
 450                      Elmt  : Elmt_Id;
 451                      Ent   : Entity_Id;
 452                      Clist : List_Id;
 453
 454                      Uplevel_Entities :
 455                        array (1 .. List_Length (Urefs)) of Entity_Id;
 456                      Num_Uplevel_Entities : Nat;
 457                      --  Uplevel_Entities (1 .. Num_Uplevel_Entities) contains
 458                      --  a list (with no duplicates) of the entities for this
 459                      --  subprogram that are referenced uplevel. The maximum
 460                      --  number of entries cannot exceed the total number of
 461                      --  uplevel references.
 462
 463                   begin
 464                      --  Populate the Uplevel_Entities array, using the flag
 465                      --  Uplevel_Reference_Noted to avoid duplicates.
 466
 467                      Num_Uplevel_Entities := 0;
 468                      Elmt := First_Elmt (Urefs);
 469                      while Present (Elmt) loop
 470                         Ent := Entity (Node (Elmt));
 471
 472                         if not Uplevel_Reference_Noted (Ent) then
 473                            Set_Uplevel_Reference_Noted (Ent, True);
 474                            Num_Uplevel_Entities := Num_Uplevel_Entities + 1;
 475                            Uplevel_Entities (Num_Uplevel_Entities) := Ent;
 476                         end if;
 477
 478                         Next_Elmt (Elmt);
 479                      end loop;
 480
 481                      --  Build list of component declarations for ARECnT
 482
 483                      Clist := Empty_List;
 484
 485                      --  If not top level, include ARECn : ARECnPT := ARECnP
 486
 487                      if STJ.Lev > 1 then
 488                         Append_To (Clist,
 489                           Make_Component_Declaration (Loc,
 490                             Defining_Identifier =>
 491                               Make_Defining_Identifier (Loc,
 492                                 Chars => Name_Find_Str (ARS)),
 493                             Component_Definition =>
 494                               Make_Component_Definition (Loc,
 495                                 Subtype_Indication =>
 496                                   Make_Identifier (Loc,
 497                                     Chars => Name_Find_Str (ARS & "PT"))),
 498                             Expression =>
 499                               Make_Identifier (Loc,
 500                                 Chars => Name_Find_Str (ARS & "P"))));
 501                      end if;
 502
 503                      --  Add components for uplevel referenced entities
 504
 505                      for J in 1 .. Num_Uplevel_Entities loop
 506                         Append_To (Clist,
 507                           Make_Component_Declaration (Loc,
 508                             Defining_Identifier =>
 509                               Make_Defining_Identifier (Loc,
 510                                 Chars => Chars (Uplevel_Entities (J))),
 511                             Component_Definition =>
 512                               Make_Component_Definition (Loc,
 513                                 Subtype_Indication =>
 514                                   New_Occurrence_Of (Addr, Loc))));
 515                      end loop;
 516
 517                      --  Now we can insert the AREC declarations into the body
 518
 519                      Prepend_List_To (Declarations (STJ.Bod),
 520                        New_List (
 521
 522                          --  type ARECT is record .. end record;
 523
 524                          Make_Full_Type_Declaration (Loc,
 525                            Defining_Identifier =>
 526                              Make_Defining_Identifier (Loc,
 527                                Chars => Name_Find_Str (ARS & "T")),
 528                            Type_Definition     =>
 529                              Make_Record_Definition (Loc,
 530                                Component_List =>
 531                                  Make_Component_List (Loc,
 532                                    Component_Items => Clist))),
 533
 534                          --  type ARECPT is access all ARECT;
 535
 536                          Make_Full_Type_Declaration (Loc,
 537                            Defining_Identifier =>
 538                              Make_Defining_Identifier (Loc,
 539                                Chars => Name_Find_Str (ARS & "PT")),
 540                              Type_Definition   =>
 541                                 Make_Access_To_Object_Definition (Loc,
 542                                   All_Present        => True,
 543                                   Subtype_Indication =>
 544                                     Make_Identifier (Loc,
 545                                       Chars => Name_Find_Str (ARS & "T")))),
 546
 547                         --  ARECP : constant ARECPT := AREC'Access;
 548
 549                         Make_Object_Declaration (Loc,
 550                           Defining_Identifier =>
 551                             Make_Defining_Identifier (Loc,
 552                               Chars => Name_Find_Str (ARS & "P")),
 553                           Constant_Present    => True,
 554                           Object_Definition   =>
 555                             Make_Identifier (Loc, Name_Find_Str (ARS & "PT")),
 556                           Expression          =>
 557                             Make_Attribute_Reference (Loc,
 558                               Prefix         =>
 559                                 Make_Identifier (Loc, Name_Find_Str (ARS)),
 560                                   Attribute_Name => Name_Access))));
 561                   end Add_AREC_Declarations;
 562                end if;
 563             end;
 564          end loop;
 565       end Arec_Decls;
 566
 567       --  Next step, for each uplevel referenced entity, add assignment
 568       --  operations to set the corresponding AREC fields, and define
 569       --  the PTR types.
 570
 571       return;
 572    end Unnest_Subprogram;
 573
 574 end Exp_Unst;