diff --git a/1-base/lace/library/lace.gpr b/1-base/lace/library/lace.gpr index 2685c6f..1e2ebc4 100644 --- a/1-base/lace/library/lace.gpr +++ b/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", diff --git a/1-base/lace/source/events/interface/lace-subject.ads b/1-base/lace/source/events/interface/lace-subject.ads index 63ff3e9..f3d6557 100644 --- a/1-base/lace/source/events/interface/lace-subject.ads +++ b/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 -- diff --git a/1-base/lace/source/events/mixin/lace-make_subject.adb b/1-base/lace/source/events/mixin/lace-make_subject.adb index 04d9f47..2f90111 100644 --- a/1-base/lace/source/events/mixin/lace-make_subject.adb +++ b/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 - loop + if Self.Emitter = null + 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, - from_Subject => Subject.item'Class (Self.all).Name); - if Subject.Logger /= null - then - Subject.Logger.log_Emit (Subject.view (Self), - my_Observers (i), - the_Event); - end if; + for i in my_Observers'Range + loop + begin + my_Observers (i).receive (the_Event, + from_Subject => Subject.item'Class (Self.all).Name); + if Subject.Logger /= null + then + Subject.Logger.log_Emit (Subject.view (Self), + my_Observers (i), + the_Event); + end if; - exception - when system.RPC.communication_Error - | storage_Error => + exception + when system.RPC.communication_Error + | storage_Error => - if Subject.Logger /= null - then - Subject.Logger.log_Emit (Subject.view (Self), - my_Observers (i), - the_Event); - end if; + if Subject.Logger /= null + then + Subject.Logger.log_Emit (Subject.view (Self), + my_Observers (i), + the_Event); + 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; diff --git a/1-base/lace/source/events/mixin/lace-make_subject.ads b/1-base/lace/source/events/mixin/lace-make_subject.ads index 6edeb84..3602695 100644 --- a/1-base/lace/source/events/mixin/lace-make_subject.ads +++ b/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; diff --git a/1-base/lace/source/events/mixin/private/lace-event_emitter.adb b/1-base/lace/source/events/mixin/private/lace-event_emitter.adb new file mode 100644 index 0000000..e7fdb52 --- /dev/null +++ b/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; diff --git a/1-base/lace/source/events/mixin/private/lace-event_emitter.ads b/1-base/lace/source/events/mixin/private/lace-event_emitter.ads new file mode 100644 index 0000000..df9f1fe --- /dev/null +++ b/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;