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-2014, 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, 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       Loc : constant Source_Ptr := Sloc (N);
 259       Ent : constant Entity_Id  := Entity (N);
 260       Par : constant Node_Id    := Insert_Node;
 261    begin
 262       if Present (Shared_Var_Procs_Instance (Ent)) then
 263          if Nkind (Insert_Node) = N_Function_Call then
 264             Establish_Transient_Scope (Insert_Node, Sec_Stack => False);
 265             Store_After_Actions_In_Scope (New_List (
 266               Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write)));
 267          else
 268             Insert_After_And_Analyze (Par,
 269               Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write));
 270          end if;
 271       end if;
 272    end Add_Write_After;
 273
 274    ---------------------
 275    -- Build_Full_Name --
 276    ---------------------
 277
 278    procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is
 279
 280       procedure Build_Name (E : Entity_Id);
 281       --  This is a recursive routine used to construct the fully qualified
 282       --  string name of the package corresponding to the shared variable.
 283
 284       ----------------
 285       -- Build_Name --
 286       ----------------
 287
 288       procedure Build_Name (E : Entity_Id) is
 289       begin
 290          if Scope (E) /= Standard_Standard then
 291             Build_Name (Scope (E));
 292             Store_String_Char ('.');
 293          end if;
 294
 295          Get_Decoded_Name_String (Chars (E));
 296          Store_String_Chars (Name_Buffer (1 .. Name_Len));
 297       end Build_Name;
 298
 299    --  Start of processing for Build_Full_Name
 300
 301    begin
 302       Start_String;
 303       Build_Name (E);
 304       N := End_String;
 305    end Build_Full_Name;
 306
 307    ------------------------------------
 308    -- Expand_Shared_Passive_Variable --
 309    ------------------------------------
 310
 311    procedure Expand_Shared_Passive_Variable (N : Node_Id) is
 312       Typ : constant Entity_Id := Etype (N);
 313
 314    begin
 315       --  Nothing to do for protected or limited objects
 316
 317       if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then
 318          return;
 319
 320       --  If we are on the left hand side of an assignment, then we add the
 321       --  write call after the assignment.
 322
 323       elsif On_Lhs_Of_Assignment (N) then
 324          Add_Write_After (N);
 325
 326       --  If we are a parameter for an out or in out formal, then in general
 327       --  we do:
 328
 329       --    read
 330       --    call
 331       --    write
 332
 333       --  but in the special case of a call to an init proc, we need to first
 334       --  call the init proc (to set discriminants), then read (to possibly
 335       --  set other components), then write (to record the updated components
 336       --  to the backing store):
 337
 338       --    init-proc-call
 339       --    read
 340       --    write
 341
 342       elsif Is_Out_Actual (N) then
 343
 344          --  Note: For an init proc call, Add_Read inserts just after the
 345          --  call node, and we want to have first the read, then the write,
 346          --  so we need to first Add_Write_After, then Add_Read.
 347
 348          Add_Write_After (N);
 349          Add_Read (N, Call => Insert_Node);
 350
 351       --  All other cases are simple reads
 352
 353       else
 354          Add_Read (N);
 355       end if;
 356    end Expand_Shared_Passive_Variable;
 357
 358    -------------------
 359    -- Is_Out_Actual --
 360    -------------------
 361
 362    function Is_Out_Actual (N : Node_Id) return Boolean is
 363       Formal : Entity_Id;
 364       Call   : Node_Id;
 365
 366    begin
 367       Find_Actual (N, Formal, Call);
 368
 369       if No (Formal) then
 370          return False;
 371
 372       else
 373          if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then
 374             Insert_Node := Call;
 375             return True;
 376          else
 377             return False;
 378          end if;
 379       end if;
 380    end Is_Out_Actual;
 381
 382    ---------------------------
 383    -- Make_Shared_Var_Procs --
 384    ---------------------------
 385
 386    function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is
 387       Loc     : constant Source_Ptr := Sloc (N);
 388       Ent     : constant Entity_Id  := Defining_Identifier (N);
 389       Typ     : constant Entity_Id  := Etype (Ent);
 390       Vnm     : String_Id;
 391       Obj     : Node_Id;
 392       Obj_Typ : Entity_Id;
 393
 394       After : constant Node_Id := Next (N);
 395       --  Node located right after N originally (after insertion of the SV
 396       --  procs this node is right after the last inserted node).
 397
 398       SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc,
 399                        Chars => New_External_Name (Chars (Ent), 'G'));
 400       --  Instance of Shared_Storage.Shared_Var_Procs associated with Ent
 401
 402       Instantiation : Node_Id;
 403       --  Package instantiation node for SVP_Instance
 404
 405    --  Start of processing for Make_Shared_Var_Procs
 406
 407    begin
 408       Build_Full_Name (Ent, Vnm);
 409
 410       --  We turn off Shared_Passive during construction and analysis of the
 411       --  generic package instantiation, to avoid improper attempts to process
 412       --  the variable references within these instantiation.
 413
 414       Set_Is_Shared_Passive (Ent, False);
 415
 416       --  Construct generic package instantiation
 417
 418       --  package varG is new Shared_Var_Procs (typ, var, "pkg.var");
 419
 420       Obj     := New_Occurrence_Of (Ent, Loc);
 421       Obj_Typ := Typ;
 422       if Is_Concurrent_Type (Typ) then
 423          Obj     := Convert_Concurrent (N => Obj, Typ => Typ);
 424          Obj_Typ := Corresponding_Record_Type (Typ);
 425       end if;
 426
 427       Instantiation :=
 428         Make_Package_Instantiation (Loc,
 429           Defining_Unit_Name   => SVP_Instance,
 430           Name                 =>
 431             New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc),
 432           Generic_Associations => New_List (
 433             Make_Generic_Association (Loc,
 434               Explicit_Generic_Actual_Parameter =>
 435                 New_Occurrence_Of (Obj_Typ, Loc)),
 436             Make_Generic_Association (Loc,
 437               Explicit_Generic_Actual_Parameter => Obj),
 438             Make_Generic_Association (Loc,
 439               Explicit_Generic_Actual_Parameter =>
 440                 Make_String_Literal (Loc, Vnm))));
 441
 442       Insert_After_And_Analyze (N, Instantiation);
 443
 444       Set_Is_Shared_Passive (Ent, True);
 445       Set_Shared_Var_Procs_Instance
 446         (Ent, Defining_Entity (Instance_Spec (Instantiation)));
 447
 448       --  Return last node before After
 449
 450       declare
 451          Nod : Node_Id := Next (N);
 452
 453       begin
 454          while Next (Nod) /= After loop
 455             Nod := Next (Nod);
 456          end loop;
 457
 458          return Nod;
 459       end;
 460    end Make_Shared_Var_Procs;
 461
 462    --------------------------
 463    -- On_Lhs_Of_Assignment --
 464    --------------------------
 465
 466    function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is
 467       P : constant Node_Id := Parent (N);
 468
 469    begin
 470       if Nkind (P) = N_Assignment_Statement then
 471          if N = Name (P) then
 472             Insert_Node := P;
 473             return True;
 474          else
 475             return False;
 476          end if;
 477
 478       elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component)
 479         and then N = Prefix (P)
 480       then
 481          return On_Lhs_Of_Assignment (P);
 482
 483       else
 484          return False;
 485       end if;
 486    end On_Lhs_Of_Assignment;
 487
 488 end Exp_Smem;