diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/libgnat/a-cofuba.adb | 189 | ||||
| -rw-r--r-- | gcc/ada/libgnat/a-cofuba.ads | 90 |
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; |