[Ada] Add reference counting in functional containers

This patch adds reference counting to dynamically allocated pointers
on arrays and elements used by the functional container. This is done
by making both the arrays and the elements controlled.

gcc/ada/

	* libgnat/a-cofuba.ads, libgnat/a-cofuba.adb: Add reference
	counting.

2 files changed, 227 insertions, 52 deletions

diff --git a/gcc/ada/libgnat/a-cofuba.adb b/gcc/ada/libgnat/a-cofuba.adb
index 77c0301..68cf2ae 100644
--- a/gcc/ada/libgnat/a-cofuba.adb
+++ b/gcc/ada/libgnat/a-cofuba.adb
@@ -52,6 +52,24 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
    --  Resize the underlying array if needed so that it can contain one more
    --  element.
 
+   function Elements (C : Container) return Element_Array_Access is
+     (C.Controlled_Base.Base.Elements)
+   with
+     Global => null,
+     Pre    =>
+       C.Controlled_Base.Base /= null
+       and then C.Controlled_Base.Base.Elements /= null;
+
+   function Get
+     (C_E : Element_Array_Access;
+      I   : Count_Type)
+      return Element_Access
+   is
+     (C_E (I).Ref.E_Access)
+   with
+     Global => null,
+     Pre    => C_E /= null and then C_E (I).Ref /= null;
+
    ---------
    -- "=" --
    ---------
@@ -61,9 +79,8 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
       if C1.Length /= C2.Length then
          return False;
       end if;
-
       for I in 1 .. C1.Length loop
-         if C1.Base.Elements (I).all /= C2.Base.Elements (I).all then
+         if Get (Elements (C1), I).all /= Get (Elements (C2), I).all then
             return False;
          end if;
       end loop;
@@ -78,7 +95,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
    function "<=" (C1 : Container; C2 : Container) return Boolean is
    begin
       for I in 1 .. C1.Length loop
-         if Find (C2, C1.Base.Elements (I)) = 0 then
+         if Find (C2, Get (Elements (C1), I)) = 0 then
             return False;
          end if;
       end loop;
@@ -95,50 +112,138 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
       I : Index_Type;
       E : Element_Type) return Container
    is
+      C_B : Array_Base_Access renames C.Controlled_Base.Base;
    begin
-      if To_Count (I) = C.Length + 1 and then C.Length = C.Base.Max_Length then
-         Resize (C.Base);
-         C.Base.Max_Length := C.Base.Max_Length + 1;
-         C.Base.Elements (C.Base.Max_Length) := new Element_Type'(E);
+      if To_Count (I) = C.Length + 1 and then C.Length = C_B.Max_Length then
+         Resize (C_B);
+         C_B.Max_Length := C_B.Max_Length + 1;
+         C_B.Elements (C_B.Max_Length) := Element_Init (E);
 
-         return Container'(Length => C.Base.Max_Length, Base => C.Base);
+         return Container'(Length          => C_B.Max_Length,
+                           Controlled_Base => C.Controlled_Base);
       else
          declare
-            A : constant Array_Base_Access := Content_Init (C.Length);
+            A : constant Array_Base_Controlled_Access :=
+              Content_Init (C.Length);
             P : Count_Type := 0;
          begin
-            A.Max_Length := C.Length + 1;
+            A.Base.Max_Length := C.Length + 1;
             for J in 1 .. C.Length + 1 loop
                if J /= To_Count (I) then
                   P := P + 1;
-                  A.Elements (J) := C.Base.Elements (P);
+                  A.Base.Elements (J) := C_B.Elements (P);
                else
-                  A.Elements (J) := new Element_Type'(E);
+                  A.Base.Elements (J) := Element_Init (E);
                end if;
             end loop;
 
-            return Container'(Length => A.Max_Length,
-                              Base   => A);
+            return Container'(Length           => A.Base.Max_Length,
+                              Controlled_Base  => A);
          end;
       end if;
    end Add;
 
+   ------------
+   -- Adjust --
+   ------------
+
+   procedure Adjust (Controlled_Base : in out Array_Base_Controlled_Access) is
+      C_B : Array_Base_Access renames Controlled_Base.Base;
+   begin
+      if C_B /= null then
+         C_B.Reference_Count := C_B.Reference_Count + 1;
+      end if;
+   end Adjust;
+
+   procedure Adjust (Ctrl_E : in out Controlled_Element_Access) is
+   begin
+      if Ctrl_E.Ref /= null then
+         Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count + 1;
+      end if;
+   end Adjust;
+
    ------------------
    -- Content_Init --
    ------------------
 
-   function Content_Init (L : Count_Type := 0) return Array_Base_Access
+   function Content_Init
+     (L : Count_Type := 0) return Array_Base_Controlled_Access
    is
       Max_Init : constant Count_Type := 100;
       Size     : constant Count_Type :=
         (if L < Count_Type'Last - Max_Init then L + Max_Init
          else Count_Type'Last);
+
+      --  The Access in the array will be initialized to null
+
       Elements : constant Element_Array_Access :=
         new Element_Array'(1 .. Size => <>);
+      B        : constant Array_Base_Access :=
+        new Array_Base'(Reference_Count => 1,
+                        Max_Length      => 0,
+                        Elements        => Elements);
    begin
-      return new Array_Base'(Max_Length => 0, Elements => Elements);
+      return (Ada.Finalization.Controlled with Base => B);
    end Content_Init;
 
+   ------------------
+   -- Element_Init --
+   ------------------
+
+   function Element_Init (E : Element_Type) return Controlled_Element_Access
+   is
+      Refcounted_E : constant Refcounted_Element_Access :=
+        new Refcounted_Element'(Reference_Count => 1,
+                                E_Access        => new Element_Type'(E));
+   begin
+      return (Ada.Finalization.Controlled with Ref => Refcounted_E);
+   end Element_Init;
+
+   --------------
+   -- Finalize --
+   --------------
+
+   procedure Finalize (Controlled_Base : in out Array_Base_Controlled_Access)
+   is
+      procedure Unchecked_Free_Base is new Ada.Unchecked_Deallocation
+        (Object => Array_Base,
+         Name   => Array_Base_Access);
+      procedure Unchecked_Free_Array is new Ada.Unchecked_Deallocation
+        (Object => Element_Array,
+         Name   => Element_Array_Access);
+
+      C_B : Array_Base_Access renames Controlled_Base.Base;
+   begin
+      if C_B /= null then
+         C_B.Reference_Count := C_B.Reference_Count - 1;
+         if C_B.Reference_Count = 0 then
+            Unchecked_Free_Array (Controlled_Base.Base.Elements);
+            Unchecked_Free_Base (Controlled_Base.Base);
+         end if;
+         C_B := null;
+      end if;
+   end Finalize;
+
+   procedure Finalize (Ctrl_E : in out Controlled_Element_Access) is
+      procedure Unchecked_Free_Ref is new Ada.Unchecked_Deallocation
+        (Object => Refcounted_Element,
+         Name   => Refcounted_Element_Access);
+
+      procedure Unchecked_Free_Element is new Ada.Unchecked_Deallocation
+        (Object => Element_Type,
+         Name   => Element_Access);
+
+   begin
+      if Ctrl_E.Ref /= null then
+         Ctrl_E.Ref.Reference_Count := Ctrl_E.Ref.Reference_Count - 1;
+         if Ctrl_E.Ref.Reference_Count = 0 then
+            Unchecked_Free_Element (Ctrl_E.Ref.E_Access);
+            Unchecked_Free_Ref (Ctrl_E.Ref);
+         end if;
+         Ctrl_E.Ref := null;
+      end if;
+   end Finalize;
+
    ----------
    -- Find --
    ----------
@@ -146,7 +251,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
    function Find (C : Container; E : access Element_Type) return Count_Type is
    begin
       for I in 1 .. C.Length loop
-         if C.Base.Elements (I).all = E.all then
+         if Get (Elements (C), I).all = E.all then
             return I;
          end if;
       end loop;
@@ -162,7 +267,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
    ---------
 
    function Get (C : Container; I : Index_Type) return Element_Type is
-     (C.Base.Elements (To_Count (I)).all);
+      (Get (Elements (C), To_Count (I)).all);
 
    ------------------
    -- Intersection --
@@ -170,19 +275,19 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
 
    function Intersection (C1 : Container; C2 : Container) return Container is
       L : constant Count_Type := Num_Overlaps (C1, C2);
-      A : constant Array_Base_Access := Content_Init (L);
+      A : constant Array_Base_Controlled_Access := Content_Init (L);
       P : Count_Type := 0;
 
    begin
-      A.Max_Length := L;
+      A.Base.Max_Length := L;
       for I in 1 .. C1.Length loop
-         if Find (C2, C1.Base.Elements (I)) > 0 then
+         if Find (C2, Get (Elements (C1), I)) > 0 then
             P := P + 1;
-            A.Elements (P) := C1.Base.Elements (I);
+            A.Base.Elements (P) := Elements (C1) (I);
          end if;
       end loop;
 
-      return Container'(Length => P, Base => A);
+      return Container'(Length => P, Controlled_Base => A);
    end Intersection;
 
    ------------
@@ -199,7 +304,7 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
 
    begin
       for I in 1 .. C1.Length loop
-         if Find (C2, C1.Base.Elements (I)) > 0 then
+         if Find (C2, Get (Elements (C1), I)) > 0 then
             P := P + 1;
          end if;
       end loop;
@@ -214,21 +319,23 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
    function Remove (C : Container; I : Index_Type) return Container is
    begin
       if To_Count (I) = C.Length then
-         return Container'(Length => C.Length - 1, Base => C.Base);
+         return Container'(Length          => C.Length - 1,
+                           Controlled_Base => C.Controlled_Base);
       else
          declare
-            A : constant Array_Base_Access := Content_Init (C.Length - 1);
+            A : constant Array_Base_Controlled_Access
+              := Content_Init (C.Length - 1);
             P : Count_Type := 0;
          begin
-            A.Max_Length := C.Length - 1;
+            A.Base.Max_Length := C.Length - 1;
             for J in 1 .. C.Length loop
                if J /= To_Count (I) then
                   P := P + 1;
-                  A.Elements (P) := C.Base.Elements (J);
+                  A.Base.Elements (P) := Elements (C) (J);
                end if;
             end loop;
 
-            return Container'(Length => C.Length - 1, Base => A);
+            return Container'(Length => C.Length - 1, Controlled_Base => A);
          end;
       end if;
    end Remove;
@@ -277,13 +384,14 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
       E : Element_Type) return Container
    is
       Result : constant Container :=
-                 Container'(Length => C.Length,
-                            Base => Content_Init (C.Length));
+                 Container'(Length          => C.Length,
+                            Controlled_Base => Content_Init (C.Length));
+      R_Base : Array_Base_Access renames Result.Controlled_Base.Base;
 
    begin
-      Result.Base.Max_Length := C.Length;
-      Result.Base.Elements (1 .. C.Length) := C.Base.Elements (1 .. C.Length);
-      Result.Base.Elements (To_Count (I)) := new Element_Type'(E);
+      R_Base.Max_Length := C.Length;
+      R_Base.Elements (1 .. C.Length) := Elements (C) (1 .. C.Length);
+      R_Base.Elements (To_Count (I)) := Element_Init (E);
       return Result;
    end Set;
 
@@ -305,20 +413,19 @@ package body Ada.Containers.Functional_Base with SPARK_Mode => Off is
 
       declare
          L : constant Count_Type := Length (C1) - N + Length (C2);
-         A : constant Array_Base_Access := Content_Init (L);
+         A : constant Array_Base_Controlled_Access := Content_Init (L);
          P : Count_Type := Length (C1);
-
       begin
-         A.Max_Length := L;
-         A.Elements (1 .. C1.Length) := C1.Base.Elements (1 .. C1.Length);
+         A.Base.Max_Length := L;
+         A.Base.Elements (1 .. C1.Length) := Elements (C1) (1 .. C1.Length);
          for I in 1 .. C2.Length loop
-            if Find (C1, C2.Base.Elements (I)) = 0 then
+            if Find (C1, Get (Elements (C2), I)) = 0 then
                P := P + 1;
-               A.Elements (P) := C2.Base.Elements (I);
+               A.Base.Elements (P) := Elements (C2) (I);
             end if;
          end loop;
 
-         return Container'(Length => L, Base => A);
+         return Container'(Length => L, Controlled_Base => A);
       end;
    end Union;
 
diff --git a/gcc/ada/libgnat/a-cofuba.ads b/gcc/ada/libgnat/a-cofuba.ads
index eacf845..8a99a43 100644
--- a/gcc/ada/libgnat/a-cofuba.ads
+++ b/gcc/ada/libgnat/a-cofuba.ads
@@ -34,6 +34,10 @@
 
 pragma Ada_2012;
 
+--  To allow reference counting on the base container
+
+private with Ada.Finalization;
+
 private generic
    type Index_Type is (<>);
    --  To avoid Constraint_Error being raised at run time, Index_Type'Base
@@ -98,33 +102,97 @@ package Ada.Containers.Functional_Base with SPARK_Mode => Off is
 
 private
 
+   --  Theoretically, each operation on a functional container implies the
+   --  creation of a new container i.e. the copy of the array itself and all
+   --  the elements in it. In the implementation, most of these copies are
+   --  avoided by sharing between the containers.
+   --
+   --  A container stores its last used index. So, when adding an
+   --  element at the end of the container, the exact same array can be reused.
+   --  As a functionnal container cannot be modifed once created, there is no
+   --  risk of unwanted modifications.
+   --
+   --                 _1_2_3_
+   --  S             :    end       => [1, 2, 3]
+   --                      |
+   --                 |1|2|3|4|.|.|
+   --                        |
+   --  Add (S, 4, 4) :      end     => [1, 2, 3, 4]
+   --
+   --  The elements are also shared between containers as much as possible. For
+   --  example, when something is added in the middle, the array is changed but
+   --  the elementes are reused.
+   --
+   --                  _1_2_3_4_
+   --  S             : |1|2|3|4|    => [1, 2, 3, 4]
+   --                   |  \ \ \
+   --  Add (S, 2, 5) : |1|5|2|3|4|  => [1, 5, 2, 3, 4]
+   --
+   --  To make this sharing possible, both the elements and the arrays are
+   --  stored inside dynamically allocated access types which shall be
+   --  deallocated when they are no longer used. The memory is managed using
+   --  reference counting both at the array and at the element level.
+
    subtype Positive_Count_Type is Count_Type range 1 .. Count_Type'Last;
 
+   type Reference_Count_Type is new Natural;
+
    type Element_Access is access all Element_Type;
 
+   type Refcounted_Element is record
+      Reference_Count : Reference_Count_Type;
+      E_Access        : Element_Access;
+   end record;
+
+   type Refcounted_Element_Access is access Refcounted_Element;
+
+   type Controlled_Element_Access is new Ada.Finalization.Controlled
+   with record
+      Ref : Refcounted_Element_Access := null;
+   end record;
+
+   function Element_Init (E : Element_Type) return Controlled_Element_Access;
+   --  Use to initialize a refcounted element
+
    type Element_Array is
-     array (Positive_Count_Type range <>) of Element_Access;
+     array (Positive_Count_Type range <>) of Controlled_Element_Access;
 
    type Element_Array_Access_Base is access Element_Array;
 
-   subtype Element_Array_Access is not null Element_Array_Access_Base;
-
-   Empty_Element_Array_Access : constant Element_Array_Access :=
-     new Element_Array'(1 .. 0 => null);
+   subtype Element_Array_Access is Element_Array_Access_Base;
 
    type Array_Base is record
-     Max_Length : Count_Type;
-     Elements   : Element_Array_Access;
+     Reference_Count : Reference_Count_Type;
+     Max_Length      : Count_Type;
+     Elements        : Element_Array_Access;
+   end record;
+
+   type Array_Base_Access is access Array_Base;
+
+   type Array_Base_Controlled_Access is new Ada.Finalization.Controlled
+   with record
+      Base : Array_Base_Access;
    end record;
 
-   type Array_Base_Access is not null access Array_Base;
+   overriding procedure Adjust
+     (Controlled_Base : in out Array_Base_Controlled_Access);
+
+   overriding procedure Finalize
+     (Controlled_Base : in out Array_Base_Controlled_Access);
+
+   overriding procedure Adjust
+     (Ctrl_E : in out Controlled_Element_Access);
+
+   overriding procedure Finalize
+     (Ctrl_E : in out Controlled_Element_Access);
 
-   function Content_Init (L : Count_Type := 0) return Array_Base_Access;
+   function Content_Init (L : Count_Type := 0)
+                          return Array_Base_Controlled_Access;
    --  Used to initialize the content of an array base with length L
 
    type Container is record
-      Length : Count_Type := 0;
-      Base   : Array_Base_Access := Content_Init;
+      Length          : Count_Type := 0;
+      Controlled_Base : Array_Base_Controlled_Access := Content_Init;
    end record;
 
 end Ada.Containers.Functional_Base;