File : 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-2015, 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 -- --
19 -- --
20 -- --
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;