a-fihema.ads, [...] (Finalization_Collection): Avoid heap allocation for Objects component.

2011-08-05  Bob Duff  <duff@adacore.com>

	* a-fihema.ads, a-fihema.adb (Finalization_Collection): Avoid heap
	allocation for Objects component. This simplifies the code somewhat. It
	is also a little more efficient in the not-so-unusual case where there
	are no controlled objects allocated.
	Make Finalization_Started flag atomic.
	(Finalize): Avoid unnecessary detachment of items from the list.
	(pcol): Minor cleanup.

From-SVN: r177439

gcc/ada/ChangeLog

+2011-08-05  Bob Duff  <duff@adacore.com>
+
+	* a-fihema.ads, a-fihema.adb (Finalization_Collection): Avoid heap
+	allocation for Objects component. This simplifies the code somewhat. It
+	is also a little more efficient in the not-so-unusual case where there
+	are no controlled objects allocated.
+	Make Finalization_Started flag atomic.
+	(Finalize): Avoid unnecessary detachment of items from the list.
+	(pcol): Minor cleanup.
+
 2011-08-05  Ed Schonberg  <schonberg@adacore.com>
 
 	* sem_ch12.adb (Analyze_Formal_Package_Declaration): reject a formal

gcc/ada/a-fihema.adb

@@ -31,7 +31,6 @@
 
 with Ada.Exceptions;          use Ada.Exceptions;
 with Ada.Unchecked_Conversion;
-with Ada.Unchecked_Deallocation;
 
 with System;                  use System;
 with System.Address_Image;
@@ -60,8 +59,6 @@ package body Ada.Finalization.Heap_Management is
    procedure Detach (N : Node_Ptr);
    --  Unhook a node from an arbitrary list
 
-   procedure Free is new Ada.Unchecked_Deallocation (Node, Node_Ptr);
-
    ---------------------------
    -- Add_Offset_To_Address --
    ---------------------------
@@ -117,7 +114,7 @@ package body Ada.Finalization.Heap_Management is
             --  top of the allocated bits into a list header.
 
             N_Ptr := Address_To_Node_Ptr (N_Addr);
-            Attach (N_Ptr, Collection.Objects);
+            Attach (N_Ptr, Collection.Objects'Unchecked_Access);
 
             --  Move the address from Prev to the start of the object. This
             --  operation effectively hides the list header.
@@ -251,54 +248,10 @@ package body Ada.Finalization.Heap_Management is
    overriding procedure Finalize
      (Collection : in out Finalization_Collection)
    is
-      function Head (L : Node_Ptr) return Node_Ptr;
-      --  Return the node that comes after the dummy head
-
-      function Is_Dummy_Head (N : Node_Ptr) return Boolean;
-      --  Determine whether a node acts as a dummy head. Such nodes do not
-      --  have an actual "object" attached to them and point to themselves.
-
-      function Is_Empty_List (L : Node_Ptr) return Boolean;
-      --  Determine whether a list is empty
-
       function Node_Ptr_To_Address (N : Node_Ptr) return Address;
       --  Not the reverse of Address_To_Node_Ptr. Return the address of the
       --  object following the list header.
 
-      ----------
-      -- Head --
-      ----------
-
-      function Head (L : Node_Ptr) return Node_Ptr is
-      begin
-         return L.Next;
-      end Head;
-
-      -------------------
-      -- Is_Dummy_Head --
-      -------------------
-
-      function Is_Dummy_Head (N : Node_Ptr) return Boolean is
-      begin
-         --  To be a dummy head, the node must point to itself in both
-         --  directions.
-
-         return
-           N.Next /= null
-             and then N.Next = N
-             and then N.Prev /= null
-             and then N.Prev = N;
-      end Is_Dummy_Head;
-
-      -------------------
-      -- Is_Empty_List --
-      -------------------
-
-      function Is_Empty_List (L : Node_Ptr) return Boolean is
-      begin
-         return L = null or else Is_Dummy_Head (L);
-      end Is_Empty_List;
-
       -------------------------
       -- Node_Ptr_To_Address --
       -------------------------
@@ -308,9 +261,8 @@ package body Ada.Finalization.Heap_Management is
          return N.all'Address + Header_Offset;
       end Node_Ptr_To_Address;
 
-      Curr_Ptr : Node_Ptr;
+      Curr_Ptr : Node_Ptr := Collection.Objects.Next; -- skip dummy head
       Ex_Occur : Exception_Occurrence;
-      Next_Ptr : Node_Ptr;
       Raised   : Boolean := False;
 
    --  Start of processing for Finalize
@@ -323,28 +275,11 @@ package body Ada.Finalization.Heap_Management is
 
       Collection.Finalization_Started := True;
 
-      while not Is_Empty_List (Collection.Objects) loop
-
-         --  Find the real head of the collection, skipping the dummy head
-
-         Curr_Ptr := Head (Collection.Objects);
-
-         --  If the dummy head is the only remaining node, all real objects
-         --  have already been detached and finalized.
-
-         if Is_Dummy_Head (Curr_Ptr) then
-            exit;
-         end if;
-
-         --  Store the next node now since the detachment will destroy the
-         --  reference to it.
-
-         Next_Ptr := Curr_Ptr.Next;
-
-         --  Remove the current node from the list
-
-         Detach (Curr_Ptr);
+      --  Go through the Objects list, and finalize each one. There is no need
+      --  to detach items from the list, because the whole collection is about
+      --  to go away.
 
+      while Curr_Ptr /= Collection.Objects'Unchecked_Access loop
          --  ??? Kludge: Don't do anything until the proper place to set
          --  primitive Finalize_Address has been determined.
 
@@ -361,13 +296,9 @@ package body Ada.Finalization.Heap_Management is
             end;
          end if;
 
-         Curr_Ptr := Next_Ptr;
+         Curr_Ptr := Curr_Ptr.Next;
       end loop;
 
-      --  Deallocate the dummy head
-
-      Free (Collection.Objects);
-
       --  If the finalization of a particular node raised an exception, reraise
       --  it after the remainder of the list has been finalized.
 
@@ -384,12 +315,10 @@ package body Ada.Finalization.Heap_Management is
      (Collection : in out Finalization_Collection)
    is
    begin
-      Collection.Objects := new Node;
-
       --  The dummy head must point to itself in both directions
 
-      Collection.Objects.Next := Collection.Objects;
-      Collection.Objects.Prev := Collection.Objects;
+      Collection.Objects.Next := Collection.Objects'Unchecked_Access;
+      Collection.Objects.Prev := Collection.Objects'Unchecked_Access;
    end Initialize;
 
    ----------
@@ -397,6 +326,10 @@ package body Ada.Finalization.Heap_Management is
    ----------
 
    procedure pcol (Collection : Finalization_Collection) is
+      Head      : constant Node_Ptr := Collection.Objects'Unrestricted_Access;
+      --  "Unrestricted", because we're evilly getting access-to-variable of a
+      --  constant!  OK for debugging code.
+
       Head_Seen : Boolean := False;
       N_Ptr     : Node_Ptr;
 
@@ -447,21 +380,18 @@ package body Ada.Finalization.Heap_Management is
       --         - points to
       --  (dummy head) - present if dummy head
 
-      N_Ptr := Collection.Objects;
+      N_Ptr := Head;
 
-      while N_Ptr /= null loop
+      while N_Ptr /= null loop -- Should never be null; we being defensive
          Put_Line ("V");
 
-         --  The current node is the head. If we have already traversed the
-         --  chain, the head will be encountered again since the chain is
-         --  circular.
+         --  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;
 
-         if N_Ptr = Collection.Objects then
-            if Head_Seen then
-               exit;
-            else
-               Head_Seen := True;
-            end if;
+            Head_Seen := True;
          end if;
 
          --  The current element is null. This should never happen since the
@@ -488,7 +418,7 @@ package body Ada.Finalization.Heap_Management is
 
          --  Detect the dummy head
 
-         if N_Ptr = Collection.Objects then
+         if N_Ptr = Head then
             Put_Line (" (dummy head)");
          else
             Put_Line ("");

gcc/ada/a-fihema.ads

@@ -93,11 +93,11 @@ package Ada.Finalization.Heap_Management is
    overriding procedure Finalize
      (Collection : in out Finalization_Collection);
    --  Traverse the objects of Collection, invoking Finalize_Address on each of
-   --  them. In the end, the routine destroys its dummy head and tail.
+   --  them.
 
    overriding procedure Initialize
      (Collection : in out Finalization_Collection);
-   --  Create a new Collection by allocating a dummy head and tail
+   --  Initialize the finalization list to empty
 
    procedure Set_Finalize_Address_Ptr
      (Collection : in out Finalization_Collection;
@@ -117,6 +117,11 @@ private
    pragma No_Strict_Aliasing (Node_Ptr);
 
    type Node is record
+      --  This should really be limited, but we can see the full view of
+      --  Limited_Controlled, which NOT limited. If it were limited, we could
+      --  default initialize here, and get rid of Initialize for
+      --  Finalization_Collection.
+
       Prev : Node_Ptr;
       Next : Node_Ptr;
    end record;
@@ -128,8 +133,10 @@ private
       --  All objects and node headers are allocated on this underlying pool;
       --  the collection is simply a wrapper around it.
 
-      Objects : Node_Ptr;
-      --  The head of a doubly linked list
+      Objects : aliased Node;
+      --  The head of a doubly linked list containing all allocated objects
+      --  with controlled parts that still exist (Unchecked_Deallocation has
+      --  not been done on them).
 
       Finalize_Address : Finalize_Address_Ptr;
       --  A reference to a routine that finalizes an object denoted by its