Add job lists for High and Low priorities.

reznikmm · reznikmm · commit 3705224e7f90 · 2024-02-14T13:33:46.000+02:00
Call `Complete` on `Fence` jobs. Refs #1141
diff --git a/source/server/lsp-job_schedulers.adb b/source/server/lsp-job_schedulers.adb
@@ -18,23 +18,58 @@
 with Ada.Unchecked_Conversion;
 with Ada.Unchecked_Deallocation;
 with System.Storage_Elements;
-with LSP.Server_Jobs;
 
 package body LSP.Job_Schedulers is
 
    procedure Free is new Ada.Unchecked_Deallocation
      (LSP.Server_Jobs.Server_Job'Class, LSP.Server_Jobs.Server_Job_Access);
 
+   procedure Complete_Last_Fence_Job
+     (Self : in out Job_Scheduler'Class;
+      Next : LSP.Server_Messages.Server_Message_Access);
+   --  Call Complete on the last done Fence job (if any) and free it
+
+   -----------------------------
+   -- Complete_Last_Fence_Job --
+   -----------------------------
+
+   procedure Complete_Last_Fence_Job
+     (Self : in out Job_Scheduler'Class;
+      Next : LSP.Server_Messages.Server_Message_Access) is
+   begin
+      if Self.Done.Assigned then
+         Self.Done.Complete (Next);
+         Free (Self.Done);
+      end if;
+   end Complete_Last_Fence_Job;
+
    ----------------
    -- Create_Job --
    ----------------
 
    procedure Create_Job
      (Self    : in out Job_Scheduler'Class;
-      Message : in out LSP.Server_Messages.Server_Message_Access) is
+      Message : in out LSP.Server_Messages.Server_Message_Access)
+   is
+      Cursor : constant Handler_Maps.Cursor :=
+        Self.Handlers.Find (Message'Tag);
+
+      Job : LSP.Server_Jobs.Server_Job_Access;
    begin
-      Self.Message := Message;
-      Message := null;
+      if Handler_Maps.Has_Element (Cursor) then
+
+         Job := Handler_Maps.Element (Cursor).Create_Job (Message);
+
+         if Job.Assigned then
+            Message := null;
+
+            if Job.Priority in Self.Jobs'Range then
+               Self.Jobs (Job.Priority).Append (Job);
+            else
+               Self.Blocker := Job;
+            end if;
+         end if;
+      end if;
    end Create_Job;
 
    --------------
@@ -43,7 +78,8 @@ package body LSP.Job_Schedulers is
 
    function Has_Jobs (Self : Job_Scheduler'Class) return Boolean is
    begin
-      return Self.Message.Assigned;
+      return Self.Blocker.Assigned or else
+        (for some List of Self.Jobs => not List.Is_Empty);
    end Has_Jobs;
 
    ----------
@@ -68,43 +104,83 @@ package body LSP.Job_Schedulers is
         LSP.Client_Message_Receivers.Client_Message_Receiver'Class;
       Waste  : out LSP.Server_Messages.Server_Message_Access)
    is
-      Job : LSP.Server_Jobs.Server_Job_Access;
+      use all type LSP.Server_Jobs.Job_Priority;
+
+      procedure Execute (Job : LSP.Server_Jobs.Server_Job_Access);
+
+      -------------
+      -- Execute --
+      -------------
+
+      procedure Execute (Job : LSP.Server_Jobs.Server_Job_Access) is
+      begin
+         Self.Complete_Last_Fence_Job (Job.Message);
+         Waste := Job.Message;
+
+         while not Job.Is_Done loop
+            Job.Execute (Client);
+         end loop;
+      end Execute;
+
+      Job : LSP.Server_Jobs.Server_Job_Access renames Self.Blocker;
    begin
-      Waste := null;
+      if not Job.Assigned then
+         Waste := null;
 
-      --  Process the most recent message if any
-      if Self.Message.Assigned then
-         declare
-            Cursor : constant Handler_Maps.Cursor :=
-              Self.Handlers.Find (Self.Message'Tag);
-         begin
-            if Handler_Maps.Has_Element (Cursor) then
-               Job := Handler_Maps.Element (Cursor).Create_Job (Self.Message);
-               Self.Message := null;
-            else
-               Waste := Self.Message;
-               Self.Message := null;
+         return;
+      end if;
+
+      if Job.Priority = Fence then
+         --  Process other jobs before any Fence job
+         while (for some List of Self.Jobs => not List.Is_Empty) loop
+            Self.Process_Job (Client, Waste);
+
+            if Waste.Assigned then
                return;
             end if;
-         end;
+         end loop;
+
+         Execute (Job);
+         Self.Done := Job;  --  keep Job live till Complete call
+         Job := null;
       else
-         null;  --  TBD: find next job here
+         Execute (Job);
+         Free (Job);
       end if;
+   end Process_High_Priority_Job;
 
-      while Job.Assigned loop
-         Job.Execute (Client);
+   -----------------
+   -- Process_Job --
+   -----------------
+
+   procedure Process_Job
+     (Self    : in out Job_Scheduler'Class;
+      Client  :
+        in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class;
+      Waste   : out LSP.Server_Messages.Server_Message_Access) is
+   begin
+      for List of reverse Self.Jobs when not List.Is_Empty loop
+         declare
+            Job : LSP.Server_Jobs.Server_Job_Access := List.First_Element;
+         begin
+            List.Delete_First;
+            Self.Complete_Last_Fence_Job (Job.Message);
+            Job.Execute (Client);
+
+            if Job.Is_Done then
+               Waste := Job.Message;
+               Free (Job);
+            else
+               Waste := null;
+               List.Append (Job);  --  Push the job back to the queue
+            end if;
 
-         if Job.Is_Done then
-            --  TBD: Call complete?
-            Waste := Job.Message;
-            Free (Job);
             exit;
-         else
-            raise Program_Error with "Unimplemeted";
-            --  TBD: put job back to the queue
-         end if;
+         end;
       end loop;
-   end Process_High_Priority_Job;
+
+      Self.Complete_Last_Fence_Job (null);
+   end Process_Job;
 
    ----------------------
    -- Register_Handler --
diff --git a/source/server/lsp-job_schedulers.ads b/source/server/lsp-job_schedulers.ads
@@ -16,9 +16,11 @@
 ------------------------------------------------------------------------------
 
 with Ada.Containers.Hashed_Maps;
+with Ada.Containers.Doubly_Linked_Lists;
 with Ada.Tags;
 
 with LSP.Client_Message_Receivers;
+with LSP.Server_Jobs;
 with LSP.Server_Message_Handlers;
 with LSP.Server_Messages;
 
@@ -41,6 +43,8 @@ package LSP.Job_Schedulers is
       Message : in out LSP.Server_Messages.Server_Message_Access);
    --  Create a job to process a server message. The scheduler takes ownership
    --  of the message and will return it to the server when the job is done.
+   --  If there is no handler for the message, then the scheduler doesn't
+   --  accept message and server should destroy it.
 
    procedure Process_High_Priority_Job
      (Self    : in out Job_Scheduler'Class;
@@ -56,7 +60,7 @@ package LSP.Job_Schedulers is
      (Self    : in out Job_Scheduler'Class;
       Client  :
         in out LSP.Client_Message_Receivers.Client_Message_Receiver'Class;
-      Waste   : out LSP.Server_Messages.Server_Message_Access) is null;
+      Waste   : out LSP.Server_Messages.Server_Message_Access);
    --  Execute jobs with ordinal priority (Low, High).
    --  When a job is done the routine returns (in Waste) the message to be
    --  deallocated by the server. The Client is used to send messages during
@@ -73,10 +77,21 @@ private
       Ada.Tags."=",
       LSP.Server_Message_Handlers."=");
 
+   package Job_Lists is new Ada.Containers.Doubly_Linked_Lists
+     (LSP.Server_Jobs.Server_Job_Access, LSP.Server_Jobs."=");
+
+   subtype Ordinal_Priority is LSP.Server_Jobs.Job_Priority
+     range LSP.Server_Jobs.Low .. LSP.Server_Jobs.High;
+
+   type Job_List_Array is array (Ordinal_Priority) of Job_Lists.List;
+
    type Job_Scheduler is tagged limited record
-      Message  : LSP.Server_Messages.Server_Message_Access;
-      --  Last added message
+      Blocker  : LSP.Server_Jobs.Server_Job_Access;
+      --  A job with non-ordinal priority (Immediate, Fence)
+      Done     : LSP.Server_Jobs.Server_Job_Access;
+      --  A job with Fence priority to be completed
       Handlers : Handler_Maps.Map;
+      Jobs     : Job_List_Array;
    end record;
 
 end LSP.Job_Schedulers;
diff --git a/source/server/lsp-server_jobs.ads b/source/server/lsp-server_jobs.ads
@@ -34,6 +34,8 @@ package LSP.Server_Jobs is
    --  new messages until the job is done. Server execute each job in its
    --  queue before executing any Fence job.
 
+   subtype Ordinal_Priority is Job_Priority range Low .. High;
+
    type Server_Job is limited interface;
 
    function Priority (Self : Server_Job) return Job_Priority is abstract;
@@ -55,6 +57,7 @@ package LSP.Server_Jobs is
       Next : LSP.Server_Messages.Server_Message_Access) is null
        with Pre'Class => Is_Done (Self);
    --  Complete message execution. The next message is provided if any.
+   --  Currently this is called only for Fence jobs.
 
    procedure Cancel
      (Self   : in out Server_Job;
@@ -68,6 +71,7 @@ package LSP.Server_Jobs is
 
    function Message (Self : Server_Job)
      return LSP.Server_Messages.Server_Message_Access is abstract;
+   --  Message to be destroyed when the job is done
 
    function Assigned (Self : access Server_Job'Class) return Boolean is
       (Self /= null);
diff --git a/source/server/lsp-servers.adb b/source/server/lsp-servers.adb
@@ -865,6 +865,11 @@ package body LSP.Servers is
       begin
          Server.Scheduler.Create_Job (Message);
 
+         if Message.Assigned then
+            --  Scheduler wasn't able to process message, destroy it
+            Server.Destroy_Queue.Enqueue (Message);
+         end if;
+
          loop
             declare
                Waste : Server_Message_Access;
