lace.event.subject: Add event emitter to lessen lag when using DSA.

1-base/lace/library/lace.gpr

@@ -26,6 +26,7 @@ is
                         "../source/events/concrete",
                         "../source/events/interface",
                         "../source/events/mixin",
+                        "../source/events/mixin/private",
                         "../source/events/mixin/" & external ("restrictions", "xgc"),
                         "../source/events/utility",
                         "../source/strings",

1-base/lace/source/events/interface/lace-subject.ads

@@ -64,6 +64,12 @@ is
    -- Observers who cannot be communicated with are returned.
 
 
+   procedure use_event_Emitter (Self : in out Item) is abstract;
+   --
+   -- Delegate event emission to a task to prevent blocking. Useful for reducing lag with DSA.
+
+
+
    ----------
    -- Logging
    --

1-base/lace/source/events/mixin/lace-make_subject.adb

@@ -13,6 +13,11 @@ is
    procedure destroy (Self : in out Item)
    is
    begin
+      if Self.Emitter /= null
+      then
+         Self.Emitter.destruct;
+      end if;
+
       Self.safe_Observers.destruct;
    end destroy;
 
@@ -29,6 +34,7 @@ is
    end Observers;
 
 
+
    overriding
    function observer_Count (Self : in Item) return Natural
    is
@@ -37,6 +43,7 @@ is
    end observer_Count;
 
 
+
    -------------
    -- Operations
    --
@@ -57,6 +64,7 @@ is
    end register;
 
 
+
    overriding
    procedure deregister (Self : in out Item;   the_Observer : in Observer.view;
                                                of_Kind      : in Event.Kind)
@@ -73,39 +81,60 @@ is
    end deregister;
 
 
+
+   overriding
+   procedure use_event_Emitter (Self : in out Item)
+   is
+   begin
+      Self.Emitter := new event_Emitter.item;
+      Self.Emitter.define (Self'unchecked_Access);
+   end use_event_Emitter;
+
+
+
    overriding
    procedure emit (Self : access Item;   the_Event : in Event.item'Class := Event.null_Event)
    is
-      use lace.Event.utility;
-      my_Observers : constant Subject.Observer_views := Self.Observers (to_Kind (the_Event'Tag));
    begin
-      for i in my_Observers'Range
+      if Self.Emitter = null
-      loop
+      then
+         declare
+            use lace.Event.utility;
+            my_Observers : constant Subject.Observer_views := Self.Observers (to_Kind (the_Event'Tag));
          begin
-            my_Observers (i).receive (the_Event,
+            for i in my_Observers'Range
-                                      from_Subject => Subject.item'Class (Self.all).Name);
+            loop
-            if Subject.Logger /= null
+               begin
-            then
+                  my_Observers (i).receive (the_Event,
-               Subject.Logger.log_Emit (Subject.view (Self),
+                                            from_Subject => Subject.item'Class (Self.all).Name);
-                                        my_Observers (i),
+                  if Subject.Logger /= null
-                                        the_Event);
+                  then
-            end if;
+                     Subject.Logger.log_Emit (Subject.view (Self),
+                                              my_Observers (i),
+                                              the_Event);
+                  end if;
 
-         exception
+               exception
-            when system.RPC.communication_Error
+                  when system.RPC.communication_Error
-               | storage_Error =>
+                     | storage_Error =>
 
-               if Subject.Logger /= null
+                     if Subject.Logger /= null
-               then
+                     then
-                  Subject.Logger.log_Emit (Subject.view (Self),
+                        Subject.Logger.log_Emit (Subject.view (Self),
-                                           my_Observers (i),
+                                                 my_Observers (i),
-                                           the_Event);
+                                                 the_Event);
-               end if;
+                     end if;
+               end;
+            end loop;
          end;
-      end loop;
+
+      else
+         Self.Emitter.add (the_Event);
+      end if;
    end emit;
 
 
+
    overriding
    function emit (Self : access Item;   the_Event : in Event.item'Class := Event.null_Event)
                   return subject.Observer_views
@@ -139,6 +168,7 @@ is
    end emit;
 
 
+
    -----------------
    -- Safe Observers
    --
@@ -166,6 +196,7 @@ is
       end destruct;
 
 
+
       procedure add (the_Observer : in Observer.view;
                      of_Kind      : in Event.Kind)
       is
@@ -188,6 +219,7 @@ is
       end add;
 
 
+
       procedure rid (the_Observer : in Observer.view;
                      of_Kind      : in Event.Kind)
       is
@@ -197,6 +229,7 @@ is
       end rid;
 
 
+
       function fetch_Observers (of_Kind : in Event.Kind) return subject.Observer_views
       is
       begin
@@ -219,6 +252,7 @@ is
       end fetch_Observers;
 
 
+
       function observer_Count return Natural
       is
          use event_kind_Maps_of_event_observers;

1-base/lace/source/events/mixin/lace-make_subject.ads

@@ -3,8 +3,11 @@ with
      lace.Subject,
      lace.Observer;
 
+
 private
 with
+     lace.event_Emitter,
+
      ada.Containers.Vectors,
      ada.Containers.indefinite_hashed_Maps;
 
@@ -32,6 +35,7 @@ is
 
    overriding
    function Observers      (Self : in Item;   of_Kind : in Event.Kind) return Subject.Observer_views;
+
    overriding
    function observer_Count (Self : in Item) return Natural;
 
@@ -54,6 +58,11 @@ is
    function  emit (Self : access Item;   the_Event : in Event.item'Class := Event.null_Event)
                    return subject.Observer_views;
 
+   overriding
+   procedure use_event_Emitter (Self : in out Item);
+   --
+   -- Delegate event emission to a task to prevent blocking. Useful for reducing lag with DSA.
+
 
 
 private
@@ -71,6 +80,7 @@ private
    type    event_Observer_Vector_view is access all event_Observer_Vector;
 
 
+
    -------------------------------------
    -- Event kind Maps of event observers
    --
@@ -82,6 +92,7 @@ private
    subtype event_kind_Map_of_event_observers  is event_kind_Maps_of_event_observers.Map;
 
 
+
    -----------------
    -- Safe observers
    --
@@ -104,14 +115,19 @@ private
    end safe_Observers;
 
 
+
    ---------------
    -- Subject Item
    --
+
+   type event_Emitter_view is access all event_Emitter.item'Class;
+
    type Item is abstract limited new T
                                  and Subject.item
    with
       record
          safe_Observers : make_Subject.safe_Observers;
+         Emitter        : event_Emitter_view;
       end record;
 
 end lace.make_Subject;

1-base/lace/source/events/mixin/private/lace-event_emitter.adb

@@ -0,0 +1,317 @@
+with
+     lace.Observer,
+     lace.Event.utility,
+
+     ada.Text_IO,
+     ada.Exceptions,
+     ada.unchecked_Deallocation,
+     ada.Containers.Vectors,
+     ada.Containers.indefinite_Holders;
+
+
+package body lace.event_Emitter
+is
+
+   ---------------
+   --- Containers.
+   --
+
+   package string_Holders is new ada.Containers.indefinite_Holders (Element_type => String);
+   subtype string_Holder  is string_Holders.Holder;
+
+
+   package event_Holders is new ada.Containers.indefinite_Holders (Element_type => lace.Event.item'Class);
+   subtype event_Holder  is event_Holders.Holder;
+
+
+   package emitter_Vectors is new ada.Containers.Vectors (Positive,
+                                                          Emitter_view);
+   subtype emitter_Vector  is emitter_Vectors.Vector;
+
+
+
+   ------------------
+   --- Safe emitters.
+   --
+
+   protected
+   type safe_Emitters
+   is
+      procedure add (new_Emitter : in     Emitter_view);
+      procedure get (an_Emitter  :    out Emitter_view);
+
+   private
+      all_Emitters : emitter_Vector;
+   end safe_Emitters;
+
+   type safe_Emitters_view is access all safe_Emitters;
+
+
+
+
+   ------------
+   --- Emitter.
+   --
+
+   task
+   type Emitter
+   is
+      entry emit (Self         : in Emitter_view;
+                  the_Event    : in lace.Event.item'Class;
+                  To           : in lace.Observer.view;
+                  from_Subject : in String;
+                  Emitters     : in safe_Emitters_view);
+   end Emitter;
+
+
+
+   task body Emitter
+   is
+      Myself       : Emitter_view;
+      Event        : event_Holder;
+      the_Observer : lace.Observer.view;
+      subject_Name : string_Holder;
+      emitter_Pool : safe_Emitters_view;
+   begin
+      loop
+         select
+            accept emit (Self         : in Emitter_view;
+                         the_Event    : in lace.Event.item'Class;
+                         To           : in lace.Observer.view;
+                         from_Subject : in String;
+                         Emitters     : in safe_Emitters_view)
+            do
+               Event       .replace_Element (the_Event);
+               subject_Name.replace_Element (from_Subject);
+
+               Myself       := Self;
+               the_Observer := To;
+
+               emitter_Pool := Emitters;
+            end emit;
+         or
+            terminate;
+         end select;
+
+         the_Observer.receive (Event.Reference,
+                               from_Subject => subject_Name.Element);
+         emitter_Pool.add     (Myself);     -- Return the emitter to the safe pool.
+      end loop;
+
+   exception
+      when E : others =>
+         ada.Text_IO.put_Line ("Error detected in 'lace.event_Emitter.Emitter' task for subject '" & subject_Name.Element & "'.");
+         ada.Text_IO.put_Line ("Event:    '" & Event.Element'Image & "'.");
+         ada.Text_IO.put_Line ("Observer: '" & the_Observer.Name   & "'.");
+         ada.Text_IO.new_Line;
+         ada.Text_IO.put_Line (ada.Exceptions.exception_Information (E));
+         ada.Text_IO.new_Line;
+   end Emitter;
+
+
+
+
+   -------------------
+   --- Emit delegator.
+   --
+
+   task body emit_Delegator
+   is
+      the_Subject      :         lace.Subject.view;
+      the_subject_Name :         string_Holder;
+
+      the_Emitters     : aliased safe_Emitters;
+
+      the_Events       :         safe_Events_view;
+      new_Events       :         event_Vector;
+      Done             :         Boolean     := False;
+
+   begin
+      accept start (Subject : in lace.Subject.view;
+                    Events  : in safe_Events_view)
+      do
+         the_Subject  := Subject;
+         the_Events   := Events;
+
+         the_subject_Name.replace_Element (Subject.Name);
+      end start;
+
+
+      loop
+         select
+            accept stop
+            do
+               Done := True;
+            end stop;
+
+         else
+            null;
+         end select;
+
+
+         exit when     Done
+                   and the_Events.is_Empty;
+
+         the_Events.get (new_Events);
+
+         for each_Event of new_Events
+         loop
+            declare
+               use lace.Event.utility;
+
+               the_Observers : constant lace.Subject.Observer_views := the_Subject.Observers (of_Kind => Kind_of (each_Event));
+            begin
+               for each_Observer of the_Observers
+               loop
+                  declare
+                     the_Emitter : Emitter_view;
+                  begin
+                     the_Emitters.get (the_Emitter);
+
+                     if the_Emitter = null
+                     then
+                        the_Emitter := new Emitter;
+                     end if;
+
+                     the_Emitter.emit (Self         => the_Emitter,
+                                       the_Event    => each_Event,
+                                       To           => each_Observer,
+                                       from_Subject => the_subject_Name.Element,
+                                       Emitters     => the_Emitters'unchecked_Access);
+                  end;
+               end loop;
+            end;
+         end loop;
+
+         delay 0.001;
+      end loop;
+
+
+      declare
+         procedure free is new ada.unchecked_Deallocation (Emitter,
+                                                           Emitter_view);
+         the_Emitter : Emitter_view;
+      begin
+         loop
+            the_Emitters.get (the_Emitter);
+            exit when the_Emitter = null;
+
+            free (the_Emitter);
+         end loop;
+      end;
+
+   exception
+      when E : others =>
+         ada.Text_IO.put_Line ("Error detected in 'lace.event_Emitter.emit_Delegator' for subject '" & the_subject_Name.Element & "'.");
+         ada.Text_IO.new_Line;
+         ada.Text_IO.put_Line (ada.Exceptions.exception_Information (E));
+         ada.Text_IO.new_Line;
+   end emit_Delegator;
+
+
+
+
+   ----------------
+   --- Safe events.
+   --
+
+   protected body safe_Events
+   is
+
+      procedure add (new_Event : in lace.Event.item'Class)
+      is
+      begin
+         all_Events.append (new_Event);
+      end add;
+
+
+
+      procedure get (the_Events : out event_Vector)
+      is
+      begin
+         the_Events := all_Events;
+         all_Events.clear;
+      end get;
+
+
+
+      function is_Empty return Boolean
+      is
+      begin
+         return all_Events.is_Empty;
+      end is_Empty;
+
+   end safe_Events;
+
+
+
+
+   ------------------
+   --- Safe emitters.
+   --
+
+   protected body safe_Emitters
+   is
+
+      procedure add (new_Emitter : in Emitter_view)
+      is
+      begin
+         all_Emitters.append (new_Emitter);
+      end add;
+
+
+
+      procedure get (an_Emitter : out Emitter_view)
+      is
+      begin
+         if all_Emitters.is_Empty
+         then
+            an_Emitter := null;
+         else
+            an_Emitter := all_Emitters.last_Element;
+            all_Emitters.delete_Last;
+         end if;
+      end get;
+
+   end safe_Emitters;
+
+
+
+
+   -----------------------
+   --- event_Emitter item.
+   --
+
+   procedure define (Self : in out Item;   Subject : in lace.Subject.view)
+   is
+   begin
+      Self.Delegator.start (Subject => Subject,
+                            Events  => Self.Events'unchecked_Access);
+   end define;
+
+
+
+   procedure destruct (Self : in out Item)
+   is
+   begin
+       Self.Delegator.stop;
+   end destruct;
+
+
+
+   procedure add (Self : in out Item;   new_Event : lace.Event.item'Class)
+   is
+   begin
+      Self.Events.add (new_Event);
+   end add;
+
+
+
+   --  procedure stop (Self : in out Item)
+   --  is
+   --  begin
+   --     Self.Delegator.stop;
+   --  end stop;
+
+
+end lace.event_Emitter;

1-base/lace/source/events/mixin/private/lace-event_emitter.ads

@@ -0,0 +1,94 @@
+with
+     lace.Event;
+
+
+private
+with
+     lace.Subject,
+     ada.Containers.indefinite_Vectors;
+
+
+private
+package lace.event_Emitter with remote_Types
+is
+
+   type Item is tagged limited private;
+
+
+   procedure define   (Self : in out Item;   Subject : in lace.Subject.view);
+   procedure destruct (Self : in out Item);
+
+
+   procedure add  (Self : in out Item;   new_Event : in lace.Event.item'Class);
+   --  procedure stop (Self : in out Item);
+
+
+
+private
+
+   ------------
+   --- Emitter.
+   --
+
+   type Emitter;
+   type Emitter_view is access Emitter;
+
+
+
+   ---------------
+   --- Containers.
+   --
+
+   use type lace.Event.item'Class;
+   package event_Vectors is new ada.Containers.indefinite_Vectors (Positive,
+                                                                   lace.Event.item'Class);
+   subtype event_Vector  is event_Vectors.Vector;
+
+
+
+   ----------------
+   --- Safe events.
+   --
+
+   protected
+   type safe_Events
+   is
+      procedure add (new_Event  : in     lace.Event.item'Class);
+      procedure get (the_Events :    out event_Vector);
+
+      function is_Empty return Boolean;
+
+   private
+      all_Events : event_Vector;
+   end safe_Events;
+
+   type safe_Events_view is access all safe_Events;
+
+
+
+   -------------------
+   --- Emit delegator.
+   --
+
+   task
+   type emit_Delegator
+   is
+      entry start (Subject  : in lace.Subject.view;
+                   Events   : in safe_Events_view);
+      entry stop;
+   end emit_Delegator;
+
+
+
+   ---------
+   --- Item.
+   --
+
+   type Item is tagged limited
+      record
+         Events    : aliased safe_Events;
+         Delegator :         emit_Delegator;
+      end record;
+
+
+end lace.event_Emitter;