1------------------------------------------------------------------------------
2--                                                                          --
3--                         GNAT COMPILER COMPONENTS                         --
4--                                                                          --
5--           S Y S T E M . F I N A L I Z A T I O N _ M A S T E R S          --
6--                                                                          --
7--                                 B o d y                                  --
8--                                                                          --
9--             Copyright (C) 2015-2019, 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
32with Ada.Exceptions; use Ada.Exceptions;
33
34with System.Address_Image;
35with System.HTable;           use System.HTable;
36with System.IO;               use System.IO;
37with System.Soft_Links;       use System.Soft_Links;
38with System.Storage_Elements; use System.Storage_Elements;
39
40package body System.Finalization_Masters is
41
42   --  Finalize_Address hash table types. In general, masters are homogeneous
43   --  collections of controlled objects. Rare cases such as allocations on a
44   --  subpool require heterogeneous masters. The following table provides a
45   --  relation between object address and its Finalize_Address routine.
46
47   type Header_Num is range 0 .. 127;
48
49   function Hash (Key : System.Address) return Header_Num;
50
51   --  Address --> Finalize_Address_Ptr
52
53   package Finalize_Address_Table is new Simple_HTable
54     (Header_Num => Header_Num,
55      Element    => Finalize_Address_Ptr,
56      No_Element => null,
57      Key        => System.Address,
58      Hash       => Hash,
59      Equal      => "=");
60
61   ---------------------------
62   -- Add_Offset_To_Address --
63   ---------------------------
64
65   function Add_Offset_To_Address
66     (Addr   : System.Address;
67      Offset : System.Storage_Elements.Storage_Offset) return System.Address
68   is
69   begin
70      return System.Storage_Elements."+" (Addr, Offset);
71   end Add_Offset_To_Address;
72
73   ------------
74   -- Attach --
75   ------------
76
77   procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
78   begin
79      Lock_Task.all;
80      Attach_Unprotected (N, L);
81      Unlock_Task.all;
82
83      --  Note: No need to unlock in case of an exception because the above
84      --  code can never raise one.
85   end Attach;
86
87   ------------------------
88   -- Attach_Unprotected --
89   ------------------------
90
91   procedure Attach_Unprotected
92     (N : not null FM_Node_Ptr;
93      L : not null FM_Node_Ptr)
94   is
95   begin
96      L.Next.Prev := N;
97      N.Next := L.Next;
98      L.Next := N;
99      N.Prev := L;
100   end Attach_Unprotected;
101
102   ---------------
103   -- Base_Pool --
104   ---------------
105
106   function Base_Pool
107     (Master : Finalization_Master) return Any_Storage_Pool_Ptr
108   is
109   begin
110      return Master.Base_Pool;
111   end Base_Pool;
112
113   -----------------------------------------
114   -- Delete_Finalize_Address_Unprotected --
115   -----------------------------------------
116
117   procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is
118   begin
119      Finalize_Address_Table.Remove (Obj);
120   end Delete_Finalize_Address_Unprotected;
121
122   ------------
123   -- Detach --
124   ------------
125
126   procedure Detach (N : not null FM_Node_Ptr) is
127   begin
128      Lock_Task.all;
129      Detach_Unprotected (N);
130      Unlock_Task.all;
131
132      --  Note: No need to unlock in case of an exception because the above
133      --  code can never raise one.
134   end Detach;
135
136   ------------------------
137   -- Detach_Unprotected --
138   ------------------------
139
140   procedure Detach_Unprotected (N : not null FM_Node_Ptr) is
141   begin
142      if N.Prev /= null and then N.Next /= null then
143         N.Prev.Next := N.Next;
144         N.Next.Prev := N.Prev;
145         N.Prev := null;
146         N.Next := null;
147      end if;
148   end Detach_Unprotected;
149
150   --------------
151   -- Finalize --
152   --------------
153
154   overriding procedure Finalize (Master : in out Finalization_Master) is
155      Cleanup  : Finalize_Address_Ptr;
156      Curr_Ptr : FM_Node_Ptr;
157      Ex_Occur : Exception_Occurrence;
158      Obj_Addr : Address;
159      Raised   : Boolean := False;
160
161      function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean;
162      --  Determine whether a list contains only one element, the dummy head
163
164      -------------------
165      -- Is_Empty_List --
166      -------------------
167
168      function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is
169      begin
170         return L.Next = L and then L.Prev = L;
171      end Is_Empty_List;
172
173   --  Start of processing for Finalize
174
175   begin
176      Lock_Task.all;
177
178      --  Synchronization:
179      --    Read  - allocation, finalization
180      --    Write - finalization
181
182      if Master.Finalization_Started then
183         Unlock_Task.all;
184
185         --  Double finalization may occur during the handling of stand alone
186         --  libraries or the finalization of a pool with subpools. Due to the
187         --  potential aliasing of masters in these two cases, do not process
188         --  the same master twice.
189
190         return;
191      end if;
192
193      --  Lock the master to prevent any allocations while the objects are
194      --  being finalized. The master remains locked because either the master
195      --  is explicitly deallocated or the associated access type is about to
196      --  go out of scope.
197
198      --  Synchronization:
199      --    Read  - allocation, finalization
200      --    Write - finalization
201
202      Master.Finalization_Started := True;
203
204      while not Is_Empty_List (Master.Objects'Unchecked_Access) loop
205         Curr_Ptr := Master.Objects.Next;
206
207         --  Synchronization:
208         --    Write - allocation, deallocation, finalization
209
210         Detach_Unprotected (Curr_Ptr);
211
212         --  Skip the list header in order to offer proper object layout for
213         --  finalization.
214
215         Obj_Addr := Curr_Ptr.all'Address + Header_Size;
216
217         --  Retrieve TSS primitive Finalize_Address depending on the master's
218         --  mode of operation.
219
220         --  Synchronization:
221         --    Read  - allocation, finalization
222         --    Write - outside
223
224         if Master.Is_Homogeneous then
225
226            --  Synchronization:
227            --    Read  - finalization
228            --    Write - allocation, outside
229
230            Cleanup := Master.Finalize_Address;
231
232         else
233            --  Synchronization:
234            --    Read  - finalization
235            --    Write - allocation, deallocation
236
237            Cleanup := Finalize_Address_Unprotected (Obj_Addr);
238         end if;
239
240         begin
241            Cleanup (Obj_Addr);
242         exception
243            when Fin_Occur : others =>
244               if not Raised then
245                  Raised := True;
246                  Save_Occurrence (Ex_Occur, Fin_Occur);
247               end if;
248         end;
249
250         --  When the master is a heterogeneous collection, destroy the object
251         --  - Finalize_Address pair since it is no longer needed.
252
253         --  Synchronization:
254         --    Read  - finalization
255         --    Write - outside
256
257         if not Master.Is_Homogeneous then
258
259            --  Synchronization:
260            --    Read  - finalization
261            --    Write - allocation, deallocation, finalization
262
263            Delete_Finalize_Address_Unprotected (Obj_Addr);
264         end if;
265      end loop;
266
267      Unlock_Task.all;
268
269      --  If the finalization of a particular object failed or Finalize_Address
270      --  was not set, reraise the exception now.
271
272      if Raised then
273         Reraise_Occurrence (Ex_Occur);
274      end if;
275   end Finalize;
276
277   ----------------------
278   -- Finalize_Address --
279   ----------------------
280
281   function Finalize_Address
282     (Master : Finalization_Master) return Finalize_Address_Ptr
283   is
284   begin
285      return Master.Finalize_Address;
286   end Finalize_Address;
287
288   ----------------------------------
289   -- Finalize_Address_Unprotected --
290   ----------------------------------
291
292   function Finalize_Address_Unprotected
293     (Obj : System.Address) return Finalize_Address_Ptr
294   is
295   begin
296      return Finalize_Address_Table.Get (Obj);
297   end Finalize_Address_Unprotected;
298
299   --------------------------
300   -- Finalization_Started --
301   --------------------------
302
303   function Finalization_Started
304     (Master : Finalization_Master) return Boolean
305   is
306   begin
307      return Master.Finalization_Started;
308   end Finalization_Started;
309
310   ----------
311   -- Hash --
312   ----------
313
314   function Hash (Key : System.Address) return Header_Num is
315   begin
316      return
317        Header_Num
318          (To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
319   end Hash;
320
321   -----------------
322   -- Header_Size --
323   -----------------
324
325   function Header_Size return System.Storage_Elements.Storage_Count is
326   begin
327      return FM_Node'Size / Storage_Unit;
328   end Header_Size;
329
330   ----------------
331   -- Initialize --
332   ----------------
333
334   overriding procedure Initialize (Master : in out Finalization_Master) is
335   begin
336      --  The dummy head must point to itself in both directions
337
338      Master.Objects.Next := Master.Objects'Unchecked_Access;
339      Master.Objects.Prev := Master.Objects'Unchecked_Access;
340   end Initialize;
341
342   --------------------
343   -- Is_Homogeneous --
344   --------------------
345
346   function Is_Homogeneous (Master : Finalization_Master) return Boolean is
347   begin
348      return Master.Is_Homogeneous;
349   end Is_Homogeneous;
350
351   -------------
352   -- Objects --
353   -------------
354
355   function Objects (Master : Finalization_Master) return FM_Node_Ptr is
356   begin
357      return Master.Objects'Unrestricted_Access;
358   end Objects;
359
360   ------------------
361   -- Print_Master --
362   ------------------
363
364   procedure Print_Master (Master : Finalization_Master) is
365      Head      : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
366      Head_Seen : Boolean := False;
367      N_Ptr     : FM_Node_Ptr;
368
369   begin
370      --  Output the basic contents of a master
371
372      --    Master   : 0x123456789
373      --    Is_Hmgen : TURE <or> FALSE
374      --    Base_Pool: null <or> 0x123456789
375      --    Fin_Addr : null <or> 0x123456789
376      --    Fin_Start: TRUE <or> FALSE
377
378      Put ("Master   : ");
379      Put_Line (Address_Image (Master'Address));
380
381      Put ("Is_Hmgen : ");
382      Put_Line (Master.Is_Homogeneous'Img);
383
384      Put ("Base_Pool: ");
385      if Master.Base_Pool = null then
386         Put_Line ("null");
387      else
388         Put_Line (Address_Image (Master.Base_Pool'Address));
389      end if;
390
391      Put ("Fin_Addr : ");
392      if Master.Finalize_Address = null then
393         Put_Line ("null");
394      else
395         Put_Line (Address_Image (Master.Finalize_Address'Address));
396      end if;
397
398      Put ("Fin_Start: ");
399      Put_Line (Master.Finalization_Started'Img);
400
401      --  Output all chained elements. The format is the following:
402
403      --    ^ <or> ? <or> null
404      --    |Header: 0x123456789 (dummy head)
405      --    |  Prev: 0x123456789
406      --    |  Next: 0x123456789
407      --    V
408
409      --  ^ - the current element points back to the correct element
410      --  ? - the current element points back to an erroneous element
411      --  n - the current element points back to null
412
413      --  Header - the address of the list header
414      --  Prev   - the address of the list header which the current element
415      --           points back to
416      --  Next   - the address of the list header which the current element
417      --           points to
418      --  (dummy head) - present if dummy head
419
420      N_Ptr := Head;
421      while N_Ptr /= null loop  --  Should never be null
422         Put_Line ("V");
423
424         --  We see the head initially; we want to exit when we see the head a
425         --  second time.
426
427         if N_Ptr = Head then
428            exit when Head_Seen;
429
430            Head_Seen := True;
431         end if;
432
433         --  The current element is null. This should never happen since the
434         --  list is circular.
435
436         if N_Ptr.Prev = null then
437            Put_Line ("null (ERROR)");
438
439         --  The current element points back to the correct element
440
441         elsif N_Ptr.Prev.Next = N_Ptr then
442            Put_Line ("^");
443
444         --  The current element points to an erroneous element
445
446         else
447            Put_Line ("? (ERROR)");
448         end if;
449
450         --  Output the header and fields
451
452         Put ("|Header: ");
453         Put (Address_Image (N_Ptr.all'Address));
454
455         --  Detect the dummy head
456
457         if N_Ptr = Head then
458            Put_Line (" (dummy head)");
459         else
460            Put_Line ("");
461         end if;
462
463         Put ("|  Prev: ");
464
465         if N_Ptr.Prev = null then
466            Put_Line ("null");
467         else
468            Put_Line (Address_Image (N_Ptr.Prev.all'Address));
469         end if;
470
471         Put ("|  Next: ");
472
473         if N_Ptr.Next = null then
474            Put_Line ("null");
475         else
476            Put_Line (Address_Image (N_Ptr.Next.all'Address));
477         end if;
478
479         N_Ptr := N_Ptr.Next;
480      end loop;
481   end Print_Master;
482
483   -------------------
484   -- Set_Base_Pool --
485   -------------------
486
487   procedure Set_Base_Pool
488     (Master   : in out Finalization_Master;
489      Pool_Ptr : Any_Storage_Pool_Ptr)
490   is
491   begin
492      Master.Base_Pool := Pool_Ptr;
493   end Set_Base_Pool;
494
495   --------------------------
496   -- Set_Finalize_Address --
497   --------------------------
498
499   procedure Set_Finalize_Address
500     (Master       : in out Finalization_Master;
501      Fin_Addr_Ptr : Finalize_Address_Ptr)
502   is
503   begin
504      --  Synchronization:
505      --    Read  - finalization
506      --    Write - allocation, outside
507
508      Lock_Task.all;
509      Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
510      Unlock_Task.all;
511   end Set_Finalize_Address;
512
513   --------------------------------------
514   -- Set_Finalize_Address_Unprotected --
515   --------------------------------------
516
517   procedure Set_Finalize_Address_Unprotected
518     (Master       : in out Finalization_Master;
519      Fin_Addr_Ptr : Finalize_Address_Ptr)
520   is
521   begin
522      if Master.Finalize_Address = null then
523         Master.Finalize_Address := Fin_Addr_Ptr;
524      end if;
525   end Set_Finalize_Address_Unprotected;
526
527   ----------------------------------------------------
528   -- Set_Heterogeneous_Finalize_Address_Unprotected --
529   ----------------------------------------------------
530
531   procedure Set_Heterogeneous_Finalize_Address_Unprotected
532     (Obj          : System.Address;
533      Fin_Addr_Ptr : Finalize_Address_Ptr)
534   is
535   begin
536      Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
537   end Set_Heterogeneous_Finalize_Address_Unprotected;
538
539   --------------------------
540   -- Set_Is_Heterogeneous --
541   --------------------------
542
543   procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
544   begin
545      --  Synchronization:
546      --    Read  - finalization
547      --    Write - outside
548
549      Lock_Task.all;
550      Master.Is_Homogeneous := False;
551      Unlock_Task.all;
552   end Set_Is_Heterogeneous;
553
554end System.Finalization_Masters;
555