AdaPower Logged in as Guest
Ada Tools and Resources

Ada 95 Reference Manual
Ada Source Code Treasury
Bindings and Packages
Ada FAQ


Join >
Articles >
Ada FAQ >
Getting Started >
Home >
Books & Tutorials >
Source Treasury >
Packages for Reuse >
Latest Additions >
Ada Projects >
Press Releases >
Ada Audio / Video >
Home Pages >
Links >
Contact >
About >
Login >
Back
Semaphores (Matthew Heaney)


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;


(c) 1998-2004 All Rights Reserved David Botton