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-2010, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNAT was originally developed  by the GNAT team at  New York University. --
  28 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 with Ada.IO_Exceptions;
  33 with Ada.Streams;
  34 with Ada.Streams.Stream_IO;
  35
  36 with System.Global_Locks;
  37 with System.Soft_Links;
  38
  39 with System;
  40 with System.File_Control_Block;
  41 with System.File_IO;
  42 with System.HTable;
  43
  44 with Ada.Unchecked_Deallocation;
  45 with Ada.Unchecked_Conversion;
  46
  47 package body System.Shared_Storage is
  48
  49    package AS renames Ada.Streams;
  50
  51    package IOX renames Ada.IO_Exceptions;
  52
  53    package FCB renames System.File_Control_Block;
  54
  55    package SFI renames System.File_IO;
  56
  57    package SIO renames Ada.Streams.Stream_IO;
  58
  59    type String_Access is access String;
  60    procedure Free is new Ada.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) to the
  92    --  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 Ada.Unchecked_Deallocation
 110      (Object => Shared_Var_File_Entry,
 111       Name   => Shared_Var_File_Entry_Ptr);
 112
 113    procedure Free is new Ada.Unchecked_Deallocation
 114      (Object => File_Stream_Type'Class,
 115       Name   => File_Stream_Access);
 116
 117    function To_AFCB_Ptr is
 118      new Ada.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    function Shared_Var_ROpen (Var : String) return SIO.Stream_Access;
 173    --  As described above, this routine returns null if the
 174    --  corresponding shared storage does not exist, and otherwise, if
 175    --  the storage does exist, a Stream_Access value that references
 176    --  the shared storage, ready to read the current value.
 177
 178    function Shared_Var_WOpen (Var : String) return SIO.Stream_Access;
 179    --  As described above, this routine returns a Stream_Access value
 180    --  that references the shared storage, ready to write the new
 181    --  value. The storage is created by this call if it does not
 182    --  already exist.
 183
 184    procedure Shared_Var_Close (Var : SIO.Stream_Access);
 185    --  This routine signals the end of a read/assign operation. It can
 186    --  be useful to embrace a read/write operation between a call to
 187    --  open and a call to close which protect the whole operation.
 188    --  Otherwise, two simultaneous operations can result in the
 189    --  raising of exception Data_Error by setting the access mode of
 190    --  the variable in an incorrect mode.
 191
 192    ---------------
 193    -- Enter_SFE --
 194    ---------------
 195
 196    procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is
 197       Freed : Shared_Var_File_Entry_Ptr;
 198
 199    begin
 200       SFE.Name := new String'(Fname);
 201
 202       --  Release least recently used entry if we have to
 203
 204       if Shared_Var_Files_Open =  Max_Shared_Var_Files then
 205          Freed := LRU_Head;
 206
 207          if Freed.Next /= null then
 208             Freed.Next.Prev := null;
 209          end if;
 210
 211          LRU_Head := Freed.Next;
 212          SFT.Remove (Freed.Name);
 213          SIO.Close (Freed.Stream.File);
 214          Free (Freed.Name);
 215          Free (Freed.Stream);
 216          Free (Freed);
 217
 218       else
 219          Shared_Var_Files_Open := Shared_Var_Files_Open + 1;
 220       end if;
 221
 222       --  Add new entry to hash table
 223
 224       SFT.Set (SFE.Name, SFE);
 225
 226       --  Add new entry at end of LRU chain
 227
 228       if LRU_Head = null then
 229          LRU_Head := SFE;
 230          LRU_Tail := SFE;
 231
 232       else
 233          SFE.Prev := LRU_Tail;
 234          LRU_Tail.Next := SFE;
 235          LRU_Tail := SFE;
 236       end if;
 237    end Enter_SFE;
 238
 239    -----------
 240    -- Equal --
 241    -----------
 242
 243    function Equal (F1, F2 : String_Access) return Boolean is
 244    begin
 245       return F1.all = F2.all;
 246    end Equal;
 247
 248    ----------
 249    -- Hash --
 250    ----------
 251
 252    function Hash (F : String_Access) return Hash_Header is
 253       N : Natural := 0;
 254
 255    begin
 256       --  Add up characters of name, mod our table size
 257
 258       for J in F'Range loop
 259          N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
 260       end loop;
 261
 262       return N;
 263    end Hash;
 264
 265    ----------------
 266    -- Initialize --
 267    ----------------
 268
 269    procedure Initialize is
 270       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
 271       pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
 272
 273       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 274       pragma Import (C, Strncpy, "strncpy");
 275
 276       Dir_Name : aliased constant String :=
 277                    "SHARED_MEMORY_DIRECTORY" & ASCII.NUL;
 278
 279       Env_Value_Ptr    : aliased Address;
 280       Env_Value_Length : aliased Integer;
 281
 282    begin
 283       if Dir = null then
 284          Get_Env_Value_Ptr
 285            (Dir_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
 286
 287          Dir := new String (1 .. Env_Value_Length);
 288
 289          if Env_Value_Length > 0 then
 290             Strncpy (Dir.all'Address, Env_Value_Ptr, Env_Value_Length);
 291          end if;
 292
 293          System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
 294       end if;
 295    end Initialize;
 296
 297    ----------
 298    -- Read --
 299    ----------
 300
 301    procedure Read
 302      (Stream : in out File_Stream_Type;
 303       Item   : out AS.Stream_Element_Array;
 304       Last   : out AS.Stream_Element_Offset)
 305    is
 306    begin
 307       SIO.Read (Stream.File, Item, Last);
 308
 309    exception when others =>
 310       Last := Item'Last;
 311    end Read;
 312
 313    --------------
 314    -- Retrieve --
 315    --------------
 316
 317    function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is
 318       SFE : Shared_Var_File_Entry_Ptr;
 319
 320    begin
 321       Initialize;
 322       SFE := SFT.Get (File'Unrestricted_Access);
 323
 324       if SFE /= null then
 325
 326          --  Move to head of LRU chain
 327
 328          if SFE = LRU_Tail then
 329             null;
 330
 331          elsif SFE = LRU_Head then
 332             LRU_Head := LRU_Head.Next;
 333             LRU_Head.Prev := null;
 334
 335          else
 336             SFE.Next.Prev := SFE.Prev;
 337             SFE.Prev.Next := SFE.Next;
 338          end if;
 339
 340          SFE.Next := null;
 341          SFE.Prev := LRU_Tail;
 342          LRU_Tail.Next := SFE;
 343          LRU_Tail := SFE;
 344       end if;
 345
 346       return SFE;
 347    end Retrieve;
 348
 349    ----------------------
 350    -- Shared_Var_Close --
 351    ----------------------
 352
 353    procedure Shared_Var_Close (Var : SIO.Stream_Access) is
 354       pragma Warnings (Off, Var);
 355
 356    begin
 357       System.Soft_Links.Unlock_Task.all;
 358    end Shared_Var_Close;
 359
 360    ---------------------
 361    -- Shared_Var_Lock --
 362    ---------------------
 363
 364    procedure Shared_Var_Lock (Var : String) is
 365       pragma Warnings (Off, Var);
 366
 367    begin
 368       System.Soft_Links.Lock_Task.all;
 369       Initialize;
 370
 371       if Lock_Count /= 0 then
 372          Lock_Count := Lock_Count + 1;
 373          System.Soft_Links.Unlock_Task.all;
 374
 375       else
 376          Lock_Count := 1;
 377          System.Soft_Links.Unlock_Task.all;
 378          System.Global_Locks.Acquire_Lock (Global_Lock);
 379       end if;
 380
 381    exception
 382       when others =>
 383          System.Soft_Links.Unlock_Task.all;
 384          raise;
 385    end Shared_Var_Lock;
 386
 387    ----------------------
 388    -- Shared_Var_Procs --
 389    ----------------------
 390
 391    package body Shared_Var_Procs is
 392
 393       use type SIO.Stream_Access;
 394
 395       ----------
 396       -- Read --
 397       ----------
 398
 399       procedure Read is
 400          S : SIO.Stream_Access := null;
 401       begin
 402          S := Shared_Var_ROpen (Full_Name);
 403          if S /= null then
 404             Typ'Read (S, V);
 405             Shared_Var_Close (S);
 406          end if;
 407       end Read;
 408
 409       ------------
 410       -- Write --
 411       ------------
 412
 413       procedure Write is
 414          S : SIO.Stream_Access := null;
 415       begin
 416          S := Shared_Var_WOpen (Full_Name);
 417          Typ'Write (S, V);
 418          Shared_Var_Close (S);
 419          return;
 420       end Write;
 421
 422    end Shared_Var_Procs;
 423
 424    ----------------------
 425    -- Shared_Var_ROpen --
 426    ----------------------
 427
 428    function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is
 429       SFE : Shared_Var_File_Entry_Ptr;
 430
 431       use type Ada.Streams.Stream_IO.File_Mode;
 432
 433    begin
 434       System.Soft_Links.Lock_Task.all;
 435       SFE := Retrieve (Var);
 436
 437       --  Here if file is not already open, try to open it
 438
 439       if SFE = null then
 440          declare
 441             S  : aliased constant String := Dir.all & Var;
 442
 443          begin
 444             SFE := new Shared_Var_File_Entry;
 445             SFE.Stream := new File_Stream_Type;
 446             SIO.Open (SFE.Stream.File, SIO.In_File, Name => S);
 447             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 448
 449             --  File opened successfully, put new entry in hash table. Note
 450             --  that in this case, file is positioned correctly for read.
 451
 452             Enter_SFE (SFE, Var);
 453
 454             exception
 455                --  If we get an exception, it means that the file does not
 456                --  exist, and in this case, we don't need the SFE and we
 457                --  return null;
 458
 459                when IOX.Name_Error =>
 460                   Free (SFE);
 461                   System.Soft_Links.Unlock_Task.all;
 462                   return null;
 463          end;
 464
 465       --  Here if file is already open, set file for reading
 466
 467       else
 468          if SIO.Mode (SFE.Stream.File) /= SIO.In_File then
 469             SIO.Set_Mode (SFE.Stream.File, SIO.In_File);
 470             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 471          end if;
 472
 473          SIO.Set_Index (SFE.Stream.File, 1);
 474       end if;
 475
 476       return SIO.Stream_Access (SFE.Stream);
 477
 478    exception
 479       when others =>
 480          System.Soft_Links.Unlock_Task.all;
 481          raise;
 482    end Shared_Var_ROpen;
 483
 484    -----------------------
 485    -- Shared_Var_Unlock --
 486    -----------------------
 487
 488    procedure Shared_Var_Unlock (Var : String) is
 489       pragma Warnings (Off, Var);
 490
 491    begin
 492       System.Soft_Links.Lock_Task.all;
 493       Initialize;
 494       Lock_Count := Lock_Count - 1;
 495
 496       if Lock_Count = 0 then
 497          System.Global_Locks.Release_Lock (Global_Lock);
 498       end if;
 499       System.Soft_Links.Unlock_Task.all;
 500
 501    exception
 502       when others =>
 503          System.Soft_Links.Unlock_Task.all;
 504          raise;
 505    end Shared_Var_Unlock;
 506
 507    ---------------------
 508    -- Share_Var_WOpen --
 509    ---------------------
 510
 511    function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is
 512       SFE : Shared_Var_File_Entry_Ptr;
 513
 514       use type Ada.Streams.Stream_IO.File_Mode;
 515
 516    begin
 517       System.Soft_Links.Lock_Task.all;
 518       SFE := Retrieve (Var);
 519
 520       if SFE = null then
 521          declare
 522             S  : aliased constant String := Dir.all & Var;
 523
 524          begin
 525             SFE := new Shared_Var_File_Entry;
 526             SFE.Stream := new File_Stream_Type;
 527             SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S);
 528             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 529
 530          exception
 531             --  If we get an exception, it means that the file does not
 532             --  exist, and in this case, we create the file.
 533
 534             when IOX.Name_Error =>
 535
 536                begin
 537                   SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
 538
 539                exception
 540                   --  Error if we cannot create the file
 541
 542                   when others =>
 543                      raise Program_Error with
 544                         "Cannot create shared variable file for """ & S & '"';
 545                end;
 546          end;
 547
 548          --  Make new hash table entry for opened/created file. Note that
 549          --  in both cases, the file is already in write mode at the start
 550          --  of the file, ready to be written.
 551
 552          Enter_SFE (SFE, Var);
 553
 554       --  Here if file is already open, set file for writing
 555
 556       else
 557          if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then
 558             SIO.Set_Mode (SFE.Stream.File, SIO.Out_File);
 559             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 560          end if;
 561
 562          SIO.Set_Index (SFE.Stream.File, 1);
 563       end if;
 564
 565       return SIO.Stream_Access (SFE.Stream);
 566
 567    exception
 568       when others =>
 569          System.Soft_Links.Unlock_Task.all;
 570          raise;
 571    end Shared_Var_WOpen;
 572
 573    -----------
 574    -- Write --
 575    -----------
 576
 577    procedure Write
 578      (Stream : in out File_Stream_Type;
 579       Item   : AS.Stream_Element_Array)
 580    is
 581    begin
 582       SIO.Write (Stream.File, Item);
 583    end Write;
 584
 585 end System.Shared_Storage;