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