path: root/gcc/ada/libgnat/s-finpri.adb

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--        S Y S T E M . F I N A L I Z A T I O N _ P R I M I T I V E S       --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--         Copyright (C) 2023-2024, 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 Ada.Unchecked_Conversion;

with System.Soft_Links; use System.Soft_Links;

package body System.Finalization_Primitives is

   procedure Raise_From_Controlled_Operation (X : Exception_Occurrence);
   pragma Import (Ada, Raise_From_Controlled_Operation,
                              "__gnat_raise_from_controlled_operation");

   function To_Collection_Node_Ptr is
     new Ada.Unchecked_Conversion (Address, Collection_Node_Ptr);

   procedure Detach_Node_From_Collection (Node : not null Collection_Node_Ptr);
   --  Remove a collection node from its associated finalization collection.
   --  Calls to the procedure with a Node that has already been detached have
   --  no effects.

   procedure Lock_Collection (Collection : in out Finalization_Collection);
   --  Lock the finalization collection. Upon return, the caller owns the lock
   --  to the collection and no other call with the same actual parameter will
   --  return until a corresponding call to Unlock_Collection has been made by
   --  the caller. This means that it is not possible to call Lock_Collection
   --  more than once on a collection without a call to Unlock_Collection in
   --  between.

   procedure Unlock_Collection (Collection : in out Finalization_Collection);
   --  Unlock the finalization collection, i.e. relinquish ownership of the
   --  lock to the collection.

   ---------------------------
   -- 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_Object_To_Collection --
   ---------------------------------

   procedure Attach_Object_To_Collection
     (Object_Address   : System.Address;
      Finalize_Address : not null Finalize_Address_Ptr;
      Collection       : in out Finalization_Collection)
   is
      Node : constant Collection_Node_Ptr :=
               To_Collection_Node_Ptr (Object_Address - Header_Size);

   begin
      Lock_Collection (Collection);

      --  Do not allow the attachment of controlled objects while the
      --  associated collection is being finalized.

      --  Synchronization:
      --    Read  - attachment, finalization
      --    Write - finalization

      if Collection.Finalization_Started then
         raise Program_Error with "attachment after finalization started";
      end if;

      --  Check whether primitive Finalize_Address is available. If it is
      --  not, then either the expansion of the designated type failed or
      --  the expansion of the allocator failed. This is a compiler bug.

      pragma Assert
        (Finalize_Address /= null, "primitive Finalize_Address not available");

      Node.Enclosing_Collection := Collection'Unrestricted_Access;
      Node.Finalize_Address     := Finalize_Address;
      Node.Prev                 := Collection.Head'Unchecked_Access;
      Node.Next                 := Collection.Head.Next;

      Collection.Head.Next.Prev := Node;
      Collection.Head.Next      := Node;

      Unlock_Collection (Collection);

   exception
      when others =>

         --  Unlock the collection in case the attachment failed and reraise
         --  the exception.

         Unlock_Collection (Collection);
         raise;
   end Attach_Object_To_Collection;

   -----------------------------
   -- Attach_Object_To_Master --
   -----------------------------

   procedure Attach_Object_To_Master
     (Object_Address   : System.Address;
      Finalize_Address : not null Finalize_Address_Ptr;
      Node             : not null Master_Node_Ptr;
      Master           : in out Finalization_Master)
   is
   begin
      Attach_Object_To_Node (Object_Address, Finalize_Address, Node.all);
      Chain_Node_To_Master (Node, Master);
   end Attach_Object_To_Master;

   ---------------------------
   -- Attach_Object_To_Node --
   ---------------------------

   procedure Attach_Object_To_Node
     (Object_Address   : System.Address;
      Finalize_Address : not null Finalize_Address_Ptr;
      Node             : in out Master_Node)
   is
   begin
      pragma Assert (Node.Object_Address = System.Null_Address
        and then Node.Finalize_Address = null);

      Node.Object_Address   := Object_Address;
      Node.Finalize_Address := Finalize_Address;
   end Attach_Object_To_Node;

   --------------------------
   -- Chain_Node_To_Master --
   --------------------------

   procedure Chain_Node_To_Master
     (Node   : not null Master_Node_Ptr;
      Master : in out Finalization_Master)
   is
   begin
      Node.Next   := Master.Head;
      Master.Head := Node;
   end Chain_Node_To_Master;

   ---------------------------------
   -- Detach_Node_From_Collection --
   ---------------------------------

   procedure Detach_Node_From_Collection
     (Node : not null Collection_Node_Ptr)
   is
   begin
      if Node.Prev /= null and then Node.Next /= null then
         Node.Prev.Next := Node.Next;
         Node.Next.Prev := Node.Prev;
         Node.Prev := null;
         Node.Next := null;
      end if;
   end Detach_Node_From_Collection;

   -----------------------------------
   -- Detach_Object_From_Collection --
   -----------------------------------

   procedure Detach_Object_From_Collection
     (Object_Address : System.Address)
   is
      Node : constant Collection_Node_Ptr :=
               To_Collection_Node_Ptr (Object_Address - Header_Size);

   begin
      Lock_Collection (Node.Enclosing_Collection.all);

      Detach_Node_From_Collection (Node);

      Unlock_Collection (Node.Enclosing_Collection.all);
   end Detach_Object_From_Collection;

   --------------
   -- Finalize --
   --------------

   overriding procedure Finalize
     (Collection : in out Finalization_Collection)
   is
      Curr_Ptr                      : Collection_Node_Ptr;
      Exc_Occur                     : Exception_Occurrence;
      Finalization_Exception_Raised : Boolean := False;
      Obj_Addr                      : Address;

      function Is_Empty_List (L : not null Collection_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 Collection_Node_Ptr) return Boolean
      is
      begin
         return L.Next = L and then L.Prev = L;
      end Is_Empty_List;

   begin
      Lock_Collection (Collection);

      --  Synchronization:
      --    Read  - attachment, finalization
      --    Write - finalization

      if Collection.Finalization_Started then
         Unlock_Collection (Collection);

         --  Double finalization may occur during the handling of stand-alone
         --  libraries or the finalization of a pool with subpools.

         return;
      end if;

      --  Lock the collection to prevent any attachment while the objects are
      --  being finalized. The collection remains locked because either it is
      --  explicitly deallocated or the associated access type is about to go
      --  out of scope.

      --  Synchronization:
      --    Read  - attachment, finalization
      --    Write - finalization

      Collection.Finalization_Started := True;

      --  Note that we cannot walk the list while finalizing its elements
      --  because the finalization of one may call Unchecked_Deallocation
      --  on another and, therefore, detach it from anywhere on the list.
      --  Instead, we empty the list by repeatedly finalizing the first
      --  element (after the dummy head) and detaching it from the list.

      while not Is_Empty_List (Collection.Head'Unchecked_Access) loop
         Curr_Ptr := Collection.Head.Next;

         --  Synchronization:
         --    Write - attachment, detachment, finalization

         Detach_Node_From_Collection (Curr_Ptr);

         --  Skip the list header in order to offer proper object layout for
         --  finalization.

         Obj_Addr := Curr_Ptr.all'Address + Header_Size;

         --  Temporarily release the lock because the call to Finalize_Address
         --  may ultimately invoke Detach_Object_From_Collection.

         Unlock_Collection (Collection);

         begin
            Curr_Ptr.Finalize_Address (Obj_Addr);
         exception
            when Fin_Occur : others =>
               if not Finalization_Exception_Raised then
                  Finalization_Exception_Raised := True;
                  Save_Occurrence (Exc_Occur, Fin_Occur);
               end if;
         end;

         --  Retake the lock for the next iteration

         Lock_Collection (Collection);
      end loop;

      Unlock_Collection (Collection);

      --  If one of the finalization actions raised an exception, reraise it

      if Finalization_Exception_Raised then
         Raise_From_Controlled_Operation (Exc_Occur);
      end if;
   end Finalize;

   ---------------------
   -- Finalize_Master --
   ---------------------

   procedure Finalize_Master (Master : in out Finalization_Master) is
      Exc_Occur                     : Exception_Occurrence;
      Finalization_Exception_Raised : Boolean := False;
      Node                          : Master_Node_Ptr;

   begin
      Node := Master.Head;

      --  If exceptions are enabled, we catch them locally and reraise one
      --  once all the finalization actions have been completed.

      if Master.Exceptions_OK then
         while Node /= null loop
            begin
               Finalize_Object (Node.all);

            exception
               when Exc : others =>
                  if not Finalization_Exception_Raised then
                     Finalization_Exception_Raised := True;

                     if Master.Library_Level then
                        if Master.Extra_Info then
                           Save_Library_Occurrence (Exc'Unrestricted_Access);
                        else
                           Save_Library_Occurrence (null);
                        end if;

                     elsif Master.Extra_Info then
                        Save_Occurrence (Exc_Occur, Exc);
                     end if;
                  end if;
            end;

            Node := Node.Next;
         end loop;

      --  Otherwise we call finalization procedures without protection

      else
         while Node /= null loop
            Finalize_Object (Node.all);

            Node := Node.Next;
         end loop;
      end if;

      Master.Head := null;

      --  If one of the finalization actions raised an exception, and we are
      --  not at library level, then reraise the exception.

      if Finalization_Exception_Raised and then not Master.Library_Level then
         if Master.Extra_Info then
            Raise_From_Controlled_Operation (Exc_Occur);
         else
            raise Program_Error with "finalize/adjust raised exception";
         end if;
      end if;
   end Finalize_Master;

   ---------------------
   -- Finalize_Object --
   ---------------------

   procedure Finalize_Object (Node : in out Master_Node) is
      FA : constant Finalize_Address_Ptr := Node.Finalize_Address;

   begin
      if FA /= null then
         pragma Assert (Node.Object_Address /= System.Null_Address);

         Node.Finalize_Address := null;

         FA (Node.Object_Address);
      end if;
   end Finalize_Object;

   ----------------
   -- Initialize --
   ----------------

   overriding procedure Initialize
     (Collection : in out Finalization_Collection)
   is
   begin
      --  The dummy head must point to itself in both directions

      Collection.Head.Prev := Collection.Head'Unchecked_Access;
      Collection.Head.Next := Collection.Head'Unchecked_Access;

      Initialize_RTS_Lock (Collection.Lock'Address);

      Collection.Finalization_Started := False;
   end Initialize;

   ---------------------
   -- Lock_Collection --
   ---------------------

   procedure Lock_Collection (Collection : in out Finalization_Collection) is
   begin
      Acquire_RTS_Lock (Collection.Lock'Address);
   end Lock_Collection;

   -------------------------------------
   -- Suppress_Object_Finalize_At_End --
   -------------------------------------

   procedure Suppress_Object_Finalize_At_End (Node : in out Master_Node) is
   begin
      Node.Finalize_Address := null;
   end Suppress_Object_Finalize_At_End;

   -----------------------
   -- Unlock_Collection --
   -----------------------

   procedure Unlock_Collection (Collection : in out Finalization_Collection) is
   begin
      Release_RTS_Lock (Collection.Lock'Address);
   end Unlock_Collection;

end System.Finalization_Primitives;