589 lines
17 KiB
Ada
589 lines
17 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- 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 --
|
|
-- <http://www.gnu.org/licenses/>. --
|
|
-- --
|
|
-- 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.CRTL;
|
|
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");
|
|
|
|
subtype size_t is CRTL.size_t;
|
|
|
|
procedure Strncpy (dest, src : System.Address; n : size_t)
|
|
renames CRTL.strncpy;
|
|
|
|
Dir_Name : aliased constant String :=
|
|
"SHARED_MEMORY_DIRECTORY" & ASCII.NUL;
|
|
|
|
Env_Value_Ptr : aliased Address;
|
|
Env_Value_Len : aliased Integer;
|
|
|
|
begin
|
|
if Dir = null then
|
|
Get_Env_Value_Ptr
|
|
(Dir_Name'Address, Env_Value_Len'Address, Env_Value_Ptr'Address);
|
|
|
|
Dir := new String (1 .. Env_Value_Len);
|
|
|
|
if Env_Value_Len > 0 then
|
|
Strncpy (Dir.all'Address, Env_Value_Ptr, size_t (Env_Value_Len));
|
|
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;
|