]>
Commit | Line | Data |
---|---|---|
70482933 RK |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3 | -- GNAT COMPILER COMPONENTS -- | |
4 | -- -- | |
5 | -- E X P _ S M E M -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
8d0d46f4 | 9 | -- Copyright (C) 1998-2021, Free Software Foundation, Inc. -- |
70482933 RK |
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- -- | |
b5c84c3c | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
70482933 RK |
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 -- | |
b5c84c3c RD |
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. -- | |
70482933 RK |
20 | -- -- |
21 | -- GNAT was originally developed by the GNAT team at New York University. -- | |
71ff80dc | 22 | -- Extensive contributions were provided by Ada Core Technologies Inc. -- |
70482933 RK |
23 | -- -- |
24 | ------------------------------------------------------------------------------ | |
25 | ||
26 | with Atree; use Atree; | |
76f9c7f4 BD |
27 | with Einfo; use Einfo; |
28 | with Einfo.Entities; use Einfo.Entities; | |
29 | with Einfo.Utils; use Einfo.Utils; | |
8071b771 | 30 | with Elists; use Elists; |
8fdafe44 | 31 | with Exp_Ch7; use Exp_Ch7; |
a808ba1b | 32 | with Exp_Ch9; use Exp_Ch9; |
b3a69993 | 33 | with Exp_Tss; use Exp_Tss; |
70482933 RK |
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; | |
a4100e55 | 40 | with Sem_Aux; use Sem_Aux; |
70482933 | 41 | with Sem_Util; use Sem_Util; |
76f9c7f4 BD |
42 | with Sinfo; use Sinfo; |
43 | with Sinfo.Nodes; use Sinfo.Nodes; | |
44 | with Sinfo.Utils; use Sinfo.Utils; | |
70482933 RK |
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 | ||
b3a69993 AC |
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. | |
70482933 RK |
63 | |
64 | procedure Add_Write_After (N : Node_Id); | |
b3a69993 AC |
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 | |
8fdafe44 AC |
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. | |
70482933 | 71 | |
0ae9f22f | 72 | procedure Build_Full_Name (E : Entity_Id; N : out String_Id); |
a2cb348e | 73 | -- Build the fully qualified string name of a shared variable |
70482933 RK |
74 | |
75 | function On_Lhs_Of_Assignment (N : Node_Id) return Boolean; | |
b3a69993 AC |
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 | |
70482933 RK |
81 | |
82 | function Is_Out_Actual (N : Node_Id) return Boolean; | |
b3a69993 AC |
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. | |
70482933 | 86 | |
7052f54e KP |
87 | function Build_Shared_Var_Proc_Call |
88 | (Loc : Source_Ptr; | |
89 | E : Node_Id; | |
90 | N : Name_Id) return Node_Id; | |
b3a69993 AC |
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). | |
7052f54e KP |
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; | |
b3a69993 AC |
101 | N : Name_Id) return Node_Id |
102 | is | |
7052f54e KP |
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), | |
7675ad4f | 108 | Selector_Name => Make_Identifier (Loc, N))); |
7052f54e KP |
109 | end Build_Shared_Var_Proc_Call; |
110 | ||
b3a69993 AC |
111 | -------------- |
112 | -- Add_Read -- | |
113 | -------------- | |
70482933 | 114 | |
b3a69993 | 115 | procedure Add_Read (N : Node_Id; Call : Node_Id := Empty) is |
70482933 RK |
116 | Loc : constant Source_Ptr := Sloc (N); |
117 | Ent : constant Node_Id := Entity (N); | |
b3a69993 AC |
118 | SVC : Node_Id; |
119 | ||
70482933 | 120 | begin |
7052f54e | 121 | if Present (Shared_Var_Procs_Instance (Ent)) then |
b3a69993 AC |
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; | |
70482933 | 129 | end if; |
b3a69993 | 130 | end Add_Read; |
70482933 RK |
131 | |
132 | ------------------------------- | |
133 | -- Add_Shared_Var_Lock_Procs -- | |
134 | ------------------------------- | |
135 | ||
136 | procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is | |
36295779 AC |
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; | |
8071b771 | 141 | Vde : Node_Id; |
36295779 | 142 | Aft : constant List_Id := New_List; |
70482933 | 143 | |
8071b771 AC |
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 | ||
70482933 | 165 | begin |
8071b771 AC |
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 | ||
70482933 RK |
187 | Build_Full_Name (Obj, Vnm); |
188 | ||
8071b771 AC |
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. | |
36295779 AC |
194 | |
195 | Vid := Make_Temporary (Loc, 'N', Obj); | |
3aac5551 RD |
196 | Vde := |
197 | Make_Object_Declaration (Loc, | |
36295779 AC |
198 | Defining_Identifier => Vid, |
199 | Constant_Present => True, | |
200 | Object_Definition => New_Occurrence_Of (Standard_String, Loc), | |
8071b771 AC |
201 | Expression => Make_String_Literal (Loc, Vnm)); |
202 | ||
3aac5551 RD |
203 | -- Already in a transient scope. Make sure that we insert Vde outside |
204 | -- that scope. | |
36295779 | 205 | |
3aac5551 | 206 | if In_Transient then |
8071b771 | 207 | Insert_Before_And_Analyze (Node_To_Be_Wrapped, Vde); |
36295779 | 208 | |
3aac5551 RD |
209 | -- Not in a transient scope yet: insert Vde as an action on N prior to |
210 | -- establishing one. | |
8071b771 | 211 | |
3aac5551 | 212 | else |
8071b771 | 213 | Insert_Action (N, Vde); |
6560f851 | 214 | Establish_Transient_Scope (N, Manage_Sec_Stack => False); |
8071b771 AC |
215 | end if; |
216 | ||
217 | -- Mark object as locked in the current (transient) scope | |
218 | ||
21c51f53 RD |
219 | Append_New_Elmt |
220 | (Obj, | |
221 | To => Scope_Stack.Table (Scope_Stack.Last).Locked_Shared_Objects); | |
36295779 | 222 | |
70482933 RK |
223 | -- First insert the Lock call before |
224 | ||
8071b771 | 225 | Insert_Action (N, Build_Shared_Var_Lock_Call (RE_Shared_Var_Lock)); |
70482933 RK |
226 | |
227 | -- Now, right after the Lock, insert a call to read the object | |
228 | ||
8071b771 | 229 | Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read)); |
70482933 | 230 | |
8071b771 AC |
231 | -- For a procedure call only, insert the call to write the object prior |
232 | -- to unlocking. | |
36295779 AC |
233 | |
234 | if Nkind (N) = N_Procedure_Call_Statement then | |
8071b771 | 235 | Append_To (Aft, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write)); |
36295779 AC |
236 | end if; |
237 | ||
8071b771 AC |
238 | -- Finally insert the Unlock call |
239 | ||
240 | Append_To (Aft, Build_Shared_Var_Lock_Call (RE_Shared_Var_Unlock)); | |
70482933 | 241 | |
8071b771 | 242 | -- Store cleanup actions in transient scope |
70482933 | 243 | |
36295779 | 244 | Store_Cleanup_Actions_In_Scope (Aft); |
70482933 | 245 | |
8071b771 AC |
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; | |
70482933 | 254 | end if; |
70482933 RK |
255 | end Add_Shared_Var_Lock_Procs; |
256 | ||
257 | --------------------- | |
258 | -- Add_Write_After -- | |
259 | --------------------- | |
260 | ||
261 | procedure Add_Write_After (N : Node_Id) is | |
8fdafe44 | 262 | Ent : constant Entity_Id := Entity (N); |
6560f851 | 263 | Loc : constant Source_Ptr := Sloc (N); |
00ba7be8 | 264 | Par : constant Node_Id := Insert_Node; |
6560f851 | 265 | |
70482933 | 266 | begin |
7052f54e | 267 | if Present (Shared_Var_Procs_Instance (Ent)) then |
8fdafe44 | 268 | if Nkind (Insert_Node) = N_Function_Call then |
6560f851 HK |
269 | Establish_Transient_Scope (Insert_Node, Manage_Sec_Stack => False); |
270 | ||
8fdafe44 AC |
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; | |
70482933 RK |
277 | end if; |
278 | end Add_Write_After; | |
279 | ||
280 | --------------------- | |
281 | -- Build_Full_Name -- | |
282 | --------------------- | |
283 | ||
0ae9f22f | 284 | procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is |
70482933 RK |
285 | |
286 | procedure Build_Name (E : Entity_Id); | |
0ae9f22f RD |
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 | ---------------- | |
70482933 RK |
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 | ||
0ae9f22f RD |
305 | -- Start of processing for Build_Full_Name |
306 | ||
70482933 RK |
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 | ||
b3a69993 AC |
326 | -- If we are on the left hand side of an assignment, then we add the |
327 | -- write call after the assignment. | |
70482933 RK |
328 | |
329 | elsif On_Lhs_Of_Assignment (N) then | |
330 | Add_Write_After (N); | |
331 | ||
b3a69993 AC |
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 | |
70482933 RK |
347 | |
348 | elsif Is_Out_Actual (N) then | |
b3a69993 AC |
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 | ||
70482933 | 354 | Add_Write_After (N); |
b3a69993 | 355 | Add_Read (N, Call => Insert_Node); |
70482933 RK |
356 | |
357 | -- All other cases are simple reads | |
358 | ||
359 | else | |
b3a69993 | 360 | Add_Read (N); |
70482933 RK |
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 | |
561b5849 RD |
369 | Formal : Entity_Id; |
370 | Call : Node_Id; | |
70482933 RK |
371 | |
372 | begin | |
561b5849 | 373 | Find_Actual (N, Formal, Call); |
70482933 | 374 | |
561b5849 | 375 | if No (Formal) then |
70482933 | 376 | return False; |
561b5849 RD |
377 | |
378 | else | |
4a08c95c | 379 | if Ekind (Formal) in E_Out_Parameter | E_In_Out_Parameter then |
561b5849 RD |
380 | Insert_Node := Call; |
381 | return True; | |
382 | else | |
383 | return False; | |
384 | end if; | |
70482933 | 385 | end if; |
70482933 RK |
386 | end Is_Out_Actual; |
387 | ||
388 | --------------------------- | |
389 | -- Make_Shared_Var_Procs -- | |
390 | --------------------------- | |
391 | ||
b5c84c3c | 392 | function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is |
a808ba1b TQ |
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; | |
70482933 | 399 | |
b5c84c3c RD |
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 | ||
7052f54e KP |
404 | SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc, |
405 | Chars => New_External_Name (Chars (Ent), 'G')); | |
b3a69993 | 406 | -- Instance of Shared_Storage.Shared_Var_Procs associated with Ent |
70482933 | 407 | |
7052f54e | 408 | Instantiation : Node_Id; |
30783513 | 409 | -- Package instantiation node for SVP_Instance |
70482933 RK |
410 | |
411 | -- Start of processing for Make_Shared_Var_Procs | |
412 | ||
413 | begin | |
414 | Build_Full_Name (Ent, Vnm); | |
415 | ||
b3a69993 AC |
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. | |
70482933 RK |
419 | |
420 | Set_Is_Shared_Passive (Ent, False); | |
421 | ||
7052f54e KP |
422 | -- Construct generic package instantiation |
423 | ||
a808ba1b TQ |
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; | |
7052f54e KP |
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 ( | |
a808ba1b TQ |
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)))); | |
7052f54e KP |
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))); | |
b5c84c3c RD |
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 | |
cbbe41d1 | 461 | Next (Nod); |
b5c84c3c RD |
462 | end loop; |
463 | ||
464 | return Nod; | |
465 | end; | |
70482933 RK |
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 | ||
4a08c95c | 484 | elsif Nkind (P) in N_Indexed_Component | N_Selected_Component |
70482933 RK |
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 | ||
70482933 | 494 | end Exp_Smem; |