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_Ch9; use Exp_Ch9;
29 with Exp_Util; use Exp_Util;
30 with Nmake; use Nmake;
31 with Namet; use Namet;
32 with Nlists; use Nlists;
33 with Rtsfind; use Rtsfind;
35 with Sem_Aux; use Sem_Aux;
36 with Sem_Util; use Sem_Util;
37 with Sinfo; use Sinfo;
38 with Snames; use Snames;
39 with Stand; use Stand;
40 with Stringt; use Stringt;
41 with Tbuild; use Tbuild;
43 package body Exp_Smem is
45 Insert_Node : Node_Id;
46 -- Node after which a write call is to be inserted
48 -----------------------
49 -- Local Subprograms --
50 -----------------------
52 procedure Add_Read_Before (N : Node_Id);
53 -- Insert a Shared_Var_ROpen call for variable before node N
55 procedure Add_Write_After (N : Node_Id);
56 -- Insert a Shared_Var_WOpen call for variable after the node
57 -- Insert_Node, as recorded by On_Lhs_Of_Assignment (where it points
58 -- to the assignment statement) or Is_Out_Actual (where it points to
59 -- the procedure call statement).
61 procedure Build_Full_Name (E : Entity_Id; N : out String_Id);
62 -- Build the fully qualified string name of a shared variable
64 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean;
65 -- Determines if N is on the left hand of the assignment. This means
66 -- that either it is a simple variable, or it is a record or array
67 -- variable with a corresponding selected or indexed component on
68 -- the left side of an assignment. If the result is True, then
69 -- Insert_Node is set to point to the assignment
71 function Is_Out_Actual (N : Node_Id) return Boolean;
72 -- In a similar manner, this function determines if N appears as an
73 -- OUT or IN OUT parameter to a procedure call. If the result is
74 -- True, then Insert_Node is set to point to the call.
76 function Build_Shared_Var_Proc_Call
79 N : Name_Id) return Node_Id;
80 -- Build a call to support procedure N for shared object E (provided by
81 -- the instance of System.Shared_Storage.Shared_Var_Procs associated to E).
83 --------------------------------
84 -- Build_Shared_Var_Proc_Call --
85 --------------------------------
87 function Build_Shared_Var_Proc_Call
90 N : Name_Id) return Node_Id is
92 return Make_Procedure_Call_Statement (Loc,
93 Name => Make_Selected_Component (Loc,
95 New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc),
96 Selector_Name => Make_Identifier (Loc, Chars => N)));
97 end Build_Shared_Var_Proc_Call;
100 -- Add_Read_Before --
101 ---------------------
103 procedure Add_Read_Before (N : Node_Id) is
104 Loc : constant Source_Ptr := Sloc (N);
105 Ent : constant Node_Id := Entity (N);
107 if Present (Shared_Var_Procs_Instance (Ent)) then
108 Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read));
112 -------------------------------
113 -- Add_Shared_Var_Lock_Procs --
114 -------------------------------
116 procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is
117 Loc : constant Source_Ptr := Sloc (N);
118 Obj : constant Entity_Id := Entity (Expression (First_Actual (N)));
123 -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around
124 -- the procedure or function call node. First we locate the right
125 -- place to do the insertion, which is the call itself in the
126 -- procedure call case, or else the nearest non subexpression
127 -- node that contains the function call.
130 while Nkind (Inode) /= N_Procedure_Call_Statement
131 and then Nkind (Inode) in N_Subexpr
133 Inode := Parent (Inode);
136 -- Now insert the Lock and Unlock calls and the read/write calls
138 -- Two concerns here. First we are not dealing with the exception
139 -- case, really we need some kind of cleanup routine to do the
140 -- Unlock. Second, these lock calls should be inside the protected
141 -- object processing, not outside, otherwise they can be done at
142 -- the wrong priority, resulting in dead lock situations ???
144 Build_Full_Name (Obj, Vnm);
146 -- First insert the Lock call before
148 Insert_Before_And_Analyze (Inode,
149 Make_Procedure_Call_Statement (Loc,
150 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc),
151 Parameter_Associations => New_List (
152 Make_String_Literal (Loc, Vnm))));
154 -- Now, right after the Lock, insert a call to read the object
156 Insert_Before_And_Analyze (Inode,
157 Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read));
159 -- Now insert the Unlock call after
161 Insert_After_And_Analyze (Inode,
162 Make_Procedure_Call_Statement (Loc,
163 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc),
164 Parameter_Associations => New_List (
165 Make_String_Literal (Loc, Vnm))));
167 -- Now for a procedure call, but not a function call, insert the
168 -- call to write the object just before the unlock.
170 if Nkind (N) = N_Procedure_Call_Statement then
171 Insert_After_And_Analyze (Inode,
172 Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write));
175 end Add_Shared_Var_Lock_Procs;
177 ---------------------
178 -- Add_Write_After --
179 ---------------------
181 procedure Add_Write_After (N : Node_Id) is
182 Loc : constant Source_Ptr := Sloc (N);
183 Ent : constant Node_Id := Entity (N);
186 if Present (Shared_Var_Procs_Instance (Ent)) then
187 Insert_After_And_Analyze (Insert_Node,
188 Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write));
192 ---------------------
193 -- Build_Full_Name --
194 ---------------------
196 procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is
198 procedure Build_Name (E : Entity_Id);
199 -- This is a recursive routine used to construct the fully qualified
200 -- string name of the package corresponding to the shared variable.
206 procedure Build_Name (E : Entity_Id) is
208 if Scope (E) /= Standard_Standard then
209 Build_Name (Scope (E));
210 Store_String_Char ('.');
213 Get_Decoded_Name_String (Chars (E));
214 Store_String_Chars (Name_Buffer (1 .. Name_Len));
217 -- Start of processing for Build_Full_Name
225 ------------------------------------
226 -- Expand_Shared_Passive_Variable --
227 ------------------------------------
229 procedure Expand_Shared_Passive_Variable (N : Node_Id) is
230 Typ : constant Entity_Id := Etype (N);
233 -- Nothing to do for protected or limited objects
235 if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then
238 -- If we are on the left hand side of an assignment, then we add
239 -- the write call after the assignment.
241 elsif On_Lhs_Of_Assignment (N) then
244 -- If we are a parameter for an out or in out formal, then put
245 -- the read before and the write after.
247 elsif Is_Out_Actual (N) then
251 -- All other cases are simple reads
256 end Expand_Shared_Passive_Variable;
262 function Is_Out_Actual (N : Node_Id) return Boolean is
267 Find_Actual (N, Formal, Call);
273 if Ekind (Formal) = E_Out_Parameter
275 Ekind (Formal) = E_In_Out_Parameter
285 ---------------------------
286 -- Make_Shared_Var_Procs --
287 ---------------------------
289 function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is
290 Loc : constant Source_Ptr := Sloc (N);
291 Ent : constant Entity_Id := Defining_Identifier (N);
292 Typ : constant Entity_Id := Etype (Ent);
297 After : constant Node_Id := Next (N);
298 -- Node located right after N originally (after insertion of the SV
299 -- procs this node is right after the last inserted node).
301 SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc,
302 Chars => New_External_Name (Chars (Ent), 'G'));
303 -- Instance of System.Shared_Storage.Shared_Var_Procs associated
306 Instantiation : Node_Id;
307 -- Package instantiation node for SVP_Instance
309 -- Start of processing for Make_Shared_Var_Procs
312 Build_Full_Name (Ent, Vnm);
314 -- We turn off Shared_Passive during construction and analysis of
315 -- the generic package instantiation, to avoid improper attempts to
316 -- process the variable references within these instantiation.
318 Set_Is_Shared_Passive (Ent, False);
320 -- Construct generic package instantiation
322 -- package varG is new Shared_Var_Procs (typ, var, "pkg.var");
324 Obj := New_Occurrence_Of (Ent, Loc);
326 if Is_Concurrent_Type (Typ) then
327 Obj := Convert_Concurrent (N => Obj, Typ => Typ);
328 Obj_Typ := Corresponding_Record_Type (Typ);
332 Make_Package_Instantiation (Loc,
333 Defining_Unit_Name => SVP_Instance,
335 New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc),
336 Generic_Associations => New_List (
337 Make_Generic_Association (Loc,
338 Explicit_Generic_Actual_Parameter =>
339 New_Occurrence_Of (Obj_Typ, Loc)),
340 Make_Generic_Association (Loc,
341 Explicit_Generic_Actual_Parameter => Obj),
342 Make_Generic_Association (Loc,
343 Explicit_Generic_Actual_Parameter =>
344 Make_String_Literal (Loc, Vnm))));
346 Insert_After_And_Analyze (N, Instantiation);
348 Set_Is_Shared_Passive (Ent, True);
349 Set_Shared_Var_Procs_Instance
350 (Ent, Defining_Entity (Instance_Spec (Instantiation)));
352 -- Return last node before After
355 Nod : Node_Id := Next (N);
358 while Next (Nod) /= After loop
364 end Make_Shared_Var_Procs;
366 --------------------------
367 -- On_Lhs_Of_Assignment --
368 --------------------------
370 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is
371 P : constant Node_Id := Parent (N);
374 if Nkind (P) = N_Assignment_Statement then
382 elsif (Nkind (P) = N_Indexed_Component
384 Nkind (P) = N_Selected_Component)
385 and then N = Prefix (P)
387 return On_Lhs_Of_Assignment (P);
392 end On_Lhs_Of_Assignment;