gcc/ada/exp_smem.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             E X P _ S M E M                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1998-2019, 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 Exp_Ch7;  use Exp_Ch7;
  30 with Exp_Ch9;  use Exp_Ch9;
  31 with Exp_Tss;  use Exp_Tss;
  32 with Exp_Util; use Exp_Util;
  33 with Nmake;    use Nmake;
  34 with Namet;    use Namet;
  35 with Nlists;   use Nlists;
  36 with Rtsfind;  use Rtsfind;
  37 with Sem;      use Sem;
  38 with Sem_Aux;  use Sem_Aux;
  39 with Sem_Util; use Sem_Util;
  40 with Sinfo;    use Sinfo;
  41 with Snames;   use Snames;
  42 with Stand;    use Stand;
  43 with Stringt;  use Stringt;
  44 with Tbuild;   use Tbuild;
  45
  46 package body Exp_Smem is
  47
  48    Insert_Node : Node_Id;
  49    --  Node after which a write call is to be inserted
  50
  51    -----------------------
  52    -- Local Subprograms --
  53    -----------------------
  54
  55    procedure Add_Read (N : Node_Id; Call : Node_Id := Empty);
  56    --  Insert a Shared_Var_ROpen call for variable before node N, unless
  57    --  Call is a call to an init-proc, in which case the call is inserted
  58    --  after Call.
  59
  60    procedure Add_Write_After (N : Node_Id);
  61    --  Insert a Shared_Var_WOpen call for variable after the node Insert_Node,
  62    --  as recorded by On_Lhs_Of_Assignment (where it points to the assignment
  63    --  statement) or Is_Out_Actual (where it points to the subprogram call).
  64    --  When Insert_Node is a function call, establish a transient scope around
  65    --  the expression, and insert the write as an after-action of the transient
  66    --  scope.
  67
  68    procedure Build_Full_Name (E : Entity_Id; N : out String_Id);
  69    --  Build the fully qualified string name of a shared variable
  70
  71    function On_Lhs_Of_Assignment (N : Node_Id) return Boolean;
  72    --  Determines if N is on the left hand of the assignment. This means that
  73    --  either it is a simple variable, or it is a record or array variable with
  74    --  a corresponding selected or indexed component on the left side of an
  75    --  assignment. If the result is True, then Insert_Node is set to point
  76    --  to the assignment
  77
  78    function Is_Out_Actual (N : Node_Id) return Boolean;
  79    --  In a similar manner, this function determines if N appears as an OUT
  80    --  or IN OUT parameter to a procedure call. If the result is True, then
  81    --  Insert_Node is set to point to the call.
  82
  83    function Build_Shared_Var_Proc_Call
  84      (Loc : Source_Ptr;
  85       E   : Node_Id;
  86       N   : Name_Id) return Node_Id;
  87    --  Build a call to support procedure N for shared object E (provided by the
  88    --  instance of System.Shared_Storage.Shared_Var_Procs associated to E).
  89
  90    --------------------------------
  91    -- Build_Shared_Var_Proc_Call --
  92    --------------------------------
  93
  94    function Build_Shared_Var_Proc_Call
  95      (Loc : Source_Ptr;
  96       E   : Entity_Id;
  97       N   : Name_Id) return Node_Id
  98    is
  99    begin
 100       return Make_Procedure_Call_Statement (Loc,
 101         Name => Make_Selected_Component (Loc,
 102           Prefix        =>
 103             New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc),
 104           Selector_Name => Make_Identifier (Loc, N)));
 105    end Build_Shared_Var_Proc_Call;
 106
 107    --------------
 108    -- Add_Read --
 109    --------------
 110
 111    procedure Add_Read (N : Node_Id; Call : Node_Id := Empty) is
 112       Loc : constant Source_Ptr := Sloc (N);
 113       Ent : constant Node_Id    := Entity (N);
 114       SVC : Node_Id;
 115
 116    begin
 117       if Present (Shared_Var_Procs_Instance (Ent)) then
 118          SVC := Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read);
 119
 120          if Present (Call) and then Is_Init_Proc (Name (Call)) then
 121             Insert_After_And_Analyze (Call, SVC);
 122          else
 123             Insert_Action (N, SVC);
 124          end if;
 125       end if;
 126    end Add_Read;
 127
 128    -------------------------------
 129    -- Add_Shared_Var_Lock_Procs --
 130    -------------------------------
 131
 132    procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is
 133       Loc : constant Source_Ptr := Sloc (N);
 134       Obj : constant Entity_Id  := Entity (Expression (First_Actual (N)));
 135       Vnm : String_Id;
 136       Vid : Entity_Id;
 137       Vde : Node_Id;
 138       Aft : constant List_Id := New_List;
 139
 140       In_Transient : constant Boolean := Scope_Is_Transient;
 141
 142       function Build_Shared_Var_Lock_Call (RE : RE_Id) return Node_Id;
 143       --  Return a procedure call statement for lock proc RTE
 144
 145       --------------------------------
 146       -- Build_Shared_Var_Lock_Call --
 147       --------------------------------
 148
 149       function Build_Shared_Var_Lock_Call (RE : RE_Id) return Node_Id is
 150       begin
 151          return
 152            Make_Procedure_Call_Statement (Loc,
 153              Name                   =>
 154                New_Occurrence_Of (RTE (RE), Loc),
 155              Parameter_Associations =>
 156                New_List (New_Occurrence_Of (Vid, Loc)));
 157       end Build_Shared_Var_Lock_Call;
 158
 159    --  Start of processing for Add_Shared_Var_Lock_Procs
 160
 161    begin
 162       --  Discussion of transient scopes: we need to have a transient scope
 163       --  to hold the required lock/unlock actions. Either the current scope
 164       --  is transient, in which case we reuse it, or we establish a new
 165       --  transient scope. If this is a function call with unconstrained
 166       --  return type, we can't introduce a transient scope here (because
 167       --  Wrap_Transient_Expression would need to declare a temporary with
 168       --  the unconstrained type outside of the transient block), but in that
 169       --  case we know that we have already established one at an outer level
 170       --  for secondary stack management purposes.
 171
 172       --  If the lock/read/write/unlock actions for this object have already
 173       --  been emitted in the current scope, no need to perform them anew.
 174
 175       if In_Transient
 176         and then Contains (Scope_Stack.Table (Scope_Stack.Last)
 177                              .Locked_Shared_Objects,
 178                            Obj)
 179       then
 180          return;
 181       end if;
 182
 183       Build_Full_Name (Obj, Vnm);
 184
 185       --  Declare a constant string to hold the name of the shared object.
 186       --  Note that this must occur outside of the transient scope, as the
 187       --  scope's finalizer needs to have access to this object. Also, it
 188       --  appears that GIGI does not support elaborating string literal
 189       --  subtypes in transient scopes.
 190
 191       Vid := Make_Temporary (Loc, 'N', Obj);
 192       Vde :=
 193         Make_Object_Declaration (Loc,
 194           Defining_Identifier => Vid,
 195           Constant_Present    => True,
 196           Object_Definition   => New_Occurrence_Of (Standard_String, Loc),
 197           Expression          => Make_String_Literal (Loc, Vnm));
 198
 199       --  Already in a transient scope. Make sure that we insert Vde outside
 200       --  that scope.
 201
 202       if In_Transient then
 203          Insert_Before_And_Analyze (Node_To_Be_Wrapped, Vde);
 204
 205       --  Not in a transient scope yet: insert Vde as an action on N prior to
 206       --  establishing one.
 207
 208       else
 209          Insert_Action (N, Vde);
 210          Establish_Transient_Scope (N, Manage_Sec_Stack => False);
 211       end if;
 212
 213       --  Mark object as locked in the current (transient) scope
 214
 215       Append_New_Elmt
 216         (Obj,
 217          To => Scope_Stack.Table (Scope_Stack.Last).Locked_Shared_Objects);
 218
 219       --  First insert the Lock call before
 220
 221       Insert_Action (N, Build_Shared_Var_Lock_Call (RE_Shared_Var_Lock));
 222
 223       --  Now, right after the Lock, insert a call to read the object
 224
 225       Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read));
 226
 227       --  For a procedure call only, insert the call to write the object prior
 228       --  to unlocking.
 229
 230       if Nkind (N) = N_Procedure_Call_Statement then
 231          Append_To (Aft, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write));
 232       end if;
 233
 234       --  Finally insert the Unlock call
 235
 236       Append_To (Aft, Build_Shared_Var_Lock_Call (RE_Shared_Var_Unlock));
 237
 238       --  Store cleanup actions in transient scope
 239
 240       Store_Cleanup_Actions_In_Scope (Aft);
 241
 242       --  If we have established a transient scope here, wrap it now
 243
 244       if not In_Transient then
 245          if Nkind (N) = N_Procedure_Call_Statement then
 246             Wrap_Transient_Statement (N);
 247          else
 248             Wrap_Transient_Expression (N);
 249          end if;
 250       end if;
 251    end Add_Shared_Var_Lock_Procs;
 252
 253    ---------------------
 254    -- Add_Write_After --
 255    ---------------------
 256
 257    procedure Add_Write_After (N : Node_Id) is
 258       Ent : constant Entity_Id  := Entity (N);
 259       Loc : constant Source_Ptr := Sloc (N);
 260       Par : constant Node_Id    := Insert_Node;
 261
 262    begin
 263       if Present (Shared_Var_Procs_Instance (Ent)) then
 264          if Nkind (Insert_Node) = N_Function_Call then
 265             Establish_Transient_Scope (Insert_Node, Manage_Sec_Stack => False);
 266
 267             Store_After_Actions_In_Scope (New_List (
 268               Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write)));
 269          else
 270             Insert_After_And_Analyze (Par,
 271               Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write));
 272          end if;
 273       end if;
 274    end Add_Write_After;
 275
 276    ---------------------
 277    -- Build_Full_Name --
 278    ---------------------
 279
 280    procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is
 281
 282       procedure Build_Name (E : Entity_Id);
 283       --  This is a recursive routine used to construct the fully qualified
 284       --  string name of the package corresponding to the shared variable.
 285
 286       ----------------
 287       -- Build_Name --
 288       ----------------
 289
 290       procedure Build_Name (E : Entity_Id) is
 291       begin
 292          if Scope (E) /= Standard_Standard then
 293             Build_Name (Scope (E));
 294             Store_String_Char ('.');
 295          end if;
 296
 297          Get_Decoded_Name_String (Chars (E));
 298          Store_String_Chars (Name_Buffer (1 .. Name_Len));
 299       end Build_Name;
 300
 301    --  Start of processing for Build_Full_Name
 302
 303    begin
 304       Start_String;
 305       Build_Name (E);
 306       N := End_String;
 307    end Build_Full_Name;
 308
 309    ------------------------------------
 310    -- Expand_Shared_Passive_Variable --
 311    ------------------------------------
 312
 313    procedure Expand_Shared_Passive_Variable (N : Node_Id) is
 314       Typ : constant Entity_Id := Etype (N);
 315
 316    begin
 317       --  Nothing to do for protected or limited objects
 318
 319       if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then
 320          return;
 321
 322       --  If we are on the left hand side of an assignment, then we add the
 323       --  write call after the assignment.
 324
 325       elsif On_Lhs_Of_Assignment (N) then
 326          Add_Write_After (N);
 327
 328       --  If we are a parameter for an out or in out formal, then in general
 329       --  we do:
 330
 331       --    read
 332       --    call
 333       --    write
 334
 335       --  but in the special case of a call to an init proc, we need to first
 336       --  call the init proc (to set discriminants), then read (to possibly
 337       --  set other components), then write (to record the updated components
 338       --  to the backing store):
 339
 340       --    init-proc-call
 341       --    read
 342       --    write
 343
 344       elsif Is_Out_Actual (N) then
 345
 346          --  Note: For an init proc call, Add_Read inserts just after the
 347          --  call node, and we want to have first the read, then the write,
 348          --  so we need to first Add_Write_After, then Add_Read.
 349
 350          Add_Write_After (N);
 351          Add_Read (N, Call => Insert_Node);
 352
 353       --  All other cases are simple reads
 354
 355       else
 356          Add_Read (N);
 357       end if;
 358    end Expand_Shared_Passive_Variable;
 359
 360    -------------------
 361    -- Is_Out_Actual --
 362    -------------------
 363
 364    function Is_Out_Actual (N : Node_Id) return Boolean is
 365       Formal : Entity_Id;
 366       Call   : Node_Id;
 367
 368    begin
 369       Find_Actual (N, Formal, Call);
 370
 371       if No (Formal) then
 372          return False;
 373
 374       else
 375          if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then
 376             Insert_Node := Call;
 377             return True;
 378          else
 379             return False;
 380          end if;
 381       end if;
 382    end Is_Out_Actual;
 383
 384    ---------------------------
 385    -- Make_Shared_Var_Procs --
 386    ---------------------------
 387
 388    function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is
 389       Loc     : constant Source_Ptr := Sloc (N);
 390       Ent     : constant Entity_Id  := Defining_Identifier (N);
 391       Typ     : constant Entity_Id  := Etype (Ent);
 392       Vnm     : String_Id;
 393       Obj     : Node_Id;
 394       Obj_Typ : Entity_Id;
 395
 396       After : constant Node_Id := Next (N);
 397       --  Node located right after N originally (after insertion of the SV
 398       --  procs this node is right after the last inserted node).
 399
 400       SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc,
 401                        Chars => New_External_Name (Chars (Ent), 'G'));
 402       --  Instance of Shared_Storage.Shared_Var_Procs associated with Ent
 403
 404       Instantiation : Node_Id;
 405       --  Package instantiation node for SVP_Instance
 406
 407    --  Start of processing for Make_Shared_Var_Procs
 408
 409    begin
 410       Build_Full_Name (Ent, Vnm);
 411
 412       --  We turn off Shared_Passive during construction and analysis of the
 413       --  generic package instantiation, to avoid improper attempts to process
 414       --  the variable references within these instantiation.
 415
 416       Set_Is_Shared_Passive (Ent, False);
 417
 418       --  Construct generic package instantiation
 419
 420       --  package varG is new Shared_Var_Procs (typ, var, "pkg.var");
 421
 422       Obj     := New_Occurrence_Of (Ent, Loc);
 423       Obj_Typ := Typ;
 424       if Is_Concurrent_Type (Typ) then
 425          Obj     := Convert_Concurrent (N => Obj, Typ => Typ);
 426          Obj_Typ := Corresponding_Record_Type (Typ);
 427       end if;
 428
 429       Instantiation :=
 430         Make_Package_Instantiation (Loc,
 431           Defining_Unit_Name   => SVP_Instance,
 432           Name                 =>
 433             New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc),
 434           Generic_Associations => New_List (
 435             Make_Generic_Association (Loc,
 436               Explicit_Generic_Actual_Parameter =>
 437                 New_Occurrence_Of (Obj_Typ, Loc)),
 438             Make_Generic_Association (Loc,
 439               Explicit_Generic_Actual_Parameter => Obj),
 440             Make_Generic_Association (Loc,
 441               Explicit_Generic_Actual_Parameter =>
 442                 Make_String_Literal (Loc, Vnm))));
 443
 444       Insert_After_And_Analyze (N, Instantiation);
 445
 446       Set_Is_Shared_Passive (Ent, True);
 447       Set_Shared_Var_Procs_Instance
 448         (Ent, Defining_Entity (Instance_Spec (Instantiation)));
 449
 450       --  Return last node before After
 451
 452       declare
 453          Nod : Node_Id := Next (N);
 454
 455       begin
 456          while Next (Nod) /= After loop
 457             Nod := Next (Nod);
 458          end loop;
 459
 460          return Nod;
 461       end;
 462    end Make_Shared_Var_Procs;
 463
 464    --------------------------
 465    -- On_Lhs_Of_Assignment --
 466    --------------------------
 467
 468    function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is
 469       P : constant Node_Id := Parent (N);
 470
 471    begin
 472       if Nkind (P) = N_Assignment_Statement then
 473          if N = Name (P) then
 474             Insert_Node := P;
 475             return True;
 476          else
 477             return False;
 478          end if;
 479
 480       elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component)
 481         and then N = Prefix (P)
 482       then
 483          return On_Lhs_Of_Assignment (P);
 484
 485       else
 486          return False;
 487       end if;
 488    end On_Lhs_Of_Assignment;
 489
 490 end Exp_Smem;