PolyORB/src/polyorb-orb_controller-basic.adb

------------------------------------------------------------------------------
--                                                                          --
--                           POLYORB COMPONENTS                             --
--                                                                          --
--         P O L Y O R B . O R B _ C O N T R O L L E R . B A S I C          --
--                                                                          --
--                                 B o d y                                  --
--                                                                          --
--            Copyright (C) 2004 Free Software Foundation, Inc.             --
--                                                                          --
-- PolyORB is free software; you  can  redistribute  it and/or modify it    --
-- under terms of the  GNU General Public License as published by the  Free --
-- Software Foundation;  either version 2,  or (at your option)  any  later --
-- version. PolyORB is distributed  in the hope that it will be  useful,    --
-- but WITHOUT ANY WARRANTY;  without even the implied warranty of MERCHAN- --
-- TABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public --
-- License  for more details.  You should have received  a copy of the GNU  --
-- General Public License distributed with PolyORB; see file COPYING. If    --
-- not, write to the Free Software Foundation, 59 Temple Place - Suite 330, --
-- Boston, MA 02111-1307, USA.                                              --
--                                                                          --
-- As a special exception,  if other files  instantiate  generics from this --
-- unit, or you link  this unit with other files  to produce an executable, --
-- this  unit  does not  by itself cause  the resulting  executable  to  be --
-- covered  by the  GNU  General  Public  License.  This exception does not --
-- however invalidate  any other reasons why  the executable file  might be --
-- covered by the  GNU Public License.                                      --
--                                                                          --
--                PolyORB is maintained by ACT Europe.                      --
--                    (email: sales@act-europe.fr)                          --
--                                                                          --
------------------------------------------------------------------------------

--  $Id$

with PolyORB.Asynch_Ev;
with PolyORB.Constants;
with PolyORB.Initialization;
pragma Elaborate_All (PolyORB.Initialization); --  WAG:3.15

with PolyORB.Log;
with PolyORB.Parameters;
with PolyORB.Utils.Strings;

package body PolyORB.ORB_Controller.Basic is

   use PolyORB.Log;
   use PolyORB.Task_Info;
   use PolyORB.Tasking.Condition_Variables;
   use PolyORB.Tasking.Mutexes;

   package L is new PolyORB.Log.Facility_Log ("polyorb.orb_controller.basic");
   procedure O1 (Message : in String; Level : Log_Level := Debug)
     renames L.Output;

   package L2 is
      new PolyORB.Log.Facility_Log ("polyorb.orb_controller_status");
   procedure O2 (Message : in String; Level : Log_Level := Debug)
     renames L2.Output;

   function Allocate_CV
     (O : access ORB_Controller_Basic)
     return Condition_Access;
   --  Return one CV

   procedure Release_All_Tasks (O : access ORB_Controller_Basic);
   --  Release all tasks in ORB_Controller O: awake idle tasks,
   --  unblock polling taks.

   procedure Awake_One_Idle_Task (O : access ORB_Controller_Basic);
   --  Awake one idle task, if any. Else raise Program_Error

   procedure Try_Allocate_One_Task (O : access ORB_Controller_Basic);
   --  Awake one idle task, if any. Elso do nothing

   -------------------
   -- Register_Task --
   -------------------

   procedure Register_Task
     (O  : access ORB_Controller_Basic;
      TI :        PTI.Task_Info_Access)
   is
      pragma Warnings (Off);
      pragma Unreferenced (TI);
      pragma Warnings (On);

   begin
      pragma Debug (O1 ("Register_Task: enter"));

      O.Registered_Tasks := O.Registered_Tasks + 1;
      O.Unscheduled_Tasks := O.Unscheduled_Tasks + 1;

      pragma Debug (O1 ("Register_Task: leave"));
      pragma Debug (O2 (Status (O)));
   end Register_Task;

   ---------------------
   -- Disable_Polling --
   ---------------------

   procedure Disable_Polling (O : access ORB_Controller_Basic) is
   begin

      --  Force all tasks currently waiting on event sources to abort

      if O.Blocked_Tasks > 0 then

         --  In this implementation, only one task may be blocked on
         --  event sources. We abort it.

         pragma Debug (O1 ("Disable_Polling: Aborting polling task"));
         PTI.Request_Abort_Polling (O.Blocked_Task_Info.all);
         PolyORB.Asynch_Ev.Abort_Check_Sources
           (Selector (O.Blocked_Task_Info.all).all);

         pragma Debug (O1 ("Disable_Polling: waiting abort is complete"));
         O.Polling_Abort_Counter := O.Polling_Abort_Counter + 1;
         Wait (O.Polling_Completed, O.ORB_Lock);
         O.Polling_Abort_Counter := O.Polling_Abort_Counter - 1;

         pragma Debug (O1 ("Disable_Polling: aborting done"));
      end if;
   end Disable_Polling;

   --------------------
   -- Enable_Polling --
   --------------------

   procedure Enable_Polling (O : access ORB_Controller_Basic) is
   begin
      pragma Debug (O1 ("Enable_Polling"));

      if O.Polling_Abort_Counter = 0 then

         --  Allocate one task to poll on AES

         Try_Allocate_One_Task (O);
      end if;
   end Enable_Polling;

   ------------------
   -- Notify_Event --
   ------------------

   procedure Notify_Event
     (O : access ORB_Controller_Basic;
      E :        Event)
   is
      use type PAE.Asynch_Ev_Monitor_Access;
      use type PRS.Request_Scheduler_Access;

   begin
      pragma Debug (O1 ("Notify_Event: " & Event_Kind'Image (E.Kind)));

      case E.Kind is

         when End_Of_Check_Sources =>

            --  A task completed polling on a monitor

            O.Blocked_Tasks := O.Blocked_Tasks - 1;
            O.Blocked_Task_Info := null;
            O.Unscheduled_Tasks := O.Unscheduled_Tasks + 1;

            if O.Polling_Abort_Counter > 0 then

               --  This task has been aborted by one or more tasks, we
               --  broadcast them.

               Broadcast (O.Polling_Completed);
            end if;

         when Event_Sources_Added =>

            --  An AES has been added to monitored AES list

            if O.Monitors (1) = null then

               --  There was no monitor registred yet, register new monitor

               O.Number_Of_AES := O.Number_Of_AES + 1;
               O.Monitors (1) := E.Add_In_Monitor;

            else

               --  Under this implementation, there can be at most one
               --  monitor. Ensure this assertion is correct.

               pragma Assert (E.Add_In_Monitor = O.Monitors (1));
               null;

            end if;

            if O.Blocked_Tasks = 0
              and then not O.Polling_Scheduled
            then

               --  No task is currently polling, allocate one

               O.Polling_Scheduled := True;
               Try_Allocate_One_Task (O);

            end if;

         when Event_Sources_Deleted =>

            --  An AES has been removed from monitored AES list

            pragma Assert (O.Monitors (1) /= null);
            null;
            --  O.Number_Of_AES := O.Number_Of_AES - 1;

         when Job_Completed =>

            --  A task has completed the execution of a job

            O.Running_Tasks := O.Running_Tasks - 1;
            O.Unscheduled_Tasks := O.Unscheduled_Tasks + 1;

         when ORB_Shutdown =>

            --  ORB shutdown has been requested

            O.Shutdown := True;

            Release_All_Tasks (O);

         when Queue_Event_Job =>

            --  Queueing an event means we delete one source

            --  O.Number_Of_AES := O.Number_Of_AES - 1;
            O.Counter := 0;
            --  Queue event to main job queue

            pragma Debug (O1 ("Queue Event_Job to default queue"));

            O.Number_Of_Pending_Jobs := O.Number_Of_Pending_Jobs + 1;
            PJ.Queue_Job (O.Job_Queue, E.Event_Job);
            Try_Allocate_One_Task (O);

         when Queue_Request_Job =>

            if O.RS = null
              or else not PRS.Try_Queue_Request_Job
              (O.RS, E.Request_Job, E.Target)
            then
               --  Default: Queue request to main job queue

               pragma Debug (O1 ("Queue Request_Job to default queue"));

               O.Number_Of_Pending_Jobs := O.Number_Of_Pending_Jobs + 1;
               PJ.Queue_Job (O.Job_Queue, E.Request_Job);
               Try_Allocate_One_Task (O);
            end if;

         when Request_Result_Ready =>

            --  A Request has been completed and a resonse is
            --  available. We must forward it to requesting task. We
            --  ensure this task will stop its current action and ask
            --  for rescheduling.

            case State (E.Requesting_Task.all) is
               when Running =>

                  --  We cannot abort a running task. We let it
                  --  complete its job and ask for rescheduling.

                  null;

               when Blocked =>

                  --  We abort this task. It will then leave Blocked
                  --  state and ask for rescheduling.

                  declare
                     use PolyORB.Asynch_Ev;

                     Sel : constant Asynch_Ev_Monitor_Access
                       := Selector (E.Requesting_Task.all);

                  begin
                     pragma Debug (O1 ("About to abort block"));

                     O.Blocked_Tasks := O.Blocked_Tasks - 1;
                     O.Unscheduled_Tasks := O.Unscheduled_Tasks + 1;

                     pragma Assert (Sel /= null);
                     Abort_Check_Sources (Sel.all);
                     pragma Debug (O1 ("Aborted."));
                  end;

               when Idle =>

                  --  We awake this task. It will then leave Idle
                  --  state and ask for rescheduling.

                  pragma Debug (O1 ("Signal requesting task"));

                  O.Idle_Tasks := O.Idle_Tasks - 1;
                  O.Unscheduled_Tasks := O.Unscheduled_Tasks + 1;
                  Signal (Condition (E.Requesting_Task.all));

               when Terminated
                 | Unscheduled =>

                  --  Nothing to do
                  --  XXX hummm, does it make sense to have these states ?

                  null;
            end case;

         when Idle_Awake =>

            --  A task has left Idle state

            List_Detach (E.Awakened_Task.all, O.Idle_Task_List);

      end case;

      pragma Debug (O2 (Status (O)));
   end Notify_Event;

   -------------------
   -- Schedule_Task --
   -------------------

   procedure Schedule_Task
     (O  : access ORB_Controller_Basic;
      TI :        PTI.Task_Info_Access)
   is
   begin
      pragma Debug (O1 ("Schedule_Task: enter " & Image (TI.all)));

      pragma Assert (PTI.State (TI.all) = Unscheduled);

      --  Update counters

      O.Unscheduled_Tasks := O.Unscheduled_Tasks - 1;

      --  Recompute TI status

      if Exit_Condition (TI.all)
        or else O.Shutdown
      then

         pragma Debug (O1 ("Task is now terminated"));
         pragma Debug (O2 (Status (O)));

         Set_State_Terminated (TI.all);

      elsif O.Number_Of_Pending_Jobs > 0 then

         O.Running_Tasks := O.Running_Tasks + 1;
         O.Number_Of_Pending_Jobs := O.Number_Of_Pending_Jobs - 1;

         pragma Debug (O1 ("Task is now running a job"));
         pragma Debug (O2 (Status (O)));

         Set_State_Running (TI.all, PJ.Fetch_Job (O.Job_Queue));

      elsif May_Poll (TI.all)
        and then O.Number_Of_AES > 0
        and then O.Polling_Abort_Counter = 0
        and then O.Blocked_Tasks = 0
      then

         O.Blocked_Tasks := O.Blocked_Tasks + 1;
         O.Polling_Scheduled := False;

         O.Blocked_Task_Info := TI;

         pragma Debug (O1 ("Task is now blocked"));
         pragma Debug (O2 (Status (O)));

         Set_State_Blocked
           (TI.all,
            O.Monitors (1),
            O.Polling_Timeout);

      else

         O.Idle_Tasks := O.Idle_Tasks + 1;

         Set_State_Idle (TI.all, Allocate_CV (O), O.ORB_Lock);
         Task_Lists.Prepend (O.Idle_Task_List, TI);
         List_Attach (TI.all, Task_Lists.First (O.Idle_Task_List));

         pragma Debug (O1 ("Task is now idle"));
         pragma Debug (O2 (Status (O)));

      end if;
   end Schedule_Task;

   ---------------------
   -- Unregister_Task --
   ---------------------

   procedure Unregister_Task
     (O  : access ORB_Controller_Basic;
      TI :        PTI.Task_Info_Access)
   is
      S : constant Task_State := State (TI.all);
   begin
      pragma Debug (O1 ("Unregister_Task: enter, State = "
                        & State (TI.all)'Img));
      pragma Debug (O2 (Status (O)));

      pragma Assert (S = Terminated);
      O.Registered_Tasks := O.Registered_Tasks - 1;

      pragma Debug (O2 (Status (O)));
      pragma Debug (O1 ("Unregister_Task: leave"));
   end Unregister_Task;

   -----------------
   -- Allocate_CV --
   -----------------

   function Allocate_CV
     (O : access ORB_Controller_Basic)
     return Condition_Access
   is
      use type CV_Lists.List;

      Result : Condition_Access;

   begin
      if O.Free_CV /= CV_Lists.Empty then

         --  Use an existing CV, from Free_CV list

         CV_Lists.Extract_First (O.Free_CV, Result);
      else
         --  else allocate a new one

         Create (Result);
      end if;

      return Result;
   end Allocate_CV;

   -----------------------
   -- Release_All_Tasks --
   -----------------------

   procedure Release_All_Tasks (O : access ORB_Controller_Basic) is
   begin
      --  Awake all idle tasks

      for J in 1 .. O.Idle_Tasks loop
         Awake_One_Idle_Task (O);
      end loop;

      --  Unblock blocked tasks

      if O.Blocked_Tasks > 0 then

         PTI.Request_Abort_Polling (O.Blocked_Task_Info.all);
         PolyORB.Asynch_Ev.Abort_Check_Sources
           (Selector (O.Blocked_Task_Info.all).all);

      end if;
   end Release_All_Tasks;

   -------------------------
   -- Awake_One_Idle_Task --
   -------------------------

   procedure Awake_One_Idle_Task (O : access ORB_Controller_Basic) is
      Task_To_Awake : Task_Info_Access;
   begin
      if O.Idle_Tasks > 0 then
         pragma Debug (O1 ("Awake one idle task"));

         --  Update Scheduler status

         O.Idle_Tasks := O.Idle_Tasks - 1;
         O.Unscheduled_Tasks := O.Unscheduled_Tasks + 1;

         --  Signal one idle task, and puts its CV in Free_CV list

         Task_Lists.Extract_First (O.Idle_Task_List, Task_To_Awake);
         List_Attach (Task_To_Awake.all, Task_Lists.Last (O.Idle_Task_List));
         Signal (Condition (Task_To_Awake.all));
         CV_Lists.Append (O.Free_CV, Condition (Task_To_Awake.all));

      else
         pragma Debug (O1 ("No idle task !"));
         raise Program_Error;

      end if;
   end Awake_One_Idle_Task;

   ---------------------------
   -- Try_Allocate_One_Task --
   ---------------------------

   procedure Try_Allocate_One_Task (O : access ORB_Controller_Basic) is
   begin

      pragma Debug (O1 ("Try_Allocate_One_Task: enter"));

      if O.Unscheduled_Tasks > 0 then

         --  Some tasks are not scheduled. We assume one of them will
         --  be allocated to handle current event.

         pragma Debug (O1 ("Assume one unaffected task will handle event"));
         null;

      else

         if O.Idle_Tasks > 0 then
            Awake_One_Idle_Task (O);

         else
            pragma Debug (O1 ("No idle tasks"));
            null;

         end if;
      end if;

      pragma Debug (O1 ("Try_Allocate_One_Task: end"));
   end Try_Allocate_One_Task;

   --------------------------------
   -- Enter_ORB_Critical_Section --
   --------------------------------

   procedure Enter_ORB_Critical_Section (O : access ORB_Controller_Basic) is
   begin
      PTM.Enter (O.ORB_Lock);
   end Enter_ORB_Critical_Section;

   --------------------------------
   -- Leave_ORB_Critical_Section --
   --------------------------------

   procedure Leave_ORB_Critical_Section (O : access ORB_Controller_Basic) is
   begin
      PTM.Leave (O.ORB_Lock);
   end Leave_ORB_Critical_Section;

   ----------------------
   -- Is_A_Job_Pending --
   ----------------------

   function Is_A_Job_Pending
     (O : access ORB_Controller_Basic)
     return Boolean
   is
   begin
      return not PJ.Is_Empty (O.Job_Queue);
   end Is_A_Job_Pending;

   ---------------------
   -- Get_Pending_Job --
   ---------------------

   function Get_Pending_Job
     (O : access ORB_Controller_Basic)
     return PJ.Job_Access
   is
   begin
      pragma Assert (Is_A_Job_Pending (O));
      O.Number_Of_Pending_Jobs := O.Number_Of_Pending_Jobs - 1;

      return PJ.Fetch_Job (O.Job_Queue);
   end Get_Pending_Job;

   ------------------
   -- Get_Monitors --
   ------------------

   function Get_Monitors
     (O : access ORB_Controller_Basic)
     return Monitor_Array
   is
      use type PAE.Asynch_Ev_Monitor_Access;

   begin
      if O.Monitors (1) /= null then
         return O.Monitors;
      else
         return Monitor_Array'(1 .. 0 => null);
      end if;
   end Get_Monitors;

   ------------
   -- Create --
   ------------

   function Create
     (OCF : access ORB_Controller_Basic_Factory)
     return ORB_Controller_Access
   is
      use PolyORB.Parameters;

      pragma Warnings (Off);
      pragma Unreferenced (OCF);
      pragma Warnings (On);

      OC : ORB_Controller_Basic_Access;
      RS : PRS.Request_Scheduler_Access;

      Polling_Interval : constant Natural
        := Get_Conf ("orb_controller",
                     "polyorb.orb_controller_basic.polling_interval",
                     0);

      Polling_Timeout : constant Natural
        := Get_Conf ("orb_controller",
                     "polyorb.orb_controller_basic.polling_timeout",
                     0);

   begin
      PRS.Create (RS);
      OC := new ORB_Controller_Basic (RS);

      Create (OC.ORB_Lock);
      Create (OC.Polling_Completed);

      OC.Job_Queue := PolyORB.Jobs.Create_Queue;

      if Polling_Interval = 0 then
         OC.Polling_Interval := PolyORB.Constants.Forever;
      else
         OC.Polling_Interval := Polling_Interval * 0.01;
      end if;

      if Polling_Timeout = 0 then
         OC.Polling_Timeout := PolyORB.Constants.Forever;
      else
         OC.Polling_Timeout := Polling_Timeout * 0.01;
      end if;

      return ORB_Controller_Access (OC);
   end Create;

   ----------------
   -- Initialize --
   ----------------

   procedure Initialize;

   procedure Initialize is
   begin
      Register_ORB_Controller_Factory (OCF);
   end Initialize;

   use PolyORB.Initialization;
   use PolyORB.Initialization.String_Lists;
   use PolyORB.Utils.Strings;

begin
   Register_Module
     (Module_Info'
      (Name      => +"orb_controller.basic",
       Conflicts => Empty,
       Depends   => +"tasking.condition_variables"
       & "tasking.mutexes"
       & "request_scheduler?",
       Provides  => +"orb_controller",
       Implicit  => False,
       Init      => Initialize'Access));
end PolyORB.ORB_Controller.Basic;