LANGUAGE STUDY NOTE

			       LSN-035-DR

		   Doing Without the Multi-Way Select


!topic LSN-035-DR -- doing without the multi-way select
!from Ted Baker and Offer Pazy
!discussion

This note is intended to partially address the question of whether
there is a reasonable user work-around for the lack of a multiway
entry call (MWC).

This is not a proposal for any new annex features.  It is just a
demonstration of how an ORDINARY USER might program a solution to
the kind of requirement that might otherwise have been programmed
using a multi-way entry call.

If one thinks it is reasonable for a user to write this kind of
code to solve this kind of problem, then this example can be
viewed as evidence that MWC does not need to be provided by the
language, so long as the other features used in the example are
provided.  

If one thinks it is unreasonable for a user to have to resort to
this level of programming, one may conclude that the MWC is needed
in the language.

Please note that this example is NOT intended to be a completely
generic solution.  In order to keep the code simple, only a very
basic form of the multi-way call is treated.  To handle
requirements that might require more general forms of the
multi-way call (e.g.  with guards and time-outs, and for entries
with barriers) a user would have to do more work.

Also note that the example does NOT address the issue of
asynchronous transfer of control (ATC).  In fact, it assumes that
there is no ATC.  Incorporation of ATC may be considered in a
subsequent note.

The following relies on (at least) the following 9X features:
 (1) finalization
 (2) 'access
 (3) 'unchecked_access
 (4) access ALL
 (5) access T'CLASS
 (6) Dynamic_Priority_Support.Get_Priority
 (7) Task_Identification.Current_Task

Protected records are also used, but only in some very restricted
ways, where they could be replaced by simpler primitives.  These
primitive effects are:
 (a) mutual exclusion;
 (b) two-stage suspend, of a very degenerate form;
 (c) test-and-set.

These are the kind of low-level primitives that might be used
internally by an Ada RTS, to implement tasking and protected
records.  Thus, the example may also give some idea of what is
involved in implementing the MS4.0 multi-way call --- though the
general MWC would be more complicated.

The objective in this example is just to give a user-programmable
replacement for the following structure:

  select 
     Event_1.Await; S_1;
  or Event_2.Await; S_2;
  ...
  or Event_n.Await; S_n;
  end select;

Above, the protected records "Event_i" are assumed to be of the
form shown below:

  protected type Event_i is
    procedure Signal;
    entry Await;
  private record
    Is_Open: Boolean:= false;
  end Event_i;

  protected body Event_i is
    procedure Signal is
    begin 
      Is_Open:= true;
    end Signal;
    entry Await when Is_Open is
    begin Is_Open:= false;
    end Await;
  end Event_i;

Note that if this PR type were different, the solution below would
need to be coded differently as well.

The replacement for the multi-way entry call will be:

  Event_1, Event_n: aliased Events.Event;
  -- Note: implicit aliasing of Event only applies in body
   ...
  Selector: Natural;
   ...
  Events.Await(Selector,
   (Event_1'access,...,Event_n'access));
  case Selector is
    when 1=> S_1;
     ...
    when n=> S_n;
    when others=> raise Program_Error;
  end case;

The Events package would be implemented by the following user code:

with Priority_Queues; -- spec. and body given further below
package Events is
  type Event is limited private;
  type Event_Access is access all Event;
  type Select_Size is range 1..user_config_limit;
  type Event_list is array (Select_Size <>) of Event_Access;
  procedure Await
    (Choice: out Natural; 
     List:   in  Event_List);
    -- waits for one of the events in List to be signaled, and
    -- sets Choice to the alternative-index of that event
  procedure Signal(E: in out Event);
    -- wakes one task that is waiting for E, if any is waiting
private
  type Select_Descriptor(Size: Select_Size:= 1);
    -- will contain an array of Select_Q_Nodes, one for each awaited event;
    -- Size is the size of this array

  type Select_Descriptor_Access is access all Select_Descriptor;

  type Select_Q_Node  is new Priority_Queues.Q_Node with record
    -- can be enqueued on an event
    Select_Descriptor: Select_Descriptor_Access;
      -- points to the Select_Descriptor that contains this node
    Alternative_Index: Select_Size;
      -- position of this node in array of Q_nodes in Select_Descriptor
    end record;
  type Select_Q_Node_Access is access all Select_Q_Node;
  function "<"(L,R: Select_Q_Node) return Boolean;
    -- Used for queue ordering

  protected type Event is
    procedure Signal;
    procedure Insert(N: in out Select_Q_Node);
    procedure Remove(N: in out Select_Q_Node);
  private record
    Head: Priority_Queues.Q_Head;
    Pending: Boolean:= false;
  end Event;

end Events;


with System;
with Finalization_Support;
with Task_Identification;
with Dynamic_Priority_Support;
package body Events is

  type Event_List_Access is access constant Event_List;

  protected type Gate_PR is
    -- Abstraction of a single-use of a two-stage suspend.
    -- (The elaboration of the Gate_PR object is the
    -- implicit "prepare-to-wait")
    procedure Release;
    entry Wait;
  private record
    Is_Open: Boolean:= false;
  end Gate_PR;

  protected type Right_PR is
    -- abstraction of a test-and-set
    procedure Claim(Failed: out Boolean);
  private record
    Is_Available: Boolean:= true;
  end Right_PR;    

  type Q_Vector is array (Select_Size) of Select_Q_Node;
  type Select_Descriptor(Size: Select_Size:= 1) is
    new Finalization_Support.Controlled with
    record
      Q:                Q_Vector(1..Size);
      List:             Event_List_Access;
      Choice:           Select_Size;
      Right_To_Release: Right_PR;
      Prio:             System.Any_priority;
      Gate:             Gate_PR;
    end record;

  -- Select_Descriptor describes a task waiting for one of several events.
  -- Q(I) gets enqueued on List.all(I).
  -- Choice is set to the alternative index of the selected event.
  -- Right_To_Release ensures only one event is selected.
  -- Prio is the priority that governs position on event queues.
  -- Gate is used to wake up the waiting task.

  -- Finalization is to remove dangling references from event queues
  -- if the waiting task is aborted while still waiting.
  
  -- Note that finalization of Select_Q_Node is inherited from
  -- Priority_Queues.Q_Node, but that this is not safe, since it
  -- is not protected from concurrent operations on the same queue.
  -- The procedure below solves this, by removing Select_Q_Nodes
  -- from the event queues before the per-node finalization is done.
  -- By the time the per-node finalization is done, the node is
  -- no longer on any queue, so the Priority_Queues.Q_Node
  -- finalization operation has no effect.

  procedure Finalize(Obj: in out Select_Descriptor) is
    Failed: Boolean;
  begin 
    Obj.Right_To_Release.Claim(Failed);
    if Obj.List/=null then
      for I in Obj.Q'range loop
        Obj.List(I).Remove(Obj.Q(I));
      end loop;
    end if;
  end Finalize;

  -- Finalize relies on the Remove operation to be
  -- safe when the object is not on any queue.

  protected body Gate_PR is
    procedure Release is
    begin Is_Open:= true; end Release;
    entry Wait when Is_Open;
  end Gate_PR;

  protected body Right_PR is
    procedure Claim(Failed: out Boolean) is
    begin 
      if Is_Available then
         Is_Available:= false; Failed:= false; 
      else Failed:= true;
      end if;
    end Claim;
  end Right_PR;    

  function "<"(L,R: Select_Q_Node) return Boolean is
  begin
    return L.Select_Descriptor.Prio > R.Select_Descriptor.Prio;
  end "<";

  -- The reason the ordering relations are apparently reversed
  -- is that the priority queue package puts smaller priorities
  -- in front, but Ada tasking puts smaller priorities in back.

  protected body Event is

    procedure Signal is
      T: Priority_Queues.Q_link;
      Failed: Boolean;
    begin
      loop Priority_Queues.Dequeue_First(Head,T);
        exit when T=null; -- i.e. when queue is empty
        declare
          D: Select_Descriptor renames
             Select_Q_Node_Access(T).Select_Descriptor.all;
        begin
          D.Right_To_Release.Claim(Failed);
          if not Failed then -- record which event is selected
             D.Choice:= Select_Q_Node_Access(T).Alternative_Index;
             D.Gate.Release;
             return;
          end if;
        end;
      end loop;
      Pending:= true;
    end signal;

    procedure Insert(N: in out Select_Q_Node) is
    begin 
      if Pending then 
        declare
          D: Select_Descriptor renames N.Select_Descriptor.all;
          Failed: Boolean;
        begin
          D.Right_To_Release.Claim(Failed);
          if not Failed then -- record which event is selected
            D.Choice:= Select_Q_Node_Access(T).Alternative_Index;
            D.Gate.Release;
            Pending:= false;
            return;
          end if;
        end;
      else
        Enqueue(Head,N);
      end if;
    end Insert;

    procedure Remove(N: in out Select_Q_Node) is
    begin Dequeue(N); end Remove;
  end Event;

  procedure Await
    (Choice: out Natural; 
     List:   in  Event_List) is
     D: Select_Descriptor(List'range);
  begin
    D.Prio:= Dynamic_Priority_Support.Get_Priority
              (Task_Identification.Current_Task);
    D.List:= List'access;
    for I in List'range loop 
      declare
        Q: Select_Q_Node renames D.Q(I);
      begin
        Q.Select_Descriptor:= D'access;
        Q.Alternative_Index:= I;
        List(I).Insert(Q);
      end;
    end loop;
    D.Gate.Wait;
    Choice:= D.Choice;
    for I in List'range loop 
      List(I).Remove(D.Q(I));
    end loop;
  end Await;

  procedure Signal(E: in out Event) is
  begin E.Signal;
  end Signal;

end Events;


with Finalization_Support;
package Priority_Queues is
  type Q_Head is limited private;
  type Q_Node is tagged limited private;
    -- is implicitly initialized to empty
  type Q_Link is access all Q_Node'CLASS;
  function "<"(L,R: Q_Node) return Boolean is <>;
    -- return True iff L should be inserted before R
  procedure Dequeue(N: in out Q_Node);
    -- remove N from whatever queue it is on, if any
  procedure Dequeue_First(Q: in out Q_Head; L: out Q_Link);
    -- remove front node of queue with header Q, if any;
    -- return pointer to this node in L; return null if Q is empty
  procedure Enqueue(Q: in out Q_Head; N: in out Q_Node);
    -- insert node N into queue Q
  Usage_Error: exception;
    -- raised by Enqueue if N is already in a queue
private
  type Q_Head is new Finalization_Support.Controlled with record
       Nxt, Prv: Q_Link;
    end record;
  type Q_Node is new Q_Head;
end Priority_Queues;

package body Priority_Queues is

  procedure Dequeue(N: in out Q_Node) is
    Nxt: constant Q_Link:= N.Nxt;
    Prv: constant Q_Link:= N.Prv;
  begin Nxt.Prv:= Prv; Prv.Nxt:= Nxt;
    N.Nxt:= N'unchecked_access; N.Prv:= N'unchecked_access;
  end Dequeue;

  procedure Dequeue_First(Q: in out Q_Head; L: out Q_Link) is
    Nxt: constant Q_Link:= Q.Nxt;
    Prv: constant Q_Link:= Q.Prv;
  begin
    if Nxt=Prv then L:= null;
    else -- delete Nxt from queue
      Nxt.Nxt.Prv:= Nxt.Prv; Q.Nxt:= Nxt.Nxt;
      Nxt.Prv:= Nxt; Nxt.Nxt:= Nxt;
      L:= Nxt;
    end if;
  end Dequeue_First; 

  procedure Enqueue(Q: in out Q_Head; N: in out Q_Node) is
    X: Q_Link:= Q.Nxt;
  begin
    if N.Nxt/=N'unchecked_access then raise Usage_Error; end if;
      -- It is an error for N to already be in a queue.
    while X/=Q'unchecked_access loop
      exit when N < X; X:= X.Nxt;
    end loop;
    N.Prv:=X.Prv; N.Nxt:=X;
    X.Prv.Nxt:=N'unchecked_access; X.Prv:=N'unchecked_access; 
  end Enqueue;

  procedure Initialize(Obj: in out Q_Head) is
  begin Obj.Nxt:= Obj'unchecked_access; Obj.Prv:= Obj'unchecked_access;
  end Initialize;

  procedure Finalize(Obj: in out Q_Head) is
    L: Q_Link;
  begin 
    loop Dequeue_First(Obj,L); exit when L=null; end loop;
  end Finalize;

  procedure Initialize(Obj: in out Q_Node) is
  begin Initialize(Q_Head(Q_Node)); 
  end Initialize;

  procedure Finalize(Obj: in out Q_Node) is
  begin Dequeue(Obj);
  end Finalize;

end Priority_Queues;

Acknowledgement:

Mike Kamrad should be given credit for helping find and correct
errors in earlier drafts and simplifying the presentation, but not
blamed for any residual errors.