1------------------------------------------------------------------------------ 2-- -- 3-- GNAT COMPILER COMPONENTS -- 4-- -- 5-- S Y S T E M . S H A R E D _ M E M O R Y -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2018, 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. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.IO_Exceptions; 33with Ada.Streams; 34with Ada.Streams.Stream_IO; 35 36with System.Global_Locks; 37with System.Soft_Links; 38 39with System; 40with System.CRTL; 41with System.File_Control_Block; 42with System.File_IO; 43with System.HTable; 44 45with Ada.Unchecked_Deallocation; 46with Ada.Unchecked_Conversion; 47 48package body System.Shared_Storage is 49 50 package AS renames Ada.Streams; 51 52 package IOX renames Ada.IO_Exceptions; 53 54 package FCB renames System.File_Control_Block; 55 56 package SFI renames System.File_IO; 57 58 package SIO renames Ada.Streams.Stream_IO; 59 60 type String_Access is access String; 61 procedure Free is new Ada.Unchecked_Deallocation 62 (Object => String, Name => String_Access); 63 64 Dir : String_Access; 65 -- Holds the directory 66 67 ------------------------------------------------ 68 -- Variables for Shared Variable Access Files -- 69 ------------------------------------------------ 70 71 Max_Shared_Var_Files : constant := 20; 72 -- Maximum number of lock files that can be open 73 74 Shared_Var_Files_Open : Natural := 0; 75 -- Number of shared variable access files currently open 76 77 type File_Stream_Type is new AS.Root_Stream_Type with record 78 File : SIO.File_Type; 79 end record; 80 type File_Stream_Access is access all File_Stream_Type'Class; 81 82 procedure Read 83 (Stream : in out File_Stream_Type; 84 Item : out AS.Stream_Element_Array; 85 Last : out AS.Stream_Element_Offset); 86 87 procedure Write 88 (Stream : in out File_Stream_Type; 89 Item : AS.Stream_Element_Array); 90 91 subtype Hash_Header is Natural range 0 .. 30; 92 -- Number of hash headers, related (for efficiency purposes only) to the 93 -- maximum number of lock files. 94 95 type Shared_Var_File_Entry; 96 type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry; 97 98 type Shared_Var_File_Entry is record 99 Name : String_Access; 100 -- Name of variable, as passed to Read_File/Write_File routines 101 102 Stream : File_Stream_Access; 103 -- Stream_IO file for the shared variable file 104 105 Next : Shared_Var_File_Entry_Ptr; 106 Prev : Shared_Var_File_Entry_Ptr; 107 -- Links for LRU chain 108 end record; 109 110 procedure Free is new Ada.Unchecked_Deallocation 111 (Object => Shared_Var_File_Entry, 112 Name => Shared_Var_File_Entry_Ptr); 113 114 procedure Free is new Ada.Unchecked_Deallocation 115 (Object => File_Stream_Type'Class, 116 Name => File_Stream_Access); 117 118 function To_AFCB_Ptr is 119 new Ada.Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr); 120 121 LRU_Head : Shared_Var_File_Entry_Ptr; 122 LRU_Tail : Shared_Var_File_Entry_Ptr; 123 -- As lock files are opened, they are organized into a least recently 124 -- used chain, which is a doubly linked list using the Next and Prev 125 -- fields of Shared_Var_File_Entry records. The field LRU_Head points 126 -- to the least recently used entry, whose prev pointer is null, and 127 -- LRU_Tail points to the most recently used entry, whose next pointer 128 -- is null. These pointers are null only if the list is empty. 129 130 function Hash (F : String_Access) return Hash_Header; 131 function Equal (F1, F2 : String_Access) return Boolean; 132 -- Hash and equality functions for hash table 133 134 package SFT is new System.HTable.Simple_HTable 135 (Header_Num => Hash_Header, 136 Element => Shared_Var_File_Entry_Ptr, 137 No_Element => null, 138 Key => String_Access, 139 Hash => Hash, 140 Equal => Equal); 141 142 -------------------------------- 143 -- Variables for Lock Control -- 144 -------------------------------- 145 146 Global_Lock : Global_Locks.Lock_Type; 147 148 Lock_Count : Natural := 0; 149 -- Counts nesting of lock calls, 0 means lock is not held 150 151 ----------------------- 152 -- Local Subprograms -- 153 ----------------------- 154 155 procedure Initialize; 156 -- Called to initialize data structures for this package. 157 -- Has no effect except on the first call. 158 159 procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String); 160 -- The first parameter is a pointer to a newly allocated SFE, whose 161 -- File field is already set appropriately. Fname is the name of the 162 -- variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE 163 -- completes the SFE value, and enters it into the hash table. If the 164 -- hash table is already full, the least recently used entry is first 165 -- closed and discarded. 166 167 function Retrieve (File : String) return Shared_Var_File_Entry_Ptr; 168 -- Given a file name, this function searches the hash table to see if 169 -- the file is currently open. If so, then a pointer to the already 170 -- created entry is returned, after first moving it to the head of 171 -- the LRU chain. If not, then null is returned. 172 173 function Shared_Var_ROpen (Var : String) return SIO.Stream_Access; 174 -- As described above, this routine returns null if the 175 -- corresponding shared storage does not exist, and otherwise, if 176 -- the storage does exist, a Stream_Access value that references 177 -- the shared storage, ready to read the current value. 178 179 function Shared_Var_WOpen (Var : String) return SIO.Stream_Access; 180 -- As described above, this routine returns a Stream_Access value 181 -- that references the shared storage, ready to write the new 182 -- value. The storage is created by this call if it does not 183 -- already exist. 184 185 procedure Shared_Var_Close (Var : SIO.Stream_Access); 186 -- This routine signals the end of a read/assign operation. It can 187 -- be useful to embrace a read/write operation between a call to 188 -- open and a call to close which protect the whole operation. 189 -- Otherwise, two simultaneous operations can result in the 190 -- raising of exception Data_Error by setting the access mode of 191 -- the variable in an incorrect mode. 192 193 --------------- 194 -- Enter_SFE -- 195 --------------- 196 197 procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is 198 Freed : Shared_Var_File_Entry_Ptr; 199 200 begin 201 SFE.Name := new String'(Fname); 202 203 -- Release least recently used entry if we have to 204 205 if Shared_Var_Files_Open = Max_Shared_Var_Files then 206 Freed := LRU_Head; 207 208 if Freed.Next /= null then 209 Freed.Next.Prev := null; 210 end if; 211 212 LRU_Head := Freed.Next; 213 SFT.Remove (Freed.Name); 214 SIO.Close (Freed.Stream.File); 215 Free (Freed.Name); 216 Free (Freed.Stream); 217 Free (Freed); 218 219 else 220 Shared_Var_Files_Open := Shared_Var_Files_Open + 1; 221 end if; 222 223 -- Add new entry to hash table 224 225 SFT.Set (SFE.Name, SFE); 226 227 -- Add new entry at end of LRU chain 228 229 if LRU_Head = null then 230 LRU_Head := SFE; 231 LRU_Tail := SFE; 232 233 else 234 SFE.Prev := LRU_Tail; 235 LRU_Tail.Next := SFE; 236 LRU_Tail := SFE; 237 end if; 238 end Enter_SFE; 239 240 ----------- 241 -- Equal -- 242 ----------- 243 244 function Equal (F1, F2 : String_Access) return Boolean is 245 begin 246 return F1.all = F2.all; 247 end Equal; 248 249 ---------- 250 -- Hash -- 251 ---------- 252 253 function Hash (F : String_Access) return Hash_Header is 254 N : Natural := 0; 255 256 begin 257 -- Add up characters of name, mod our table size 258 259 for J in F'Range loop 260 N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1); 261 end loop; 262 263 return N; 264 end Hash; 265 266 ---------------- 267 -- Initialize -- 268 ---------------- 269 270 procedure Initialize is 271 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); 272 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); 273 274 subtype size_t is CRTL.size_t; 275 276 procedure Strncpy (dest, src : System.Address; n : size_t) 277 renames CRTL.strncpy; 278 279 Dir_Name : aliased constant String := 280 "SHARED_MEMORY_DIRECTORY" & ASCII.NUL; 281 282 Env_Value_Ptr : aliased Address; 283 Env_Value_Len : aliased Integer; 284 285 begin 286 if Dir = null then 287 Get_Env_Value_Ptr 288 (Dir_Name'Address, Env_Value_Len'Address, Env_Value_Ptr'Address); 289 290 Dir := new String (1 .. Env_Value_Len); 291 292 if Env_Value_Len > 0 then 293 Strncpy (Dir.all'Address, Env_Value_Ptr, size_t (Env_Value_Len)); 294 end if; 295 296 System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock"); 297 end if; 298 end Initialize; 299 300 ---------- 301 -- Read -- 302 ---------- 303 304 procedure Read 305 (Stream : in out File_Stream_Type; 306 Item : out AS.Stream_Element_Array; 307 Last : out AS.Stream_Element_Offset) 308 is 309 begin 310 SIO.Read (Stream.File, Item, Last); 311 312 exception when others => 313 Last := Item'Last; 314 end Read; 315 316 -------------- 317 -- Retrieve -- 318 -------------- 319 320 function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is 321 SFE : Shared_Var_File_Entry_Ptr; 322 323 begin 324 Initialize; 325 SFE := SFT.Get (File'Unrestricted_Access); 326 327 if SFE /= null then 328 329 -- Move to head of LRU chain 330 331 if SFE = LRU_Tail then 332 null; 333 334 elsif SFE = LRU_Head then 335 LRU_Head := LRU_Head.Next; 336 LRU_Head.Prev := null; 337 338 else 339 SFE.Next.Prev := SFE.Prev; 340 SFE.Prev.Next := SFE.Next; 341 end if; 342 343 SFE.Next := null; 344 SFE.Prev := LRU_Tail; 345 LRU_Tail.Next := SFE; 346 LRU_Tail := SFE; 347 end if; 348 349 return SFE; 350 end Retrieve; 351 352 ---------------------- 353 -- Shared_Var_Close -- 354 ---------------------- 355 356 procedure Shared_Var_Close (Var : SIO.Stream_Access) is 357 pragma Warnings (Off, Var); 358 359 begin 360 System.Soft_Links.Unlock_Task.all; 361 end Shared_Var_Close; 362 363 --------------------- 364 -- Shared_Var_Lock -- 365 --------------------- 366 367 procedure Shared_Var_Lock (Var : String) is 368 pragma Warnings (Off, Var); 369 370 begin 371 System.Soft_Links.Lock_Task.all; 372 Initialize; 373 374 if Lock_Count /= 0 then 375 Lock_Count := Lock_Count + 1; 376 System.Soft_Links.Unlock_Task.all; 377 378 else 379 Lock_Count := 1; 380 System.Soft_Links.Unlock_Task.all; 381 System.Global_Locks.Acquire_Lock (Global_Lock); 382 end if; 383 384 exception 385 when others => 386 System.Soft_Links.Unlock_Task.all; 387 raise; 388 end Shared_Var_Lock; 389 390 ---------------------- 391 -- Shared_Var_Procs -- 392 ---------------------- 393 394 package body Shared_Var_Procs is 395 396 use type SIO.Stream_Access; 397 398 ---------- 399 -- Read -- 400 ---------- 401 402 procedure Read is 403 S : SIO.Stream_Access := null; 404 begin 405 S := Shared_Var_ROpen (Full_Name); 406 if S /= null then 407 Typ'Read (S, V); 408 Shared_Var_Close (S); 409 end if; 410 end Read; 411 412 ------------ 413 -- Write -- 414 ------------ 415 416 procedure Write is 417 S : SIO.Stream_Access := null; 418 begin 419 S := Shared_Var_WOpen (Full_Name); 420 Typ'Write (S, V); 421 Shared_Var_Close (S); 422 return; 423 end Write; 424 425 end Shared_Var_Procs; 426 427 ---------------------- 428 -- Shared_Var_ROpen -- 429 ---------------------- 430 431 function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is 432 SFE : Shared_Var_File_Entry_Ptr; 433 434 use type Ada.Streams.Stream_IO.File_Mode; 435 436 begin 437 System.Soft_Links.Lock_Task.all; 438 SFE := Retrieve (Var); 439 440 -- Here if file is not already open, try to open it 441 442 if SFE = null then 443 declare 444 S : aliased constant String := Dir.all & Var; 445 446 begin 447 SFE := new Shared_Var_File_Entry; 448 SFE.Stream := new File_Stream_Type; 449 SIO.Open (SFE.Stream.File, SIO.In_File, Name => S); 450 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); 451 452 -- File opened successfully, put new entry in hash table. Note 453 -- that in this case, file is positioned correctly for read. 454 455 Enter_SFE (SFE, Var); 456 457 exception 458 -- If we get an exception, it means that the file does not 459 -- exist, and in this case, we don't need the SFE and we 460 -- return null; 461 462 when IOX.Name_Error => 463 Free (SFE); 464 System.Soft_Links.Unlock_Task.all; 465 return null; 466 end; 467 468 -- Here if file is already open, set file for reading 469 470 else 471 if SIO.Mode (SFE.Stream.File) /= SIO.In_File then 472 SIO.Set_Mode (SFE.Stream.File, SIO.In_File); 473 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); 474 end if; 475 476 SIO.Set_Index (SFE.Stream.File, 1); 477 end if; 478 479 return SIO.Stream_Access (SFE.Stream); 480 481 exception 482 when others => 483 System.Soft_Links.Unlock_Task.all; 484 raise; 485 end Shared_Var_ROpen; 486 487 ----------------------- 488 -- Shared_Var_Unlock -- 489 ----------------------- 490 491 procedure Shared_Var_Unlock (Var : String) is 492 pragma Warnings (Off, Var); 493 494 begin 495 System.Soft_Links.Lock_Task.all; 496 Initialize; 497 Lock_Count := Lock_Count - 1; 498 499 if Lock_Count = 0 then 500 System.Global_Locks.Release_Lock (Global_Lock); 501 end if; 502 System.Soft_Links.Unlock_Task.all; 503 504 exception 505 when others => 506 System.Soft_Links.Unlock_Task.all; 507 raise; 508 end Shared_Var_Unlock; 509 510 --------------------- 511 -- Share_Var_WOpen -- 512 --------------------- 513 514 function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is 515 SFE : Shared_Var_File_Entry_Ptr; 516 517 use type Ada.Streams.Stream_IO.File_Mode; 518 519 begin 520 System.Soft_Links.Lock_Task.all; 521 SFE := Retrieve (Var); 522 523 if SFE = null then 524 declare 525 S : aliased constant String := Dir.all & Var; 526 527 begin 528 SFE := new Shared_Var_File_Entry; 529 SFE.Stream := new File_Stream_Type; 530 SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S); 531 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); 532 533 exception 534 -- If we get an exception, it means that the file does not 535 -- exist, and in this case, we create the file. 536 537 when IOX.Name_Error => 538 539 begin 540 SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S); 541 542 exception 543 -- Error if we cannot create the file 544 545 when others => 546 raise Program_Error with 547 "cannot create shared variable file for """ & S & '"'; 548 end; 549 end; 550 551 -- Make new hash table entry for opened/created file. Note that 552 -- in both cases, the file is already in write mode at the start 553 -- of the file, ready to be written. 554 555 Enter_SFE (SFE, Var); 556 557 -- Here if file is already open, set file for writing 558 559 else 560 if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then 561 SIO.Set_Mode (SFE.Stream.File, SIO.Out_File); 562 SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); 563 end if; 564 565 SIO.Set_Index (SFE.Stream.File, 1); 566 end if; 567 568 return SIO.Stream_Access (SFE.Stream); 569 570 exception 571 when others => 572 System.Soft_Links.Unlock_Task.all; 573 raise; 574 end Shared_Var_WOpen; 575 576 ----------- 577 -- Write -- 578 ----------- 579 580 procedure Write 581 (Stream : in out File_Stream_Type; 582 Item : AS.Stream_Element_Array) 583 is 584 begin 585 SIO.Write (Stream.File, Item); 586 end Write; 587 588end System.Shared_Storage; 589