Subversion Repositories openrisc

------------------------------------------------------------------------------

--                                                                          --

--                         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-2009, 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;