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-2013, 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_Ch7; use Exp_Ch7; 29with Exp_Ch9; use Exp_Ch9; 30with Exp_Tss; use Exp_Tss; 31with Exp_Util; use Exp_Util; 32with Nmake; use Nmake; 33with Namet; use Namet; 34with Nlists; use Nlists; 35with Rtsfind; use Rtsfind; 36with Sem; use Sem; 37with Sem_Aux; use Sem_Aux; 38with Sem_Util; use Sem_Util; 39with Sinfo; use Sinfo; 40with Snames; use Snames; 41with Stand; use Stand; 42with Stringt; use Stringt; 43with Tbuild; use Tbuild; 44 45package body Exp_Smem is 46 47 Insert_Node : Node_Id; 48 -- Node after which a write call is to be inserted 49 50 ----------------------- 51 -- Local Subprograms -- 52 ----------------------- 53 54 procedure Add_Read (N : Node_Id; Call : Node_Id := Empty); 55 -- Insert a Shared_Var_ROpen call for variable before node N, unless 56 -- Call is a call to an init-proc, in which case the call is inserted 57 -- after Call. 58 59 procedure Add_Write_After (N : Node_Id); 60 -- Insert a Shared_Var_WOpen call for variable after the node Insert_Node, 61 -- as recorded by On_Lhs_Of_Assignment (where it points to the assignment 62 -- statement) or Is_Out_Actual (where it points to the subprogram call). 63 -- When Insert_Node is a function call, establish a transient scope around 64 -- the expression, and insert the write as an after-action of the transient 65 -- scope. 66 67 procedure Build_Full_Name (E : Entity_Id; N : out String_Id); 68 -- Build the fully qualified string name of a shared variable 69 70 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean; 71 -- Determines if N is on the left hand of the assignment. This means that 72 -- either it is a simple variable, or it is a record or array variable with 73 -- a corresponding selected or indexed component on the left side of an 74 -- assignment. If the result is True, then Insert_Node is set to point 75 -- to the assignment 76 77 function Is_Out_Actual (N : Node_Id) return Boolean; 78 -- In a similar manner, this function determines if N appears as an OUT 79 -- or IN OUT parameter to a procedure call. If the result is True, then 80 -- Insert_Node is set to point to the call. 81 82 function Build_Shared_Var_Proc_Call 83 (Loc : Source_Ptr; 84 E : Node_Id; 85 N : Name_Id) return Node_Id; 86 -- Build a call to support procedure N for shared object E (provided by the 87 -- instance of System.Shared_Storage.Shared_Var_Procs associated to E). 88 89 -------------------------------- 90 -- Build_Shared_Var_Proc_Call -- 91 -------------------------------- 92 93 function Build_Shared_Var_Proc_Call 94 (Loc : Source_Ptr; 95 E : Entity_Id; 96 N : Name_Id) return Node_Id 97 is 98 begin 99 return Make_Procedure_Call_Statement (Loc, 100 Name => Make_Selected_Component (Loc, 101 Prefix => 102 New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc), 103 Selector_Name => Make_Identifier (Loc, N))); 104 end Build_Shared_Var_Proc_Call; 105 106 -------------- 107 -- Add_Read -- 108 -------------- 109 110 procedure Add_Read (N : Node_Id; Call : Node_Id := Empty) is 111 Loc : constant Source_Ptr := Sloc (N); 112 Ent : constant Node_Id := Entity (N); 113 SVC : Node_Id; 114 115 begin 116 if Present (Shared_Var_Procs_Instance (Ent)) then 117 SVC := Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read); 118 119 if Present (Call) and then Is_Init_Proc (Name (Call)) then 120 Insert_After_And_Analyze (Call, SVC); 121 else 122 Insert_Action (N, SVC); 123 end if; 124 end if; 125 end Add_Read; 126 127 ------------------------------- 128 -- Add_Shared_Var_Lock_Procs -- 129 ------------------------------- 130 131 procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is 132 Loc : constant Source_Ptr := Sloc (N); 133 Obj : constant Entity_Id := Entity (Expression (First_Actual (N))); 134 Inode : Node_Id; 135 Vnm : String_Id; 136 137 begin 138 -- We have to add Shared_Var_Lock and Shared_Var_Unlock calls around 139 -- the procedure or function call node. First we locate the right place 140 -- to do the insertion, which is the call itself in the procedure call 141 -- case, or else the nearest non subexpression node that contains the 142 -- function call. 143 144 Inode := N; 145 while Nkind (Inode) /= N_Procedure_Call_Statement 146 and then Nkind (Inode) in N_Subexpr 147 loop 148 Inode := Parent (Inode); 149 end loop; 150 151 -- Now insert the Lock and Unlock calls and the read/write calls 152 153 -- Two concerns here. First we are not dealing with the exception case, 154 -- really we need some kind of cleanup routine to do the Unlock. Second, 155 -- these lock calls should be inside the protected object processing, 156 -- not outside, otherwise they can be done at the wrong priority, 157 -- resulting in dead lock situations ??? 158 159 Build_Full_Name (Obj, Vnm); 160 161 -- First insert the Lock call before 162 163 Insert_Before_And_Analyze (Inode, 164 Make_Procedure_Call_Statement (Loc, 165 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Lock), Loc), 166 Parameter_Associations => New_List ( 167 Make_String_Literal (Loc, Vnm)))); 168 169 -- Now, right after the Lock, insert a call to read the object 170 171 Insert_Before_And_Analyze (Inode, 172 Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read)); 173 174 -- Now insert the Unlock call after 175 176 Insert_After_And_Analyze (Inode, 177 Make_Procedure_Call_Statement (Loc, 178 Name => New_Occurrence_Of (RTE (RE_Shared_Var_Unlock), Loc), 179 Parameter_Associations => New_List ( 180 Make_String_Literal (Loc, Vnm)))); 181 182 -- Now for a procedure call, but not a function call, insert the 183 -- call to write the object just before the unlock. 184 185 if Nkind (N) = N_Procedure_Call_Statement then 186 Insert_After_And_Analyze (Inode, 187 Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write)); 188 end if; 189 end Add_Shared_Var_Lock_Procs; 190 191 --------------------- 192 -- Add_Write_After -- 193 --------------------- 194 195 procedure Add_Write_After (N : Node_Id) is 196 Loc : constant Source_Ptr := Sloc (N); 197 Ent : constant Entity_Id := Entity (N); 198 Par : constant Node_Id := Insert_Node; 199 begin 200 if Present (Shared_Var_Procs_Instance (Ent)) then 201 if Nkind (Insert_Node) = N_Function_Call then 202 Establish_Transient_Scope (Insert_Node, Sec_Stack => False); 203 Store_After_Actions_In_Scope (New_List ( 204 Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write))); 205 else 206 Insert_After_And_Analyze (Par, 207 Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write)); 208 end if; 209 end if; 210 end Add_Write_After; 211 212 --------------------- 213 -- Build_Full_Name -- 214 --------------------- 215 216 procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is 217 218 procedure Build_Name (E : Entity_Id); 219 -- This is a recursive routine used to construct the fully qualified 220 -- string name of the package corresponding to the shared variable. 221 222 ---------------- 223 -- Build_Name -- 224 ---------------- 225 226 procedure Build_Name (E : Entity_Id) is 227 begin 228 if Scope (E) /= Standard_Standard then 229 Build_Name (Scope (E)); 230 Store_String_Char ('.'); 231 end if; 232 233 Get_Decoded_Name_String (Chars (E)); 234 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 235 end Build_Name; 236 237 -- Start of processing for Build_Full_Name 238 239 begin 240 Start_String; 241 Build_Name (E); 242 N := End_String; 243 end Build_Full_Name; 244 245 ------------------------------------ 246 -- Expand_Shared_Passive_Variable -- 247 ------------------------------------ 248 249 procedure Expand_Shared_Passive_Variable (N : Node_Id) is 250 Typ : constant Entity_Id := Etype (N); 251 252 begin 253 -- Nothing to do for protected or limited objects 254 255 if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then 256 return; 257 258 -- If we are on the left hand side of an assignment, then we add the 259 -- write call after the assignment. 260 261 elsif On_Lhs_Of_Assignment (N) then 262 Add_Write_After (N); 263 264 -- If we are a parameter for an out or in out formal, then in general 265 -- we do: 266 267 -- read 268 -- call 269 -- write 270 271 -- but in the special case of a call to an init proc, we need to first 272 -- call the init proc (to set discriminants), then read (to possibly 273 -- set other components), then write (to record the updated components 274 -- to the backing store): 275 276 -- init-proc-call 277 -- read 278 -- write 279 280 elsif Is_Out_Actual (N) then 281 282 -- Note: For an init proc call, Add_Read inserts just after the 283 -- call node, and we want to have first the read, then the write, 284 -- so we need to first Add_Write_After, then Add_Read. 285 286 Add_Write_After (N); 287 Add_Read (N, Call => Insert_Node); 288 289 -- All other cases are simple reads 290 291 else 292 Add_Read (N); 293 end if; 294 end Expand_Shared_Passive_Variable; 295 296 ------------------- 297 -- Is_Out_Actual -- 298 ------------------- 299 300 function Is_Out_Actual (N : Node_Id) return Boolean is 301 Formal : Entity_Id; 302 Call : Node_Id; 303 304 begin 305 Find_Actual (N, Formal, Call); 306 307 if No (Formal) then 308 return False; 309 310 else 311 if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then 312 Insert_Node := Call; 313 return True; 314 else 315 return False; 316 end if; 317 end if; 318 end Is_Out_Actual; 319 320 --------------------------- 321 -- Make_Shared_Var_Procs -- 322 --------------------------- 323 324 function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is 325 Loc : constant Source_Ptr := Sloc (N); 326 Ent : constant Entity_Id := Defining_Identifier (N); 327 Typ : constant Entity_Id := Etype (Ent); 328 Vnm : String_Id; 329 Obj : Node_Id; 330 Obj_Typ : Entity_Id; 331 332 After : constant Node_Id := Next (N); 333 -- Node located right after N originally (after insertion of the SV 334 -- procs this node is right after the last inserted node). 335 336 SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc, 337 Chars => New_External_Name (Chars (Ent), 'G')); 338 -- Instance of Shared_Storage.Shared_Var_Procs associated with Ent 339 340 Instantiation : Node_Id; 341 -- Package instantiation node for SVP_Instance 342 343 -- Start of processing for Make_Shared_Var_Procs 344 345 begin 346 Build_Full_Name (Ent, Vnm); 347 348 -- We turn off Shared_Passive during construction and analysis of the 349 -- generic package instantiation, to avoid improper attempts to process 350 -- the variable references within these instantiation. 351 352 Set_Is_Shared_Passive (Ent, False); 353 354 -- Construct generic package instantiation 355 356 -- package varG is new Shared_Var_Procs (typ, var, "pkg.var"); 357 358 Obj := New_Occurrence_Of (Ent, Loc); 359 Obj_Typ := Typ; 360 if Is_Concurrent_Type (Typ) then 361 Obj := Convert_Concurrent (N => Obj, Typ => Typ); 362 Obj_Typ := Corresponding_Record_Type (Typ); 363 end if; 364 365 Instantiation := 366 Make_Package_Instantiation (Loc, 367 Defining_Unit_Name => SVP_Instance, 368 Name => 369 New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc), 370 Generic_Associations => New_List ( 371 Make_Generic_Association (Loc, 372 Explicit_Generic_Actual_Parameter => 373 New_Occurrence_Of (Obj_Typ, Loc)), 374 Make_Generic_Association (Loc, 375 Explicit_Generic_Actual_Parameter => Obj), 376 Make_Generic_Association (Loc, 377 Explicit_Generic_Actual_Parameter => 378 Make_String_Literal (Loc, Vnm)))); 379 380 Insert_After_And_Analyze (N, Instantiation); 381 382 Set_Is_Shared_Passive (Ent, True); 383 Set_Shared_Var_Procs_Instance 384 (Ent, Defining_Entity (Instance_Spec (Instantiation))); 385 386 -- Return last node before After 387 388 declare 389 Nod : Node_Id := Next (N); 390 391 begin 392 while Next (Nod) /= After loop 393 Nod := Next (Nod); 394 end loop; 395 396 return Nod; 397 end; 398 end Make_Shared_Var_Procs; 399 400 -------------------------- 401 -- On_Lhs_Of_Assignment -- 402 -------------------------- 403 404 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is 405 P : constant Node_Id := Parent (N); 406 407 begin 408 if Nkind (P) = N_Assignment_Statement then 409 if N = Name (P) then 410 Insert_Node := P; 411 return True; 412 else 413 return False; 414 end if; 415 416 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component) 417 and then N = Prefix (P) 418 then 419 return On_Lhs_Of_Assignment (P); 420 421 else 422 return False; 423 end if; 424 end On_Lhs_Of_Assignment; 425 426end Exp_Smem; 427