In this article we show how to implement a (binary) semaphore in Ada.
Discussion
One way to prevent a resource from being accessed by multiple threads
simultaneously is to associate a semaphore with the resource.
A thread that needs exclusive access to a resource seizes the semaphore,
which causes the thread to wait until the threads ahead of it in the
queue have released the semaphore.
When the thread is done with the resource, it releases the semaphore,
allowing other waiting threads to proceed.
Implementation
The semaphore type is very simple, needing only a pair of operations for
seizing and releasing:
package Binary_Semaphores is
type Semaphore_Type is limited private;
procedure Seize (Semaphore : in out Semaphore_Type);
procedure Release (Semaphore : in out Semaphore_Type);
...
end Binary_Semaphores;
The full view of the type is implemented as a protected type:
package Binary_Semaphores is
...
private
protected type Semaphore_Type is
procedure Release;
entry Seize;
private
In_Use : Boolean := False;
end Semaphore_Type;
end Binary_Semaphores;
Compare the partial and full declarations of the type carefully. The
partial view is declared as limited private:
type Semaphore_Type is limited private;
while the full view is implemented as a protected type:
protected type Semaphore_Type is ...;
Many Ada programmers don't realize you can do this, and would implement
the full view of the type as a plain record with protected type
component. This is wrong. Just implement the type as a protected type
directly.
The protected type declares Release as a protected procedure, which
means that, although calls are synchronized, no actual blocking occurs.
However, Seize is declared as a protected entry, because we want callers
to block if the resource is already in use.
The only state the semaphore has is a flag to indicate whether the
resource is in use. We use the flag as an entry barrier for Seize:
entry Seize when not In_Use is
^^^^^^^^^^
begin
In_Use := True;
end;
When the resource is In_Use, the barrier is false, so the caller blocks
until the barrier condition changes. When it does, the body of Seize
executes, setting the flag back to true (which blocks other callers).
The protected procedure Release just sets the In_Use flag back to
false:
procedure Release is
begin
In_Use := False;
end;
This immediately forces the barrier for Seize to be reevaluated,
allowing the next caller to proceed.
The major problem with semaphores is that it's very easy to not release
the semaphore when you're done with the resource. This can deadlock the
entire system because every thread that tries to seize the resource will
block forever, waiting for a release that never happens.
There are many ways to forget to release a resource. You might be
modifying something someone else wrote, and not be paying attention to
the fact that the resource was locked, and needs to be unlocked:
procedure Do_Something (Resource : in out T) is
begin
Seize (Resource.Semaphore);
...
--
-- Lah-dee-dah-dee-dah. Oh, here I am maintaining this code. I'll
-- just add this "quick fix" (yeah, right) to test the flag and
-- bail out early:
--
if Done then
return; -- oops! Early return...
end if;
...
Release (Resource.Semaphore); ... doesn't get called.
end Do_Something;
Another, more pernicious problem is that even if you do remember to
release the resource, an unhandled exception will cause the program
counter to skip past that line:
procedure Do_Something (Resource : in out T) is
begin
Seize (Resource.Semaphore);
...
X := 0;
...
Y := Z / X; -- oops! Constraint_Error raised...
...
Release (Resource.Semaphore); -- ... doesn't get executed.
end Do_Something;
You might even remember to handle the exception locally, but forget to
release the resource in the exception handler.
If you think I'm trying to scare you into thinking that you shouldn't
use a semaphore, that's because I'm trying to scare you into thinking
that you shouldn't use a semaphore.
You need to be convinced that using a semaphore all by itself is very
dangerous and error prone. So be afraid. Be very afraid.
In order to make a semaphore safe, we need a way to make sure that it
gets released no matter how the frame terminates.
The solution is to use the "resource allocation is initialization"
idiom. We use a controlled object to seize the semaphore during its
initialization, and release the semaphore during its finalization.
The semaphore control object binds to a semaphore via an access
discriminant:
type Semaphore_Control (Semaphore : access Semaphore_Type) is
limited private;
The type is implemented as a derivation of Limited_Controlled that
overrides Initialize and Finalize:
type Semaphore_Control (Semaphore : access Semaphore_Type) is
new Limited_Controlled with null record;
procedure Initialize (Control : in out Semaphore_Control);
procedure Finalize (Control : in out Semaphore_Control);
The control object implements Initialize by calling the Seize entry of
the semaphore object it is bound to:
procedure Initialize (Control : in out Semaphore_Control) is
begin
Control.Semaphore.Seize;
end;
It implements Finalize by calling the Release procedure of the
semaphore:
procedure Finalize (Control : in out Semaphore_Control) is
begin
Control.Semaphore.Seize;
end;
The Finalize operation for a controlled object always gets called no
matter how the frame terminates, so this guarantees that the resource
will get released.
To use our semaphore control object, we just declare it. There's
nothing else we need to do:
Resource : Resource_Type;
Semaphore : aliased Semaphore_Type;
procedure Op (...) is
Control : Semaphore_Control (Semaphore'Access);
begin
<do op>
end;
The Seize and Release operations of the Semaphore object are called
automatically during the construction and deconstruction of the Control
object.
This really simplifies things, because we don't have to think about
resource allocation and deallocation:
procedure Do_Something (Resource : in out T) is
Control : Semaphore_Control (Resource.Semaphore);
begin
...
--
-- Lah-dee-dah-dee-dah. Oh, here I am maintaining this code. I'll
-- just add this quick fix to test the flag and bail out early:
--
if Done then
return; -- Early return is ... harmless.
end if;
...
end Do_Something;
If you need to temporarily claim exclusive access to a resource, then
you can declare a semaphore control object in a temporary scope:
Stack : aliased File_Stack;
Stack_Semaphore : aliased Semaphore_Type;
procedure Op (...) is
begin
<do lots of stuff>
declare
Control : Semaphore_Control (Stack_Semaphore'Access); <--
Iterator : Stack_Iterator (Stack'Access);
begin
while not Is_Done (Iterator) loop
Put_Line (Get_Name (Get_Item (Iterator)));
Advance (Iterator);
end loop;
end;
<do lots more stuff>
end Op;
We can use a semaphore to implement abstractions that are accessed by
multiple threads simultaneously. The semaphore will synchronize
callers, so state can't get corrupted because of interleaved execution.
Let's use My Favorite Example, a concurrent bounded stack. The public
part of the spec looks perfectly normal:
generic
type Item_Type is private;
Max_Depth : in Positive;
package Stacks is
type Stack_Type is limited private;
procedure Push
(Item : in Item_Type;
On : in out Stack_Type);
procedure Set_Top
(Stack : in out Stack_Type;
Item : in Item_Type);
generic
with procedure Process
(Item : in out Item_Type;
Done : in out Boolean);
procedure For_Every_Item (Stack : in out Stack_Type);
...
end Stacks;
To add support for concurrency, we include a semaphore as part of the
representation of the stack:
type Stack_Type is
limited record
Items : Item_Array;
Top : Natural := 0;
Sema : aliased Semaphore_Type; <--
end record;
end Stacks;
Every stack operation is implemented by declaring a semaphore control
object, and binding it to the stack's semaphore:
procedure Push
(Item : in Item_Type;
On : in out Stack_Type) is
Control : Semaphore_Control (On.Sema'Access); <--
begin
On.Top := On.Top + 1;
On.Items (On.Top) := Item;
end;
It's critical that the caller have exclusive access to the stack during
a Push. Interleaved execution would most certainly cause the top index
to have an incorrect value.
The caller will block during initialization of the Control object, until
the threads ahead of it manipulating the same stack are done.
We do the same for the implementation of the passive iterator:
procedure For_Every_Item (Stack : in out Stack_Type) is
Control : Semaphore_Control (Stack.Sema'Access); <--
Done : Boolean := False;
begin
for I in reverse 1 .. Stack.Top loop
Process (Stack.Items (I), Done);
exit when Done;
end loop;
end For_Every_Item;
You can safely iterate through the stack without worrying about whether
other threads are modifying the stack at the same time, and without
having to handle exceptions that propagate out of Process.
Let's re-implement the TCP connection type from the original State
pattern example, to add support for concurrent access.
Like we just did for the stack, we add a semaphore to the implementation
of the Connection_Type:
type Connection_Type is
new Root_Connection_Type with record
State : State_Access := Get_Default;
File : Streams.File_Type;
Sema : aliased Semaphore_Type; <--
end record;
Every public connection operation now declares a semaphore control
object, and binds it to the connection object's semaphore:
procedure Active_Open
(Connection : in out Connection_Type) is
Control : Semaphore_Control (Connection.Sema'Access); <--
begin
Active_Open (Connection.State, Connection);
end;
procedure Close
(Connection : in out Connection_Type) is
Control : Semaphore_Control (Connection.Sema'Access); <--
begin
Close (Connection.State, Connection);
end;
Now multiple threads can manipulate the same connection object, with a
guarantee that its state cannot be corrupted.
Note that only public operations called by clients of Connection_Type
are synchronized this way. Internal operations called during execution
of State_Type operations are not synchronized.
For example, the Set_State operation has the same implementation as it
did previously:
procedure Set_State
(Connection : in out Connection_Type;
State : in State_Access) is
begin
Connection.State := State;
end;
Internal operations are called as part of the same thread of execution,
and the caller has already locked the object. If the connection object
were locked again, the caller would deadlock.
--STX
package body Binary_Semaphores is
protected body Semaphore_Type is
procedure Release is
begin
In_Use := False;
end;
entry Seize when not In_Use is
begin
In_Use := True;
end;
end Semaphore_Type;
procedure Seize (Semaphore : in out Semaphore_Type) is
begin
Semaphore.Seize;
end;
procedure Release (Semaphore : in out Semaphore_Type) is
begin
Semaphore.Release;
end;
procedure Initialize (Control : in out Semaphore_Control) is
begin
Control.Semaphore.Seize;
end;
procedure Finalize (Control : in out Semaphore_Control) is
begin
Control.Semaphore.Seize;
end;
end Binary_Semaphores;
with Ada.Finalization;
package Binary_Semaphores is
pragma Preelaborate;
type Semaphore_Type is limited private;
procedure Seize (Semaphore : in out Semaphore_Type);
procedure Release (Semaphore : in out Semaphore_Type);
type Semaphore_Control (Semaphore : access Semaphore_Type) is
limited private;
private
protected type Semaphore_Type is
procedure Release;
entry Seize;
private
In_Use : Boolean := False;
end Semaphore_Type;
use Ada.Finalization;
type Semaphore_Control (Semaphore : access Semaphore_Type) is
new Limited_Controlled with null record;
procedure Initialize (Control : in out Semaphore_Control);
procedure Finalize (Control : in out Semaphore_Control);
end Binary_Semaphores;
package body Stacks is
procedure Push
(Item : in Item_Type;
On : in out Stack_Type) is
Control : Semaphore_Control (On.Sema'Access);
begin
On.Top := On.Top + 1;
On.Items (On.Top) := Item;
end;
procedure Set_Top
(Stack : in out Stack_Type;
Item : in Item_Type) is
Control : Semaphore_Control (Stack.Sema'Access);
begin
Stack.Items (Stack.Top) := Item;
end;
procedure For_Every_Item (Stack : in out Stack_Type) is
Control : Semaphore_Control (Stack.Sema'Access);
Done : Boolean := False;
begin
for I in reverse 1 .. Stack.Top loop
Process (Stack.Items (I), Done);
exit when Done;
end loop;
end For_Every_Item;
end Stacks;
with Binary_Semaphores;
generic
type Item_Type is private;
Max_Depth : in Positive;
package Stacks is
type Stack_Type is limited private;
procedure Push
(Item : in Item_Type;
On : in out Stack_Type);
procedure Set_Top
(Stack : in out Stack_Type;
Item : in Item_Type);
generic
with procedure Process
(Item : in out Item_Type;
Done : in out Boolean);
procedure For_Every_Item (Stack : in out Stack_Type);
private
subtype Item_Array_Range is Positive range 1 .. Max_Depth;
type Item_Array is array (Item_Array_Range) of Item_Type;
use Binary_Semaphores;
type Stack_Type is
limited record
Items : Item_Array;
Top : Natural := 0;
Sema : aliased Semaphore_Type;
end record;
end Stacks;
with TCP.States.Closed;
package body TCP.Connections is
function Get_Default return State_Access renames
States.Closed.State;
procedure Active_Open
(Connection : in out Connection_Type) is
Control : Semaphore_Control (Connection.Sema'Access);
begin
Active_Open (Connection.State, Connection);
end;
procedure Passive_Open
(Connection : in out Connection_Type) is
Control : Semaphore_Control (Connection.Sema'Access);
begin
Passive_Open (Connection.State, Connection);
end;
procedure Close
(Connection : in out Connection_Type) is
Control : Semaphore_Control (Connection.Sema'Access);
begin
Close (Connection.State, Connection);
end;
procedure Send
(Connection : in out Connection_Type) is
Control : Semaphore_Control (Connection.Sema'Access);
begin
Send (Connection.State, Connection);
end;
procedure Acknowledge
(Connection : in out Connection_Type) is
Control : Semaphore_Control (Connection.Sema'Access);
begin
Acknowledge (Connection.State, Connection);
end;
procedure Synchronize
(Connection : in out Connection_Type) is
Control : Semaphore_Control (Connection.Sema'Access);
begin
Synchronize (Connection.State, Connection);
end;
procedure Process_Stream
(Connection : in out Connection_Type;
Item : in Stream_Element_Array) is
Control : Semaphore_Control (Connection.Sema'Access);
begin
Do_Process_Stream (Connection, Item);
end;
procedure Set_State
(Connection : in out Connection_Type;
State : in State_Access) is
begin
Connection.State := State;
end;
procedure Do_Process_Stream
(Connection : in out Connection_Type;
Item : in Stream_Element_Array) is
use Streams;
begin
Write (Connection.File, Item);
end;
end TCP.Connections;
with TCP.States;
with TCP.Streams;
with Ada.Streams; use Ada.Streams;
with Binary_Semaphores;
package TCP.Connections is
pragma Elaborate_Body;
type Connection_Type is limited private;
procedure Active_Open
(Connection : in out Connection_Type);
procedure Passive_Open
(Connection : in out Connection_Type);
procedure Close
(Connection : in out Connection_Type);
procedure Send
(Connection : in out Connection_Type);
procedure Acknowledge
(Connection : in out Connection_Type);
procedure Synchronize
(Connection : in out Connection_Type);
procedure Process_Stream
(Connection : in out Connection_Type;
Item : in Stream_Element_Array);
private
use States;
function Get_Default return State_Access;
use Binary_Semaphores;
type Connection_Type is
new Root_Connection_Type with record
State : State_Access := Get_Default;
File : Streams.File_Type;
Sema : aliased Semaphore_Type;
end record;
procedure Set_State
(Connection : in out Connection_Type;
State : in State_Access);
procedure Do_Process_Stream
(Connection : in out Connection_Type;
Item : in Stream_Element_Array);
end TCP.Connections;
package TCP.States.Closed is
pragma Elaborate_Body;
type Closed_State_Type is new Root_State_Type with private;
procedure Active_Open
(State : access Closed_State_Type;
Connection : in out Root_Connection_Type'Class);
procedure Passive_Open
(State : access Closed_State_Type;
Connection : in out Root_Connection_Type'Class);
function State return State_Access;
private
type Closed_State_Type is new Root_State_Type with null record;
end TCP.States.Closed;
with Ada.Streams; use Ada.Streams;
package TCP.States is
pragma Preelaborate;
type Root_State_Type (<>) is
abstract tagged limited private;
type State_Access is access all Root_State_Type'Class;
type Root_Connection_Type is
abstract tagged limited null record;
procedure Set_State
(Connection : in out Root_Connection_Type;
State : in State_Access) is abstract;
procedure Do_Process_Stream
(Connection : in out Root_Connection_Type;
Item : in Stream_Element_Array) is abstract;
procedure Transmit
(State : access Root_State_Type;
Connection : in out Root_Connection_Type'Class;
Item : in Stream_Element_Array);
procedure Active_Open
(State : access Root_State_Type;
Connection : in out Root_Connection_Type'Class);
procedure Passive_Open
(State : access Root_State_Type;
Connection : in out Root_Connection_Type'Class);
procedure Close
(State : access Root_State_Type;
Connection : in out Root_Connection_Type'Class);
procedure Synchronize
(State : access Root_State_Type;
Connection : in out Root_Connection_Type'Class);
procedure Acknowledge
(State : access Root_State_Type;
Connection : in out Root_Connection_Type'Class);
procedure Send
(State : access Root_State_Type;
Connection : in out Root_Connection_Type'Class);
private
type Root_State_Type is
abstract tagged limited null record;
end TCP.States;
with Ada.Streams; use Ada.Streams;
package TCP.Streams is
pragma Elaborate_Body;
type Stream_Access is access all Root_Stream_Type'Class;
type File_Type is limited private;
procedure Open
(File : in out File_Type;
Name : in String);
procedure Close
(File : in out File_Type);
function Get_Stream
(File : File_Type) return Stream_Access;
procedure Read
(File : in File_Type;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset);
procedure Write
(File : in File_Type;
Item : in Stream_Element_Array);
private
type TCP_Stream_Type is
new Root_Stream_Type with null record; --???
procedure Read
(Stream : in out TCP_Stream_Type;
Item : out Stream_Element_Array;
Last : out Stream_Element_Offset);
procedure Write
(Stream : in out TCP_Stream_Type;
Item : in Stream_Element_Array);
type File_Type is
limited record
Index : Natural := 0;
end record;
end TCP.Streams;
package TCP is
pragma Pure;
end TCP;
|
