Re: Robert Dewar's great article about the Strengths of Ada over other langauges in multiprocessing!

[Vadim Godunko <vgodunko@gmail.com>]

On Mar 9, 4:37 pm, "Dmitry A. Kazakov" <mail...@dmitry-kazakov.de>
wrote:
>
> It is unclear in which the context you are using protected objects. I don't
> see why a protected object should be slower than, say, critical section +
> operation.
>
I have attach all source code. Protected object used for atomic
reference counting (The design may be looks strange, I just have plans
to replace protected object by the inline assembler code). C++ class
used inline assembler for the same. Both C++ class and Ada tagged type
share internal string data.

> >       for J in 1 .. 1_000 loop
> >          if J mod 2 = 1 then
> >             B := A;
>
> Is this a deep copy?
No.

> What is controlled, array, elements, both?
Array's elements are controlled.

> What is the locking policy, per container, per element, both?
Per element.

------->-8--------

private with Ada.Finalization;

private with League.Internals.Atomics;

package League.Strings is

   pragma Preelaborate;

   type Universal_String is tagged private;

   function To_Universal_String (Item : in Wide_Wide_String)
     return Universal_String;

   function To_Wide_Wide_String (Self : in Universal_String'Class)
     return Wide_Wide_String;

   function "=" (Left  : in Universal_String;
                 Right : in Universal_String)
     return Boolean;

private

   type Utf16_String is new Wide_String;

   type Utf16_String_Access is access all Utf16_String;

   type Private_Data is record
      Counter : aliased League.Internals.Atomics.Counter;
      String  : Utf16_String_Access;
      Last    : Natural := 0;
      Length  : Natural := 0;
   end record;

   type Private_Data_Access is access all Private_Data;

   Empty_String : aliased Utf16_String := "";

   Shared_Empty : aliased Private_Data
     := (String => Empty_String'Access,
         others => <>);

   type Universal_String is new Ada.Finalization.Controlled with
record
      Data : Private_Data_Access := Shared_Empty'Access;
   end record;

   overriding
   procedure Initialize (Self : in out Universal_String);

   overriding
   procedure Adjust (Self : in out Universal_String);

   overriding
   procedure Finalize (Self : in out Universal_String);

end League.Strings;

with Ada.Unchecked_Deallocation;

package body League.Strings is

   Surrogate_First      : constant := 16#D800#;
   High_Surrogate_First : constant := 16#D800#;
   High_Surrogate_Last  : constant := 16#DBFF#;
   Low_Surrogate_First  : constant := 16#DC00#;
   Low_Surrogate_Last   : constant := 16#DFFF#;
   Surrogate_Last       : constant := 16#DFFF#;

   subtype Surrogate_Wide_Character is Wide_Character
     range Wide_Character'Val (Surrogate_First)
             .. Wide_Character'Val (Surrogate_Last);

   subtype High_Surrogate_Wide_Character is Surrogate_Wide_Character
     range Wide_Character'Val (High_Surrogate_First)
             .. Wide_Character'Val (High_Surrogate_Last);

   subtype Low_Surrogate_Wide_Character is Surrogate_Wide_Character
     range Wide_Character'Val (Low_Surrogate_First)
             .. Wide_Character'Val (Low_Surrogate_Last);

   procedure Free is
     new Ada.Unchecked_Deallocation (Private_Data,
Private_Data_Access);

   procedure Free is
     new Ada.Unchecked_Deallocation (Utf16_String,
Utf16_String_Access);

   function "=" (Left  : in Universal_String;
                 Right : in Universal_String)
     return Boolean
   is
   begin
      raise Program_Error;
      return False;
   end "=";

   overriding
   procedure Adjust (Self : in out Universal_String) is
   begin
      League.Internals.Atomics.Increment (Self.Data.Counter'Access);
   end Adjust;

   overriding
   procedure Finalize (Self : in out Universal_String) is
   begin
      if League.Internals.Atomics.Decrement (Self.Data.Counter'Access)
then
         pragma Assert (Self.Data /= Shared_Empty'Access);

         Free (Self.Data.String);
         Free (Self.Data);
      end if;
   end Finalize;

   overriding
   procedure Initialize (Self : in out Universal_String) is
   begin
      League.Internals.Atomics.Increment (Self.Data.Counter'Access);
   end Initialize;

   function To_Universal_String (Item : in Wide_Wide_String)
     return Universal_String
   is
      Aux  : Utf16_String_Access
        := new Utf16_String (1 .. Item'Length * 2);
      --  Reserve memory in assumption of all character will be
encoded as
      --  surrogate pair.

      Last : Natural := 0;

   begin
      for J in Item'Range loop
         if Item (J) > Wide_Wide_Character'Val (Code_Point'Last)
           or else Item (J) in Wide_Wide_Character'Val
(Surrogate_First)
                                 .. Wide_Wide_Character'Val
(Surrogate_Last)
         then
            raise Constraint_Error
              with "Wide_Wide_Character is not a valid Unicode code
point";
         end if;

         declare
            C : constant Code_Point
              := Wide_Wide_Character'Pos (Item (J));

         begin
            if C <= 16#FFFF# then
               Last := Last + 1;
               Aux (Last) := Wide_Character'Val (C);

            else
               Last := Last + 1;
               Aux (Last) :=
                 Wide_Character'Val (High_Surrogate_First + C /
16#400#);

               Last := Last + 1;
               Aux (Last) :=
                 Wide_Character'Val (Low_Surrogate_First + C mod
16#400#);
            end if;
         end;
      end loop;

      return
       (Ada.Finalization.Controlled with
          Data =>
            new Private_Data'
                 (Counter => League.Internals.Atomics.One,
                  String  => Aux,
                  Last    => Last,
                  Length  => Item'Length));

   exception
      when others =>
         Free (Aux);

         raise;
   end To_Universal_String;

   function To_Wide_Wide_String (Self : in Universal_String'Class)
     return Wide_Wide_String
   is
      Current : Positive := 1;

   begin
      return Result : Wide_Wide_String (1 .. Self.Data.Length) do
         for J in Result'Range loop
            if Self.Data.String (Current) in Surrogate_Wide_Character
then
               if Current < Self.Data.Last
                 and then Self.Data.String (Current)
                            in High_Surrogate_Wide_Character
                 and then Self.Data.String (Current + 1)
                            in Low_Surrogate_Wide_Character
               then
                  Result (J) :=
                    Wide_Wide_Character'Val
                     ((Wide_Character'Pos (Self.Data.String (Current))
                         - High_Surrogate_First) * 16#400#
                        + (Wide_Character'Pos
                            (Self.Data.String (Current + 1))
                            - Low_Surrogate_First)
                        + 16#1_0000#);
                  Current := Current + 2;

               else
                  raise Constraint_Error
                    with "Ill-formed UTF-16 string: invalid surrogate
pair";
               end if;

            else
               Result (J) :=
                 Wide_Wide_Character'Val
                  (Wide_Character'Pos (Self.Data.String (Current)));
               Current := Current + 1;
            end if;
         end loop;

         pragma Assert (Current = Self.Data.Last + 1);
      end return;
   end To_Wide_Wide_String;

end League.Strings;
private with Interfaces.C;

package League.Internals.Atomics is

   pragma Preelaborate;

   type Counter is private;

   Zero : constant Counter;
   One  : constant Counter;

   procedure Increment (Self : not null access Counter);
   --  Atomicaly increment counter value.

   function Decrement (Self : not null access Counter)
     return Boolean;
   --  Atomicaly decrement counter value. Returns True if counter has
zero
   --  value after decrement.

private

   type Counter is record
      Value : Interfaces.C.int := 1;
   end record;

   Zero : constant Counter := (Value => 0);
   One  : constant Counter := (Value => 1);

end League.Internals.Atomics;
------------------------------------------------------------------------------
--  This is portable version of the package.
------------------------------------------------------------------------------

package body League.Internals.Atomics is

   protected Guard is

      procedure Increment (Self : not null access Counter);

      procedure Decrement (Self : not null access Counter;
                           Zero : out Boolean);

   end Guard;

   function Decrement (Self : not null access Counter)
     return Boolean
   is
      Aux : Boolean;

   begin
      Guard.Decrement (Self, Aux);

      return Aux;
   end Decrement;

   protected body Guard is

      procedure Decrement (Self : not null access Counter;
                           Zero : out Boolean)
      is
         use type Interfaces.C.int;

      begin
         Self.Value := Self.Value - 1;

         Zero := Self.Value = 0;
      end Decrement;

      procedure Increment (Self : not null access Counter) is
         use type Interfaces.C.int;

      begin
         Self.Value := Self.Value + 1;
      end Increment;

   end Guard;

   procedure Increment (Self : not null access Counter) is
   begin
      Guard.Increment (Self);
   end Increment;

end League.Internals.Atomics;
package League.Internals is

   pragma Pure;

end League.Internals;
package League is

   pragma Pure;

   type Code_Point is mod 16#11_0000#;
   for Code_Point'Size use 32;

end League;