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-2008, 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.IO_Exceptions;
  35 with Ada.Streams;
  36 with Ada.Streams.Stream_IO;
  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 Ada.Unchecked_Deallocation;
  47 with Ada.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    package SIO renames Ada.Streams.Stream_IO;
  60
  61    type String_Access is access String;
  62    procedure Free is new Ada.Unchecked_Deallocation
  63      (Object => String, Name => String_Access);
  64
  65    Dir : String_Access;
  66    --  Holds the directory
  67
  68    ------------------------------------------------
  69    -- Variables for Shared Variable Access Files --
  70    ------------------------------------------------
  71
  72    Max_Shared_Var_Files : constant := 20;
  73    --  Maximum number of lock files that can be open
  74
  75    Shared_Var_Files_Open : Natural := 0;
  76    --  Number of shared variable access files currently open
  77
  78    type File_Stream_Type is new AS.Root_Stream_Type with record
  79       File : SIO.File_Type;
  80    end record;
  81    type File_Stream_Access is access all File_Stream_Type'Class;
  82
  83    procedure Read
  84      (Stream : in out File_Stream_Type;
  85       Item   : out AS.Stream_Element_Array;
  86       Last   : out AS.Stream_Element_Offset);
  87
  88    procedure Write
  89      (Stream : in out File_Stream_Type;
  90       Item   : AS.Stream_Element_Array);
  91
  92    subtype Hash_Header is Natural range 0 .. 30;
  93    --  Number of hash headers, related (for efficiency purposes only)
  94    --  to the maximum number of lock files..
  95
  96    type Shared_Var_File_Entry;
  97    type Shared_Var_File_Entry_Ptr is access Shared_Var_File_Entry;
  98
  99    type Shared_Var_File_Entry is record
 100       Name : String_Access;
 101       --  Name of variable, as passed to Read_File/Write_File routines
 102
 103       Stream : File_Stream_Access;
 104       --  Stream_IO file for the shared variable file
 105
 106       Next : Shared_Var_File_Entry_Ptr;
 107       Prev : Shared_Var_File_Entry_Ptr;
 108       --  Links for LRU chain
 109    end record;
 110
 111    procedure Free is new Ada.Unchecked_Deallocation
 112      (Object => Shared_Var_File_Entry,
 113       Name   => Shared_Var_File_Entry_Ptr);
 114
 115    procedure Free is new Ada.Unchecked_Deallocation
 116      (Object => File_Stream_Type'Class,
 117       Name   => File_Stream_Access);
 118
 119    function To_AFCB_Ptr is
 120      new Ada.Unchecked_Conversion (SIO.File_Type, FCB.AFCB_Ptr);
 121
 122    LRU_Head : Shared_Var_File_Entry_Ptr;
 123    LRU_Tail : Shared_Var_File_Entry_Ptr;
 124    --  As lock files are opened, they are organized into a least recently
 125    --  used chain, which is a doubly linked list using the Next and Prev
 126    --  fields of Shared_Var_File_Entry records. The field LRU_Head points
 127    --  to the least recently used entry, whose prev pointer is null, and
 128    --  LRU_Tail points to the most recently used entry, whose next pointer
 129    --  is null. These pointers are null only if the list is empty.
 130
 131    function Hash  (F : String_Access)      return Hash_Header;
 132    function Equal (F1, F2 : String_Access) return Boolean;
 133    --  Hash and equality functions for hash table
 134
 135    package SFT is new System.HTable.Simple_HTable
 136      (Header_Num => Hash_Header,
 137       Element    => Shared_Var_File_Entry_Ptr,
 138       No_Element => null,
 139       Key        => String_Access,
 140       Hash       => Hash,
 141       Equal      => Equal);
 142
 143    --------------------------------
 144    -- Variables for Lock Control --
 145    --------------------------------
 146
 147    Global_Lock : Global_Locks.Lock_Type;
 148
 149    Lock_Count : Natural := 0;
 150    --  Counts nesting of lock calls, 0 means lock is not held
 151
 152    -----------------------
 153    -- Local Subprograms --
 154    -----------------------
 155
 156    procedure Initialize;
 157    --  Called to initialize data structures for this package.
 158    --  Has no effect except on the first call.
 159
 160    procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String);
 161    --  The first parameter is a pointer to a newly allocated SFE, whose
 162    --  File field is already set appropriately. Fname is the name of the
 163    --  variable as passed to Shared_Var_RFile/Shared_Var_WFile. Enter_SFE
 164    --  completes the SFE value, and enters it into the hash table. If the
 165    --  hash table is already full, the least recently used entry is first
 166    --  closed and discarded.
 167
 168    function Retrieve (File : String) return Shared_Var_File_Entry_Ptr;
 169    --  Given a file name, this function searches the hash table to see if
 170    --  the file is currently open. If so, then a pointer to the already
 171    --  created entry is returned, after first moving it to the head of
 172    --  the LRU chain. If not, then null is returned.
 173
 174    function Shared_Var_ROpen (Var : String) return SIO.Stream_Access;
 175    --  As described above, this routine returns null if the
 176    --  corresponding shared storage does not exist, and otherwise, if
 177    --  the storage does exist, a Stream_Access value that references
 178    --  the shared storage, ready to read the current value.
 179
 180    function Shared_Var_WOpen (Var : String) return SIO.Stream_Access;
 181    --  As described above, this routine returns a Stream_Access value
 182    --  that references the shared storage, ready to write the new
 183    --  value. The storage is created by this call if it does not
 184    --  already exist.
 185
 186    procedure Shared_Var_Close (Var : SIO.Stream_Access);
 187    --  This routine signals the end of a read/assign operation. It can
 188    --  be useful to embrace a read/write operation between a call to
 189    --  open and a call to close which protect the whole operation.
 190    --  Otherwise, two simultaneous operations can result in the
 191    --  raising of exception Data_Error by setting the access mode of
 192    --  the variable in an incorrect mode.
 193
 194    ---------------
 195    -- Enter_SFE --
 196    ---------------
 197
 198    procedure Enter_SFE (SFE : Shared_Var_File_Entry_Ptr; Fname : String) is
 199       Freed : Shared_Var_File_Entry_Ptr;
 200
 201    begin
 202       SFE.Name := new String'(Fname);
 203
 204       --  Release least recently used entry if we have to
 205
 206       if Shared_Var_Files_Open =  Max_Shared_Var_Files then
 207          Freed := LRU_Head;
 208
 209          if Freed.Next /= null then
 210             Freed.Next.Prev := null;
 211          end if;
 212
 213          LRU_Head := Freed.Next;
 214          SFT.Remove (Freed.Name);
 215          SIO.Close (Freed.Stream.File);
 216          Free (Freed.Name);
 217          Free (Freed.Stream);
 218          Free (Freed);
 219
 220       else
 221          Shared_Var_Files_Open := Shared_Var_Files_Open + 1;
 222       end if;
 223
 224       --  Add new entry to hash table
 225
 226       SFT.Set (SFE.Name, SFE);
 227
 228       --  Add new entry at end of LRU chain
 229
 230       if LRU_Head = null then
 231          LRU_Head := SFE;
 232          LRU_Tail := SFE;
 233
 234       else
 235          SFE.Prev := LRU_Tail;
 236          LRU_Tail.Next := SFE;
 237          LRU_Tail := SFE;
 238       end if;
 239    end Enter_SFE;
 240
 241    -----------
 242    -- Equal --
 243    -----------
 244
 245    function Equal (F1, F2 : String_Access) return Boolean is
 246    begin
 247       return F1.all = F2.all;
 248    end Equal;
 249
 250    ----------
 251    -- Hash --
 252    ----------
 253
 254    function Hash (F : String_Access) return Hash_Header is
 255       N : Natural := 0;
 256
 257    begin
 258       --  Add up characters of name, mod our table size
 259
 260       for J in F'Range loop
 261          N := (N + Character'Pos (F (J))) mod (Hash_Header'Last + 1);
 262       end loop;
 263
 264       return N;
 265    end Hash;
 266
 267    ----------------
 268    -- Initialize --
 269    ----------------
 270
 271    procedure Initialize is
 272       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
 273       pragma Import (C, Get_Env_Value_Ptr, "__gnat_getenv");
 274
 275       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
 276       pragma Import (C, Strncpy, "strncpy");
 277
 278       Dir_Name : aliased constant String :=
 279                    "SHARED_MEMORY_DIRECTORY" & ASCII.NUL;
 280
 281       Env_Value_Ptr    : aliased Address;
 282       Env_Value_Length : aliased Integer;
 283
 284    begin
 285       if Dir = null then
 286          Get_Env_Value_Ptr
 287            (Dir_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
 288
 289          Dir := new String (1 .. Env_Value_Length);
 290
 291          if Env_Value_Length > 0 then
 292             Strncpy (Dir.all'Address, Env_Value_Ptr, Env_Value_Length);
 293          end if;
 294
 295          System.Global_Locks.Create_Lock (Global_Lock, Dir.all & "__lock");
 296       end if;
 297    end Initialize;
 298
 299    ----------
 300    -- Read --
 301    ----------
 302
 303    procedure Read
 304      (Stream : in out File_Stream_Type;
 305       Item   : out AS.Stream_Element_Array;
 306       Last   : out AS.Stream_Element_Offset)
 307    is
 308    begin
 309       SIO.Read (Stream.File, Item, Last);
 310
 311    exception when others =>
 312       Last := Item'Last;
 313    end Read;
 314
 315    --------------
 316    -- Retrieve --
 317    --------------
 318
 319    function Retrieve (File : String) return Shared_Var_File_Entry_Ptr is
 320       SFE : Shared_Var_File_Entry_Ptr;
 321
 322    begin
 323       Initialize;
 324       SFE := SFT.Get (File'Unrestricted_Access);
 325
 326       if SFE /= null then
 327
 328          --  Move to head of LRU chain
 329
 330          if SFE = LRU_Tail then
 331             null;
 332
 333          elsif SFE = LRU_Head then
 334             LRU_Head := LRU_Head.Next;
 335             LRU_Head.Prev := null;
 336
 337          else
 338             SFE.Next.Prev := SFE.Prev;
 339             SFE.Prev.Next := SFE.Next;
 340          end if;
 341
 342          SFE.Next := null;
 343          SFE.Prev := LRU_Tail;
 344          LRU_Tail.Next := SFE;
 345          LRU_Tail := SFE;
 346       end if;
 347
 348       return SFE;
 349    end Retrieve;
 350
 351    ----------------------
 352    -- Shared_Var_Close --
 353    ----------------------
 354
 355    procedure Shared_Var_Close (Var : SIO.Stream_Access) is
 356       pragma Warnings (Off, Var);
 357
 358    begin
 359       System.Soft_Links.Unlock_Task.all;
 360    end Shared_Var_Close;
 361
 362    ---------------------
 363    -- Shared_Var_Lock --
 364    ---------------------
 365
 366    procedure Shared_Var_Lock (Var : String) is
 367       pragma Warnings (Off, Var);
 368
 369    begin
 370       System.Soft_Links.Lock_Task.all;
 371       Initialize;
 372
 373       if Lock_Count /= 0 then
 374          Lock_Count := Lock_Count + 1;
 375          System.Soft_Links.Unlock_Task.all;
 376
 377       else
 378          Lock_Count := 1;
 379          System.Soft_Links.Unlock_Task.all;
 380          System.Global_Locks.Acquire_Lock (Global_Lock);
 381       end if;
 382
 383    exception
 384       when others =>
 385          System.Soft_Links.Unlock_Task.all;
 386          raise;
 387    end Shared_Var_Lock;
 388
 389    ----------------------
 390    -- Shared_Var_Procs --
 391    ----------------------
 392
 393    package body Shared_Var_Procs is
 394
 395       use type SIO.Stream_Access;
 396
 397       ----------
 398       -- Read --
 399       ----------
 400
 401       procedure Read is
 402          S : SIO.Stream_Access := null;
 403       begin
 404          S := Shared_Var_ROpen (Full_Name);
 405          if S /= null then
 406             Typ'Read (S, V);
 407             Shared_Var_Close (S);
 408          end if;
 409       end Read;
 410
 411       ------------
 412       -- Write --
 413       ------------
 414
 415       procedure Write is
 416          S : SIO.Stream_Access := null;
 417       begin
 418          S := Shared_Var_WOpen (Full_Name);
 419          Typ'Write (S, V);
 420          Shared_Var_Close (S);
 421          return;
 422       end Write;
 423
 424    end Shared_Var_Procs;
 425
 426    ----------------------
 427    -- Shared_Var_ROpen --
 428    ----------------------
 429
 430    function Shared_Var_ROpen (Var : String) return SIO.Stream_Access is
 431       SFE : Shared_Var_File_Entry_Ptr;
 432
 433       use type Ada.Streams.Stream_IO.File_Mode;
 434
 435    begin
 436       System.Soft_Links.Lock_Task.all;
 437       SFE := Retrieve (Var);
 438
 439       --  Here if file is not already open, try to open it
 440
 441       if SFE = null then
 442          declare
 443             S  : aliased constant String := Dir.all & Var;
 444
 445          begin
 446             SFE := new Shared_Var_File_Entry;
 447             SFE.Stream := new File_Stream_Type;
 448             SIO.Open (SFE.Stream.File, SIO.In_File, Name => S);
 449             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 450
 451             --  File opened successfully, put new entry in hash table. Note
 452             --  that in this case, file is positioned correctly for read.
 453
 454             Enter_SFE (SFE, Var);
 455
 456             exception
 457                --  If we get an exception, it means that the file does not
 458                --  exist, and in this case, we don't need the SFE and we
 459                --  return null;
 460
 461                when IOX.Name_Error =>
 462                   Free (SFE);
 463                   System.Soft_Links.Unlock_Task.all;
 464                   return null;
 465          end;
 466
 467       --  Here if file is already open, set file for reading
 468
 469       else
 470          if SIO.Mode (SFE.Stream.File) /= SIO.In_File then
 471             SIO.Set_Mode (SFE.Stream.File, SIO.In_File);
 472             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 473          end if;
 474
 475          SIO.Set_Index (SFE.Stream.File, 1);
 476       end if;
 477
 478       return SIO.Stream_Access (SFE.Stream);
 479
 480    exception
 481       when others =>
 482          System.Soft_Links.Unlock_Task.all;
 483          raise;
 484    end Shared_Var_ROpen;
 485
 486    -----------------------
 487    -- Shared_Var_Unlock --
 488    -----------------------
 489
 490    procedure Shared_Var_Unlock (Var : String) is
 491       pragma Warnings (Off, Var);
 492
 493    begin
 494       System.Soft_Links.Lock_Task.all;
 495       Initialize;
 496       Lock_Count := Lock_Count - 1;
 497
 498       if Lock_Count = 0 then
 499          System.Global_Locks.Release_Lock (Global_Lock);
 500       end if;
 501       System.Soft_Links.Unlock_Task.all;
 502
 503    exception
 504       when others =>
 505          System.Soft_Links.Unlock_Task.all;
 506          raise;
 507    end Shared_Var_Unlock;
 508
 509    ---------------------
 510    -- Share_Var_WOpen --
 511    ---------------------
 512
 513    function Shared_Var_WOpen (Var : String) return SIO.Stream_Access is
 514       SFE : Shared_Var_File_Entry_Ptr;
 515
 516       use type Ada.Streams.Stream_IO.File_Mode;
 517
 518    begin
 519       System.Soft_Links.Lock_Task.all;
 520       SFE := Retrieve (Var);
 521
 522       if SFE = null then
 523          declare
 524             S  : aliased constant String := Dir.all & Var;
 525
 526          begin
 527             SFE := new Shared_Var_File_Entry;
 528             SFE.Stream := new File_Stream_Type;
 529             SIO.Open (SFE.Stream.File, SIO.Out_File, Name => S);
 530             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 531
 532          exception
 533             --  If we get an exception, it means that the file does not
 534             --  exist, and in this case, we create the file.
 535
 536             when IOX.Name_Error =>
 537
 538                begin
 539                   SIO.Create (SFE.Stream.File, SIO.Out_File, Name => S);
 540
 541                exception
 542                   --  Error if we cannot create the file
 543
 544                   when others =>
 545                      raise Program_Error with
 546                         "Cannot create shared variable file for """ & S & '"';
 547                end;
 548          end;
 549
 550          --  Make new hash table entry for opened/created file. Note that
 551          --  in both cases, the file is already in write mode at the start
 552          --  of the file, ready to be written.
 553
 554          Enter_SFE (SFE, Var);
 555
 556       --  Here if file is already open, set file for writing
 557
 558       else
 559          if SIO.Mode (SFE.Stream.File) /= SIO.Out_File then
 560             SIO.Set_Mode (SFE.Stream.File, SIO.Out_File);
 561             SFI.Make_Unbuffered (To_AFCB_Ptr (SFE.Stream.File));
 562          end if;
 563
 564          SIO.Set_Index (SFE.Stream.File, 1);
 565       end if;
 566
 567       return SIO.Stream_Access (SFE.Stream);
 568
 569    exception
 570       when others =>
 571          System.Soft_Links.Unlock_Task.all;
 572          raise;
 573    end Shared_Var_WOpen;
 574
 575    -----------
 576    -- Write --
 577    -----------
 578
 579    procedure Write
 580      (Stream : in out File_Stream_Type;
 581       Item   : AS.Stream_Element_Array)
 582    is
 583    begin
 584       SIO.Write (Stream.File, Item);
 585    end Write;
 586
 587 end System.Shared_Storage;