1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
9 -- Copyright (C) 1998-2008, 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 Exp_Util; use Exp_Util;
29 with Nmake; use Nmake;
30 with Namet; use Namet;
31 with Nlists; use Nlists;
32 with Rtsfind; use Rtsfind;
34 with Sem_Aux; use Sem_Aux;
35 with Sem_Util; use Sem_Util;
36 with Sinfo; use Sinfo;
37 with Snames; use Snames;
38 with Stand; use Stand;
39 with Stringt; use Stringt;
40 with Tbuild; use Tbuild;
42 package body Exp_Smem is
44 Insert_Node : Node_Id;
45 -- Node after which a write call is to be inserted
47 -----------------------
48 -- Local Subprograms --
49 -----------------------
51 procedure Add_Read_Before (N : Node_Id);
52 -- Insert a Shared_Var_ROpen call for variable before node N
54 procedure Add_Write_After (N : Node_Id);
55 -- Insert a Shared_Var_WOpen call for variable after the node
56 -- Insert_Node, as recorded by On_Lhs_Of_Assignment (where it points
57 -- to the assignment statement) or Is_Out_Actual (where it points to
58 -- the procedure call statement).
60 procedure Build_Full_Name (E : Entity_Id; N : out String_Id);
61 -- Build the fully qualified string name of a shared variable
63 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean;
64 -- Determines if N is on the left hand of the assignment. This means
65 -- that either it is a simple variable, or it is a record or array
66 -- variable with a corresponding selected or indexed component on
67 -- the left side of an assignment. If the result is True, then
68 -- Insert_Node is set to point to the assignment
70 function Is_Out_Actual (N : Node_Id) return Boolean;
71 -- In a similar manner, this function determines if N appears as an
72 -- OUT or IN OUT parameter to a procedure call. If the result is
73 -- True, then Insert_Node is set to point to the call.
75 function Build_Shared_Var_Proc_Call
78 N : Name_Id) return Node_Id;
79 -- Build a call to support procedure N for shared object E (provided by
80 -- the instance of System.Shared_Storage.Shared_Var_Procs associated to E).
82 --------------------------------
83 -- Build_Shared_Var_Proc_Call --
84 --------------------------------
86 function Build_Shared_Var_Proc_Call
89 N : Name_Id) return Node_Id is
91 return Make_Procedure_Call_Statement (Loc,
92 Name => Make_Selected_Component (Loc,
94 New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc),
95 Selector_Name => Make_Identifier (Loc, Chars => N)));
96 end Build_Shared_Var_Proc_Call;
100 ---------------------
102 procedure Add_Read_Before (N : Node_Id) is
103 Loc : constant Source_Ptr := Sloc (N);
104 Ent : constant Node_Id := Entity (N);
106 if Present (Shared_Var_Procs_Instance (Ent)) then
107 Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read));
111 -------------------------------
112 -- Add_Shared_Var_Lock_Procs --
113 -------------------------------
115 procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is
116 Loc : constant Source_Ptr := Sloc (N);
117 Obj : constant Entity_Id := Entity (Expression (First_Actual (N)));
122 -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around
123 -- the procedure or function call node. First we locate the right
124 -- place to do the insertion, which is the call itself in the
125 -- procedure call case, or else the nearest non subexpression
126 -- node that contains the function call.
129 while Nkind (Inode) /= N_Procedure_Call_Statement
130 and then Nkind (Inode) in N_Subexpr
132 Inode := Parent (Inode);
135 -- Now insert the Lock and Unlock calls and the read/write calls
137 -- Two concerns here. First we are not dealing with the exception
138 -- case, really we need some kind of cleanup routine to do the
139 -- Unlock. Second, these lock calls should be inside the protected
140 -- object processing, not outside, otherwise they can be done at
141 -- the wrong priority, resulting in dead lock situations ???
143 Build_Full_Name (Obj, Vnm);
145 -- First insert the Lock call before
147 Insert_Before_And_Analyze (Inode,
148 Make_Procedure_Call_Statement (Loc,
149 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc),
150 Parameter_Associations => New_List (
151 Make_String_Literal (Loc, Vnm))));
153 -- Now, right after the Lock, insert a call to read the object
155 Insert_Before_And_Analyze (Inode,
156 Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read));
158 -- Now insert the Unlock call after
160 Insert_After_And_Analyze (Inode,
161 Make_Procedure_Call_Statement (Loc,
162 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
163 Parameter_Associations => New_List (
164 Make_String_Literal (Loc, Vnm))));
166 -- Now for a procedure call, but not a function call, insert the
167 -- call to write the object just before the unlock.
169 if Nkind (N) = N_Procedure_Call_Statement then
170 Insert_After_And_Analyze (Inode,
171 Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write));
174 end Add_Shared_Var_Lock_Procs;
176 ---------------------
177 -- Add_Write_After --
178 ---------------------
180 procedure Add_Write_After (N : Node_Id) is
181 Loc : constant Source_Ptr := Sloc (N);
182 Ent : constant Node_Id := Entity (N);
185 if Present (Shared_Var_Procs_Instance (Ent)) then
186 Insert_After_And_Analyze (Insert_Node,
187 Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write));
191 ---------------------
192 -- Build_Full_Name --
193 ---------------------
195 procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is
197 procedure Build_Name (E : Entity_Id);
198 -- This is a recursive routine used to construct the fully qualified
199 -- string name of the package corresponding to the shared variable.
205 procedure Build_Name (E : Entity_Id) is
207 if Scope (E) /= Standard_Standard then
208 Build_Name (Scope (E));
209 Store_String_Char ('.');
212 Get_Decoded_Name_String (Chars (E));
213 Store_String_Chars (Name_Buffer (1 .. Name_Len));
216 -- Start of processing for Build_Full_Name
224 ------------------------------------
225 -- Expand_Shared_Passive_Variable --
226 ------------------------------------
228 procedure Expand_Shared_Passive_Variable (N : Node_Id) is
229 Typ : constant Entity_Id := Etype (N);
232 -- Nothing to do for protected or limited objects
234 if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then
237 -- If we are on the left hand side of an assignment, then we add
238 -- the write call after the assignment.
240 elsif On_Lhs_Of_Assignment (N) then
243 -- If we are a parameter for an out or in out formal, then put
244 -- the read before and the write after.
246 elsif Is_Out_Actual (N) then
250 -- All other cases are simple reads
255 end Expand_Shared_Passive_Variable;
261 function Is_Out_Actual (N : Node_Id) return Boolean is
266 Find_Actual (N, Formal, Call);
272 if Ekind (Formal) = E_Out_Parameter
274 Ekind (Formal) = E_In_Out_Parameter
284 ---------------------------
285 -- Make_Shared_Var_Procs --
286 ---------------------------
288 function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is
289 Loc : constant Source_Ptr := Sloc (N);
290 Ent : constant Entity_Id := Defining_Identifier (N);
291 Typ : constant Entity_Id := Etype (Ent);
294 After : constant Node_Id := Next (N);
295 -- Node located right after N originally (after insertion of the SV
296 -- procs this node is right after the last inserted node).
298 SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc,
299 Chars => New_External_Name (Chars (Ent), 'G'));
300 -- Instance of System.Shared_Storage.Shared_Var_Procs associated
303 Instantiation : Node_Id;
304 -- Package instantiation node for SVP_Instance
306 -- Start of processing for Make_Shared_Var_Procs
309 Build_Full_Name (Ent, Vnm);
311 -- We turn off Shared_Passive during construction and analysis of
312 -- the generic package instantiation, to avoid improper attempts to
313 -- process the variable references within these instantiation.
315 Set_Is_Shared_Passive (Ent, False);
317 -- Construct generic package instantiation
319 -- package varG is new Shared_Var_Procs (Typ, var, "pkg.var");
322 Make_Package_Instantiation (Loc,
323 Defining_Unit_Name => SVP_Instance,
325 New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc),
326 Generic_Associations => New_List (
327 Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter =>
328 New_Occurrence_Of (Typ, Loc)),
329 Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter =>
330 New_Occurrence_Of (Ent, Loc)),
331 Make_Generic_Association (Loc, Explicit_Generic_Actual_Parameter =>
332 Make_String_Literal (Loc, Vnm))));
334 Insert_After_And_Analyze (N, Instantiation);
336 Set_Is_Shared_Passive (Ent, True);
337 Set_Shared_Var_Procs_Instance
338 (Ent, Defining_Entity (Instance_Spec (Instantiation)));
340 -- Return last node before After
343 Nod : Node_Id := Next (N);
346 while Next (Nod) /= After loop
352 end Make_Shared_Var_Procs;
354 --------------------------
355 -- On_Lhs_Of_Assignment --
356 --------------------------
358 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is
359 P : constant Node_Id := Parent (N);
362 if Nkind (P) = N_Assignment_Statement then
370 elsif (Nkind (P) = N_Indexed_Component
372 Nkind (P) = N_Selected_Component)
373 and then N = Prefix (P)
375 return On_Lhs_Of_Assignment (P);
380 end On_Lhs_Of_Assignment;