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