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-2010, 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_Ch9; use Exp_Ch9; 29with Exp_Util; use Exp_Util; 30with Nmake; use Nmake; 31with Namet; use Namet; 32with Nlists; use Nlists; 33with Rtsfind; use Rtsfind; 34with Sem; use Sem; 35with Sem_Aux; use Sem_Aux; 36with Sem_Util; use Sem_Util; 37with Sinfo; use Sinfo; 38with Snames; use Snames; 39with Stand; use Stand; 40with Stringt; use Stringt; 41with Tbuild; use Tbuild; 42 43package body Exp_Smem is 44 45 Insert_Node : Node_Id; 46 -- Node after which a write call is to be inserted 47 48 ----------------------- 49 -- Local Subprograms -- 50 ----------------------- 51 52 procedure Add_Read_Before (N : Node_Id); 53 -- Insert a Shared_Var_ROpen call for variable before node N 54 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). 60 61 procedure Build_Full_Name (E : Entity_Id; N : out String_Id); 62 -- Build the fully qualified string name of a shared variable 63 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 70 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. 75 76 function Build_Shared_Var_Proc_Call 77 (Loc : Source_Ptr; 78 E : Node_Id; 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). 82 83 -------------------------------- 84 -- Build_Shared_Var_Proc_Call -- 85 -------------------------------- 86 87 function Build_Shared_Var_Proc_Call 88 (Loc : Source_Ptr; 89 E : Entity_Id; 90 N : Name_Id) return Node_Id is 91 begin 92 return Make_Procedure_Call_Statement (Loc, 93 Name => Make_Selected_Component (Loc, 94 Prefix => 95 New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc), 96 Selector_Name => Make_Identifier (Loc, N))); 97 end Build_Shared_Var_Proc_Call; 98 99 --------------------- 100 -- Add_Read_Before -- 101 --------------------- 102 103 procedure Add_Read_Before (N : Node_Id) is 104 Loc : constant Source_Ptr := Sloc (N); 105 Ent : constant Node_Id := Entity (N); 106 begin 107 if Present (Shared_Var_Procs_Instance (Ent)) then 108 Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read)); 109 end if; 110 end Add_Read_Before; 111 112 ------------------------------- 113 -- Add_Shared_Var_Lock_Procs -- 114 ------------------------------- 115 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))); 119 Inode : Node_Id; 120 Vnm : String_Id; 121 122 begin 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. 128 129 Inode := N; 130 while Nkind (Inode) /= N_Procedure_Call_Statement 131 and then Nkind (Inode) in N_Subexpr 132 loop 133 Inode := Parent (Inode); 134 end loop; 135 136 -- Now insert the Lock and Unlock calls and the read/write calls 137 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 ??? 143 144 Build_Full_Name (Obj, Vnm); 145 146 -- First insert the Lock call before 147 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)))); 153 154 -- Now, right after the Lock, insert a call to read the object 155 156 Insert_Before_And_Analyze (Inode, 157 Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read)); 158 159 -- Now insert the Unlock call after 160 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)))); 166 167 -- Now for a procedure call, but not a function call, insert the 168 -- call to write the object just before the unlock. 169 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)); 173 end if; 174 175 end Add_Shared_Var_Lock_Procs; 176 177 --------------------- 178 -- Add_Write_After -- 179 --------------------- 180 181 procedure Add_Write_After (N : Node_Id) is 182 Loc : constant Source_Ptr := Sloc (N); 183 Ent : constant Node_Id := Entity (N); 184 185 begin 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)); 189 end if; 190 end Add_Write_After; 191 192 --------------------- 193 -- Build_Full_Name -- 194 --------------------- 195 196 procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is 197 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. 201 202 ---------------- 203 -- Build_Name -- 204 ---------------- 205 206 procedure Build_Name (E : Entity_Id) is 207 begin 208 if Scope (E) /= Standard_Standard then 209 Build_Name (Scope (E)); 210 Store_String_Char ('.'); 211 end if; 212 213 Get_Decoded_Name_String (Chars (E)); 214 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 215 end Build_Name; 216 217 -- Start of processing for Build_Full_Name 218 219 begin 220 Start_String; 221 Build_Name (E); 222 N := End_String; 223 end Build_Full_Name; 224 225 ------------------------------------ 226 -- Expand_Shared_Passive_Variable -- 227 ------------------------------------ 228 229 procedure Expand_Shared_Passive_Variable (N : Node_Id) is 230 Typ : constant Entity_Id := Etype (N); 231 232 begin 233 -- Nothing to do for protected or limited objects 234 235 if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then 236 return; 237 238 -- If we are on the left hand side of an assignment, then we add 239 -- the write call after the assignment. 240 241 elsif On_Lhs_Of_Assignment (N) then 242 Add_Write_After (N); 243 244 -- If we are a parameter for an out or in out formal, then put 245 -- the read before and the write after. 246 247 elsif Is_Out_Actual (N) then 248 Add_Read_Before (N); 249 Add_Write_After (N); 250 251 -- All other cases are simple reads 252 253 else 254 Add_Read_Before (N); 255 end if; 256 end Expand_Shared_Passive_Variable; 257 258 ------------------- 259 -- Is_Out_Actual -- 260 ------------------- 261 262 function Is_Out_Actual (N : Node_Id) return Boolean is 263 Formal : Entity_Id; 264 Call : Node_Id; 265 266 begin 267 Find_Actual (N, Formal, Call); 268 269 if No (Formal) then 270 return False; 271 272 else 273 if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then 274 Insert_Node := Call; 275 return True; 276 else 277 return False; 278 end if; 279 end if; 280 end Is_Out_Actual; 281 282 --------------------------- 283 -- Make_Shared_Var_Procs -- 284 --------------------------- 285 286 function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is 287 Loc : constant Source_Ptr := Sloc (N); 288 Ent : constant Entity_Id := Defining_Identifier (N); 289 Typ : constant Entity_Id := Etype (Ent); 290 Vnm : String_Id; 291 Obj : Node_Id; 292 Obj_Typ : Entity_Id; 293 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). 297 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 301 -- with Ent. 302 303 Instantiation : Node_Id; 304 -- Package instantiation node for SVP_Instance 305 306 -- Start of processing for Make_Shared_Var_Procs 307 308 begin 309 Build_Full_Name (Ent, Vnm); 310 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. 314 315 Set_Is_Shared_Passive (Ent, False); 316 317 -- Construct generic package instantiation 318 319 -- package varG is new Shared_Var_Procs (typ, var, "pkg.var"); 320 321 Obj := New_Occurrence_Of (Ent, Loc); 322 Obj_Typ := Typ; 323 if Is_Concurrent_Type (Typ) then 324 Obj := Convert_Concurrent (N => Obj, Typ => Typ); 325 Obj_Typ := Corresponding_Record_Type (Typ); 326 end if; 327 328 Instantiation := 329 Make_Package_Instantiation (Loc, 330 Defining_Unit_Name => SVP_Instance, 331 Name => 332 New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc), 333 Generic_Associations => New_List ( 334 Make_Generic_Association (Loc, 335 Explicit_Generic_Actual_Parameter => 336 New_Occurrence_Of (Obj_Typ, Loc)), 337 Make_Generic_Association (Loc, 338 Explicit_Generic_Actual_Parameter => Obj), 339 Make_Generic_Association (Loc, 340 Explicit_Generic_Actual_Parameter => 341 Make_String_Literal (Loc, Vnm)))); 342 343 Insert_After_And_Analyze (N, Instantiation); 344 345 Set_Is_Shared_Passive (Ent, True); 346 Set_Shared_Var_Procs_Instance 347 (Ent, Defining_Entity (Instance_Spec (Instantiation))); 348 349 -- Return last node before After 350 351 declare 352 Nod : Node_Id := Next (N); 353 354 begin 355 while Next (Nod) /= After loop 356 Nod := Next (Nod); 357 end loop; 358 359 return Nod; 360 end; 361 end Make_Shared_Var_Procs; 362 363 -------------------------- 364 -- On_Lhs_Of_Assignment -- 365 -------------------------- 366 367 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is 368 P : constant Node_Id := Parent (N); 369 370 begin 371 if Nkind (P) = N_Assignment_Statement then 372 if N = Name (P) then 373 Insert_Node := P; 374 return True; 375 else 376 return False; 377 end if; 378 379 elsif (Nkind (P) = N_Indexed_Component 380 or else 381 Nkind (P) = N_Selected_Component) 382 and then N = Prefix (P) 383 then 384 return On_Lhs_Of_Assignment (P); 385 386 else 387 return False; 388 end if; 389 end On_Lhs_Of_Assignment; 390 391end Exp_Smem; 392