------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- S Y S T E M . S H A R E D _ M E M O R Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 1998-2015, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- . -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Ada.IO_Exceptions; with Ada.Streams; with Ada.Streams.Stream_IO; with System.Global_Locks; with System.Soft_Links; with System; with System.File_Control_Block; with System.File_IO; with System.HTable; with Ada.Unchecked_Deallocation; with Ada.Unchecked_Conversion; package body System.Shared_Storage is package AS renames Ada.Streams; package IOX renames Ada.IO_Exceptions; package FCB renames System.File_Control_Block; package SFI renames System.File_IO; package SIO renames Ada.Streams.Stream_IO; type String_Access is access String; procedure Free is new Ada.Unchecked_Deallocation (Object => String, Name => String_Access); Dir : String_Access; -- Holds the directory ------------------------------------------------ -- Variables for Shared Variable Access Files -- ------------------------------------------------ Max_Shared_Var_Files : constant := 20; -- Maximum number of lock files that can be open Shared_Var_Files_Open : Natural := 0; -- Number of shared variable access files currently open type File_Stream_Type is new AS.Root_Stream_Type with record File : SIO.File_Type; end record; type File_Stream_Access is access all File_Stream_Type'Class; procedure Read (Stream : in out File_Stream_Type; Item : out AS.Stream_Element_Array; Last : out AS.Stream_Element_Offset); procedure Write (Stream : in out File_Stream_Type; Item : AS.Stream_Element_Array); subtype Hash_Header is Natural range 0 .. 30; -- Number of hash headers, related (for efficiency purposes only) to the -- maximum number of lock files. type Shared_Var_File_Entry; type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry; type Shared_Var_File_Entry is record Name : String_Access; -- Name of variable, as passed to Read_File/Write_File routines Stream : File_Stream_Access; -- Stream_IO file for the shared variable file Next : Shared_Var_File_Entry_Ptr; Prev : Shared_Var_File_Entry_Ptr; -- Links for LRU chain end record; procedure Free is new Ada.Unchecked_Deallocation (Object => Shared_Var_File_Entry, Name => Shared_Var_File_Entry_Ptr); procedure Free is new Ada.Unchecked_Deallocation (Object => File_Stream_Type'Class, Name => File_Stream_Access); function To_AFCB_Ptr is new Ada.Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr); LRU_Head : Shared_Var_File_Entry_Ptr; LRU_Tail : Shared_Var_File_Entry_Ptr; -- As lock files are opened, they are organized into a least recently -- used chain, which is a doubly linked list using the Next and Prev -- fields of Shared_Var_File_Entry records. The field LRU_Head points -- to the least recently used entry, whose prev pointer is null, and -- LRU_Tail points to the most recently used entry, whose next pointer -- is null. These pointers are null only if the list is empty. function Hash (F : String_Access) return Hash_Header; function Equal (F1, F2 : String_Access) return Boolean; -- Hash and equality functions for hash table package SFT is new System.HTable.Simple_HTable (Header_Num => Hash_Header, Element => Shared_Var_File_Entry_Ptr, No_Element => null, Key => String_Access, Hash => Hash, Equal => Equal); -------------------------------- -- Variables for Lock Control -- -------------------------------- Global_Lock : Global_Locks.Lock_Type; Lock_Count : Natural := 0; -- Counts nesting of lock calls, 0 means lock is not held ----------------------- -- Local Subprograms -- ----------------------- procedure Initialize; -- Called to initialize data structures for this package. -- Has no effect except on the first call. procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String); -- The first parameter is a pointer to a newly allocated SFE, whose -- File field is already set appropriately. Fname is the name of the -- variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE -- completes the SFE value, and enters it into the hash table. If the -- hash table is already full, the least recently used entry is first -- closed and discarded. function Retrieve (File : String) return Shared_Var_File_Entry_Ptr; -- Given a file name, this function searches the hash table to see if -- the file is currently open. If so, then a pointer to the already -- created entry is returned, after first moving it to the head of -- the LRU chain. If not, then null is returned. function Shared_Var_ROpen (Var : String) return SIO.Stream_Access; -- As described above, this routine returns null if the -- corresponding shared storage does not exist, and otherwise, if -- the storage does exist, a Stream_Access value that references -- the shared storage, ready to read the current value. function Shared_Var_WOpen (Var : String) return SIO.Stream_Access; -- As described above, this routine returns a Stream_Access value -- that references the shared storage, ready to write the new -- value. The storage is created by this call if it does not -- already exist. procedure Shared_Var_Close (Var : SIO.Stream_Access); -- This routine signals the end of a read/assign operation. It can -- be useful to embrace a read/write operation between a call to -- open and a call to close which protect the whole operation. -- Otherwise, two simultaneous operations can result in the -- raising of exception Data_Error by setting the access mode of -- the variable in an incorrect mode. --------------- -- Enter_SFE -- --------------- procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is Freed : Shared_Var_File_Entry_Ptr; begin SFE.Name := new String'(Fname); -- Release least recently used entry if we have to if Shared_Var_Files_Open = Max_Shared_Var_Files then Freed := LRU_Head; if Freed.Next /= null then Freed.Next.Prev := null; end if; LRU_Head := Freed.Next; SFT.Remove (Freed.Name); SIO.Close (Freed.Stream.File); Free (Freed.Name); Free (Freed.Stream); Free (Freed); else Shared_Var_Files_Open := Shared_Var_Files_Open + 1; end if; -- Add new entry to hash table SFT.Set (SFE.Name, SFE); -- Add new entry at end of LRU chain if LRU_Head = null then LRU_Head := SFE; LRU_Tail := SFE; else SFE.Prev := LRU_Tail; LRU_Tail.Next := SFE; LRU_Tail := SFE; end if; end Enter_SFE; ----------- -- Equal -- ----------- function Equal (F1, F2 : String_Access) return Boolean is begin return F1.all = F2.all; end Equal; ---------- -- Hash -- ---------- function Hash (F : String_Access) return Hash_Header is N : Natural := 0; begin -- Add up characters of name, mod our table size for J in F'Range loop N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1); end loop; return N; end Hash; ---------------- -- Initialize -- ---------------- procedure Initialize is procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address); pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv"); procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer); pragma Import (C, Strncpy, "strncpy"); Dir_Name : aliased constant String := "SHARED_MEMORY_DIRECTORY" & ASCII.NUL; Env_Value_Ptr : aliased Address; Env_Value_Length : aliased Integer; begin if Dir = null then Get_Env_Value_Ptr (Dir_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address); Dir := new String (1 .. Env_Value_Length); if Env_Value_Length > 0 then Strncpy (Dir.all'Address, Env_Value_Ptr, Env_Value_Length); end if; System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock"); end if; end Initialize; ---------- -- Read -- ---------- procedure Read (Stream : in out File_Stream_Type; Item : out AS.Stream_Element_Array; Last : out AS.Stream_Element_Offset) is begin SIO.Read (Stream.File, Item, Last); exception when others => Last := Item'Last; end Read; -------------- -- Retrieve -- -------------- function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is SFE : Shared_Var_File_Entry_Ptr; begin Initialize; SFE := SFT.Get (File'Unrestricted_Access); if SFE /= null then -- Move to head of LRU chain if SFE = LRU_Tail then null; elsif SFE = LRU_Head then LRU_Head := LRU_Head.Next; LRU_Head.Prev := null; else SFE.Next.Prev := SFE.Prev; SFE.Prev.Next := SFE.Next; end if; SFE.Next := null; SFE.Prev := LRU_Tail; LRU_Tail.Next := SFE; LRU_Tail := SFE; end if; return SFE; end Retrieve; ---------------------- -- Shared_Var_Close -- ---------------------- procedure Shared_Var_Close (Var : SIO.Stream_Access) is pragma Warnings (Off, Var); begin System.Soft_Links.Unlock_Task.all; end Shared_Var_Close; --------------------- -- Shared_Var_Lock -- --------------------- procedure Shared_Var_Lock (Var : String) is pragma Warnings (Off, Var); begin System.Soft_Links.Lock_Task.all; Initialize; if Lock_Count /= 0 then Lock_Count := Lock_Count + 1; System.Soft_Links.Unlock_Task.all; else Lock_Count := 1; System.Soft_Links.Unlock_Task.all; System.Global_Locks.Acquire_Lock (Global_Lock); end if; exception when others => System.Soft_Links.Unlock_Task.all; raise; end Shared_Var_Lock; ---------------------- -- Shared_Var_Procs -- ---------------------- package body Shared_Var_Procs is use type SIO.Stream_Access; ---------- -- Read -- ---------- procedure Read is S : SIO.Stream_Access := null; begin S := Shared_Var_ROpen (Full_Name); if S /= null then Typ'Read (S, V); Shared_Var_Close (S); end if; end Read; ------------ -- Write -- ------------ procedure Write is S : SIO.Stream_Access := null; begin S := Shared_Var_WOpen (Full_Name); Typ'Write (S, V); Shared_Var_Close (S); return; end Write; end Shared_Var_Procs; ---------------------- -- Shared_Var_ROpen -- ---------------------- function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is SFE : Shared_Var_File_Entry_Ptr; use type Ada.Streams.Stream_IO.File_Mode; begin System.Soft_Links.Lock_Task.all; SFE := Retrieve (Var); -- Here if file is not already open, try to open it if SFE = null then declare S : aliased constant String := Dir.all & Var; begin SFE := new Shared_Var_File_Entry; SFE.Stream := new File_Stream_Type; SIO.Open (SFE.Stream.File, SIO.In_File, Name => S); SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); -- File opened successfully, put new entry in hash table. Note -- that in this case, file is positioned correctly for read. Enter_SFE (SFE, Var); exception -- If we get an exception, it means that the file does not -- exist, and in this case, we don't need the SFE and we -- return null; when IOX.Name_Error => Free (SFE); System.Soft_Links.Unlock_Task.all; return null; end; -- Here if file is already open, set file for reading else if SIO.Mode (SFE.Stream.File) /= SIO.In_File then SIO.Set_Mode (SFE.Stream.File, SIO.In_File); SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); end if; SIO.Set_Index (SFE.Stream.File, 1); end if; return SIO.Stream_Access (SFE.Stream); exception when others => System.Soft_Links.Unlock_Task.all; raise; end Shared_Var_ROpen; ----------------------- -- Shared_Var_Unlock -- ----------------------- procedure Shared_Var_Unlock (Var : String) is pragma Warnings (Off, Var); begin System.Soft_Links.Lock_Task.all; Initialize; Lock_Count := Lock_Count - 1; if Lock_Count = 0 then System.Global_Locks.Release_Lock (Global_Lock); end if; System.Soft_Links.Unlock_Task.all; exception when others => System.Soft_Links.Unlock_Task.all; raise; end Shared_Var_Unlock; --------------------- -- Share_Var_WOpen -- --------------------- function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is SFE : Shared_Var_File_Entry_Ptr; use type Ada.Streams.Stream_IO.File_Mode; begin System.Soft_Links.Lock_Task.all; SFE := Retrieve (Var); if SFE = null then declare S : aliased constant String := Dir.all & Var; begin SFE := new Shared_Var_File_Entry; SFE.Stream := new File_Stream_Type; SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S); SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); exception -- If we get an exception, it means that the file does not -- exist, and in this case, we create the file. when IOX.Name_Error => begin SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S); exception -- Error if we cannot create the file when others => raise Program_Error with "cannot create shared variable file for """ & S & '"'; end; end; -- Make new hash table entry for opened/created file. Note that -- in both cases, the file is already in write mode at the start -- of the file, ready to be written. Enter_SFE (SFE, Var); -- Here if file is already open, set file for writing else if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then SIO.Set_Mode (SFE.Stream.File, SIO.Out_File); SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File)); end if; SIO.Set_Index (SFE.Stream.File, 1); end if; return SIO.Stream_Access (SFE.Stream); exception when others => System.Soft_Links.Unlock_Task.all; raise; end Shared_Var_WOpen; ----------- -- Write -- ----------- procedure Write (Stream : in out File_Stream_Type; Item : AS.Stream_Element_Array) is begin SIO.Write (Stream.File, Item); end Write; end System.Shared_Storage;