Index: natools.gpr ================================================================== --- natools.gpr +++ natools.gpr @@ -1,10 +1,11 @@ project Natools is type Build_Type is ("Release", "Coverage"); Mode : Build_Type := external ("MODE", "Release"); - type Task_Safety is ("None", "Portable"); + type Task_Safety is ("None", "Portable", "Intel"); + -- Task-safe, portable, efficient: choose two Safety : Task_Safety := external ("TASK_SAFETY", "None"); Prefix := ""; Extra_Switches := (); @@ -77,8 +78,13 @@ when "Portable" => for spec ("Natools.References") use "natools-references__protected.ads"; for body ("Natools.References") use "natools-references__protected.adb"; + when "Intel" => + for spec ("Natools.References") + use "natools-references__intel.ads"; + for body ("Natools.References") + use "natools-references__intel.adb"; end case; end Naming; end Natools; ADDED src/natools-references__intel.adb Index: src/natools-references__intel.adb ================================================================== --- src/natools-references__intel.adb +++ src/natools-references__intel.adb @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013-2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +with Ada.Characters.Latin_1; +with Ada.Unchecked_Deallocation; +with System.Machine_Code; + +package body Natools.References is + + --------------------------------- + -- Low-level memory management -- + --------------------------------- + + overriding procedure Adjust (Object : in out Immutable_Reference) is + begin + if Object.Count /= null then + Increment (Object.Count); + end if; + end Adjust; + + + overriding procedure Finalize (Object : in out Immutable_Reference) is + procedure Free is + new Ada.Unchecked_Deallocation (Held_Data, Data_Access); + procedure Free is + new Ada.Unchecked_Deallocation (Counter, Counter_Access); + + Deallocate : Boolean; + begin + if Object.Count /= null then + Decrement (Object.Count, Deallocate); + + if Deallocate then + Free (Object.Count); + Free (Object.Data); + else + Object.Count := null; + Object.Data := null; + end if; + end if; + end Finalize; + + + + ----------------------------------------- + -- Object construction and destruction -- + ----------------------------------------- + + function Create + (Constructor : not null access function return Held_Data) + return Immutable_Reference is + begin + return (Ada.Finalization.Controlled with + Data => new Held_Data'(Constructor.all), + Count => new Counter'(1)); + end Create; + + + procedure Replace + (Ref : in out Immutable_Reference; + Constructor : not null access function return Held_Data) is + begin + Finalize (Ref); + Ref.Data := new Held_Data'(Constructor.all); + Ref.Count := new Counter'(1); + end Replace; + + + function Create (Data : in Data_Access) return Immutable_Reference is + begin + if Data = null then + return Null_Immutable_Reference; + else + return (Ada.Finalization.Controlled with + Data => Data, + Count => new Counter'(1)); + end if; + end Create; + + + procedure Replace + (Ref : in out Immutable_Reference; + Data : in Data_Access) is + begin + Finalize (Ref); + + if Data /= null then + Ref.Data := Data; + Ref.Count := new Counter'(1); + end if; + end Replace; + + + procedure Reset (Ref : in out Immutable_Reference) is + begin + Finalize (Ref); + end Reset; + + + function Is_Empty (Ref : Immutable_Reference) return Boolean is + begin + return Ref.Count = null; + end Is_Empty; + + + function "=" (Left, Right : Immutable_Reference) return Boolean is + begin + return Left.Data = Right.Data; + end "="; + + + + ---------------------- + -- Dereferenciation -- + ---------------------- + + function Query (Ref : in Immutable_Reference) return Accessor is + begin + return Accessor'(Data => Ref.Data, Parent => Ref); + end Query; + + + function Update (Ref : in Reference) return Mutator is + begin + return Mutator'(Data => Ref.Data, Parent => Ref); + end Update; + + + procedure Query + (Ref : in Immutable_Reference; + Process : not null access procedure (Object : in Held_Data)) is + begin + Process.all (Ref.Data.all); + end Query; + + + procedure Update + (Ref : in Reference; + Process : not null access procedure (Object : in out Held_Data)) is + begin + Process.all (Ref.Data.all); + end Update; + + + + ------------------------ + -- Counter Management -- + ------------------------ + +-- procedure Increment (Object : in Counter_Access) is +-- begin +-- Object.all := Object.all + 1; +-- end Increment; +-- +-- procedure Decrement (Object : in Counter_Access; Zero : out Boolean) is +-- begin +-- Object.all := Object.all - 1; +-- Zero := Object.all = 0; +-- end Decrement; + + procedure Increment (Object : in Counter_Access) is + begin + System.Machine_Code.Asm + (Template => "lock incl %0", + Outputs => Counter'Asm_Output ("+m", Object.all), + Volatile => True, + Clobber => "cc, memory"); + end Increment; + + + procedure Decrement (Object : in Counter_Access; Zero : out Boolean) is + package Latin_1 renames Ada.Characters.Latin_1; + use type Interfaces.Unsigned_8; + Z_Flag : Interfaces.Unsigned_8; + begin + System.Machine_Code.Asm + (Template => "lock decl %0" & Latin_1.LF & Latin_1.HT + & "setz %1", + Outputs => (Counter'Asm_Output ("+m", Object.all), + Interfaces.Unsigned_8'Asm_Output ("=q", Z_Flag)), + Volatile => True, + Clobber => "cc, memory"); + Zero := Z_Flag = 1; + end Decrement; + +end Natools.References; + ADDED src/natools-references__intel.ads Index: src/natools-references__intel.ads ================================================================== --- src/natools-references__intel.ads +++ src/natools-references__intel.ads @@ -0,0 +1,144 @@ +------------------------------------------------------------------------------ +-- Copyright (c) 2013-2014, Natacha Porté -- +-- -- +-- Permission to use, copy, modify, and distribute this software for any -- +-- purpose with or without fee is hereby granted, provided that the above -- +-- copyright notice and this permission notice appear in all copies. -- +-- -- +-- THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES -- +-- WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF -- +-- MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR -- +-- ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES -- +-- WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN -- +-- ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF -- +-- OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. -- +------------------------------------------------------------------------------ + +------------------------------------------------------------------------------ +-- Natools.References implements reference-counted smart pointer to any -- +-- type of objects. -- +-- This is a basic implementation that does not support weak references, -- +-- but uses Intel assembly code to ensure task safety. -- +-- Beware though that there is still no guarantee on the task-safety of the -- +-- operations performed on the referred objects. -- +------------------------------------------------------------------------------ + +with Ada.Finalization; +with System.Storage_Pools; + +private with Interfaces; + +generic + type Held_Data (<>) is limited private; + Counter_Pool : in out System.Storage_Pools.Root_Storage_Pool'Class; + Data_Pool : in out System.Storage_Pools.Root_Storage_Pool'Class; + +package Natools.References is + pragma Preelaborate (References); + + type Accessor (Data : not null access constant Held_Data) is + limited private; + type Mutator (Data : not null access Held_Data) is + limited private; + + type Data_Access is access Held_Data; + for Data_Access'Storage_Pool use Data_Pool; + + + type Immutable_Reference is new Ada.Finalization.Controlled with private; + + function Create + (Constructor : not null access function return Held_Data) + return Immutable_Reference; + -- Create a new held object and return a reference to it + + procedure Replace + (Ref : in out Immutable_Reference; + Constructor : not null access function return Held_Data); + -- Replace the object held in Ref with a newly created object + + function Create (Data : in Data_Access) return Immutable_Reference; + -- Create a new reference from Data. + -- From this point the referred object is owned by this + -- package and must NOT be freed or changed or accessed. + + procedure Replace (Ref : in out Immutable_Reference; Data : in Data_Access); + -- Integrate Data into Ref. + -- From this point the referred object is owned by this + -- package and must NOT be freed or changed or accessed. + + procedure Reset (Ref : in out Immutable_Reference); + -- Empty Ref + + function Is_Empty (Ref : Immutable_Reference) return Boolean; + -- Check whether Ref refers to an actual object + + function "=" (Left, Right : Immutable_Reference) return Boolean; + -- Check whether Left and Right refer to the same object + + function Query (Ref : in Immutable_Reference) return Accessor; + pragma Inline (Query); + -- Return a derefenciable constant access to the held object + + procedure Query + (Ref : in Immutable_Reference; + Process : not null access procedure (Object : in Held_Data)); + -- Call Process with the held object + + Null_Immutable_Reference : constant Immutable_Reference; + + + type Reference is new Immutable_Reference with private; + + function Update (Ref : in Reference) return Mutator; + pragma Inline (Update); + -- Return a ereferenciable mutable access to the held object + + procedure Update + (Ref : in Reference; + Process : not null access procedure (Object : in out Held_Data)); + -- Call Process with the held object + + Null_Reference : constant Reference; + +private + + type Counter is new Interfaces.Unsigned_32; + + type Counter_Access is access Counter; + for Counter_Access'Storage_Pool use Counter_Pool; + + procedure Increment (Object : in Counter_Access); + pragma Inline (Increment); + + procedure Decrement (Object : in Counter_Access; Zero : out Boolean); + pragma Inline (Decrement); + + type Immutable_Reference is new Ada.Finalization.Controlled with record + Count : Counter_Access := null; + Data : Data_Access := null; + end record; + + overriding procedure Adjust (Object : in out Immutable_Reference); + -- Increate reference counter + + overriding procedure Finalize (Object : in out Immutable_Reference); + -- Decrease reference counter and release memory if needed + + type Reference is new Immutable_Reference with null record; + + type Accessor (Data : not null access constant Held_Data) is limited record + Parent : Immutable_Reference; + end record; + + type Mutator (Data : not null access Held_Data) is limited record + Parent : Reference; + end record; + + Null_Immutable_Reference : constant Immutable_Reference + := (Ada.Finalization.Controlled with Count => null, Data => null); + + Null_Reference : constant Reference + := (Null_Immutable_Reference with null record); + +end Natools.References; Index: tests.gpr ================================================================== --- tests.gpr +++ tests.gpr @@ -15,14 +15,14 @@ for Default_Switches use Natools.Linker'Default_Switches; end Linker; package Naming is case Natools.Safety is - when "None" => + when "None" | "Intel" => for body ("Natools.References.Tools") use "natools-references-tools__unsafe.adb"; when "Portable" => for body ("Natools.References.Tools") use "natools-references-tools__protected.adb"; end case; end Naming; end Tests;