gcc/ada/s-shasto.adb

------------------------------------------------------------------------------
--                                                                          --
--                         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-2010, 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.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;