gcc/ada/s-shasto.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                 S Y S T E M . S H A R E D _ M E M O R Y                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1998-2006, Free Software Foundation, Inc.         --
  10 --                                                                          --
  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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with Ada.Exceptions;
  35 with Ada.IO_Exceptions;
  36 with Ada.Streams;
  37
  38 with System.Global_Locks;
  39 with System.Soft_Links;
  40
  41 with System;
  42 with System.File_Control_Block;
  43 with System.File_IO;
  44 with System.HTable;
  45
  46 with Unchecked_Deallocation;
  47 with Unchecked_Conversion;
  48
  49 package body System.Shared_Storage is
  50
  51    package AS renames Ada.Streams;
  52
  53    package IOX renames Ada.IO_Exceptions;
  54
  55    package FCB renames System.File_Control_Block;
  56
  57    package SFI renames System.File_IO;
  58
  59    type String_Access is access String;
  60    procedure Free is new Unchecked_Deallocation
  61      (Object => String, Name => String_Access);
  62
  63    Dir : String_Access;
  64    --  Holds the directory
  65
  66    ------------------------------------------------
  67    -- Variables for Shared Variable Access Files --
  68    ------------------------------------------------
  69
  70    Max_Shared_Var_Files : constant := 20;
  71    --  Maximum number of lock files that can be open
  72
  73    Shared_Var_Files_Open : Natural := 0;
  74    --  Number of shared variable access files currently open
  75
  76    type File_Stream_Type is new AS.Root_Stream_Type with record
  77       File : SIO.File_Type;
  78    end record;
  79    type File_Stream_Access is access all File_Stream_Type'Class;
  80
  81    procedure Read
  82      (Stream : in out File_Stream_Type;
  83       Item   : out AS.Stream_Element_Array;
  84       Last   : out AS.Stream_Element_Offset);
  85
  86    procedure Write
  87      (Stream : in out File_Stream_Type;
  88       Item   : AS.Stream_Element_Array);
  89
  90    subtype Hash_Header is Natural range 0 .. 30;
  91    --  Number of hash headers, related (for efficiency purposes only)
  92    --  to the maximum number of lock files..
  93
  94    type Shared_Var_File_Entry;
  95    type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry;
  96
  97    type Shared_Var_File_Entry is record
  98       Name : String_Access;
  99       --  Name of variable, as passed to Read_File/Write_File routines
 100
 101       Stream : File_Stream_Access;
 102       --  Stream_IO file for the shared variable file
 103
 104       Next : Shared_Var_File_Entry_Ptr;
 105       Prev : Shared_Var_File_Entry_Ptr;
 106       --  Links for LRU chain
 107    end record;
 108
 109    procedure Free is new Unchecked_Deallocation
 110      (Object => Shared_Var_File_Entry,
 111       Name   => Shared_Var_File_Entry_Ptr);
 112
 113    procedure Free is new Unchecked_Deallocation
 114      (Object => File_Stream_Type'Class,
 115       Name   => File_Stream_Access);
 116
 117    function To_AFCB_Ptr is
 118      new Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr);
 119
 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.
 128
 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
 132
 133    package SFT is new System.HTable.Simple_HTable
 134      (Header_Num => Hash_Header,
 135       Element    => Shared_Var_File_Entry_Ptr,
 136       No_Element => null,
 137       Key        => String_Access,
 138       Hash       => Hash,
 139       Equal      => Equal);
 140
 141    --------------------------------
 142    -- Variables for Lock Control --
 143    --------------------------------
 144
 145    Global_Lock : Global_Locks.Lock_Type;
 146
 147    Lock_Count : Natural := 0;
 148    --  Counts nesting of lock calls, 0 means lock is not held
 149
 150    -----------------------
 151    -- Local Subprograms --
 152    -----------------------
 153
 154    procedure Initialize;
 155    --  Called to initialize data structures for this package.
 156    --  Has no effect except on the first call.
 157
 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.
 165
 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.
 171
 172    ---------------
 173    -- Enter_SFE --
 174    ---------------
 175
 176    procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is
 177       Freed : Shared_Var_File_Entry_Ptr;
 178
 179    begin
 180       SFE.Name := new String'(Fname);
 181
 182       --  Release least recently used entry if we have to
 183
 184       if Shared_Var_Files_Open =  Max_Shared_Var_Files then
 185          Freed := LRU_Head;
 186
 187          if Freed.Next /= null then
 188             Freed.Next.Prev := null;
 189          end if;
 190
 191          LRU_Head := Freed.Next;
 192          SFT.Remove (Freed.Name);
 193          SIO.Close (Freed.Stream.File);
 194          Free (Freed.Name);
 195          Free (Freed.Stream);
 196          Free (Freed);
 197
 198       else
 199          Shared_Var_Files_Open := Shared_Var_Files_Open + 1;
 200       end if;
 201
 202       --  Add new entry to hash table
 203
 204       SFT.Set (SFE.Name, SFE);
 205
 206       --  Add new entry at end of LRU chain
 207
 208       if LRU_Head = null then
 209          LRU_Head := SFE;
 210          LRU_Tail := SFE;
 211
 212       else
 213          SFE.Prev := LRU_Tail;
 214          LRU_Tail.Next := SFE;
 215          LRU_Tail := SFE;
 216       end if;
 217    end Enter_SFE;
 218
 219    -----------
 220    -- Equal --
 221    -----------
 222
 223    function Equal (F1, F2 : String_Access) return Boolean is
 224    begin
 225       return F1.all = F2.all;
 226    end Equal;
 227
 228    ----------
 229    -- Hash --
 230    ----------
 231
 232    function Hash (F : String_Access) return Hash_Header is
 233       N : Natural := 0;
 234
 235    begin
 236       --  Add up characters of name, mod our table size
 237
 238       for J in F'Range loop
 239          N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
 240       end loop;
 241
 242       return N;
 243    end Hash;
 244
 245    ----------------
 246    -- Initialize --
 247    ----------------
 248
 249    procedure Initialize is
 250       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
 251       pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
 252
 253       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 254       pragma Import (C, Strncpy, "strncpy");
 255
 256       Dir_Name : aliased constant String :=
 257                    "SHARED_MEMORY_DIRECTORY" & ASCII.NUL;
 258
 259       Env_Value_Ptr    : aliased Address;
 260       Env_Value_Length : aliased Integer;
 261
 262    begin
 263       if Dir = null then
 264          Get_Env_Value_Ptr
 265            (Dir_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
 266
 267          Dir := new String (1 .. Env_Value_Length);
 268
 269          if Env_Value_Length > 0 then
 270             Strncpy (Dir.all'Address, Env_Value_Ptr, Env_Value_Length);
 271          end if;
 272
 273          System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
 274       end if;
 275    end Initialize;
 276
 277    ----------
 278    -- Read --
 279    ----------
 280
 281    procedure Read
 282      (Stream : in out File_Stream_Type;
 283       Item   : out AS.Stream_Element_Array;
 284       Last   : out AS.Stream_Element_Offset)
 285    is
 286    begin
 287       SIO.Read (Stream.File, Item, Last);
 288
 289    exception when others =>
 290       Last := Item'Last;
 291    end Read;
 292
 293    --------------
 294    -- Retrieve --
 295    --------------
 296
 297    function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is
 298       SFE : Shared_Var_File_Entry_Ptr;
 299
 300    begin
 301       Initialize;
 302       SFE := SFT.Get (File'Unrestricted_Access);
 303
 304       if SFE /= null then
 305
 306          --  Move to head of LRU chain
 307
 308          if SFE = LRU_Tail then
 309             null;
 310
 311          elsif SFE = LRU_Head then
 312             LRU_Head := LRU_Head.Next;
 313             LRU_Head.Prev := null;
 314
 315          else
 316             SFE.Next.Prev := SFE.Prev;
 317             SFE.Prev.Next := SFE.Next;
 318          end if;
 319
 320          SFE.Next := null;
 321          SFE.Prev := LRU_Tail;
 322          LRU_Tail.Next := SFE;
 323          LRU_Tail := SFE;
 324       end if;
 325
 326       return SFE;
 327    end Retrieve;
 328
 329    ----------------------
 330    -- Shared_Var_Close --
 331    ----------------------
 332
 333    procedure Shared_Var_Close (Var : SIO.Stream_Access) is
 334       pragma Warnings (Off, Var);
 335
 336    begin
 337       System.Soft_Links.Unlock_Task.all;
 338    end Shared_Var_Close;
 339
 340    ---------------------
 341    -- Shared_Var_Lock --
 342    ---------------------
 343
 344    procedure Shared_Var_Lock (Var : String) is
 345       pragma Warnings (Off, Var);
 346
 347    begin
 348       System.Soft_Links.Lock_Task.all;
 349       Initialize;
 350
 351       if Lock_Count /= 0 then
 352          Lock_Count := Lock_Count + 1;
 353          System.Soft_Links.Unlock_Task.all;
 354
 355       else
 356          Lock_Count := 1;
 357          System.Soft_Links.Unlock_Task.all;
 358          System.Global_Locks.Acquire_Lock (Global_Lock);
 359       end if;
 360
 361    exception
 362       when others =>
 363          System.Soft_Links.Unlock_Task.all;
 364          raise;
 365    end Shared_Var_Lock;
 366
 367    ----------------------
 368    -- Shared_Var_ROpen --
 369    ----------------------
 370
 371    function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is
 372       SFE : Shared_Var_File_Entry_Ptr;
 373
 374       use type Ada.Streams.Stream_IO.File_Mode;
 375
 376    begin
 377       System.Soft_Links.Lock_Task.all;
 378       SFE := Retrieve (Var);
 379
 380       --  Here if file is not already open, try to open it
 381
 382       if SFE = null then
 383          declare
 384             S  : aliased constant String := Dir.all & Var;
 385
 386          begin
 387             SFE := new Shared_Var_File_Entry;
 388             SFE.Stream := new File_Stream_Type;
 389             SIO.Open (SFE.Stream.File, SIO.In_File, Name => S);
 390             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 391
 392             --  File opened successfully, put new entry in hash table. Note
 393             --  that in this case, file is positioned correctly for read.
 394
 395             Enter_SFE (SFE, Var);
 396
 397             exception
 398                --  If we get an exception, it means that the file does not
 399                --  exist, and in this case, we don't need the SFE and we
 400                --  return null;
 401
 402                when IOX.Name_Error =>
 403                   Free (SFE);
 404                   System.Soft_Links.Unlock_Task.all;
 405                   return null;
 406          end;
 407
 408       --  Here if file is already open, set file for reading
 409
 410       else
 411          if SIO.Mode (SFE.Stream.File) /= SIO.In_File then
 412             SIO.Set_Mode (SFE.Stream.File, SIO.In_File);
 413             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 414          end if;
 415
 416          SIO.Set_Index (SFE.Stream.File, 1);
 417       end if;
 418
 419       return SIO.Stream_Access (SFE.Stream);
 420
 421    exception
 422       when others =>
 423          System.Soft_Links.Unlock_Task.all;
 424          raise;
 425    end Shared_Var_ROpen;
 426
 427    -----------------------
 428    -- Shared_Var_Unlock --
 429    -----------------------
 430
 431    procedure Shared_Var_Unlock (Var : String) is
 432       pragma Warnings (Off, Var);
 433
 434    begin
 435       System.Soft_Links.Lock_Task.all;
 436       Initialize;
 437       Lock_Count := Lock_Count - 1;
 438
 439       if Lock_Count = 0 then
 440          System.Global_Locks.Release_Lock (Global_Lock);
 441       end if;
 442       System.Soft_Links.Unlock_Task.all;
 443
 444    exception
 445       when others =>
 446          System.Soft_Links.Unlock_Task.all;
 447          raise;
 448    end Shared_Var_Unlock;
 449
 450    ---------------------
 451    -- Share_Var_WOpen --
 452    ---------------------
 453
 454    function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is
 455       SFE : Shared_Var_File_Entry_Ptr;
 456
 457       use type Ada.Streams.Stream_IO.File_Mode;
 458
 459    begin
 460       System.Soft_Links.Lock_Task.all;
 461       SFE := Retrieve (Var);
 462
 463       if SFE = null then
 464          declare
 465             S  : aliased constant String := Dir.all & Var;
 466
 467          begin
 468             SFE := new Shared_Var_File_Entry;
 469             SFE.Stream := new File_Stream_Type;
 470             SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S);
 471             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 472
 473          exception
 474             --  If we get an exception, it means that the file does not
 475             --  exist, and in this case, we create the file.
 476
 477             when IOX.Name_Error =>
 478
 479                begin
 480                   SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
 481
 482                exception
 483                   --  Error if we cannot create the file
 484
 485                   when others =>
 486                      Ada.Exceptions.Raise_Exception
 487                        (Program_Error'Identity,
 488                         "Cannot create shared variable file for """ &
 489                         S & '"'); -- "
 490                end;
 491          end;
 492
 493          --  Make new hash table entry for opened/created file. Note that
 494          --  in both cases, the file is already in write mode at the start
 495          --  of the file, ready to be written.
 496
 497          Enter_SFE (SFE, Var);
 498
 499       --  Here if file is already open, set file for writing
 500
 501       else
 502          if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then
 503             SIO.Set_Mode (SFE.Stream.File, SIO.Out_File);
 504             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 505          end if;
 506
 507          SIO.Set_Index (SFE.Stream.File, 1);
 508       end if;
 509
 510       return SIO.Stream_Access (SFE.Stream);
 511
 512    exception
 513       when others =>
 514          System.Soft_Links.Unlock_Task.all;
 515          raise;
 516    end Shared_Var_WOpen;
 517
 518    -----------
 519    -- Write --
 520    -----------
 521
 522    procedure Write
 523      (Stream : in out File_Stream_Type;
 524       Item   : AS.Stream_Element_Array)
 525    is
 526    begin
 527       SIO.Write (Stream.File, Item);
 528    end Write;
 529
 530 end System.Shared_Storage;