nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source
This commit is contained in:
Rod Kay
2024-08-18 11:04:16 +10:00
parent 56d8ff97e4
commit cd004acd69
6 changed files with 490 additions and 22 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
1-base/lace/library/lace.gpr
View File

@@ -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",

6
1-base/lace/source/events/interface/lace-subject.ads
View File

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

34
1-base/lace/source/events/mixin/lace-make_subject.adb
View File

@@ -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,9 +81,24 @@ 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
begin
if Self.Emitter = null
then
declare
use lace.Event.utility;
my_Observers : constant Subject.Observer_views := Self.Observers (to_Kind (the_Event'Tag));
begin
@@ -103,9 +126,15 @@ is
end if;
end;
end loop;
end;
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;

16
1-base/lace/source/events/mixin/lace-make_subject.ads
View File

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

317
1-base/lace/source/events/mixin/private/lace-event_emitter.adb Normal file
View File

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

94
1-base/lace/source/events/mixin/private/lace-event_emitter.ads Normal file
View File

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