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