1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2023, Free Software Foundation, Inc. --
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. --
21 -- GNAT was originally developed by the GNAT team at New York University. --
22 -- Extensive contributions were provided by Ada Core Technologies Inc. --
24 ------------------------------------------------------------------------------
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
;
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
;
50 package body Exp_Smem
is
52 Insert_Node
: Node_Id
;
53 -- Node after which a write call is to be inserted
55 -----------------------
56 -- Local Subprograms --
57 -----------------------
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
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
72 procedure Build_Full_Name
(E
: Entity_Id
; N
: out String_Id
);
73 -- Build the fully qualified string name of a shared variable
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
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.
87 function Build_Shared_Var_Proc_Call
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).
94 --------------------------------
95 -- Build_Shared_Var_Proc_Call --
96 --------------------------------
98 function Build_Shared_Var_Proc_Call
101 N
: Name_Id
) return Node_Id
104 return Make_Procedure_Call_Statement
(Loc
,
105 Name
=> Make_Selected_Component
(Loc
,
107 New_Occurrence_Of
(Shared_Var_Procs_Instance
(E
), Loc
),
108 Selector_Name
=> Make_Identifier
(Loc
, N
)));
109 end Build_Shared_Var_Proc_Call
;
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
);
121 if Present
(Shared_Var_Procs_Instance
(Ent
)) then
122 SVC
:= Build_Shared_Var_Proc_Call
(Loc
, Ent
, Name_Read
);
124 if Present
(Call
) and then Is_Init_Proc
(Name
(Call
)) then
125 Insert_After_And_Analyze
(Call
, SVC
);
127 Insert_Action
(N
, SVC
);
132 -------------------------------
133 -- Add_Shared_Var_Lock_Procs --
134 -------------------------------
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
)));
142 Aft
: constant List_Id
:= New_List
;
144 In_Transient
: constant Boolean := Scope_Is_Transient
;
146 function Build_Shared_Var_Lock_Call
(RE
: RE_Id
) return Node_Id
;
147 -- Return a procedure call statement for lock proc RTE
149 --------------------------------
150 -- Build_Shared_Var_Lock_Call --
151 --------------------------------
153 function Build_Shared_Var_Lock_Call
(RE
: RE_Id
) return Node_Id
is
156 Make_Procedure_Call_Statement
(Loc
,
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
;
163 -- Start of processing for Add_Shared_Var_Lock_Procs
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.
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.
180 and then Contains
(Scope_Stack
.Table
(Scope_Stack
.Last
)
181 .Locked_Shared_Objects
,
187 Build_Full_Name
(Obj
, Vnm
);
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.
195 Vid
:= Make_Temporary
(Loc
, 'N', Obj
);
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
));
203 -- Already in a transient scope. Make sure that we insert Vde outside
207 Insert_Before_And_Analyze
(Node_To_Be_Wrapped
, Vde
);
209 -- Not in a transient scope yet: insert Vde as an action on N prior to
213 Insert_Action
(N
, Vde
);
214 Establish_Transient_Scope
(N
, Manage_Sec_Stack
=> False);
217 -- Mark object as locked in the current (transient) scope
221 To
=> Scope_Stack
.Table
(Scope_Stack
.Last
).Locked_Shared_Objects
);
223 -- First insert the Lock call before
225 Insert_Action
(N
, Build_Shared_Var_Lock_Call
(RE_Shared_Var_Lock
));
227 -- Now, right after the Lock, insert a call to read the object
229 Insert_Action
(N
, Build_Shared_Var_Proc_Call
(Loc
, Obj
, Name_Read
));
231 -- For a procedure call only, insert the call to write the object prior
234 if Nkind
(N
) = N_Procedure_Call_Statement
then
235 Append_To
(Aft
, Build_Shared_Var_Proc_Call
(Loc
, Obj
, Name_Write
));
238 -- Finally insert the Unlock call
240 Append_To
(Aft
, Build_Shared_Var_Lock_Call
(RE_Shared_Var_Unlock
));
242 -- Store cleanup actions in transient scope
244 Store_Cleanup_Actions_In_Scope
(Aft
);
246 -- If we have established a transient scope here, wrap it now
248 if not In_Transient
then
249 if Nkind
(N
) = N_Procedure_Call_Statement
then
250 Wrap_Transient_Statement
(N
);
252 Wrap_Transient_Expression
(N
);
255 end Add_Shared_Var_Lock_Procs
;
257 ---------------------
258 -- Add_Write_After --
259 ---------------------
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
;
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);
271 Store_After_Actions_In_Scope
(New_List
(
272 Build_Shared_Var_Proc_Call
(Loc
, Ent
, Name_Write
)));
274 Insert_After_And_Analyze
(Par
,
275 Build_Shared_Var_Proc_Call
(Loc
, Ent
, Name_Write
));
280 ---------------------
281 -- Build_Full_Name --
282 ---------------------
284 procedure Build_Full_Name
(E
: Entity_Id
; N
: out String_Id
) is
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.
294 procedure Build_Name
(E
: Entity_Id
) is
296 if Scope
(E
) /= Standard_Standard
then
297 Build_Name
(Scope
(E
));
298 Store_String_Char
('.');
301 Get_Decoded_Name_String
(Chars
(E
));
302 Store_String_Chars
(Name_Buffer
(1 .. Name_Len
));
305 -- Start of processing for Build_Full_Name
313 ------------------------------------
314 -- Expand_Shared_Passive_Variable --
315 ------------------------------------
317 procedure Expand_Shared_Passive_Variable
(N
: Node_Id
) is
318 Typ
: constant Entity_Id
:= Etype
(N
);
321 -- Nothing to do for protected or limited objects
323 if Is_Limited_Type
(Typ
) or else Is_Concurrent_Type
(Typ
) then
326 -- If we are on the left hand side of an assignment, then we add the
327 -- write call after the assignment.
329 elsif On_Lhs_Of_Assignment
(N
) then
332 -- If we are a parameter for an out or in out formal, then in general
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):
348 elsif Is_Out_Actual
(N
) then
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.
355 Add_Read
(N
, Call
=> Insert_Node
);
357 -- All other cases are simple reads
362 end Expand_Shared_Passive_Variable
;
368 function Is_Out_Actual
(N
: Node_Id
) return Boolean is
373 Find_Actual
(N
, Formal
, Call
);
379 if Ekind
(Formal
) in E_Out_Parameter | E_In_Out_Parameter
then
388 ---------------------------
389 -- Make_Shared_Var_Procs --
390 ---------------------------
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
);
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).
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
408 Instantiation
: Node_Id
;
409 -- Package instantiation node for SVP_Instance
411 -- Start of processing for Make_Shared_Var_Procs
414 Build_Full_Name
(Ent
, Vnm
);
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.
420 Set_Is_Shared_Passive
(Ent
, False);
422 -- Construct generic package instantiation
424 -- package varG is new Shared_Var_Procs (typ, var, "pkg.var");
426 Obj
:= New_Occurrence_Of
(Ent
, Loc
);
428 if Is_Concurrent_Type
(Typ
) then
429 Obj
:= Convert_Concurrent
(N
=> Obj
, Typ
=> Typ
);
430 Obj_Typ
:= Corresponding_Record_Type
(Typ
);
434 Make_Package_Instantiation
(Loc
,
435 Defining_Unit_Name
=> SVP_Instance
,
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
))));
448 Insert_After_And_Analyze
(N
, Instantiation
);
450 Set_Is_Shared_Passive
(Ent
, True);
451 Set_Shared_Var_Procs_Instance
452 (Ent
, Defining_Entity
(Instance_Spec
(Instantiation
)));
454 -- Return last node before After
457 Nod
: Node_Id
:= Next
(N
);
460 while Next
(Nod
) /= After
loop
466 end Make_Shared_Var_Procs
;
468 --------------------------
469 -- On_Lhs_Of_Assignment --
470 --------------------------
472 function On_Lhs_Of_Assignment
(N
: Node_Id
) return Boolean is
473 P
: constant Node_Id
:= Parent
(N
);
476 if Nkind
(P
) = N_Assignment_Statement
then
484 elsif Nkind
(P
) in N_Indexed_Component | N_Selected_Component
485 and then N
= Prefix
(P
)
487 return On_Lhs_Of_Assignment
(P
);
492 end On_Lhs_Of_Assignment
;