diff --git a/minimal/src/gnatcoll-refcount.adb b/minimal/src/gnatcoll-refcount.adb index e6ac5888..7efca99f 100644 --- a/minimal/src/gnatcoll-refcount.adb +++ b/minimal/src/gnatcoll-refcount.adb @@ -402,6 +402,272 @@ package body GNATCOLL.Refcount is end From_Element; end Shared_Pointers; + ----------------------------- + -- Limited_Shared_Pointers -- + ----------------------------- + + package body Limited_Shared_Pointers is + use type Pools.Element_Access; + + procedure Unchecked_Free is new Ada.Unchecked_Deallocation + (Element_Type, Pools.Element_Access); + + pragma Warnings (Off, "*possible aliasing problem*"); + function Convert is new Ada.Unchecked_Conversion + (Pools.Element_Access, System.Address); + function Convert is new Ada.Unchecked_Conversion + (System.Address, Pools.Element_Access); + pragma Warnings (On, "*possible aliasing problem*"); + + --------- + -- Set -- + --------- + + procedure Set + (Self : in out Ref'Class; + Get_Data : access function return Element_Type) + is + R : access Counters; + begin + Finalize (Self); + Self.Data := new Element_Type'(Get_Data.all); -- uses storage pool + R := Pools.Header_Of (Self.Data); + R.Refcount := 1; + R.Weak_Data := null; + end Set; + + ------------------- + -- Unchecked_Get -- + ------------------- + + function Unchecked_Get (Self : Ref'Class) return Element_Access is + begin + return Self.Data; + end Unchecked_Get; + + ------------- + -- Process -- + ------------- + + procedure Process + (Self : Ref'Class; + Process : not null access procedure (E : Element_Type)) is + begin + Process (Self.Data.all); + end Process; + + ------------- + -- Is_Null -- + ------------- + + function Is_Null (Self : Ref'Class) return Boolean is + begin + return Self.Data = null; + end Is_Null; + + ---------- + -- Weak -- + ---------- + + function Weak (Self : Ref'Class) return Weak_Ref is + R : Counters_Access; + V : Weak_Data_Access; + begin + if Self.Data = null then + return Null_Weak_Ref; + end if; + + R := Pools.Header_Of (Self.Data); + + if R.Weak_Data = null then + V := new Weak_Data' + (Refcount => 2, -- hold by Self and the result + Lock => 0, + Element => Convert (Self.Data)); + if not Sync_Bool_Compare_And_Swap + (R.Weak_Data'Access, Oldval => null, Newval => V) + then + -- Was set by another thread concurrently + Unchecked_Free (V); + + -- Need to increase refcount for the old weak ref + Inc_Ref (R.Weak_Data, Atomic_Counters); + end if; + + else + Inc_Ref (R.Weak_Data, Atomic_Counters); + end if; + + return (Controlled with Data => R.Weak_Data); + end Weak; + + --------- + -- Set -- + --------- + + procedure Set (Self : in out Ref'Class; Weak : Weak_Ref'Class) is + Data : Pools.Element_Access; + WD : Weak_Data_Access := Weak.Data; + NL : Atomic_Counter; + begin + Finalize (Self); + + if WD = null then + return; + end if; + + Data := Convert (WD.Element); + + if Data = null then + return; + end if; + + if Integer (Sync_Add_And_Fetch (WD.Lock'Access, 2)) rem 2 /= 0 then + return; + end if; + + if Inc_Ref (Pools.Header_Of (Data), Atomic_Counters) then + Self.Data := Data; + end if; + + NL := Sync_Sub_And_Fetch (WD.Lock'Access, 2); + + pragma Assert + (Integer (NL) rem 2 = 0, "Unexpected Lock value " & NL'Img); + end Set; + + --------------- + -- Was_Freed -- + --------------- + + function Was_Freed (Self : Weak_Ref'Class) return Boolean is + begin + return Self.Data = null + or else Self.Data.Element = System.Null_Address; + end Was_Freed; + + --------- + -- "=" -- + --------- + + overriding function "=" (P1, P2 : Ref) return Boolean is + begin + return P1.Data = P2.Data; + end "="; + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (Self : in out Ref) is + RC : Atomic_Counter; + begin + if Self.Data /= null then + RC := Inc_Ref (Pools.Header_Of (Self.Data), Atomic_Counters); + + pragma Assert + (RC > 1, "Unexpected reference counter after adjust" & RC'Img); + end if; + end Adjust; + + ------------ + -- Adjust -- + ------------ + + overriding procedure Adjust (Self : in out Weak_Ref) is + begin + if Self.Data /= null then + Inc_Ref (Self.Data, Atomic_Counters); + end if; + end Adjust; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Self : in out Weak_Ref) is + begin + if Self.Data /= null then + Finalize (Self.Data, Atomic_Counters); + + -- Make Finalize idempotent, since it could be called several + -- times for the same instance (RM 7.6.1(24)). + + Self.Data := null; + end if; + end Finalize; + + -------------- + -- Finalize -- + -------------- + + overriding procedure Finalize (Self : in out Ref) is + R : Counters_Access; + Data : Pools.Element_Access := Self.Data; + begin + if Data /= null then + Self.Data := null; + + R := Pools.Header_Of (Data); + + if (if Atomic_Counters + then Decrement (R.Refcount) + else Unsafe_Decrement (R.Refcount)) + then + if R.Weak_Data /= null then + R.Weak_Data.Element := Null_Address; + + -- Spinlock to wait until all Set Ref from Weak_Ref + -- operations completed. + + while R.Weak_Data.Lock /= 0 + or else not Sync_Bool_Compare_And_Swap_Counter + (R.Weak_Data.Lock'Access, 0, 1) + loop + -- Would be better to use GCC _mm_pause instruction + -- instead of zero delay but it is not supported in GCC + -- for all platforms. + + delay 0.0; + end loop; + + Finalize (R.Weak_Data, Atomic_Counters); + end if; + + Release (Data.all); + Unchecked_Free (Data); -- using storage_pool + end if; + end if; + end Finalize; + + ------------------ + -- Get_Refcount -- + ------------------ + + function Get_Refcount (Self : Ref'Class) return Natural is + begin + if Self.Data = null then + return 0; + else + return Natural (Pools.Header_Of (Self.Data).Refcount); + end if; + end Get_Refcount; + + ------------------ + -- From_Element -- + ------------------ + + procedure From_Element + (Self : out Ref'Class; Element : Element_Access) is + begin + if Self.Data /= Element then + Finalize (Self); + Self.Data := Element; + Adjust (Self); + end if; + end From_Element; + end Limited_Shared_Pointers; + -------------------- -- Smart_Pointers -- -------------------- diff --git a/minimal/src/gnatcoll-refcount.ads b/minimal/src/gnatcoll-refcount.ads index 60201dd0..a3387e0d 100644 --- a/minimal/src/gnatcoll-refcount.ads +++ b/minimal/src/gnatcoll-refcount.ads @@ -321,6 +321,235 @@ package GNATCOLL.Refcount is (Ada.Finalization.Controlled with Data => null); end Shared_Pointers; + ----------------------------- + -- Limited_Shared_Pointers -- + ----------------------------- + + generic + type Element_Type (<>) is limited private; + -- The element that will be encapsulated within a smart pointer. + + with procedure Release (Self : in out Element_Type) is null; + -- This procedure should be used if you need to perform actions when + -- the last reference to an element is removed. Typically, this is + -- used to free element_type and its contents, when it is not a + -- controlled type. + + Atomic_Counters : Boolean := Application_Uses_Tasks; + -- Whether to use atomic (and thus thread-safe) counters. If set to + -- True, the smart pointer is task safe. Of course, that does not + -- mean that the Element_Type itself is task safe. + -- This has a small impact on performance. + + package Limited_Shared_Pointers is + pragma Suppress (All_Checks); + + Is_Task_Safe : constant Boolean := Atomic_Counters; + -- Make the formal parameter visible to users of this package + + type Ref is tagged private; + Null_Ref : constant Ref; + -- This type acts like a pointer, but holds a reference to the object, + -- which will thus never be freed while there exists at least one + -- reference to it. + + type Weak_Ref is tagged private; + Null_Weak_Ref : constant Weak_Ref; + -- A weak reference to an object. The value returned by Get will be + -- reset to null when the object is freed (because its last reference + -- expired). Holding a weak reference does not prevent the deallocation + -- of the object. + + package Pools is new Headers.Typed (Element_Type); + subtype Element_Access is Pools.Element_Access; + + procedure Set + (Self : in out Ref'Class; + Get_Data : access function return Element_Type); + pragma Inline (Set); + -- The return value of Get_Data will be put under control of Self, and + -- freed when the last reference to it is removed. + + procedure From_Element (Self : out Ref'Class; Element : Element_Access); + pragma Inline (From_Element); + -- Given an element that is already under control of a + -- shared pointer, returns the corresponding shared pointer. + -- This is especially useful when the element_type is a tagged + -- type. This element might be used for dynamic dispatching, but + -- it might be necessary to retrieve the smart pointer: + -- + -- type Object is tagged private; + -- package Pointers is new Shared_Pointers (Object'Class); + -- use Pointers; + -- + -- procedure Method (Self : Object'Class) is + -- R : Ref; + -- begin + -- From_Element (R, Self); + -- end Method; + -- + -- R : Ref; + -- R.Set (Get_Obj); + -- Method (R.Get); + -- + -- Warning: this must only be called when Element comes from a + -- shared pointer, otherwise an invalid memory access will result. + + type Reference_Type (Element : access Element_Type) + is limited null record + with Implicit_Dereference => Element; + -- A reference to an element_type. + -- This type is used as the return value for Get, instead of an + -- Element_Access, because it is safer: + -- * applications cannot free the returned value (and + -- they should never do it !) + -- * the Element discriminant cannot be stored in a variable, + -- so that prevents keeping a reference when it could be freed at + -- any time. + -- * since the type is limited, it is in general difficult to + -- store it in records. This is intended, since the shared + -- pointer itself should be stored instead (at the access type + -- might be freed at any time). + -- This type is often mostly transparent for the application. Assuming + -- the Element_Type is defined as: + -- + -- type Element_Type is tagged record + -- Field : Integer; + -- end record; + -- procedure Primitive (Self : Element_Type); + -- procedure Primitive2 (Self : access Element_Type); + -- + -- then a shared pointer SP can be used as: + -- + -- SP.Get.Field := 1; + -- SP.Get.Primitive1; + -- SP.Get.Element.Primitive2; + -- + -- WARNING: + -- The use of a reference_type ensures that Get can return an access to + -- the object (more efficient than a copy when the objects are large), + -- while preventing users from freeing the returned value. But this + -- does not prevent all invalid cases. Using 'renames', for instance, + -- can lead to invalid code, as in: + -- + -- package IP is new Shared_Pointers (Integer); + -- use IP; + -- R : Ref; + -- R.Set (99); + -- declare + -- Int : Integer renames R.Get.Element.all; + -- begin + -- R := Null_Ref; -- Frees Int ! + -- Put_Line (I'Img); -- Invalid memory access + -- end; + -- + -- Another dangerous use is to have a procedure that receives the + -- result of Get and modifies the shared pointer, as in: + -- + -- package OP is new Shared_Pointers (Object'Class); + -- use OP; + -- R : Ref; + -- procedure Foo (Obj : Object'Class) is + -- begin + -- R := Null_Ref; -- freezes Obj ! + -- end Foo; + -- Foo (R.Get); + -- + -- The proper solution here is that Foo should receive the smart + -- pointer itself, not the encapsulated value. + + function Unchecked_Get (Self : Ref'Class) return Element_Access + with Inline; + -- A version that returns directly the element access. This is meant + -- for easy conversion of existing code, but its use is discouraged + -- in new code, where Get should be used instead. + -- The resulting access must not be deallocated. Passing it to + -- Set might also be dangerous if the Element_Type contains data + -- that might be freed when other smart pointers are freed. + -- It also must not be stored in a record (store Self instead). + + function Get (Self : Ref'Class) return Reference_Type + is ((Element => Unchecked_Get (Self))) + with Inline; + -- A safer version of Unchecked_Get. + -- There is no performance penalty, since the compiler knows that a + -- Reference_Type is in fact always of the same size and can be + -- returned on the stack. + -- It is safer because the associated access type cannot be converted + -- to a non-local access type, nor freed. + + procedure Process + (Self : Ref'Class; + Process : not null access procedure (E : Element_Type)) + with Inline; + -- This procedure is similar to the function Get, but doesn't expose + -- the access type to the user. + -- This is safer than Get, since it avoids the multiple issues + -- highlighted in the comments for Reference_Type (namely that Self + -- might become null while the application holds a reference, which + -- then references invalid memory). + -- On the other hand, it is more awkward to use, and does not work if + -- you need to pass multiple smart pointers. There is however nothing + -- tricky in this procedure, since it simply calls + -- Process (Self.Get) + -- and the simple fact that Self is a parameter ensures it retains at + -- least one reference during the execution of Process. + -- + -- If you want to always be on the safe side and prevent users from + -- using Get, you could add the following configuration pragma to your + -- compilation: + -- pragma Restrictions + -- (No_Use_Of_Entity => GNATCOLL.Refcount.Shared_Pointers.Get); + + function Is_Null (Self : Ref'Class) return Boolean with Inline; + -- Whether the data is unset. Using this function might avoid the + -- need for a "use type Element_Access" in your code. + + overriding function "=" (P1, P2 : Ref) return Boolean with Inline; + -- This operator checks whether P1 and P2 share the same pointer. + -- When the pointers differ, this operator returns False even if the + -- two pointed elements are equal. + + function Weak (Self : Ref'Class) return Weak_Ref; + procedure Set (Self : in out Ref'Class; Weak : Weak_Ref'Class); + -- Set returns a reference to the object. Otherwise, it would be + -- possible for a procedure to retrieve a pointer from the weak + -- reference, and then reference it throughout the procedure, even + -- though the pointer might be freed in between. + -- + -- If Weak is Null_Weak_Ref, then the element pointed by Self simply + -- loses a reference, and Self points to nothing on exit. + + function Was_Freed (Self : Weak_Ref'Class) return Boolean; + -- True if the object referenced by Self was freed. + + function Get_Refcount (Self : Ref'Class) return Natural; + -- Return the current reference count. + -- This is mostly intended for debug purposes. + + private + type Ref is new Ada.Finalization.Controlled with record + Data : Element_Access; + end record; + pragma Finalize_Storage_Only (Ref); + overriding procedure Adjust (Self : in out Ref); + pragma Inline (Adjust); + overriding procedure Finalize (Self : in out Ref); + + type Weak_Ref is new Ada.Finalization.Controlled with record + Data : Weak_Data_Access; + end record; + pragma Finalize_Storage_Only (Weak_Ref); + overriding procedure Adjust (Self : in out Weak_Ref); + pragma Inline (Adjust); + overriding procedure Finalize (Self : in out Weak_Ref); + + Null_Ref : constant Ref := + (Ada.Finalization.Controlled with Data => null); + Null_Weak_Ref : constant Weak_Ref := + (Ada.Finalization.Controlled with Data => null); + end Limited_Shared_Pointers; + -------------------- -- Smart_Pointers -- --------------------