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