--  $Id: threads.adb,v 1.4 2008/11/20 22:18:50 baker Exp baker $

--  The core of the logic is in procedure Schedule.  If you want
--  to understand, that is the best place to start reading.

--  See Threads.Sched_DSS (file threads-sched_dss.adb) for an
--  example of the detailed work of a scheduling policy.

with Simulator;
with Error_Log; use Error_Log;  -- for file Log
with Ada.Text_IO; use Ada.Text_IO;  -- for file Log
with Ada.Strings; use Ada.Strings;
with Ada.Strings.Fixed; use Ada.Strings.Fixed;
package body Threads is

   --  ordering relation for thread queues

   function ">" (L, R : Thread_Ref) return Boolean is
   begin
      return L.Priority > R.Priority;
   end ">";

   package body Scheduling_Policies is

      procedure Bind_Thread
        (P : in out Object;
         T : Thread_Ref) is
      begin
         P.T := T;
      end Bind_Thread;

   end Scheduling_Policies;

   procedure Bind_Policy
     (T : in out Thread_Ref;
      P : Policies_Class_Ref) is
   begin
      T.Policy := P;
   end Bind_Policy;

   procedure Init (T : Thread_Ref) is
   begin
      T.Is_Suspended := True;
      T.Is_In_Ready_Queue := False;
      T.Policy.Init;
   end Init;

   procedure Reset_All is new
     Threads_Queues.For_All (Init);

   procedure Initialize is
   begin
      Current := Idle_Thread;
      Last_Dispatching_Time := 0;
      Last_Idle_Time := Simulator.Current_Time;
      Ready_Queue.Clear;
      Reset_All (All_Threads);
   end Initialize;

   function New_Thread
     (Go : Events.Class_Ref;
      Stop : Events.Class_Ref;
      Name : String)
     return Thread_Ref is
      T : Thread_Ref;
   begin
      T := new Thread;
      T.Go := Go;
      T.Stop := Stop;
      T.Name := Name (Name'First .. Name'First + T.Name'Length - 1);
      All_Threads.Add (T);
      return T;
   end New_Thread;

   --  The following provides a mechanism for notifying all
   --  threads of a context-switch event.  This is potentially
   --  very inefficient, but it might be necessary for some
   --  scheduling policies. With restricted visibility of
   --  information, this may be needed to provide early
   --  replenishment to multiple server threads if the system
   --  becomes idle, for example.

   --  ??? Consider keeping a separate list of threads for
   --  policies that require this notification, to avoid the
   --  overhead of processing the other threads?  Or, find some
   --  even better way to reduce overhead?

   procedure Notify (T : Thread_Ref) is
   begin
      T.Policy.New_Current_Thread;
   end Notify;

   procedure Notify_All is
      new Threads_Queues.For_All (Notify);

   Scheduler_Active : Boolean := False;

   procedure Schedule is
      Top : Thread_Ref;
      Now : constant Time := Simulator.Current_Time;
   begin

      pragma Assert (not Scheduler_Active);
      Scheduler_Active := True;

      --  find highest priority thread

      if Ready_Queue.Is_Empty then
         --  idle system
         Top := Idle_Thread;
      else
         Top := Ready_Queue.Front_Of;
      end if;

      if Top = Current then
         if Debug_Level > 5 then
            Put (Log, "threads.schedule ");
            if Current = null then
               Put (Log, "null ");
            else
               Put (Log, Current.Name);
            end if;
            Put (Log, "-> ");
            if Top = null then
               Put (Log, "null");
            else Put (Log, Top.Name);
            end if;
            New_Line (Log);
         end if;
         Scheduler_Active := False;
         return;
      end if;

      if Current = Idle_Thread then
         --  transition from idle to non-idle system
         Total_Idle := Total_Idle + (Now - Last_Idle_Time);
      else
         --  tell current task that it is preempted or suspended
         Current.Stop.Event_Time := Now;
         Current.Stop.Handler;
         --  tell policy plug-in that this thread is preempted or
         --  suspended
         Current.Policy.Stop;
      end if;

      if Debug_Level > 3 then
         Put (Log, "threads.schedule ");
         if Current = null then
            Put (Log, "null ");
         else
            Put (Log, Current.Name);
         end if;
         Put (Log, "-> ");
         if Top = null then
            Put (Log, "null");
         else Put (Log, Top.Name);
         end if;
         New_Line (Log);
      end if;

      -- ""context switch"
      Current := Top;
      Last_Dispatching_Time := Now;

      --  Notify interested schedulers of the context switcht.
      --  This gives them a chance to replenish budgets etc.
      --  if the system is becoming idle or if it has just
      --  dropped to a lower priority level.

      --  ???  Most or all of them might not be interested!
      --  This is a price we seem to be paying for modularization.
      --  ???  A real kernel scheduler could not afford this
      --  kind of inefficient algorithm.  Think of a better way
      --  for schedulers to get the information they need.

      Notify_All (All_Threads);

      if Current = Idle_Thread then

         --  Make the transistion to and idle system.
         --  If there are any scheduling policies that
         --  require action in this case, we need to provide
         --  a mechanism here to execute the appropraite call-outs.
         --  ???  Consider doing this by maintaining a list
         --  of affected threads for each such call-out?

         Last_Idle_Time := Now;
      else
         Current.Go.Event_Time := Now;
         Current.Go.Handler;
         Current.Policy.Go;
      end if;

      Scheduler_Active := False;

   end Schedule;

   procedure New_Job (T : Thread_Ref;
                      J : Jobs.Job) is
   begin
      T.Policy.New_Job (J);
   end New_Job;

   procedure Suspend (T : Thread_Ref) is
   begin
      pragma Debug (Debug (1, Name (T.all) & "threads.suspend "));
      pragma Assert (not T.Is_Suspended);
      T.Is_Suspended := True;
      if T.Is_In_Ready_Queue then
         Ready_Queue.Delete (T);
         T.Is_In_Ready_Queue := False;
      end if;
      --  call out to policy to indicate suspension
      T.Policy.Suspend;
   end Suspend;

   procedure Unsuspend (T : Thread_Ref) is
   begin
      pragma Debug (Debug (1, Name (T.all) & "threads.unsuspend "));
      pragma Assert (T.Is_Suspended);
      T.Is_Suspended := False;
      --  call out to policy, to possibly recompute priority
      T.Policy.Unsuspend;
      if T.Priority < Time'Last then
         Ready_Queue.Add (T);
         T.Is_In_Ready_Queue := True;
      end if;
   end Unsuspend;

   procedure Policy_Suspend (T : Thread_Ref) is
   begin
      pragma Debug (Debug (1, Name (T.all) & "threads.policy_suspend"));
      T.Priority := Time'Last;
      if T.Is_In_Ready_Queue then
         Ready_Queue.Delete (T);
         T.Is_In_Ready_Queue := False;
      end if;
   end Policy_Suspend;

   procedure Policy_Unsuspend
     (T : Thread_Ref;
      New_Priority : Time) is
   begin
      pragma Debug (Debug (1, Name (T.all) & "threads.policy_unsuspend"));
      pragma Assert (New_Priority < Time'Last);
      pragma Assert (T.Priority = Time'Last);
      pragma Assert (not T.Is_In_Ready_Queue);
      if not T.Is_Suspended then
         T.Priority := New_Priority;
         Ready_Queue.Add (T);
         T.Is_In_Ready_Queue := True;
      end if;
   end Policy_Unsuspend;

   function Name (T : Thread) return String is
   begin
      return "task " & Trim (T.Name, Right) & ' ';
   end Name;

   procedure Set_Debug (Level : Integer) is
   begin
      Debug_Level := Level;
   end Set_Debug;

end Threads;