ada/PolyORB
0
0
Fork 0
mirror of https://github.com/AdaCore/PolyORB.git synced 2026-02-12 13:01:15 -08:00
Code Issues Packages Projects Releases Wiki Activity
Files
dfbebe2424df8759e08c78c1c7b10691a3a17fe9
PolyORB/src/polyorb-orb_controller-basic.adb
Thomas Quinot dfbebe2424 Ensure that tasks that leave the Idle state by another 
path than Awake_One_Idle_Task (eg as a consequence of the
result of a pending request becoming ready) are correctly
removed from the idle list.

Fixes D708-012.

[Imported from Perforce change 8351 at 2006-12-01 20:33:07]

Subversion-branch: /trunk/polyorb
Subversion-revision: 35949
2004-08-09 17:08:08 +00:00

670 lines
19 KiB
Ada
Raw Blame History

------------------------------------------------------------------------------
-- --
-- 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;
Reference in New Issue View Git Blame Copy Permalink