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-2013, 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
26with Atree;    use Atree;
27with Einfo;    use Einfo;
28with Exp_Ch7;  use Exp_Ch7;
29with Exp_Ch9;  use Exp_Ch9;
30with Exp_Tss;  use Exp_Tss;
31with Exp_Util; use Exp_Util;
32with Nmake;    use Nmake;
33with Namet;    use Namet;
34with Nlists;   use Nlists;
35with Rtsfind;  use Rtsfind;
36with Sem;      use Sem;
37with Sem_Aux;  use Sem_Aux;
38with Sem_Util; use Sem_Util;
39with Sinfo;    use Sinfo;
40with Snames;   use Snames;
41with Stand;    use Stand;
42with Stringt;  use Stringt;
43with Tbuild;   use Tbuild;
44
45package body Exp_Smem is
46
47   Insert_Node : Node_Id;
48   --  Node after which a write call is to be inserted
49
50   -----------------------
51   -- Local Subprograms --
52   -----------------------
53
54   procedure Add_Read (N : Node_Id; Call : Node_Id := Empty);
55   --  Insert a Shared_Var_ROpen call for variable before node N, unless
56   --  Call is a call to an init-proc, in which case the call is inserted
57   --  after Call.
58
59   procedure Add_Write_After (N : Node_Id);
60   --  Insert a Shared_Var_WOpen call for variable after the node Insert_Node,
61   --  as recorded by On_Lhs_Of_Assignment (where it points to the assignment
62   --  statement) or Is_Out_Actual (where it points to the subprogram call).
63   --  When Insert_Node is a function call, establish a transient scope around
64   --  the expression, and insert the write as an after-action of the transient
65   --  scope.
66
67   procedure Build_Full_Name (E : Entity_Id; N : out String_Id);
68   --  Build the fully qualified string name of a shared variable
69
70   function On_Lhs_Of_Assignment (N : Node_Id) return Boolean;
71   --  Determines if N is on the left hand of the assignment. This means that
72   --  either it is a simple variable, or it is a record or array variable with
73   --  a corresponding selected or indexed component on the left side of an
74   --  assignment. If the result is True, then Insert_Node is set to point
75   --  to the assignment
76
77   function Is_Out_Actual (N : Node_Id) return Boolean;
78   --  In a similar manner, this function determines if N appears as an OUT
79   --  or IN OUT parameter to a procedure call. If the result is True, then
80   --  Insert_Node is set to point to the call.
81
82   function Build_Shared_Var_Proc_Call
83     (Loc : Source_Ptr;
84      E   : Node_Id;
85      N   : Name_Id) return Node_Id;
86   --  Build a call to support procedure N for shared object E (provided by the
87   --  instance of System.Shared_Storage.Shared_Var_Procs associated to E).
88
89   --------------------------------
90   -- Build_Shared_Var_Proc_Call --
91   --------------------------------
92
93   function Build_Shared_Var_Proc_Call
94     (Loc : Source_Ptr;
95      E   : Entity_Id;
96      N   : Name_Id) return Node_Id
97   is
98   begin
99      return Make_Procedure_Call_Statement (Loc,
100        Name => Make_Selected_Component (Loc,
101          Prefix        =>
102            New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc),
103          Selector_Name => Make_Identifier (Loc, N)));
104   end Build_Shared_Var_Proc_Call;
105
106   --------------
107   -- Add_Read --
108   --------------
109
110   procedure Add_Read (N : Node_Id; Call : Node_Id := Empty) is
111      Loc : constant Source_Ptr := Sloc (N);
112      Ent : constant Node_Id    := Entity (N);
113      SVC : Node_Id;
114
115   begin
116      if Present (Shared_Var_Procs_Instance (Ent)) then
117         SVC := Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read);
118
119         if Present (Call) and then Is_Init_Proc (Name (Call)) then
120            Insert_After_And_Analyze (Call, SVC);
121         else
122            Insert_Action (N, SVC);
123         end if;
124      end if;
125   end Add_Read;
126
127   -------------------------------
128   -- Add_Shared_Var_Lock_Procs --
129   -------------------------------
130
131   procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is
132      Loc   : constant Source_Ptr := Sloc (N);
133      Obj   : constant Entity_Id  := Entity (Expression (First_Actual (N)));
134      Inode : Node_Id;
135      Vnm   : String_Id;
136
137   begin
138      --  We have to add Shared_Var_Lock and Shared_Var_Unlock calls around
139      --  the procedure or function call node. First we locate the right place
140      --  to do the insertion, which is the call itself in the procedure call
141      --  case, or else the nearest non subexpression node that contains the
142      --  function call.
143
144      Inode := N;
145      while Nkind (Inode) /= N_Procedure_Call_Statement
146        and then Nkind (Inode) in N_Subexpr
147      loop
148         Inode := Parent (Inode);
149      end loop;
150
151      --  Now insert the Lock and Unlock calls and the read/write calls
152
153      --  Two concerns here. First we are not dealing with the exception case,
154      --  really we need some kind of cleanup routine to do the Unlock. Second,
155      --  these lock calls should be inside the protected object processing,
156      --  not outside, otherwise they can be done at the wrong priority,
157      --  resulting in dead lock situations ???
158
159      Build_Full_Name (Obj, Vnm);
160
161      --  First insert the Lock call before
162
163      Insert_Before_And_Analyze (Inode,
164        Make_Procedure_Call_Statement (Loc,
165          Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc),
166          Parameter_Associations => New_List (
167            Make_String_Literal (Loc, Vnm))));
168
169      --  Now, right after the Lock, insert a call to read the object
170
171      Insert_Before_And_Analyze (Inode,
172        Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read));
173
174      --  Now insert the Unlock call after
175
176      Insert_After_And_Analyze (Inode,
177        Make_Procedure_Call_Statement (Loc,
178          Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
179          Parameter_Associations => New_List (
180            Make_String_Literal (Loc, Vnm))));
181
182      --  Now for a procedure call, but not a function call, insert the
183      --  call to write the object just before the unlock.
184
185      if Nkind (N) = N_Procedure_Call_Statement then
186         Insert_After_And_Analyze (Inode,
187           Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write));
188      end if;
189   end Add_Shared_Var_Lock_Procs;
190
191   ---------------------
192   -- Add_Write_After --
193   ---------------------
194
195   procedure Add_Write_After (N : Node_Id) is
196      Loc : constant Source_Ptr := Sloc (N);
197      Ent : constant Entity_Id  := Entity (N);
198      Par : constant Node_Id    := Insert_Node;
199   begin
200      if Present (Shared_Var_Procs_Instance (Ent)) then
201         if Nkind (Insert_Node) = N_Function_Call then
202            Establish_Transient_Scope (Insert_Node, Sec_Stack => False);
203            Store_After_Actions_In_Scope (New_List (
204              Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write)));
205         else
206            Insert_After_And_Analyze (Par,
207              Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write));
208         end if;
209      end if;
210   end Add_Write_After;
211
212   ---------------------
213   -- Build_Full_Name --
214   ---------------------
215
216   procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is
217
218      procedure Build_Name (E : Entity_Id);
219      --  This is a recursive routine used to construct the fully qualified
220      --  string name of the package corresponding to the shared variable.
221
222      ----------------
223      -- Build_Name --
224      ----------------
225
226      procedure Build_Name (E : Entity_Id) is
227      begin
228         if Scope (E) /= Standard_Standard then
229            Build_Name (Scope (E));
230            Store_String_Char ('.');
231         end if;
232
233         Get_Decoded_Name_String (Chars (E));
234         Store_String_Chars (Name_Buffer (1 .. Name_Len));
235      end Build_Name;
236
237   --  Start of processing for Build_Full_Name
238
239   begin
240      Start_String;
241      Build_Name (E);
242      N := End_String;
243   end Build_Full_Name;
244
245   ------------------------------------
246   -- Expand_Shared_Passive_Variable --
247   ------------------------------------
248
249   procedure Expand_Shared_Passive_Variable (N : Node_Id) is
250      Typ : constant Entity_Id := Etype (N);
251
252   begin
253      --  Nothing to do for protected or limited objects
254
255      if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then
256         return;
257
258      --  If we are on the left hand side of an assignment, then we add the
259      --  write call after the assignment.
260
261      elsif On_Lhs_Of_Assignment (N) then
262         Add_Write_After (N);
263
264      --  If we are a parameter for an out or in out formal, then in general
265      --  we do:
266
267      --    read
268      --    call
269      --    write
270
271      --  but in the special case of a call to an init proc, we need to first
272      --  call the init proc (to set discriminants), then read (to possibly
273      --  set other components), then write (to record the updated components
274      --  to the backing store):
275
276      --    init-proc-call
277      --    read
278      --    write
279
280      elsif Is_Out_Actual (N) then
281
282         --  Note: For an init proc call, Add_Read inserts just after the
283         --  call node, and we want to have first the read, then the write,
284         --  so we need to first Add_Write_After, then Add_Read.
285
286         Add_Write_After (N);
287         Add_Read (N, Call => Insert_Node);
288
289      --  All other cases are simple reads
290
291      else
292         Add_Read (N);
293      end if;
294   end Expand_Shared_Passive_Variable;
295
296   -------------------
297   -- Is_Out_Actual --
298   -------------------
299
300   function Is_Out_Actual (N : Node_Id) return Boolean is
301      Formal : Entity_Id;
302      Call   : Node_Id;
303
304   begin
305      Find_Actual (N, Formal, Call);
306
307      if No (Formal) then
308         return False;
309
310      else
311         if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then
312            Insert_Node := Call;
313            return True;
314         else
315            return False;
316         end if;
317      end if;
318   end Is_Out_Actual;
319
320   ---------------------------
321   -- Make_Shared_Var_Procs --
322   ---------------------------
323
324   function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is
325      Loc     : constant Source_Ptr := Sloc (N);
326      Ent     : constant Entity_Id  := Defining_Identifier (N);
327      Typ     : constant Entity_Id  := Etype (Ent);
328      Vnm     : String_Id;
329      Obj     : Node_Id;
330      Obj_Typ : Entity_Id;
331
332      After : constant Node_Id := Next (N);
333      --  Node located right after N originally (after insertion of the SV
334      --  procs this node is right after the last inserted node).
335
336      SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc,
337                       Chars => New_External_Name (Chars (Ent), 'G'));
338      --  Instance of Shared_Storage.Shared_Var_Procs associated with Ent
339
340      Instantiation : Node_Id;
341      --  Package instantiation node for SVP_Instance
342
343   --  Start of processing for Make_Shared_Var_Procs
344
345   begin
346      Build_Full_Name (Ent, Vnm);
347
348      --  We turn off Shared_Passive during construction and analysis of the
349      --  generic package instantiation, to avoid improper attempts to process
350      --  the variable references within these instantiation.
351
352      Set_Is_Shared_Passive (Ent, False);
353
354      --  Construct generic package instantiation
355
356      --  package varG is new Shared_Var_Procs (typ, var, "pkg.var");
357
358      Obj     := New_Occurrence_Of (Ent, Loc);
359      Obj_Typ := Typ;
360      if Is_Concurrent_Type (Typ) then
361         Obj     := Convert_Concurrent (N => Obj, Typ => Typ);
362         Obj_Typ := Corresponding_Record_Type (Typ);
363      end if;
364
365      Instantiation :=
366        Make_Package_Instantiation (Loc,
367          Defining_Unit_Name   => SVP_Instance,
368          Name                 =>
369            New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc),
370          Generic_Associations => New_List (
371            Make_Generic_Association (Loc,
372              Explicit_Generic_Actual_Parameter =>
373                New_Occurrence_Of (Obj_Typ, Loc)),
374            Make_Generic_Association (Loc,
375              Explicit_Generic_Actual_Parameter => Obj),
376            Make_Generic_Association (Loc,
377              Explicit_Generic_Actual_Parameter =>
378                Make_String_Literal (Loc, Vnm))));
379
380      Insert_After_And_Analyze (N, Instantiation);
381
382      Set_Is_Shared_Passive (Ent, True);
383      Set_Shared_Var_Procs_Instance
384        (Ent, Defining_Entity (Instance_Spec (Instantiation)));
385
386      --  Return last node before After
387
388      declare
389         Nod : Node_Id := Next (N);
390
391      begin
392         while Next (Nod) /= After loop
393            Nod := Next (Nod);
394         end loop;
395
396         return Nod;
397      end;
398   end Make_Shared_Var_Procs;
399
400   --------------------------
401   -- On_Lhs_Of_Assignment --
402   --------------------------
403
404   function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is
405      P : constant Node_Id := Parent (N);
406
407   begin
408      if Nkind (P) = N_Assignment_Statement then
409         if N = Name (P) then
410            Insert_Node := P;
411            return True;
412         else
413            return False;
414         end if;
415
416      elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component)
417        and then N = Prefix (P)
418      then
419         return On_Lhs_Of_Assignment (P);
420
421      else
422         return False;
423      end if;
424   end On_Lhs_Of_Assignment;
425
426end Exp_Smem;
427