In an earlier implementation of the dining philosophers example, we used
suspension objects to keep philosopher tasks waiting for chopsticks.
This allowed us to implement the Chopsticks protected object without
using an entry queue.
Here we extend that idea to the Line_Views package. Previously, tasks
that call Update would get queued on the Wait entry of a semaphore, to
serialize access to package state and to Text_IO. Now, in this
alternate implementation, we suspend the calling task using its
suspension object.
Implementation
If the Line_Views resource is already in use (meaning that another task
is in the middle of calling Update), then instead waiting in a protected
object entry queue, the calling task suspends itself on a suspension
object.
We use a special, entry-less semaphore object containing a queue of
(pointers to) suspension objects. During Update, a pointer to the
task's suspension object is added to the queue. When the task who owns
the resource is done (has left its critical region), it signals the task
at the front of the queue.
If the task calling Update finds that the resource isn't already in use,
then its suspension object is set to True immediately, and the task
proceeds without any waiting.
The spec of the semaphore looks like this:
protected type Semaphore_Type (Size : Positive) is
procedure Wait (SO : in Suspension_Object_Access);
procedure Signal;
private
Queue : Queue_Type (Size);
In_Use : Boolean := False;
end Semaphore_Type;
This is a bounded semaphore, and we pass in the maximum number of tasks
as a discriminant.
The In_Use flag indicates whether another thread has already claimed the
resource, and Queue is just a bounded queue of pointers to suspension
objects.
Associated with each task is a suspension object. In order to use a
resource, the task "registers" its suspension object with the semaphore,
and then immediately following that calls Suspend_Until_True.
The span of a task's critical region looks a little like this:
Semaphore.Wait (My_Suspension_Object'Access);
Suspend_Until_True (My_Suspension_Object);
<critical region>
Semaphore.Signal;
Note that the name Wait is a bit of a misnomer (it's a protected
procedure, not an entry), because no real waiting occurs until calling
Suspend_Until_True, and only then if the suspension object has the value
False.
Wait is implemented as follows:
procedure Wait (SO : in Suspension_Object_Access) is
begin
if In_Use then
Add (SO, To => Queue);
Set_False (SO.all);
else
In_Use := True;
Set_True (SO.all);
end if;
end Wait;
If the semaphore is in use, then we set the suspension object to False,
to actually suspend the calling task, and add the suspension object to
the queue.
Otherwise, we set the In_Use flag to indicate that the resource has been
claimed, and set the task's suspension object to True. When the task
calls Suspend_Until_True, the suspension object will already be True,
and the task enters its critical region right away.
When the task leaves its critical region, it calls Signal:
procedure Signal is
begin
pragma Assert (In_Use);
if Is_Empty (Queue) then
In_Use := False;
else
Set_True (Get_Front (Queue).all);
Pop (Queue);
end if;
end Signal;
An empty queue means there's no other task waiting to use the resource,
so we just set the In_Use flag is to False, and we're done. Otherwise,
we resume the waiting task at the front of the queue, and remove that
task from the queue.
In order to use this semaphore, the Line_Views package needs suspension
objects. Since this package is part of the Philosophers subsystem, we
will reuse the suspension objects already being used for chopstick
management.
We move the suspension object array out of the body of the Philosophers
package, and into the spec of a private Internals package:
private package Philosophers.Internals is
type Suspension_Object_Array is
array (Philosopher_Id) of aliased Suspension_Object;
Semaphores : Suspension_Object_Array;
end Philosophers.Internals;
Making the package private hides the package from clients outside the
subsystem. Only packages (really, their bodies) that are children of
package Philosophers are allowed to with Internals. In a sense, package
Internals is the "body" of the subsystem.
Now that a suspension object is available, we can implement the Update
operation:
Number_Of_Philosophers : constant := Philosopher_Id'Last;
LV_Sema_Size : constant := Number_Of_Philosophers - 1;
LV_Sema : Semaphores.Bounded.Semaphore_Type (LV_Sema_Size);
procedure Update
(Id : in Philosopher_Id;
State : in State_Type) is
SO : Suspension_Object renames Internals.Semaphores (Id);
begin
LV_Sema.Wait (SO'Access);
Suspend_Until_True (SO);
Do_Update (Id, State);
LV_Sema.Signal;
end Update;
The task registers its suspension object with the semaphore, by calling
Wait, and then suspends itself. When the current task (the owner of the
the resource) is done, it signals the semaphore, and that resumes the
suspended task.
I should have implemented Update using a Controlled object to make sure
Signal gets called, and in a real system I probably would. I didn't do
it that way here because I was trying to keep the focus on the use of a
suspension object as an alternative to an entry queue.
A note about the size of the semaphore queue. There are five tasks
total, but if one task is executing, we only need keep a maximum of four
tasks waiting. That's why the size of the semaphore queue is four
instead of five.
This particular example is similar to the example in section D.10 of the
Ada95 Rationale. You may find it helpful to peruse that section.
The sources below are in a format suitable for use with gnatchop.
--STX
with Ada.Text_IO;
package Duration_IO is
new Ada.Text_IO.Fixed_IO (Duration);
with Ada.Synchronous_Task_Control; use Ada.Synchronous_Task_Control;
private package Philosophers.Internals is
type Suspension_Object_Array is
array (Philosopher_Id) of aliased Suspension_Object;
Semaphores : Suspension_Object_Array;
end Philosophers.Internals;
with Ada.Text_IO; use Ada.Text_IO;
with Duration_IO; use Duration_IO;
with Philosophers.Internals;
with Semaphores.Bounded;
with Ada.Synchronous_Task_Control; use Ada.Synchronous_Task_Control;
package body Philosophers.Line_Views is
Number_Of_Philosophers : constant := Philosopher_Id'Last;
LV_Sema_Size : constant := Number_Of_Philosophers - 1;
LV_Sema : Semaphores.Bounded.Semaphore_Type (LV_Sema_Size);
Current : Natural := 0;
Count : Natural := Philosopher_Id'Last;
procedure Do_Update
(Id : in Philosopher_Id;
State : in State_Type) is
begin
if Current = Id then
Put (", ");
else
New_Line;
Current := Id;
Put ("Philosopher" & Philosopher_Id'Image (Id) & " ");
end if;
Put (State_Type'Image (State));
if State = Eating
or State = Thinking
then
Put (" (");
Put (Get_Delay (Id), Fore => 0, Aft => 1, Exp => 0);
Put (")");
elsif State = Dying then
Count := Count - 1;
if Count = 0 then
New_Line (2);
Put_Line ("All the philosophers have terminated.");
end if;
end if;
exception
when others =>
Put_Line ("An error occured updating philosopher task" &
Integer'Image (Id) &
" in state " &
State_Type'Image (State));
end Do_Update;
procedure Update
(Id : in Philosopher_Id;
State : in State_Type) is
SO : Suspension_Object renames Internals.Semaphores (Id);
begin
LV_Sema.Wait (SO'Access);
Suspend_Until_True (SO);
Do_Update (Id, State);
LV_Sema.Signal;
end Update;
end Philosophers.Line_Views;
package Philosophers.Line_Views is
pragma Elaborate_Body;
procedure Update
(Id : in Philosopher_Id;
State : in State_Type);
end Philosophers.Line_Views;
with Ada.Numerics.Float_Random; use Ada.Numerics.Float_Random;
with Ada.Synchronous_Task_Control; use Ada.Synchronous_Task_Control;
with Ada.Text_IO;
with Philosophers.Internals; use Philosophers.Internals;
package body Philosophers is
Update : Update_Access;
package Id_Management is
function Get_Id return Philosopher_Id;
end;
use Id_Management;
package body Id_Management is
Id : Natural := 0;
function Get_Id return Philosopher_Id is
begin
Id := Id + 1;
return Id;
end;
end Id_Management;
task type Philosopher_Task_Type (Id : Philosopher_Id := Get_Id);
type Philosopher_Task_Array is
array (Philosopher_Id) of Philosopher_Task_Type;
Philosopher_Tasks : Philosopher_Task_Array;
type Duration_Array is
array (Philosopher_Id) of Duration;
Delay_Times : Duration_Array;
protected Random_Delay is
procedure Get (Id : in Philosopher_Id);
procedure Initialize;
private
G : Generator;
end Random_Delay;
procedure Start
(Update : in Update_Access) is
begin
Ada.Text_IO.Put_Line
("Using suspension objects to wait for " &
"chopsticks and display device.");
Philosophers.Update := Update;
Random_Delay.Initialize;
for Id in Philosopher_Id loop
Set_True (Semaphores (Id));
end loop;
end Start;
function Get_Delay (Id : Philosopher_Id) return Duration is
begin
return Delay_Times (Id);
end;
type Boolean_Array is array (Philosopher_Id) of Boolean;
protected Chopsticks is
procedure Pick_Up
(Id : in Philosopher_Id;
Success : out Boolean);
procedure Put_Down
(Id : in Philosopher_Id);
private
Available : Boolean_Array := (others => True);
end Chopsticks;
task body Philosopher_Task_Type is
Delay_Time : Duration renames Delay_Times (Id);
Semaphore : Suspension_Object renames Semaphores (Id);
Picked_Up_Chopsticks : Boolean;
begin
Suspend_Until_True (Semaphore);
Update (Id, Breathing);
for I in 1 .. 5 loop
loop
Update (Id, Picking_Up);
Chopsticks.Pick_Up (Id, Picked_Up_Chopsticks);
exit when Picked_Up_Chopsticks;
Update (Id, Suspending);
Suspend_Until_True (Semaphore);
end loop;
Random_Delay.Get (Id);
Update (Id, Eating);
delay Delay_Time;
Update (Id, Done_Eating);
Chopsticks.Put_Down (Id);
Random_Delay.Get (Id);
Update (Id, Thinking);
delay Delay_Time;
Update (Id, Done_Thinking);
end loop;
Update (Id, Dying);
delay 60.0; -- hack to work around error in my RTS
end Philosopher_Task_Type;
protected body Chopsticks is
procedure Pick_Up
(Id : in Philosopher_Id;
Success : out Boolean) is
Next : constant Philosopher_Id := Id mod 5 + 1;
begin
if Available (Id) and Available (Next) then
Available (Id) := False;
Available (Next) := False;
Success := True;
else
Set_False (Semaphores (Id));
Success := False;
end if;
end Pick_Up;
procedure Put_Down
(Id : in Philosopher_Id) is
Prev : constant Philosopher_Id := (Id + 3) mod 5 + 1;
Next : constant Philosopher_Id := Id mod 5 + 1;
begin
Available (Id) := True;
Available (Next) := True;
Set_True (Semaphores (Prev));
Set_True (Semaphores (Next));
end Put_Down;
end Chopsticks;
protected body Random_Delay is
procedure Get (Id : in Philosopher_Id) is
F : constant Float := Random (G);
begin
Delay_Times (Id) := 10 * Duration (F);
end;
procedure Initialize is
begin
Reset (G);
end;
end Random_Delay;
end Philosophers;
package Philosophers is
subtype Philosopher_Id is Positive range 1 .. 5;
type State_Type is
(Breathing,
Thinking,
Done_Thinking,
Picking_Up,
Suspending,
Eating,
Done_Eating,
Dying);
type Update_Access is
access procedure (Id : in Philosopher_Id;
State : in State_Type);
procedure Start (Update : in Update_Access);
function Get_Delay (Id : Philosopher_Id) return Duration;
end Philosophers;
package body Queues.Bounded is
procedure Add
(Item : in Item_Type;
To : in out Queue_Type) is
begin
pragma Assert (To.Length < To.Size);
To.Items (To.B) := Item;
To.B := To.B mod To.Size + 1;
To.Length := To.Length + 1;
end Add;
procedure Pop
(Queue : in out Queue_Type) is
begin
pragma Assert (Queue.Length > 0);
Queue.F := Queue.F mod Queue.Size + 1;
Queue.Length := Queue.Length - 1;
end;
function Get_Front
(Queue : Queue_Type) return Item_Type is
begin
pragma Assert (Queue.Length > 0);
return Queue.Items (Queue.F);
end;
function Is_Empty
(Queue : Queue_Type) return Boolean is
begin
return Queue.Length = 0;
end;
function Is_Full
(Queue : Queue_Type) return Boolean is
begin
return Queue.Length = Queue.Size;
end;
end Queues.Bounded;
generic
type Item_Type is private;
package Queues.Bounded is
type Queue_Type (Size : Positive) is limited private;
procedure Add
(Item : in Item_Type;
To : in out Queue_Type);
procedure Pop
(Queue : in out Queue_Type);
function Get_Front
(Queue : Queue_Type) return Item_Type;
function Is_Empty
(Queue : Queue_Type) return Boolean;
function Is_Full
(Queue : Queue_Type) return Boolean;
private
type Item_Array is array (Positive range <>) of Item_Type;
type Queue_Type (Size : Positive) is
limited record
Items : Item_Array (1 .. Size);
Length : Natural := 0;
F, B : Positive := 1;
end record;
end Queues.Bounded;
package Queues is
pragma Pure;
end Queues;
package body Semaphores.Bounded is
protected body Semaphore_Type is
procedure Wait (SO : in Suspension_Object_Access) is
begin
if In_Use then
Add (SO, To => Queue);
Set_False (SO.all);
else
In_Use := True;
Set_True (SO.all);
end if;
end Wait;
procedure Signal is
begin
pragma Assert (In_Use);
if Is_Empty (Queue) then
In_Use := False;
else
Set_True (Get_Front (Queue).all);
Pop (Queue);
end if;
end Signal;
end Semaphore_Type;
end Semaphores.Bounded;
with Ada.Synchronous_Task_Control; use Ada.Synchronous_Task_Control;
with Queues.Bounded;
pragma Elaborate (Queues.Bounded);
package Semaphores.Bounded is
pragma Elaborate_Body;
type Suspension_Object_Access is
access all Suspension_Object;
package SO_Queues is
new Queues.Bounded (Suspension_Object_Access);
use SO_Queues;
protected type Semaphore_Type (Size : Positive) is
procedure Wait (SO : in Suspension_Object_Access);
procedure Signal;
private
Queue : Queue_Type (Size);
In_Use : Boolean := False;
end Semaphore_Type;
end Semaphores.Bounded;
package Semaphores is
pragma Pure;
end Semaphores;
with Philosophers.Line_Views; use Philosophers;
procedure Test_Philosophers is
begin
Start (Line_Views.Update'Access);
end;
|
