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-2019, 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 Elists; use Elists; 29with Exp_Ch7; use Exp_Ch7; 30with Exp_Ch9; use Exp_Ch9; 31with Exp_Tss; use Exp_Tss; 32with Exp_Util; use Exp_Util; 33with Nmake; use Nmake; 34with Namet; use Namet; 35with Nlists; use Nlists; 36with Rtsfind; use Rtsfind; 37with Sem; use Sem; 38with Sem_Aux; use Sem_Aux; 39with Sem_Util; use Sem_Util; 40with Sinfo; use Sinfo; 41with Snames; use Snames; 42with Stand; use Stand; 43with Stringt; use Stringt; 44with Tbuild; use Tbuild; 45 46package body Exp_Smem is 47 48 Insert_Node : Node_Id; 49 -- Node after which a write call is to be inserted 50 51 ----------------------- 52 -- Local Subprograms -- 53 ----------------------- 54 55 procedure Add_Read (N : Node_Id; Call : Node_Id := Empty); 56 -- Insert a Shared_Var_ROpen call for variable before node N, unless 57 -- Call is a call to an init-proc, in which case the call is inserted 58 -- after Call. 59 60 procedure Add_Write_After (N : Node_Id); 61 -- Insert a Shared_Var_WOpen call for variable after the node Insert_Node, 62 -- as recorded by On_Lhs_Of_Assignment (where it points to the assignment 63 -- statement) or Is_Out_Actual (where it points to the subprogram call). 64 -- When Insert_Node is a function call, establish a transient scope around 65 -- the expression, and insert the write as an after-action of the transient 66 -- scope. 67 68 procedure Build_Full_Name (E : Entity_Id; N : out String_Id); 69 -- Build the fully qualified string name of a shared variable 70 71 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean; 72 -- Determines if N is on the left hand of the assignment. This means that 73 -- either it is a simple variable, or it is a record or array variable with 74 -- a corresponding selected or indexed component on the left side of an 75 -- assignment. If the result is True, then Insert_Node is set to point 76 -- to the assignment 77 78 function Is_Out_Actual (N : Node_Id) return Boolean; 79 -- In a similar manner, this function determines if N appears as an OUT 80 -- or IN OUT parameter to a procedure call. If the result is True, then 81 -- Insert_Node is set to point to the call. 82 83 function Build_Shared_Var_Proc_Call 84 (Loc : Source_Ptr; 85 E : Node_Id; 86 N : Name_Id) return Node_Id; 87 -- Build a call to support procedure N for shared object E (provided by the 88 -- instance of System.Shared_Storage.Shared_Var_Procs associated to E). 89 90 -------------------------------- 91 -- Build_Shared_Var_Proc_Call -- 92 -------------------------------- 93 94 function Build_Shared_Var_Proc_Call 95 (Loc : Source_Ptr; 96 E : Entity_Id; 97 N : Name_Id) return Node_Id 98 is 99 begin 100 return Make_Procedure_Call_Statement (Loc, 101 Name => Make_Selected_Component (Loc, 102 Prefix => 103 New_Occurrence_Of (Shared_Var_Procs_Instance (E), Loc), 104 Selector_Name => Make_Identifier (Loc, N))); 105 end Build_Shared_Var_Proc_Call; 106 107 -------------- 108 -- Add_Read -- 109 -------------- 110 111 procedure Add_Read (N : Node_Id; Call : Node_Id := Empty) is 112 Loc : constant Source_Ptr := Sloc (N); 113 Ent : constant Node_Id := Entity (N); 114 SVC : Node_Id; 115 116 begin 117 if Present (Shared_Var_Procs_Instance (Ent)) then 118 SVC := Build_Shared_Var_Proc_Call (Loc, Ent, Name_Read); 119 120 if Present (Call) and then Is_Init_Proc (Name (Call)) then 121 Insert_After_And_Analyze (Call, SVC); 122 else 123 Insert_Action (N, SVC); 124 end if; 125 end if; 126 end Add_Read; 127 128 ------------------------------- 129 -- Add_Shared_Var_Lock_Procs -- 130 ------------------------------- 131 132 procedure Add_Shared_Var_Lock_Procs (N : Node_Id) is 133 Loc : constant Source_Ptr := Sloc (N); 134 Obj : constant Entity_Id := Entity (Expression (First_Actual (N))); 135 Vnm : String_Id; 136 Vid : Entity_Id; 137 Vde : Node_Id; 138 Aft : constant List_Id := New_List; 139 140 In_Transient : constant Boolean := Scope_Is_Transient; 141 142 function Build_Shared_Var_Lock_Call (RE : RE_Id) return Node_Id; 143 -- Return a procedure call statement for lock proc RTE 144 145 -------------------------------- 146 -- Build_Shared_Var_Lock_Call -- 147 -------------------------------- 148 149 function Build_Shared_Var_Lock_Call (RE : RE_Id) return Node_Id is 150 begin 151 return 152 Make_Procedure_Call_Statement (Loc, 153 Name => 154 New_Occurrence_Of (RTE (RE), Loc), 155 Parameter_Associations => 156 New_List (New_Occurrence_Of (Vid, Loc))); 157 end Build_Shared_Var_Lock_Call; 158 159 -- Start of processing for Add_Shared_Var_Lock_Procs 160 161 begin 162 -- Discussion of transient scopes: we need to have a transient scope 163 -- to hold the required lock/unlock actions. Either the current scope 164 -- is transient, in which case we reuse it, or we establish a new 165 -- transient scope. If this is a function call with unconstrained 166 -- return type, we can't introduce a transient scope here (because 167 -- Wrap_Transient_Expression would need to declare a temporary with 168 -- the unconstrained type outside of the transient block), but in that 169 -- case we know that we have already established one at an outer level 170 -- for secondary stack management purposes. 171 172 -- If the lock/read/write/unlock actions for this object have already 173 -- been emitted in the current scope, no need to perform them anew. 174 175 if In_Transient 176 and then Contains (Scope_Stack.Table (Scope_Stack.Last) 177 .Locked_Shared_Objects, 178 Obj) 179 then 180 return; 181 end if; 182 183 Build_Full_Name (Obj, Vnm); 184 185 -- Declare a constant string to hold the name of the shared object. 186 -- Note that this must occur outside of the transient scope, as the 187 -- scope's finalizer needs to have access to this object. Also, it 188 -- appears that GIGI does not support elaborating string literal 189 -- subtypes in transient scopes. 190 191 Vid := Make_Temporary (Loc, 'N', Obj); 192 Vde := 193 Make_Object_Declaration (Loc, 194 Defining_Identifier => Vid, 195 Constant_Present => True, 196 Object_Definition => New_Occurrence_Of (Standard_String, Loc), 197 Expression => Make_String_Literal (Loc, Vnm)); 198 199 -- Already in a transient scope. Make sure that we insert Vde outside 200 -- that scope. 201 202 if In_Transient then 203 Insert_Before_And_Analyze (Node_To_Be_Wrapped, Vde); 204 205 -- Not in a transient scope yet: insert Vde as an action on N prior to 206 -- establishing one. 207 208 else 209 Insert_Action (N, Vde); 210 Establish_Transient_Scope (N, Manage_Sec_Stack => False); 211 end if; 212 213 -- Mark object as locked in the current (transient) scope 214 215 Append_New_Elmt 216 (Obj, 217 To => Scope_Stack.Table (Scope_Stack.Last).Locked_Shared_Objects); 218 219 -- First insert the Lock call before 220 221 Insert_Action (N, Build_Shared_Var_Lock_Call (RE_Shared_Var_Lock)); 222 223 -- Now, right after the Lock, insert a call to read the object 224 225 Insert_Action (N, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Read)); 226 227 -- For a procedure call only, insert the call to write the object prior 228 -- to unlocking. 229 230 if Nkind (N) = N_Procedure_Call_Statement then 231 Append_To (Aft, Build_Shared_Var_Proc_Call (Loc, Obj, Name_Write)); 232 end if; 233 234 -- Finally insert the Unlock call 235 236 Append_To (Aft, Build_Shared_Var_Lock_Call (RE_Shared_Var_Unlock)); 237 238 -- Store cleanup actions in transient scope 239 240 Store_Cleanup_Actions_In_Scope (Aft); 241 242 -- If we have established a transient scope here, wrap it now 243 244 if not In_Transient then 245 if Nkind (N) = N_Procedure_Call_Statement then 246 Wrap_Transient_Statement (N); 247 else 248 Wrap_Transient_Expression (N); 249 end if; 250 end if; 251 end Add_Shared_Var_Lock_Procs; 252 253 --------------------- 254 -- Add_Write_After -- 255 --------------------- 256 257 procedure Add_Write_After (N : Node_Id) is 258 Ent : constant Entity_Id := Entity (N); 259 Loc : constant Source_Ptr := Sloc (N); 260 Par : constant Node_Id := Insert_Node; 261 262 begin 263 if Present (Shared_Var_Procs_Instance (Ent)) then 264 if Nkind (Insert_Node) = N_Function_Call then 265 Establish_Transient_Scope (Insert_Node, Manage_Sec_Stack => False); 266 267 Store_After_Actions_In_Scope (New_List ( 268 Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write))); 269 else 270 Insert_After_And_Analyze (Par, 271 Build_Shared_Var_Proc_Call (Loc, Ent, Name_Write)); 272 end if; 273 end if; 274 end Add_Write_After; 275 276 --------------------- 277 -- Build_Full_Name -- 278 --------------------- 279 280 procedure Build_Full_Name (E : Entity_Id; N : out String_Id) is 281 282 procedure Build_Name (E : Entity_Id); 283 -- This is a recursive routine used to construct the fully qualified 284 -- string name of the package corresponding to the shared variable. 285 286 ---------------- 287 -- Build_Name -- 288 ---------------- 289 290 procedure Build_Name (E : Entity_Id) is 291 begin 292 if Scope (E) /= Standard_Standard then 293 Build_Name (Scope (E)); 294 Store_String_Char ('.'); 295 end if; 296 297 Get_Decoded_Name_String (Chars (E)); 298 Store_String_Chars (Name_Buffer (1 .. Name_Len)); 299 end Build_Name; 300 301 -- Start of processing for Build_Full_Name 302 303 begin 304 Start_String; 305 Build_Name (E); 306 N := End_String; 307 end Build_Full_Name; 308 309 ------------------------------------ 310 -- Expand_Shared_Passive_Variable -- 311 ------------------------------------ 312 313 procedure Expand_Shared_Passive_Variable (N : Node_Id) is 314 Typ : constant Entity_Id := Etype (N); 315 316 begin 317 -- Nothing to do for protected or limited objects 318 319 if Is_Limited_Type (Typ) or else Is_Concurrent_Type (Typ) then 320 return; 321 322 -- If we are on the left hand side of an assignment, then we add the 323 -- write call after the assignment. 324 325 elsif On_Lhs_Of_Assignment (N) then 326 Add_Write_After (N); 327 328 -- If we are a parameter for an out or in out formal, then in general 329 -- we do: 330 331 -- read 332 -- call 333 -- write 334 335 -- but in the special case of a call to an init proc, we need to first 336 -- call the init proc (to set discriminants), then read (to possibly 337 -- set other components), then write (to record the updated components 338 -- to the backing store): 339 340 -- init-proc-call 341 -- read 342 -- write 343 344 elsif Is_Out_Actual (N) then 345 346 -- Note: For an init proc call, Add_Read inserts just after the 347 -- call node, and we want to have first the read, then the write, 348 -- so we need to first Add_Write_After, then Add_Read. 349 350 Add_Write_After (N); 351 Add_Read (N, Call => Insert_Node); 352 353 -- All other cases are simple reads 354 355 else 356 Add_Read (N); 357 end if; 358 end Expand_Shared_Passive_Variable; 359 360 ------------------- 361 -- Is_Out_Actual -- 362 ------------------- 363 364 function Is_Out_Actual (N : Node_Id) return Boolean is 365 Formal : Entity_Id; 366 Call : Node_Id; 367 368 begin 369 Find_Actual (N, Formal, Call); 370 371 if No (Formal) then 372 return False; 373 374 else 375 if Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) then 376 Insert_Node := Call; 377 return True; 378 else 379 return False; 380 end if; 381 end if; 382 end Is_Out_Actual; 383 384 --------------------------- 385 -- Make_Shared_Var_Procs -- 386 --------------------------- 387 388 function Make_Shared_Var_Procs (N : Node_Id) return Node_Id is 389 Loc : constant Source_Ptr := Sloc (N); 390 Ent : constant Entity_Id := Defining_Identifier (N); 391 Typ : constant Entity_Id := Etype (Ent); 392 Vnm : String_Id; 393 Obj : Node_Id; 394 Obj_Typ : Entity_Id; 395 396 After : constant Node_Id := Next (N); 397 -- Node located right after N originally (after insertion of the SV 398 -- procs this node is right after the last inserted node). 399 400 SVP_Instance : constant Entity_Id := Make_Defining_Identifier (Loc, 401 Chars => New_External_Name (Chars (Ent), 'G')); 402 -- Instance of Shared_Storage.Shared_Var_Procs associated with Ent 403 404 Instantiation : Node_Id; 405 -- Package instantiation node for SVP_Instance 406 407 -- Start of processing for Make_Shared_Var_Procs 408 409 begin 410 Build_Full_Name (Ent, Vnm); 411 412 -- We turn off Shared_Passive during construction and analysis of the 413 -- generic package instantiation, to avoid improper attempts to process 414 -- the variable references within these instantiation. 415 416 Set_Is_Shared_Passive (Ent, False); 417 418 -- Construct generic package instantiation 419 420 -- package varG is new Shared_Var_Procs (typ, var, "pkg.var"); 421 422 Obj := New_Occurrence_Of (Ent, Loc); 423 Obj_Typ := Typ; 424 if Is_Concurrent_Type (Typ) then 425 Obj := Convert_Concurrent (N => Obj, Typ => Typ); 426 Obj_Typ := Corresponding_Record_Type (Typ); 427 end if; 428 429 Instantiation := 430 Make_Package_Instantiation (Loc, 431 Defining_Unit_Name => SVP_Instance, 432 Name => 433 New_Occurrence_Of (RTE (RE_Shared_Var_Procs), Loc), 434 Generic_Associations => New_List ( 435 Make_Generic_Association (Loc, 436 Explicit_Generic_Actual_Parameter => 437 New_Occurrence_Of (Obj_Typ, Loc)), 438 Make_Generic_Association (Loc, 439 Explicit_Generic_Actual_Parameter => Obj), 440 Make_Generic_Association (Loc, 441 Explicit_Generic_Actual_Parameter => 442 Make_String_Literal (Loc, Vnm)))); 443 444 Insert_After_And_Analyze (N, Instantiation); 445 446 Set_Is_Shared_Passive (Ent, True); 447 Set_Shared_Var_Procs_Instance 448 (Ent, Defining_Entity (Instance_Spec (Instantiation))); 449 450 -- Return last node before After 451 452 declare 453 Nod : Node_Id := Next (N); 454 455 begin 456 while Next (Nod) /= After loop 457 Nod := Next (Nod); 458 end loop; 459 460 return Nod; 461 end; 462 end Make_Shared_Var_Procs; 463 464 -------------------------- 465 -- On_Lhs_Of_Assignment -- 466 -------------------------- 467 468 function On_Lhs_Of_Assignment (N : Node_Id) return Boolean is 469 P : constant Node_Id := Parent (N); 470 471 begin 472 if Nkind (P) = N_Assignment_Statement then 473 if N = Name (P) then 474 Insert_Node := P; 475 return True; 476 else 477 return False; 478 end if; 479 480 elsif Nkind_In (P, N_Indexed_Component, N_Selected_Component) 481 and then N = Prefix (P) 482 then 483 return On_Lhs_Of_Assignment (P); 484 485 else 486 return False; 487 end if; 488 end On_Lhs_Of_Assignment; 489 490end Exp_Smem; 491