Natools

project Natools is
   type Build_Type is ("Release", "Coverage");
   Mode : Build_Type := external ("MODE", "Release");

   type Task_Safety is ("None", "Portable", "Intel");
      --  Task-safe, portable, efficient: choose two
   Safety : Task_Safety := external ("TASK_SAFETY", "None");

   Prefix := "";
   Extra_Switches := ();

   case Mode is
      when "Release" =>

            for body ("Natools.References")
              use "natools-references__unsafe.adb";
         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;

------------------------------------------------------------------------------
-- 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;

------------------------------------------------------------------------------
-- 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;

   package Linker is
      for Default_Switches use Natools.Linker'Default_Switches;
   end Linker;

   package Naming is
      case Natools.Safety is
         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;