From e56a7eec1f61cb160df2a0bc10e2708753a9a667 Mon Sep 17 00:00:00 2001 From: Rod Kay Date: Wed, 28 Aug 2024 17:28:25 +1000 Subject: [PATCH] lace.event: Add an event connector to speed up remote connections. --- .../source/events/lace-event_connector.adb | 378 ++++++++++++++++++ .../source/events/lace-event_connector.ads | 116 ++++++ .../events/utility/lace-event-utility.adb | 1 + 3 files changed, 495 insertions(+) create mode 100644 1-base/lace/source/events/lace-event_connector.adb create mode 100644 1-base/lace/source/events/lace-event_connector.ads diff --git a/1-base/lace/source/events/lace-event_connector.adb b/1-base/lace/source/events/lace-event_connector.adb new file mode 100644 index 0000000..6abbccc --- /dev/null +++ b/1-base/lace/source/events/lace-event_connector.adb @@ -0,0 +1,378 @@ +with + lace.Event.utility, + + ada.Text_IO, + ada.Exceptions, + ada.unchecked_Deallocation, + ada.Containers.Vectors; + + +package body lace.event_Connector +is + + --------------- + --- Containers. + -- + + package connector_Vectors is new ada.Containers.Vectors (Positive, + Connector_view); + subtype connector_Vector is connector_Vectors.Vector; + + + + -------------------- + --- Safe connectors. + -- + + protected + type safe_Connectors + is + procedure add (new_Connector : in Connector_view); + procedure get ( a_Connector : out Connector_view); + + private + all_Connectors : connector_Vector; + end safe_Connectors; + + type safe_Connectors_view is access all safe_Connectors; + + + + + -------------- + --- Connector. + -- + + task + type Connector + is + entry connect (Self : in Connector_view; + the_Connection : in Connection; + Connectors : in safe_Connectors_view); + end Connector; + + + + task body Connector + is + use ada.Text_IO, + lace.Text; + + Myself : Connector_view; + my_Connection : Connection; + connector_Pool : safe_Connectors_view; + begin + loop + begin + select + accept connect (Self : in Connector_view; + the_Connection : in Connection; + Connectors : in safe_Connectors_view) + do + my_Connection := the_Connection; + Myself := Self; + connector_Pool := Connectors; + end connect; + or + terminate; + end select; + + if my_Connection.is_Connecting + then + lace.Event.utility.connect (the_Observer => my_Connection.Observer, + to_Subject => my_Connection.Subject, + with_Response => my_Connection.Response, + to_Event_Kind => Event.Kind (+my_Connection.Event_Kind)); + else + lace.Event.utility.disconnect (the_Observer => my_Connection.Observer, + from_Subject => my_Connection.Subject, + for_Response => my_Connection.Response, + to_Event_Kind => Event.Kind (+my_Connection.Event_Kind), + subject_Name => my_Connection.Subject.Name); + end if; + + connector_Pool.add (Myself); -- Return the connector to the safe pool. + + exception + when E : others => + new_Line; + put_Line (ada.Exceptions.exception_Information (E)); + put_Line ("Error detected in 'lace.event_Connector.Connector' task."); + new_Line; + put_Line ("Subject: '" & my_Connection.Subject.Name & "'."); + put_Line ("Observer: '" & my_Connection.Observer.Name & "'."); + put_Line ("Event: '" & (+my_Connection.Event_Kind) & "'."); + put_Line ("Response '" & my_Connection.Response.Name & "'."); + new_Line; + put_Line ("Continuing."); + new_Line (2); + + connector_Pool.add (Myself); -- Return the connector to the safe pool. + end; + end loop; + + exception + when E : others => + new_Line; + put_Line (ada.Exceptions.exception_Information (E)); + put_Line ("Fatal error detected in 'lace.event_Connector.Connector' task."); + new_Line; + put_Line ("Subject: '" & my_Connection.Subject.Name & "'."); + put_Line ("Observer: '" & my_Connection.Observer.Name & "'."); + put_Line ("Event: '" & (+my_Connection.Event_Kind) & "'."); + put_Line ("Response '" & my_Connection.Response.Name & "'."); + new_Line (2); + end Connector; + + + + ------------------------- + --- Connection delegator. + -- + + task body connection_Delegator + is + use ada.Text_IO; + + the_Connectors : aliased safe_Connectors; + the_Connections : safe_Connections_view; + new_Connections : connection_Vector; + Done : Boolean := False; + + + procedure shutdown + is + procedure free is new ada.unchecked_Deallocation (Connector, + Connector_view); + the_Connector : Connector_view; + begin + loop + the_Connectors.get (the_Connector); + exit when the_Connector = null; + + free (the_Connector); + end loop; + end shutdown; + + + begin + ada.text_io.put_Line ("KKK0"); + + accept start (Connections : in safe_Connections_view) + do + ada.text_io.put_Line ("KKK2"); + + the_Connections := Connections; + ada.text_io.put_Line ("KKK3"); + + end start; + + + loop + select + accept stop + do + Done := True; + end stop; + + else + null; + end select; + + + exit when Done + and the_Connections.is_Empty; + + the_Connections.get (new_Connections); + + for each_Connection of new_Connections + loop + declare + use lace.Text; + the_Connector : Connector_view; + begin + the_Connectors.get (the_Connector); + + if the_Connector = null + then + the_Connector := new Connector; + end if; + + the_Connector.connect (Self => the_Connector, + the_Connection => each_Connection, + Connectors => the_Connectors'unchecked_Access); + exception + when E : others => + new_Line; + put_Line (ada.Exceptions.exception_Information (E)); + new_Line; + put_Line ("Error detected in 'lace.event_Connector.connector_Delegator'."); + new_Line; + put_Line ("Subject: '" & each_Connection.Subject.Name & "'."); + put_Line ("Observer: '" & each_Connection.Observer.Name & "'."); + put_Line ("Event: '" & (+each_Connection.Event_Kind) & "'."); + put_Line ("Response '" & each_Connection.Response.Name & "'."); + new_Line; + put_Line ("Continuing."); + new_Line (2); + end; + end loop; + + delay 0.001; -- Keep task from churning when idle. + end loop; + + shutdown; + + exception + when E : others => + new_Line; + put_Line (ada.Exceptions.exception_Information (E)); + new_Line; + put_Line ("Fatal error detected in 'lace.event_Connector.connection_Delegator'."); + new_Line (2); + + shutdown; + end connection_Delegator; + + + + + --------------------- + --- Safe connections. + -- + + protected body safe_Connections + is + + procedure add (new_Connection : in Connection) + is + begin + all_Connections.append (new_Connection); + end add; + + + + procedure get (the_Connections : out connection_Vector) + is + begin + the_Connections := all_Connections; + all_Connections.clear; + end get; + + + + function is_Empty return Boolean + is + begin + return all_Connections.is_Empty; + end is_Empty; + + + end safe_Connections; + + + + + ------------------ + --- Safe emitters. + -- + + protected body safe_Connectors + is + + procedure add (new_Connector : in Connector_view) + is + begin + all_Connectors.append (new_Connector); + end add; + + + + procedure get (a_Connector : out Connector_view) + is + begin + if all_Connectors.is_Empty + then + a_Connector := null; + else + a_Connector := all_Connectors.last_Element; + all_Connectors.delete_Last; + end if; + end get; + + + end safe_Connectors; + + + + + ------------------------- + --- event_Connector item. + -- + + procedure define (Self : in out Item) + is + begin + ada.text_io.put_Line ("KKK"); + Self.Delegator.start (Connections => Self.Connections'unchecked_Access); + ada.text_io.put_Line ("JJJ"); + end define; + + + + procedure destruct (Self : in out Item) + is + begin + Self.Delegator.stop; + end destruct; + + + + procedure connect (Self : in out Item; the_Observer : in Observer.view; + to_Subject : in Subject .view; + with_Response : in Response.view; + to_Event_Kind : in Event.Kind) + is + use lace.Text; + + new_Connection : Connection := (Observer => the_Observer, + Subject => to_Subject, + Response => with_Response, + Event_Kind => <>, + subject_Name => <>, + is_Connecting => True); + begin + String_is (new_Connection.Event_Kind, + String (to_Event_Kind)); + + Self.Connections.add (new_Connection); + end connect; + + + + procedure disconnect (Self : in out Item; the_Observer : in Observer.view; + from_Subject : in Subject .view; + for_Response : in Response.view; + to_Event_Kind : in Event.Kind; + subject_Name : in String) + is + use lace.Text; + + new_Disconnection : Connection := (Observer => the_Observer, + Subject => from_Subject, + Response => for_Response, + Event_Kind => <>, + subject_Name => <>, + is_Connecting => False); + begin + String_is (new_Disconnection.event_Kind, + String (to_Event_Kind)); + + String_is (new_Disconnection.subject_Name, + subject_Name); + + Self.Connections.add (new_Disconnection); + end disconnect; + + +end lace.event_Connector; diff --git a/1-base/lace/source/events/lace-event_connector.ads b/1-base/lace/source/events/lace-event_connector.ads new file mode 100644 index 0000000..ef51f99 --- /dev/null +++ b/1-base/lace/source/events/lace-event_connector.ads @@ -0,0 +1,116 @@ +with + lace.Event, + lace.Response, + lace.Observer, + lace.Subject; + + +private +with + lace.Text, + ada.Containers.indefinite_Vectors; + + +package lace.event_Connector +is + + type Item is tagged limited private; + + + procedure define (Self : in out Item); + procedure destruct (Self : in out Item); + + procedure connect (Self : in out Item; the_Observer : in Observer.view; + to_Subject : in Subject .view; + with_Response : in Response.view; + to_Event_Kind : in Event.Kind); + + procedure disconnect (Self : in out Item; the_Observer : in Observer.view; + from_Subject : in Subject .view; + for_Response : in Response.view; + to_Event_Kind : in Event.Kind; + subject_Name : in String); + + +private + + -------------- + --- Connector. + -- + + type Connector; + type Connector_view is access Connector; + + + + --------------- + --- Connection. + -- + + type Connection is + record + Observer : lace.Observer.view; + Subject : lace.Subject .view; + Response : lace.Response.view; + Event_Kind : lace.Text.item_256; + subject_Name : lace.Text.item_256; + is_Connecting : Boolean; + end record; + + + + --------------- + --- Containers. + -- + + package connection_Vectors is new ada.Containers.indefinite_Vectors (Positive, + Connection); + subtype connection_Vector is connection_Vectors.Vector; + + + + --------------------- + --- Safe connections. + -- + + protected + type safe_Connections + is + procedure add (new_Connection : in Connection); + procedure get (the_Connections : out connection_Vector); + + function is_Empty return Boolean; + + private + all_Connections : connection_Vector; + end safe_Connections; + + type safe_Connections_view is access all safe_Connections; + + + + ------------------------- + --- Connection delegator. + -- + + task + type connection_Delegator + is + entry start (Connections : in safe_Connections_view); + entry stop; + end connection_Delegator; + + + + --------- + --- Item. + -- + + type Item is tagged limited + record + Connections : aliased safe_Connections; + Delegator : connection_Delegator; + end record; + + +end lace.event_Connector; diff --git a/1-base/lace/source/events/utility/lace-event-utility.adb b/1-base/lace/source/events/utility/lace-event-utility.adb index e3853fd..71e3881 100644 --- a/1-base/lace/source/events/utility/lace-event-utility.adb +++ b/1-base/lace/source/events/utility/lace-event-utility.adb @@ -62,6 +62,7 @@ is end connect; + procedure disconnect (the_Observer : in Observer.view; from_Subject : in Subject .view; for_Response : in Response.view;