555 lines
16 KiB
Ada
555 lines
16 KiB
Ada
------------------------------------------------------------------------------
|
|
-- --
|
|
-- GNAT COMPILER COMPONENTS --
|
|
-- --
|
|
-- 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 --
|
|
-- --
|
|
-- B o d y --
|
|
-- --
|
|
-- Copyright (C) 2015, Free Software Foundation, Inc. --
|
|
-- --
|
|
-- GNAT is free software; you can redistribute it and/or modify it under --
|
|
-- terms of the GNU General Public License as published by the Free Soft- --
|
|
-- ware Foundation; either version 3, or (at your option) any later ver- --
|
|
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
|
|
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
|
|
-- or FITNESS FOR A PARTICULAR PURPOSE. --
|
|
-- --
|
|
-- As a special exception under Section 7 of GPL version 3, you are granted --
|
|
-- additional permissions described in the GCC Runtime Library Exception, --
|
|
-- version 3.1, as published by the Free Software Foundation. --
|
|
-- --
|
|
-- You should have received a copy of the GNU General Public License and --
|
|
-- a copy of the GCC Runtime Library Exception along with this program; --
|
|
-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
|
|
-- <http://www.gnu.org/licenses/>. --
|
|
-- --
|
|
-- GNAT was originally developed by the GNAT team at New York University. --
|
|
-- Extensive contributions were provided by Ada Core Technologies Inc. --
|
|
-- --
|
|
------------------------------------------------------------------------------
|
|
|
|
with Ada.Exceptions; use Ada.Exceptions;
|
|
|
|
with System.Address_Image;
|
|
with System.HTable; use System.HTable;
|
|
with System.IO; use System.IO;
|
|
with System.Soft_Links; use System.Soft_Links;
|
|
with System.Storage_Elements; use System.Storage_Elements;
|
|
|
|
package body System.Finalization_Masters is
|
|
|
|
-- Finalize_Address hash table types. In general, masters are homogeneous
|
|
-- collections of controlled objects. Rare cases such as allocations on a
|
|
-- subpool require heterogeneous masters. The following table provides a
|
|
-- relation between object address and its Finalize_Address routine.
|
|
|
|
type Header_Num is range 0 .. 127;
|
|
|
|
function Hash (Key : System.Address) return Header_Num;
|
|
|
|
-- Address --> Finalize_Address_Ptr
|
|
|
|
package Finalize_Address_Table is new Simple_HTable
|
|
(Header_Num => Header_Num,
|
|
Element => Finalize_Address_Ptr,
|
|
No_Element => null,
|
|
Key => System.Address,
|
|
Hash => Hash,
|
|
Equal => "=");
|
|
|
|
---------------------------
|
|
-- Add_Offset_To_Address --
|
|
---------------------------
|
|
|
|
function Add_Offset_To_Address
|
|
(Addr : System.Address;
|
|
Offset : System.Storage_Elements.Storage_Offset) return System.Address
|
|
is
|
|
begin
|
|
return System.Storage_Elements."+" (Addr, Offset);
|
|
end Add_Offset_To_Address;
|
|
|
|
------------
|
|
-- Attach --
|
|
------------
|
|
|
|
procedure Attach (N : not null FM_Node_Ptr; L : not null FM_Node_Ptr) is
|
|
begin
|
|
Lock_Task.all;
|
|
Attach_Unprotected (N, L);
|
|
Unlock_Task.all;
|
|
|
|
-- Note: No need to unlock in case of an exception because the above
|
|
-- code can never raise one.
|
|
end Attach;
|
|
|
|
------------------------
|
|
-- Attach_Unprotected --
|
|
------------------------
|
|
|
|
procedure Attach_Unprotected
|
|
(N : not null FM_Node_Ptr;
|
|
L : not null FM_Node_Ptr)
|
|
is
|
|
begin
|
|
L.Next.Prev := N;
|
|
N.Next := L.Next;
|
|
L.Next := N;
|
|
N.Prev := L;
|
|
end Attach_Unprotected;
|
|
|
|
---------------
|
|
-- Base_Pool --
|
|
---------------
|
|
|
|
function Base_Pool
|
|
(Master : Finalization_Master) return Any_Storage_Pool_Ptr
|
|
is
|
|
begin
|
|
return Master.Base_Pool;
|
|
end Base_Pool;
|
|
|
|
-----------------------------------------
|
|
-- Delete_Finalize_Address_Unprotected --
|
|
-----------------------------------------
|
|
|
|
procedure Delete_Finalize_Address_Unprotected (Obj : System.Address) is
|
|
begin
|
|
Finalize_Address_Table.Remove (Obj);
|
|
end Delete_Finalize_Address_Unprotected;
|
|
|
|
------------
|
|
-- Detach --
|
|
------------
|
|
|
|
procedure Detach (N : not null FM_Node_Ptr) is
|
|
begin
|
|
Lock_Task.all;
|
|
Detach_Unprotected (N);
|
|
Unlock_Task.all;
|
|
|
|
-- Note: No need to unlock in case of an exception because the above
|
|
-- code can never raise one.
|
|
end Detach;
|
|
|
|
------------------------
|
|
-- Detach_Unprotected --
|
|
------------------------
|
|
|
|
procedure Detach_Unprotected (N : not null FM_Node_Ptr) is
|
|
begin
|
|
if N.Prev /= null and then N.Next /= null then
|
|
N.Prev.Next := N.Next;
|
|
N.Next.Prev := N.Prev;
|
|
N.Prev := null;
|
|
N.Next := null;
|
|
end if;
|
|
end Detach_Unprotected;
|
|
|
|
--------------
|
|
-- Finalize --
|
|
--------------
|
|
|
|
overriding procedure Finalize (Master : in out Finalization_Master) is
|
|
Cleanup : Finalize_Address_Ptr;
|
|
Curr_Ptr : FM_Node_Ptr;
|
|
Ex_Occur : Exception_Occurrence;
|
|
Obj_Addr : Address;
|
|
Raised : Boolean := False;
|
|
|
|
function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean;
|
|
-- Determine whether a list contains only one element, the dummy head
|
|
|
|
-------------------
|
|
-- Is_Empty_List --
|
|
-------------------
|
|
|
|
function Is_Empty_List (L : not null FM_Node_Ptr) return Boolean is
|
|
begin
|
|
return L.Next = L and then L.Prev = L;
|
|
end Is_Empty_List;
|
|
|
|
-- Start of processing for Finalize
|
|
|
|
begin
|
|
Lock_Task.all;
|
|
|
|
-- Synchronization:
|
|
-- Read - allocation, finalization
|
|
-- Write - finalization
|
|
|
|
if Master.Finalization_Started then
|
|
Unlock_Task.all;
|
|
|
|
-- Double finalization may occur during the handling of stand alone
|
|
-- libraries or the finalization of a pool with subpools. Due to the
|
|
-- potential aliasing of masters in these two cases, do not process
|
|
-- the same master twice.
|
|
|
|
return;
|
|
end if;
|
|
|
|
-- Lock the master to prevent any allocations while the objects are
|
|
-- being finalized. The master remains locked because either the master
|
|
-- is explicitly deallocated or the associated access type is about to
|
|
-- go out of scope.
|
|
|
|
-- Synchronization:
|
|
-- Read - allocation, finalization
|
|
-- Write - finalization
|
|
|
|
Master.Finalization_Started := True;
|
|
|
|
while not Is_Empty_List (Master.Objects'Unchecked_Access) loop
|
|
Curr_Ptr := Master.Objects.Next;
|
|
|
|
-- Synchronization:
|
|
-- Write - allocation, deallocation, finalization
|
|
|
|
Detach_Unprotected (Curr_Ptr);
|
|
|
|
-- Skip the list header in order to offer proper object layout for
|
|
-- finalization.
|
|
|
|
Obj_Addr := Curr_Ptr.all'Address + Header_Size;
|
|
|
|
-- Retrieve TSS primitive Finalize_Address depending on the master's
|
|
-- mode of operation.
|
|
|
|
-- Synchronization:
|
|
-- Read - allocation, finalization
|
|
-- Write - outside
|
|
|
|
if Master.Is_Homogeneous then
|
|
|
|
-- Synchronization:
|
|
-- Read - finalization
|
|
-- Write - allocation, outside
|
|
|
|
Cleanup := Master.Finalize_Address;
|
|
|
|
else
|
|
-- Synchronization:
|
|
-- Read - finalization
|
|
-- Write - allocation, deallocation
|
|
|
|
Cleanup := Finalize_Address_Unprotected (Obj_Addr);
|
|
end if;
|
|
|
|
begin
|
|
Cleanup (Obj_Addr);
|
|
exception
|
|
when Fin_Occur : others =>
|
|
if not Raised then
|
|
Raised := True;
|
|
Save_Occurrence (Ex_Occur, Fin_Occur);
|
|
end if;
|
|
end;
|
|
|
|
-- When the master is a heterogeneous collection, destroy the object
|
|
-- - Finalize_Address pair since it is no longer needed.
|
|
|
|
-- Synchronization:
|
|
-- Read - finalization
|
|
-- Write - outside
|
|
|
|
if not Master.Is_Homogeneous then
|
|
|
|
-- Synchronization:
|
|
-- Read - finalization
|
|
-- Write - allocation, deallocation, finalization
|
|
|
|
Delete_Finalize_Address_Unprotected (Obj_Addr);
|
|
end if;
|
|
end loop;
|
|
|
|
Unlock_Task.all;
|
|
|
|
-- If the finalization of a particular object failed or Finalize_Address
|
|
-- was not set, reraise the exception now.
|
|
|
|
if Raised then
|
|
Reraise_Occurrence (Ex_Occur);
|
|
end if;
|
|
end Finalize;
|
|
|
|
----------------------
|
|
-- Finalize_Address --
|
|
----------------------
|
|
|
|
function Finalize_Address
|
|
(Master : Finalization_Master) return Finalize_Address_Ptr
|
|
is
|
|
begin
|
|
return Master.Finalize_Address;
|
|
end Finalize_Address;
|
|
|
|
----------------------------------
|
|
-- Finalize_Address_Unprotected --
|
|
----------------------------------
|
|
|
|
function Finalize_Address_Unprotected
|
|
(Obj : System.Address) return Finalize_Address_Ptr
|
|
is
|
|
begin
|
|
return Finalize_Address_Table.Get (Obj);
|
|
end Finalize_Address_Unprotected;
|
|
|
|
--------------------------
|
|
-- Finalization_Started --
|
|
--------------------------
|
|
|
|
function Finalization_Started
|
|
(Master : Finalization_Master) return Boolean
|
|
is
|
|
begin
|
|
return Master.Finalization_Started;
|
|
end Finalization_Started;
|
|
|
|
----------
|
|
-- Hash --
|
|
----------
|
|
|
|
function Hash (Key : System.Address) return Header_Num is
|
|
begin
|
|
return
|
|
Header_Num
|
|
(To_Integer (Key) mod Integer_Address (Header_Num'Range_Length));
|
|
end Hash;
|
|
|
|
-----------------
|
|
-- Header_Size --
|
|
-----------------
|
|
|
|
function Header_Size return System.Storage_Elements.Storage_Count is
|
|
begin
|
|
return FM_Node'Size / Storage_Unit;
|
|
end Header_Size;
|
|
|
|
----------------
|
|
-- Initialize --
|
|
----------------
|
|
|
|
overriding procedure Initialize (Master : in out Finalization_Master) is
|
|
begin
|
|
-- The dummy head must point to itself in both directions
|
|
|
|
Master.Objects.Next := Master.Objects'Unchecked_Access;
|
|
Master.Objects.Prev := Master.Objects'Unchecked_Access;
|
|
end Initialize;
|
|
|
|
--------------------
|
|
-- Is_Homogeneous --
|
|
--------------------
|
|
|
|
function Is_Homogeneous (Master : Finalization_Master) return Boolean is
|
|
begin
|
|
return Master.Is_Homogeneous;
|
|
end Is_Homogeneous;
|
|
|
|
-------------
|
|
-- Objects --
|
|
-------------
|
|
|
|
function Objects (Master : Finalization_Master) return FM_Node_Ptr is
|
|
begin
|
|
return Master.Objects'Unrestricted_Access;
|
|
end Objects;
|
|
|
|
------------------
|
|
-- Print_Master --
|
|
------------------
|
|
|
|
procedure Print_Master (Master : Finalization_Master) is
|
|
Head : constant FM_Node_Ptr := Master.Objects'Unrestricted_Access;
|
|
Head_Seen : Boolean := False;
|
|
N_Ptr : FM_Node_Ptr;
|
|
|
|
begin
|
|
-- Output the basic contents of a master
|
|
|
|
-- Master : 0x123456789
|
|
-- Is_Hmgen : TURE <or> FALSE
|
|
-- Base_Pool: null <or> 0x123456789
|
|
-- Fin_Addr : null <or> 0x123456789
|
|
-- Fin_Start: TRUE <or> FALSE
|
|
|
|
Put ("Master : ");
|
|
Put_Line (Address_Image (Master'Address));
|
|
|
|
Put ("Is_Hmgen : ");
|
|
Put_Line (Master.Is_Homogeneous'Img);
|
|
|
|
Put ("Base_Pool: ");
|
|
if Master.Base_Pool = null then
|
|
Put_Line ("null");
|
|
else
|
|
Put_Line (Address_Image (Master.Base_Pool'Address));
|
|
end if;
|
|
|
|
Put ("Fin_Addr : ");
|
|
if Master.Finalize_Address = null then
|
|
Put_Line ("null");
|
|
else
|
|
Put_Line (Address_Image (Master.Finalize_Address'Address));
|
|
end if;
|
|
|
|
Put ("Fin_Start: ");
|
|
Put_Line (Master.Finalization_Started'Img);
|
|
|
|
-- Output all chained elements. The format is the following:
|
|
|
|
-- ^ <or> ? <or> null
|
|
-- |Header: 0x123456789 (dummy head)
|
|
-- | Prev: 0x123456789
|
|
-- | Next: 0x123456789
|
|
-- V
|
|
|
|
-- ^ - the current element points back to the correct element
|
|
-- ? - the current element points back to an erroneous element
|
|
-- n - the current element points back to null
|
|
|
|
-- Header - the address of the list header
|
|
-- Prev - the address of the list header which the current element
|
|
-- points back to
|
|
-- Next - the address of the list header which the current element
|
|
-- points to
|
|
-- (dummy head) - present if dummy head
|
|
|
|
N_Ptr := Head;
|
|
while N_Ptr /= null loop -- Should never be null
|
|
Put_Line ("V");
|
|
|
|
-- We see the head initially; we want to exit when we see the head a
|
|
-- second time.
|
|
|
|
if N_Ptr = Head then
|
|
exit when Head_Seen;
|
|
|
|
Head_Seen := True;
|
|
end if;
|
|
|
|
-- The current element is null. This should never happen since the
|
|
-- list is circular.
|
|
|
|
if N_Ptr.Prev = null then
|
|
Put_Line ("null (ERROR)");
|
|
|
|
-- The current element points back to the correct element
|
|
|
|
elsif N_Ptr.Prev.Next = N_Ptr then
|
|
Put_Line ("^");
|
|
|
|
-- The current element points to an erroneous element
|
|
|
|
else
|
|
Put_Line ("? (ERROR)");
|
|
end if;
|
|
|
|
-- Output the header and fields
|
|
|
|
Put ("|Header: ");
|
|
Put (Address_Image (N_Ptr.all'Address));
|
|
|
|
-- Detect the dummy head
|
|
|
|
if N_Ptr = Head then
|
|
Put_Line (" (dummy head)");
|
|
else
|
|
Put_Line ("");
|
|
end if;
|
|
|
|
Put ("| Prev: ");
|
|
|
|
if N_Ptr.Prev = null then
|
|
Put_Line ("null");
|
|
else
|
|
Put_Line (Address_Image (N_Ptr.Prev.all'Address));
|
|
end if;
|
|
|
|
Put ("| Next: ");
|
|
|
|
if N_Ptr.Next = null then
|
|
Put_Line ("null");
|
|
else
|
|
Put_Line (Address_Image (N_Ptr.Next.all'Address));
|
|
end if;
|
|
|
|
N_Ptr := N_Ptr.Next;
|
|
end loop;
|
|
end Print_Master;
|
|
|
|
-------------------
|
|
-- Set_Base_Pool --
|
|
-------------------
|
|
|
|
procedure Set_Base_Pool
|
|
(Master : in out Finalization_Master;
|
|
Pool_Ptr : Any_Storage_Pool_Ptr)
|
|
is
|
|
begin
|
|
Master.Base_Pool := Pool_Ptr;
|
|
end Set_Base_Pool;
|
|
|
|
--------------------------
|
|
-- Set_Finalize_Address --
|
|
--------------------------
|
|
|
|
procedure Set_Finalize_Address
|
|
(Master : in out Finalization_Master;
|
|
Fin_Addr_Ptr : Finalize_Address_Ptr)
|
|
is
|
|
begin
|
|
-- Synchronization:
|
|
-- Read - finalization
|
|
-- Write - allocation, outside
|
|
|
|
Lock_Task.all;
|
|
Set_Finalize_Address_Unprotected (Master, Fin_Addr_Ptr);
|
|
Unlock_Task.all;
|
|
end Set_Finalize_Address;
|
|
|
|
--------------------------------------
|
|
-- Set_Finalize_Address_Unprotected --
|
|
--------------------------------------
|
|
|
|
procedure Set_Finalize_Address_Unprotected
|
|
(Master : in out Finalization_Master;
|
|
Fin_Addr_Ptr : Finalize_Address_Ptr)
|
|
is
|
|
begin
|
|
if Master.Finalize_Address = null then
|
|
Master.Finalize_Address := Fin_Addr_Ptr;
|
|
end if;
|
|
end Set_Finalize_Address_Unprotected;
|
|
|
|
----------------------------------------------------
|
|
-- Set_Heterogeneous_Finalize_Address_Unprotected --
|
|
----------------------------------------------------
|
|
|
|
procedure Set_Heterogeneous_Finalize_Address_Unprotected
|
|
(Obj : System.Address;
|
|
Fin_Addr_Ptr : Finalize_Address_Ptr)
|
|
is
|
|
begin
|
|
Finalize_Address_Table.Set (Obj, Fin_Addr_Ptr);
|
|
end Set_Heterogeneous_Finalize_Address_Unprotected;
|
|
|
|
--------------------------
|
|
-- Set_Is_Heterogeneous --
|
|
--------------------------
|
|
|
|
procedure Set_Is_Heterogeneous (Master : in out Finalization_Master) is
|
|
begin
|
|
-- Synchronization:
|
|
-- Read - finalization
|
|
-- Write - outside
|
|
|
|
Lock_Task.all;
|
|
Master.Is_Homogeneous := False;
|
|
Unlock_Task.all;
|
|
end Set_Is_Heterogeneous;
|
|
|
|
end System.Finalization_Masters;
|