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