Guarded Data Structures

Suppose we want to purge a concurrent stack, doing something with each
item as it is popped, like this:

  while not Is_Empty (Stack) loop
    declare
       Item : constant T := Get_Top (Stack);
    begin
       Do_Something_To (Item);
       Pop (Stack);
    end;
  end loop;


In our earlier implementation of the stack, we used a semaphore to
synchronize access to the stack for every operation.  Using that
implementation here would not be very efficient, since multiple
operations are called during every pass through the loop.

What we'd rather do is claim exclusive access to the stack just once,
before the loop, and then release the stack when we're done iterating.
Inside the loop no further synchronization would be necessary.

A "guarded" data structure is a generalization of a semaphore, with
operations to seize and release the structure.  Using a guard is a more
efficient way to manipulate a structure when operations need to be
called in batch:

  Seize (Structure);

  <do a bunch of stuff to the structure>

  Release (Structure);


Implementation

Let's assemble a guarded stack of integers from reusable components.  At
the end of the day what we want is a package that looks like this:

  package Integer_Stacks is

      type Integer_Stack is ...;


      procedure Seize (Stack : in out Integer_Stack);

      procedure Release (Stack : in out Integer_Stack);


      procedure Push (Item : in     Integer;
                      On   : in out Integer_Stack);

      function Get_Top (Stack : Integer_Stack) return Integer;

      ...

  end Integer_Stacks;


We start by instantiating a bounded sequential stack:

  generic

     type Item_Type is private;

     Max_Depth : in Positive;

  package Stacks is

     type Stack_Type is tagged limited private;

     procedure Push
       (Item : in     Item_Type;
        On   : in out Stack_Type);

     ...

  end Stacks;


  package Integer_Stacks is

    package Stack_Types is
      new Stacks (Integer, Max_Depth => 10);

    ...

  end Integer_Stacks;


We implement the guarded type using mixin inheritance.  Per that idiom,
we derive from a generic formal type, and extend it with a semaphore
component:

  generic

     type Resource_Type (<>) is abstract tagged limited private;

  package Guard_Mixin is

     type Guarded_Resource is
       new Resource_Type with record
          Semaphore : Semaphore_Type;
       end record;

     procedure Seize (Resource : in out Guarded_Resource);

     procedure Release (Resource : in out Guarded_Resource);

  end Guard_Mixin;


The semaphore is a public attribute, to allow clients to make timed or
conditional entry calls.  We also provide explicit Seize and Release
operations, for clients who would rather use parameter (instead of
prefix) notation.

We now take our sequential stack type, and mix-in a guard:

  package Integer_Stacks is

    package Stack_Types is
      new Stacks (Integer, Max_Depth => 10);

    package Guarded_Stacks is
      new Guard_Mixin (Stack_Types.Stack_Type);

    ...

  end Integer_Stacks;


This gives us type Integer_Stacks.Guarded_Stacks.Guarded_Resource, which
is not quite what we want.  We also want stack operations to be directly
visible from Integer_Stacks, not from one of its nested packages.

So we make one more derivation:

  package Integer_Stacks is

    package Stack_Types is new Stacks (Integer, Max_Depth => 10);

    package Guarded_Stacks is new Guard_Mixin (Stack_Types.Stack_Type);

    type Integer_Stack is
      new Guarded_Stacks.Guarded_Resource with null record;

    ...

  end Integer_Stacks;


Deriving from a type in an inner package, in order to make its
operations directly visible from the outer package, is called
"transitivity of visibility."

There's one more declaration we need to make.  The original stack
package provides a passive iterator:

   generic

      with procedure Process
        (Item : in out Item_Type;
         Done : in out Boolean);

   procedure For_Every_Item (Stack : in out Stack_Type'Class);


What we'd like is for clients to have visibility to this generic
procedure directly from the Integer_Stacks package.  We can effect this
by using a generic renaming declaration:

   generic procedure For_Every_Item renames
     Stack_Types.For_Every_Item;


Note carefully that the stack parameter in the iterator is declared as
Stack_Type'Class.  Generic operations aren't primitive and therefore
don't get inherited, so you have to make the parameter class-wide, in
order for the procedure to work for any type in the derivation tree.

The completed spec looks like this:

  package Integer_Stacks is

     package Stack_Types is
       new Stacks (Integer, Max_Depth => 10);

     package Guarded_Stacks is
       new Guard_Mixin (Stack_Types.Stack_Type);

     type Integer_Stack is
       new Guarded_Stacks.Guarded_Resource with null record;

     generic procedure For_Every_Item renames
       Stack_Types.For_Every_Item;

  end Integer_Stacks;


A guarded component is error prone for the same reason a semaphore is:
it's really easy to not release the structure after you've seized it.

We use the same technique as we did earlier, and that's to declare an
object that releases the guard automatically during its finalization.
What we do here is a little different, though, because the type being
controlled is the result of an instantiation of a generic.

We import the guard type as a generic formal type, and import the Seize
and Release operations as generic formal parameters:

  generic

     type Guarded_Type (<>) is limited private;

     with procedure Seize (Guarded : in out Guarded_Type) is <>;

     with procedure Release (Guarded : in out Guarded_Type) is <>;

  package Guarded_Controls is

     type Guarded_Control (Guarded : access Guarded_Type) is
        limited private;

  private

     ...

  end Guarded_Controls;


This package will work for any type.  And if operations named Seize and
Release are directly visible at the point of instantiation, then you
don't even have to list them as generic actuals.

The type is implemented by deriving from Limited_Controlled and
overriding Initialize and Finalize:

  private

     use Ada.Finalization;

     type Guarded_Control (Guarded : access Guarded_Type) is
       new Limited_Controlled with null record;

     procedure Initialize (Control : in out Guarded_Control);

     procedure Finalize (Control : in out Guarded_Control);

  end Guarded_Controls;


The control type just calls the Seize and Release operations of the
object designated by its access discriminant:

  package body Guarded_Controls is

     procedure Initialize (Control : in out Guarded_Control) is
     begin
        Seize (Control.Guarded.all);   <--
     end;

     procedure Finalize (Control : in out Guarded_Control) is
     begin
        Release (Control.Guarded.all);  <--
     end;

  end Guarded_Controls;


The guarded control type for guarded integer stacks is provided by an
instantiation of the generic guarded control package, declared as a
child of Integer_Stacks:

  with Guarded_Controls;

  package Integer_Stacks.Controls is
    new Guarded_Controls (Integer_Stack);

Note how we don't have to explicitly supply Seize and Release as generic
actual subprograms, because they are directly visible at the point of
instantiation.

Now, finally, we can iterate over the stack, efficiently, with exclusive
access:


   Stack : aliased Integer_Stack;

   ...

   declare
      Control : Guarded_Control (Stack'Access);
   begin
      while not Is_Empty (Stack) loop
         Put (Integer'Image (Get_Top (Stack)));
         Pop (Stack);
      end loop;

      New_Line;
   end;


Matt
<mailto:matthew_heaney@acm.org>



--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;

end Binary_Semaphores;
package Binary_Semaphores is

   pragma Pure;


   protected type Semaphore_Type is

      procedure Release;

      entry Seize;

   private

      In_Use : Boolean := False;

   end Semaphore_Type;

end Binary_Semaphores;
package body Guard_Mixin is

   procedure Seize (Resource : in out Guarded_Resource) is
   begin
      Resource.Semaphore.Seize;
   end;

   procedure Release (Resource : in out Guarded_Resource) is
   begin
      Resource.Semaphore.Release;
   end;

end Guard_Mixin;

with Binary_Semaphores;  use Binary_Semaphores;

generic

   type Resource_Type (<>) is abstract tagged limited private;

package Guard_Mixin is

   type Guarded_Resource is
     new Resource_Type with record
        Semaphore : Semaphore_Type;
     end record;

   procedure Seize (Resource : in out Guarded_Resource);

   procedure Release (Resource : in out Guarded_Resource);

end Guard_Mixin;

package body Guarded_Controls is

   procedure Initialize (Control : in out Guarded_Control) is
   begin
      Seize (Control.Guarded.all);
   end;

   procedure Finalize (Control : in out Guarded_Control) is
   begin
      Release (Control.Guarded.all);
   end;

end Guarded_Controls;
with Ada.Finalization;

generic

   type Guarded_Type (<>) is limited private;

   with procedure Seize (Guarded : in out Guarded_Type) is <>;

   with procedure Release (Guarded : in out Guarded_Type) is <>;

package Guarded_Controls is

   type Guarded_Control (Guarded : access Guarded_Type) is
      limited private;

private

   use Ada.Finalization;

   type Guarded_Control (Guarded : access Guarded_Type) is
     new Limited_Controlled with null record;

   procedure Initialize (Control : in out Guarded_Control);

   procedure Finalize (Control : in out Guarded_Control);

end Guarded_Controls;



with Guarded_Controls;

package Integer_Stacks.Controls is
  new Guarded_Controls (Integer_Stack);




with Stacks;
with Guard_Mixin;

pragma Elaborate (Stacks);
pragma Elaborate (Guard_Mixin);

package Integer_Stacks is

   pragma Pure;


   package Stack_Types is
     new Stacks (Integer, Max_Depth => 10);

   package Guarded_Stacks is
     new Guard_Mixin (Stack_Types.Stack_Type);

   type Integer_Stack is
     new Guarded_Stacks.Guarded_Resource with null record;

   generic procedure For_Every_Item renames
     Stack_Types.For_Every_Item;

end Integer_Stacks;


with Integer_Stacks; use Integer_Stacks;

package P is

   Stack : aliased Integer_Stack;

end;

package body Stacks is


   procedure Push
     (Item : in     Item_Type;
      On   : in out Stack_Type) is
   begin
      On.Top := On.Top + 1;
      On.Items (On.Top) := Item;
   end;


   procedure Pop
     (Stack : in out Stack_Type) is
   begin
      Stack.Top := Stack.Top - 1;
   end;


   function Get_Top
     (Stack : Stack_Type) return Item_Type is
   begin
      return Stack.Items (Stack.Top);
   end;


   procedure Set_Top
     (Stack : in out Stack_Type;
      Item  : in     Item_Type) is
   begin
      Stack.Items (Stack.Top) := Item;
   end;


   function Is_Empty (Stack : Stack_Type) return Boolean is
   begin
      return Stack.Top = 0;
   end;


   procedure For_Every_Item (Stack : in out Stack_Type'Class) is

      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;





generic

   type Item_Type is private;

   Max_Depth : in Positive;

package Stacks is

   pragma Preelaborate;

   type Stack_Type is tagged limited private;


   procedure Push
     (Item : in     Item_Type;
      On   : in out Stack_Type);

   procedure Pop
     (Stack : in out Stack_Type);

   function Get_Top
     (Stack : Stack_Type) return Item_Type;

   procedure Set_Top
     (Stack : in out Stack_Type;
      Item  : in     Item_Type);

   function Is_Empty (Stack : Stack_Type) return Boolean;


   generic

      with procedure Process
        (Item : in out Item_Type;
         Done : in out Boolean);

   procedure For_Every_Item (Stack : in out Stack_Type'Class);

private

   subtype Item_Array_Range is Positive range 1 .. Max_Depth;

   type Item_Array is array (Item_Array_Range) of Item_Type;

   type Stack_Type is
      tagged limited record
         Items : Item_Array;
         Top   : Natural := 0;
      end record;

end Stacks;
with Integer_Stacks.Controls;
use Integer_Stacks, Integer_Stacks.Controls;

with P; use P;

with Ada.Text_IO; use Ada.Text_IO;

procedure Test_Stacks is
begin

   declare
      Control : Guarded_Control (Stack'Access);
   begin
      Push (10, On => Stack);
      Push (9, On => Stack);
      Push (8, On => Stack);
   end;

   declare
      procedure Put_Item
        (Item : in out Integer;
         Done : in out Boolean) is
      begin
         Put (Integer'Image (Item));
      end;

      procedure Put_Items is
        new For_Every_Item (Put_Item);

      Control : Guarded_Control (Stack'Access);
   begin
      Put_Items (Stack);
      New_Line;
   end;


   declare
      Control : Guarded_Control (Stack'Access);
   begin
      while not Is_Empty (Stack) loop
         Put (Integer'Image (Get_Top (Stack)));
         Pop (Stack);
      end loop;

      New_Line;
   end;

end Test_Stacks;