1 ------------------------------------------------------------------------------
3 -- GNAT COMPILER COMPONENTS --
5 -- S Y S T E M . S H A R E D _ M E M O R Y --
9 -- Copyright (C) 1998-2010, Free Software Foundation, Inc. --
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. --
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. --
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/>. --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
30 ------------------------------------------------------------------------------
32 with Ada.IO_Exceptions;
34 with Ada.Streams.Stream_IO;
36 with System.Global_Locks;
37 with System.Soft_Links;
40 with System.File_Control_Block;
44 with Ada.Unchecked_Deallocation;
45 with Ada.Unchecked_Conversion;
47 package body System.Shared_Storage is
49 package AS renames Ada.Streams;
51 package IOX renames Ada.IO_Exceptions;
53 package FCB renames System.File_Control_Block;
55 package SFI renames System.File_IO;
57 package SIO renames Ada.Streams.Stream_IO;
59 type String_Access is access String;
60 procedure Free is new Ada.Unchecked_Deallocation
61 (Object => String, Name => String_Access);
64 -- Holds the directory
66 ------------------------------------------------
67 -- Variables for Shared Variable Access Files --
68 ------------------------------------------------
70 Max_Shared_Var_Files : constant := 20;
71 -- Maximum number of lock files that can be open
73 Shared_Var_Files_Open : Natural := 0;
74 -- Number of shared variable access files currently open
76 type File_Stream_Type is new AS.Root_Stream_Type with record
79 type File_Stream_Access is access all File_Stream_Type'Class;
82 (Stream : in out File_Stream_Type;
83 Item : out AS.Stream_Element_Array;
84 Last : out AS.Stream_Element_Offset);
87 (Stream : in out File_Stream_Type;
88 Item : AS.Stream_Element_Array);
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.
94 type Shared_Var_File_Entry;
95 type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry;
97 type Shared_Var_File_Entry is record
99 -- Name of variable, as passed to Read_File/Write_File routines
101 Stream : File_Stream_Access;
102 -- Stream_IO file for the shared variable file
104 Next : Shared_Var_File_Entry_Ptr;
105 Prev : Shared_Var_File_Entry_Ptr;
106 -- Links for LRU chain
109 procedure Free is new Ada.Unchecked_Deallocation
110 (Object => Shared_Var_File_Entry,
111 Name => Shared_Var_File_Entry_Ptr);
113 procedure Free is new Ada.Unchecked_Deallocation
114 (Object => File_Stream_Type'Class,
115 Name => File_Stream_Access);
117 function To_AFCB_Ptr is
118 new Ada.Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr);
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.
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
133 package SFT is new System.HTable.Simple_HTable
134 (Header_Num => Hash_Header,
135 Element => Shared_Var_File_Entry_Ptr,
137 Key => String_Access,
141 --------------------------------
142 -- Variables for Lock Control --
143 --------------------------------
145 Global_Lock : Global_Locks.Lock_Type;
147 Lock_Count : Natural := 0;
148 -- Counts nesting of lock calls, 0 means lock is not held
150 -----------------------
151 -- Local Subprograms --
152 -----------------------
154 procedure Initialize;
155 -- Called to initialize data structures for this package.
156 -- Has no effect except on the first call.
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.
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.
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.
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
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.
196 procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is
197 Freed : Shared_Var_File_Entry_Ptr;
200 SFE.Name := new String'(Fname);
202 -- Release least recently used entry if we have to
204 if Shared_Var_Files_Open = Max_Shared_Var_Files then
207 if Freed.Next /= null then
208 Freed.Next.Prev := null;
211 LRU_Head := Freed.Next;
212 SFT.Remove (Freed.Name);
213 SIO.Close (Freed.Stream.File);
219 Shared_Var_Files_Open := Shared_Var_Files_Open + 1;
222 -- Add new entry to hash table
224 SFT.Set (SFE.Name, SFE);
226 -- Add new entry at end of LRU chain
228 if LRU_Head = null then
233 SFE.Prev := LRU_Tail;
234 LRU_Tail.Next := SFE;
243 function Equal (F1, F2 : String_Access) return Boolean is
245 return F1.all = F2.all;
252 function Hash (F : String_Access) return Hash_Header is
256 -- Add up characters of name, mod our table size
258 for J in F'Range loop
259 N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
269 procedure Initialize is
270 procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
271 pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
273 procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
274 pragma Import (C, Strncpy, "strncpy");
276 Dir_Name : aliased constant String :=
277 "SHARED_MEMORY_DIRECTORY" & ASCII.NUL;
279 Env_Value_Ptr : aliased Address;
280 Env_Value_Length : aliased Integer;
285 (Dir_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
287 Dir := new String (1 .. Env_Value_Length);
289 if Env_Value_Length > 0 then
290 Strncpy (Dir.all'Address, Env_Value_Ptr, Env_Value_Length);
293 System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
302 (Stream : in out File_Stream_Type;
303 Item : out AS.Stream_Element_Array;
304 Last : out AS.Stream_Element_Offset)
307 SIO.Read (Stream.File, Item, Last);
309 exception when others =>
317 function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is
318 SFE : Shared_Var_File_Entry_Ptr;
322 SFE := SFT.Get (File'Unrestricted_Access);
326 -- Move to head of LRU chain
328 if SFE = LRU_Tail then
331 elsif SFE = LRU_Head then
332 LRU_Head := LRU_Head.Next;
333 LRU_Head.Prev := null;
336 SFE.Next.Prev := SFE.Prev;
337 SFE.Prev.Next := SFE.Next;
341 SFE.Prev := LRU_Tail;
342 LRU_Tail.Next := SFE;
349 ----------------------
350 -- Shared_Var_Close --
351 ----------------------
353 procedure Shared_Var_Close (Var : SIO.Stream_Access) is
354 pragma Warnings (Off, Var);
357 System.Soft_Links.Unlock_Task.all;
358 end Shared_Var_Close;
360 ---------------------
361 -- Shared_Var_Lock --
362 ---------------------
364 procedure Shared_Var_Lock (Var : String) is
365 pragma Warnings (Off, Var);
368 System.Soft_Links.Lock_Task.all;
371 if Lock_Count /= 0 then
372 Lock_Count := Lock_Count + 1;
373 System.Soft_Links.Unlock_Task.all;
377 System.Soft_Links.Unlock_Task.all;
378 System.Global_Locks.Acquire_Lock (Global_Lock);
383 System.Soft_Links.Unlock_Task.all;
387 ----------------------
388 -- Shared_Var_Procs --
389 ----------------------
391 package body Shared_Var_Procs is
393 use type SIO.Stream_Access;
400 S : SIO.Stream_Access := null;
402 S := Shared_Var_ROpen (Full_Name);
405 Shared_Var_Close (S);
414 S : SIO.Stream_Access := null;
416 S := Shared_Var_WOpen (Full_Name);
418 Shared_Var_Close (S);
422 end Shared_Var_Procs;
424 ----------------------
425 -- Shared_Var_ROpen --
426 ----------------------
428 function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is
429 SFE : Shared_Var_File_Entry_Ptr;
431 use type Ada.Streams.Stream_IO.File_Mode;
434 System.Soft_Links.Lock_Task.all;
435 SFE := Retrieve (Var);
437 -- Here if file is not already open, try to open it
441 S : aliased constant String := Dir.all & Var;
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));
449 -- File opened successfully, put new entry in hash table. Note
450 -- that in this case, file is positioned correctly for read.
452 Enter_SFE (SFE, Var);
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
459 when IOX.Name_Error =>
461 System.Soft_Links.Unlock_Task.all;
465 -- Here if file is already open, set file for reading
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));
473 SIO.Set_Index (SFE.Stream.File, 1);
476 return SIO.Stream_Access (SFE.Stream);
480 System.Soft_Links.Unlock_Task.all;
482 end Shared_Var_ROpen;
484 -----------------------
485 -- Shared_Var_Unlock --
486 -----------------------
488 procedure Shared_Var_Unlock (Var : String) is
489 pragma Warnings (Off, Var);
492 System.Soft_Links.Lock_Task.all;
494 Lock_Count := Lock_Count - 1;
496 if Lock_Count = 0 then
497 System.Global_Locks.Release_Lock (Global_Lock);
499 System.Soft_Links.Unlock_Task.all;
503 System.Soft_Links.Unlock_Task.all;
505 end Shared_Var_Unlock;
507 ---------------------
508 -- Share_Var_WOpen --
509 ---------------------
511 function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is
512 SFE : Shared_Var_File_Entry_Ptr;
514 use type Ada.Streams.Stream_IO.File_Mode;
517 System.Soft_Links.Lock_Task.all;
518 SFE := Retrieve (Var);
522 S : aliased constant String := Dir.all & Var;
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));
531 -- If we get an exception, it means that the file does not
532 -- exist, and in this case, we create the file.
534 when IOX.Name_Error =>
537 SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
540 -- Error if we cannot create the file
543 raise Program_Error with
544 "Cannot create shared variable file for """ & S & '"';
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.
552 Enter_SFE (SFE, Var);
554 -- Here if file is already open, set file for writing
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));
562 SIO.Set_Index (SFE.Stream.File, 1);
565 return SIO.Stream_Access (SFE.Stream);
569 System.Soft_Links.Unlock_Task.all;
571 end Shared_Var_WOpen;
578 (Stream : in out File_Stream_Type;
579 Item : AS.Stream_Element_Array)
582 SIO.Write (Stream.File, Item);
585 end System.Shared_Storage;