home *** CD-ROM | disk | FTP | other *** search
/ Geek Gadgets 1 / ADE-1.bin / ade-dist / gnat-2.06-src.tgz / tar.out / fsf / gnat / ada / s-tasren.adb < prev    next >
Text File  |  1996-09-28  |  35KB  |  1,059 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                GNU ADA RUNTIME LIBRARY (GNARL) COMPONENTS                --
  4. --                                                                          --
  5. --            S Y S T E M . T A S K I N G . R E N D E Z V O U S             --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.34 $                             --
  10. --                                                                          --
  11. --     Copyright (c) 1991,1992,1993,1994,1995 FSU, All Rights Reserved      --
  12. --                                                                          --
  13. -- GNARL is free software; you can redistribute it  and/or modify it  under --
  14. -- terms  of  the  GNU  Library General Public License  as published by the --
  15. -- Free Software  Foundation;  either version 2, or (at  your  option)  any --
  16. -- later  version.  GNARL is distributed  in the hope that  it will be use- --
  17. -- ful, but but WITHOUT ANY WARRANTY;  without even the implied warranty of --
  18. -- MERCHANTABILITY  or  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Gen- --
  19. -- eral Library Public License  for more details.  You should have received --
  20. -- a  copy of the GNU Library General Public License along with GNARL;  see --
  21. -- file COPYING.LIB.  If not,  write to the  Free Software Foundation,  675 --
  22. -- Mass Ave, Cambridge, MA 02139, USA.                                      --
  23. --                                                                          --
  24. ------------------------------------------------------------------------------
  25.  
  26. with System.Task_Primitives; use System.Task_Primitives;
  27.  
  28. with System.Tasking.Abortion;
  29. --  Used for, Abortion.Defer_Abortion,
  30. --            Abortion.Undefer_Abortion,
  31. --            Abortion.Change_Base_Priority
  32.  
  33. with System.Tasking.Queuing; use System.Tasking.Queuing;
  34. --  Used for, Queuing.Enqueue,
  35. --            Queuing.Dequeue,
  36. --            Queuing.Dequeue_Head,
  37. --            Queuing.Count_Waiting,
  38. --            Queuing.Select_Task_Entry_Call
  39.  
  40. with System.Tasking.Utilities;
  41. --  Used for, Utilities.Abort_To_Level
  42. --            Utilities.Reset_Priority
  43. --            Utilities.Terminate_Alternative
  44. --            Utilities.Runtime_Assert_Shutdown
  45. --            Utilities.Wait_For_Completion;
  46.  
  47. with System.Tasking.Entry_Calls;
  48. --  Used for, Wait_For_Completion
  49. --            Wait_Until_Abortable
  50.  
  51. with System.Compiler_Exceptions;
  52. --  Used for, Compiler_Exceptions."="
  53. --            Exception_ID
  54. --            Null_Exception
  55.  
  56. package body System.Tasking.Rendezvous is
  57.  
  58.    procedure Defer_Abortion
  59.      renames Abortion.Defer_Abortion;
  60.  
  61.    procedure Undefer_Abortion renames
  62.      Abortion.Undefer_Abortion;
  63.  
  64.    type Select_Treatment is (
  65.      Accept_Alternative_Selected,
  66.      Accept_Alternative_Completed,
  67.      Else_Selected,
  68.      Terminate_Selected,
  69.      Accept_Alternative_Open,
  70.      No_Alternative_Open);
  71.  
  72.    Default_Treatment : constant array (Select_Modes) of Select_Treatment :=
  73.      (Simple_Mode         => No_Alternative_Open,
  74.       Else_Mode           => Else_Selected,
  75.       Terminate_Mode      => Terminate_Selected);
  76.  
  77.    -----------------------
  78.    -- Local Subprograms --
  79.    -----------------------
  80.  
  81.    procedure Boost_Priority
  82.      (Call     : Entry_Call_Link;
  83.       Acceptor : Task_ID);
  84.    pragma Inline (Boost_Priority);
  85.  
  86.    procedure Call_Synchronous
  87.      (Acceptor              : Task_ID;
  88.       E                     : Task_Entry_Index;
  89.       Uninterpreted_Data    : System.Address;
  90.       Mode                  : Call_Modes;
  91.       Rendezvous_Successful : out Boolean);
  92.    pragma Inline (Call_Synchronous);
  93.    --  This call is used to make a simple or conditional entry call.
  94.  
  95.    procedure Do_Or_Queue
  96.      (Entry_Call : in out Entry_Call_Link);
  97.    --  Either initiate the entry call, such that the accepting task is
  98.    --  free to execute the rendezvous, queue the call on the acceptor's
  99.    --  queue, or cancel the call.  Conditional calls that cannot be
  100.    --  accepted immediately are cancelled.
  101.  
  102.    procedure Adjust_For_Terminate_Alternative_Call (Acceptor : Task_ID);
  103.    --  Called by caller to wake up the acceptor if it is waiting on
  104.    --  terminate_alternative.
  105.  
  106.    --------------------
  107.    -- Boost_Priority --
  108.    --------------------
  109.  
  110.    procedure Boost_Priority
  111.      (Call     : Entry_Call_Link;
  112.       Acceptor : Task_ID)
  113.    is
  114.       Caller : Task_ID := Call.Self;
  115.  
  116.    begin
  117.       if Get_Priority (Caller.LL_TCB'Access) >
  118.          Get_Priority (Acceptor.LL_TCB'Access)
  119.       then
  120.          Call.Acceptor_Prev_Priority := Acceptor.Current_Priority;
  121.          Acceptor.Current_Priority := Caller.Current_Priority;
  122.          Set_Priority (Acceptor.LL_TCB'Access, Acceptor.Current_Priority);
  123.       else
  124.          Call.Acceptor_Prev_Priority := Priority_Not_Boosted;
  125.       end if;
  126.    end Boost_Priority;
  127.  
  128.    -----------------
  129.    -- Do_Or_Queue --
  130.    -----------------
  131.  
  132.    procedure Do_Or_Queue
  133.      (Entry_Call : in out Entry_Call_Link)
  134.    is
  135.       E          : Task_Entry_Index := Task_Entry_Index (Entry_Call.E);
  136.       Acceptor   : Task_ID          := Entry_Call.Called_Task;
  137.    begin
  138.  
  139.       if Acceptor.Accepting = Not_Accepting then
  140.          if Callable (Acceptor) then
  141.             if Entry_Call.Mode /= Conditional_Call
  142.               or else not Entry_Call.Abortable
  143.             then
  144.                Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
  145.             end if;
  146.          else
  147.  
  148.             --  If the acceptor is not callable, cancel the call
  149.             --  and raise Tasking_Error.  The call is not cancelled
  150.             --  for an asynchronous call, since Cancel_Task_Entry_Call
  151.             --  will do the decrement in that case.
  152.  
  153.             --  ??? It would be better if all entry call cancellation
  154.             --      and the raising of Tasking_Error could be isolated
  155.             --      to Wait_For_Completion.
  156.  
  157.             if Entry_Call.Mode /= Asynchronous_Call then
  158.                Entry_Call.Self.ATC_Nesting_Level :=
  159.                  Entry_Call.Self.ATC_Nesting_Level - 1;
  160.             end if;
  161.  
  162.             Unlock (Acceptor.L);
  163.             Undefer_Abortion;
  164.             raise Tasking_Error;
  165.  
  166.          end if;
  167.  
  168.       else
  169.  
  170.          --  ??? This should have a special case for Trivial_Accept, so that
  171.          --      we don't have the loop setup overhead.
  172.  
  173.          for J in Acceptor.Open_Accepts'Range loop
  174.             if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then
  175.             --  do rendezvous
  176.                Acceptor.Accepting := Not_Accepting;
  177.  
  178.                Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
  179.                Acceptor.Call := Entry_Call;
  180.                Acceptor.Chosen_Index := J;
  181.  
  182.                Entry_Call.Abortable := False;
  183.                --  Not abortable while in progress.
  184.  
  185.                if Acceptor.Open_Accepts (J).Null_Body then
  186.  
  187.                   Entry_Call.Done := True;
  188.                   --  Normally, this would have to be protected by
  189.                   --  the caller's mutex.  However, in this case we
  190.                   --  know that the acceptor is accepting, which means
  191.                   --  that it has yet to remove a call from its queue,
  192.                   --  and it will need to lock its own mutex to do that,
  193.                   --  which we hold.  It won't look at Entry_Call.Done
  194.                   --  until it has the call, so it should be safe to
  195.                   --  set it here.
  196.  
  197.                   Cond_Signal (Acceptor.Cond);
  198.                else
  199.                   Boost_Priority (Entry_Call, Acceptor);
  200.                   Cond_Signal (Acceptor.Cond);
  201.                end if;
  202.                exit;
  203.             end if;
  204.  
  205.          end loop;
  206.  
  207.          --  If the acceptor was ready to accept this call,
  208.          --  Acceptor.Accepting will have been set to Not_Accepting
  209.          --  in the above loop.  Otherwise, the acceptor is accepting,
  210.          --  but not this entry.  Try to queue the call.
  211.  
  212.          if Acceptor.Accepting /= Not_Accepting
  213.            and then (Entry_Call.Mode /= Conditional_Call
  214.              or else not Entry_Call.Abortable)
  215.          then
  216.             Enqueue (Acceptor.Entry_Queues (E), Entry_Call);
  217.          end if;
  218.  
  219.       end if;
  220.    end Do_Or_Queue;
  221.  
  222.    -------------------------------------------
  223.    -- Adjust_For_Terminate_Alternative_Call --
  224.    -------------------------------------------
  225.  
  226.    procedure Adjust_For_Terminate_Alternative_Call (Acceptor : Task_ID) is
  227.       P             : Task_ID;
  228.       Error         : boolean;
  229.    begin
  230.       Write_Lock (Acceptor.L, Error);
  231.  
  232.       if Acceptor.Terminate_Alternative then
  233.          Acceptor.Stage := Active;
  234.          Acceptor.Awake_Count := Acceptor.Awake_Count + 1;
  235.  
  236.          --  At this point, T.Awake_Count and P.Awaited_Dependent_Count could
  237.          --  be out of synchronization. However, we know that
  238.          --  P.Awaited_Dependent_Count cannot be zero, and cannot go to zero,
  239.          --  since some other dependent must have just called us. There should
  240.          --  therefore be no danger of the parent terminating before we
  241.          --  increment P.Awaited_Dependent_Count below.
  242.  
  243.          if Acceptor.Awake_Count = 1 then
  244.             Unlock (Acceptor.L);
  245.  
  246.             if Acceptor.Pending_ATC_Level <
  247.               Acceptor.ATC_Nesting_Level then
  248.                Abortion.Undefer_Abortion;
  249.                pragma Assert (
  250.                  Utilities.Runtime_Assert_Shutdown (
  251.                    "Continuing after being aborted!"));
  252.             end if;
  253.  
  254.             P := Acceptor.Parent;
  255.             Write_Lock (P.L, Error);
  256.  
  257.             if P.Awake_Count /= 0 then
  258.                P.Awake_Count := P.Awake_Count + 1;
  259.  
  260.             else
  261.                Unlock (P.L);
  262.                Utilities.Abort_To_Level (Acceptor, 0);
  263.                Abortion.Undefer_Abortion;
  264.                pragma Assert (
  265.                  Utilities.Runtime_Assert_Shutdown (
  266.                    "Continuing after being aborted!"));
  267.             end if;
  268.  
  269.             --  Conservative checks which should only matter when an interrupt
  270.             --  entry was chosen. In this case, the current task completes if
  271.             --  the parent has already been signaled that all children have
  272.             --  terminated.
  273.  
  274.             if Acceptor.Master_of_Task = P.Master_Within then
  275.                if P.Awaited_Dependent_Count /= 0 then
  276.                   P.Awaited_Dependent_Count := P.Awaited_Dependent_Count + 1;
  277.  
  278.                elsif P.Stage = Await_Dependents then
  279.                   Unlock (P.L);
  280.                   Utilities.Abort_To_Level (Acceptor, 0);
  281.                   Abortion.Undefer_Abortion;
  282.                   pragma Assert (
  283.                     Utilities.Runtime_Assert_Shutdown (
  284.                       "Continuing after being aborted!"));
  285.                end if;
  286.             end if;
  287.  
  288.             Unlock (P.L);
  289.  
  290.          else
  291.             Unlock (Acceptor.L);
  292.  
  293.             if Acceptor.Pending_ATC_Level <
  294.               Acceptor.ATC_Nesting_Level then
  295.                Abortion.Undefer_Abortion;
  296.                pragma Assert (
  297.                  Utilities.Runtime_Assert_Shutdown (
  298.                    "Continuing after being aborted!"));
  299.             end if;
  300.          end if;
  301.  
  302.          Write_Lock (Acceptor.L, Error);
  303.  
  304.          Acceptor.Terminate_Alternative := false;
  305.          --  Need to set this flag off in order not to make subsequent calls
  306.          --  to be treated to calls to Select With Terminate Alternative.
  307.  
  308.       end if;
  309.       Unlock (Acceptor.L);
  310.  
  311.    end Adjust_For_Terminate_Alternative_Call;
  312.  
  313.    ----------------------
  314.    -- Call_Synchronous --
  315.    ----------------------
  316.  
  317.    procedure Call_Synchronous
  318.      (Acceptor              : Task_ID;
  319.       E                     : Task_Entry_Index;
  320.       Uninterpreted_Data    : System.Address;
  321.       Mode                  : Call_Modes;
  322.       Rendezvous_Successful : out Boolean)
  323.    is
  324.       Caller : constant Task_ID := Self;
  325.       Level                 : ATC_Level;
  326.       Entry_Call            : Entry_Call_Link;
  327.       Error                 : Boolean;
  328.  
  329.    begin
  330.  
  331.       pragma Assert (Mode /= Asynchronous_Call
  332.         or else Utilities.Runtime_Assert_Shutdown (
  333.           "Asynchronous call being treated synchronously."));
  334.  
  335.       Defer_Abortion;
  336.       Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;
  337.       Level := Caller.ATC_Nesting_Level;
  338.  
  339.       Entry_Call := Caller.Entry_Calls (Level)'Access;
  340.  
  341.       Entry_Call.Next := null;
  342.       Entry_Call.Mode := Mode;
  343.       Entry_Call.Abortable := True;
  344.       Entry_Call.Done := False;
  345.       Entry_Call.E := Entry_Index (E);
  346.       Entry_Call.Prio := Caller.Current_Priority;
  347.       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
  348.       Entry_Call.Called_Task := Acceptor;
  349.       Entry_Call.Exception_To_Raise := Compiler_Exceptions.Null_Exception;
  350.  
  351.       --  Note: the caller will undefer abortion on return (see WARNING above)
  352.  
  353.       Adjust_For_Terminate_Alternative_Call (Acceptor);
  354.  
  355.       Write_Lock (Acceptor.L, Error);
  356.       Do_Or_Queue (Entry_Call);
  357.       Unlock (Acceptor.L);
  358.       System.Tasking.Entry_Calls.Wait_For_Completion (Entry_Call);
  359.       Rendezvous_Successful := Entry_Call.Done;
  360.       Undefer_Abortion;
  361.  
  362.       pragma Assert (
  363.         Caller.Pending_ATC_Level >= Caller.ATC_Nesting_Level or else
  364.           Utilities.Runtime_Assert_Shutdown (
  365.             "Continuing after aborting self!"));
  366.  
  367.       Utilities.Check_Exception;
  368.    end Call_Synchronous;
  369.  
  370.    -----------------
  371.    -- Call_Simple --
  372.    -----------------
  373.  
  374.    procedure Call_Simple
  375.      (Acceptor  : Task_ID;
  376.       E         : Task_Entry_Index;
  377.       Uninterpreted_Data : System.Address)
  378.    is
  379.       Rendezvous_Successful : Boolean;
  380.  
  381.    begin
  382.       Call_Synchronous
  383.         (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful);
  384.    end Call_Simple;
  385.  
  386.    ----------------------------
  387.    -- Cancel_Task_Entry_Call --
  388.    ----------------------------
  389.  
  390.    procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is
  391.       Caller   : Task_ID := Self;
  392.       Call     : Entry_Call_Link;
  393.  
  394.    begin
  395.       pragma Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First or else
  396.         Utilities.Runtime_Assert_Shutdown (
  397.           "Attempt to cancel nonexistent task entry call."));
  398.  
  399.       Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;
  400.  
  401.       pragma Assert (Call.Mode = Asynchronous_Call or else
  402.         Utilities.Runtime_Assert_Shutdown (
  403.           "Attempt to perform ATC on non-asynchronous task entry call"));
  404.  
  405.       pragma Assert (Call.Called_PO = Null_PO or else
  406.         Utilities.Runtime_Assert_Shutdown (
  407.           "Attempt to use Cancel_Task_Entry_Call on protected entry call."));
  408.  
  409.       Defer_Abortion;
  410.  
  411.       Utilities.Abort_To_Level (Caller, Call.Level - 1);
  412.       System.Tasking.Entry_Calls.Wait_For_Completion (Call);
  413.  
  414.       Cancelled := not Call.Done;
  415.       --  This allows the triggered statements to be skipped.
  416.  
  417.       Undefer_Abortion;
  418.       Utilities.Check_Exception;
  419.    end Cancel_Task_Entry_Call;
  420.  
  421.    ------------------------
  422.    -- Requeue_Task_Entry --
  423.    ------------------------
  424.  
  425.    procedure Requeue_Task_Entry
  426.      (Acceptor   : Task_ID;
  427.       E          : Task_Entry_Index;
  428.       With_Abort : Boolean)
  429.    is
  430.       Old_Acceptor  : Task_ID := Self;
  431.       Caller        : Task_ID;
  432.       Entry_Call    : Entry_Call_Link;
  433.       Error         : Boolean;
  434.  
  435.    begin
  436.       Defer_Abortion;
  437.       Write_Lock (Old_Acceptor.L, Error);
  438.       Entry_Call := Old_Acceptor.Call;
  439.       Caller := Entry_Call.Self;
  440.       Old_Acceptor.Call := null;
  441.  
  442.       Entry_Call.Abortable := False;
  443.       --  Don't permit this call to be aborted until we have switched to
  444.       --  the new acceptor.  Otherwise, we may queue a cancelled call below.
  445.  
  446.       Unlock (Old_Acceptor.L);
  447.  
  448.       Entry_Call.E := Entry_Index (E);
  449.  
  450.       Write_Lock (Acceptor.L, Error);
  451.       Entry_Call.Called_Task := Acceptor;
  452.       Entry_Call.Abortable := With_Abort;
  453.       Entry_Call.Has_Been_Abortable :=
  454.         With_Abort or Entry_Call.Has_Been_Abortable;
  455.       Do_Or_Queue (Entry_Call);
  456.       Unlock (Acceptor.L);
  457.  
  458.       Write_Lock (Caller.L, Error);
  459.       Caller.Pending_Action := True;
  460.  
  461.       Cond_Signal (Caller.Cond);
  462.       --  If this is a conditional entry call, and has just become
  463.       --  abortable, the caller should be awakened to cancel the call.
  464.  
  465.       Unlock (Caller.L);
  466.       Undefer_Abortion;
  467.    end Requeue_Task_Entry;
  468.  
  469.    -------------------------------------
  470.    -- Requeue_Protected_To_Task_Entry --
  471.    -------------------------------------
  472.  
  473.    procedure Requeue_Protected_To_Task_Entry
  474.      (Object     : Protection_Access;
  475.       Acceptor   : Task_ID;
  476.       E          : Task_Entry_Index;
  477.       With_Abort : Boolean)
  478.    is
  479.       Entry_Call    : Entry_Call_Link := Object.Call_In_Progress;
  480.       Caller        : Task_ID         := Entry_Call.Self;
  481.       Error         : Boolean;
  482.       Abortable     : Boolean;
  483.    begin
  484.       Defer_Abortion;
  485.       Entry_Call.E := Entry_Index (E);
  486.       Object.Call_In_Progress := null;
  487.  
  488.       Write_Lock (Acceptor.L, Error);
  489.       Entry_Call.Called_Task := Acceptor;
  490.       Entry_Call.Called_PO := Null_PO;
  491.       Entry_Call.Abortable := With_Abort;
  492.       Entry_Call.Has_Been_Abortable :=
  493.         With_Abort or Entry_Call.Has_Been_Abortable;
  494.       Do_Or_Queue (Entry_Call);
  495.       Unlock (Acceptor.L);
  496.  
  497.       Write_Lock (Caller.L, Error);
  498.       Entry_Call.E := Entry_Index (E);
  499.  
  500.       Caller.Pending_Action := True;
  501.       Cond_Signal (Caller.Cond);
  502.       --  If this is a conditional entry call, and has just become
  503.       --  abortable, the caller should be awakened to cancel the call.
  504.  
  505.       Unlock (Caller.L);
  506.       Undefer_Abortion;
  507.    end Requeue_Protected_To_Task_Entry;
  508.  
  509.    ---------------------
  510.    -- Task_Entry_Call --
  511.    ---------------------
  512.  
  513.    procedure Task_Entry_Call
  514.      (Acceptor              : Task_ID;
  515.       E                     : Task_Entry_Index;
  516.       Uninterpreted_Data    : System.Address;
  517.       Mode                  : Call_Modes;
  518.       Rendezvous_Successful : out Boolean)
  519.    is
  520.       Caller                : constant Task_ID := Self;
  521.       Rendezvous_Completed  : Boolean;
  522.       Entry_Call            : Entry_Call_Link;
  523.       Cancel_Was_Successful : Boolean;
  524.       Error                 : Boolean;
  525.       Initially_Abortable    : Boolean;
  526.  
  527.    begin
  528.       --  Simple or conditional call
  529.  
  530.       if Mode = Simple_Call or else Mode = Conditional_Call then
  531.          Call_Synchronous
  532.            (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful);
  533.  
  534.       --  Asynchronous call
  535.  
  536.       else
  537.  
  538.          --  Abortion must already be deferred by the compiler-generated
  539.          --  code.  Without this, an abortion that occurs between the time
  540.          --  that this call is made and the time that the abortable part's
  541.          --  cleanup handler is set up might miss the cleanup handler and
  542.          --  leave the call pending.
  543.  
  544.          Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;
  545.  
  546.          Entry_Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;
  547.  
  548.          Entry_Call.Next := null;
  549.          Entry_Call.Mode := Mode;
  550.          Entry_Call.Abortable := True;
  551.          Entry_Call.Done := False;
  552.          Entry_Call.E := Entry_Index (E);
  553.          Entry_Call.Prio := Caller.Current_Priority;
  554.          Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
  555.          Entry_Call.Called_Task := Acceptor;
  556.          Entry_Call.Called_PO := Null_PO;
  557.          Entry_Call.Exception_To_Raise := Compiler_Exceptions.Null_Exception;
  558.  
  559.          Adjust_For_Terminate_Alternative_Call (Acceptor);
  560.  
  561.          Write_Lock (Acceptor.L, Error);
  562.          Do_Or_Queue (Entry_Call);
  563.  
  564.          Initially_Abortable := Entry_Call.Abortable;
  565.  
  566.          Unlock (Acceptor.L);
  567.  
  568.          --  If the call was not queued abortably, we need to wait until
  569.          --  it is before proceeding with the abortable part.
  570.          --  Wait_Until_Abortable can be called unconditionally here,
  571.          --  but it is expensive.
  572.  
  573.          if not Initially_Abortable then
  574.             System.Tasking.Entry_Calls.Wait_Until_Abortable
  575.               (Caller, Entry_Call);
  576.          end if;
  577.  
  578.          Rendezvous_Successful := Entry_Call.Done;
  579.          --  This needs to be atomic.
  580.  
  581.       end if;
  582.    end Task_Entry_Call;
  583.  
  584.    -----------------
  585.    -- Accept_Call --
  586.    -----------------
  587.  
  588.    procedure Accept_Call
  589.      (E                  : Task_Entry_Index;
  590.       Uninterpreted_Data : out System.Address)
  591.    is
  592.       Acceptor     : constant Task_ID := Self;
  593.       Caller       : Task_ID := null;
  594.       Open_Accepts : aliased Accept_List (1 .. 1);
  595.       Entry_Call   : Entry_Call_Link;
  596.       Error        : Boolean;
  597.  
  598.    begin
  599.       Defer_Abortion;
  600.       Write_Lock (Acceptor.L, Error);
  601.  
  602.       --  If someone is completing this task, it must be because they plan
  603.       --  to abort it. This task should not try to access its pending entry
  604.       --  calls or queues in this case, as they are being emptied. Wait for
  605.       --  abortion to kill us.
  606.  
  607.       if Acceptor.Stage >= Completing then
  608.  
  609.          loop
  610.             if Acceptor.Pending_Action then
  611.                if Acceptor.Pending_Priority_Change then
  612.                   Abortion.Change_Base_Priority (Acceptor);
  613.                end if;
  614.  
  615.                exit when
  616.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  617.                Acceptor.Pending_Action := False;
  618.             end if;
  619.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  620.          end loop;
  621.  
  622.          Unlock (Acceptor.L);
  623.          Undefer_Abortion;
  624.          pragma Assert (
  625.            Utilities.Runtime_Assert_Shutdown (
  626.              "Continuing execution after being aborted."));
  627.       end if;
  628.  
  629.       Dequeue_Head (Acceptor.Entry_Queues (E), Entry_Call);
  630.  
  631.       if Entry_Call /= null then
  632.          Caller := Entry_Call.Self;
  633.          Boost_Priority (Entry_Call, Acceptor);
  634.          Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
  635.  
  636.          Entry_Call.Abortable := False;
  637.          --  Not abortable while in progress.
  638.  
  639.          Acceptor.Call := Entry_Call;
  640.          Uninterpreted_Data := Entry_Call.Uninterpreted_Data;
  641.  
  642.       else
  643.          --  Wait for a caller
  644.  
  645.          Open_Accepts (1).Null_Body := false;
  646.          Open_Accepts (1).S := E;
  647.          Acceptor.Open_Accepts := Open_Accepts'Unchecked_Access;
  648.  
  649.          Acceptor.Accepting := Simple_Accept;
  650.  
  651.          --  Wait for normal call
  652.  
  653.          while Acceptor.Accepting /= Not_Accepting loop
  654.             if Acceptor.Pending_Action then
  655.                if Acceptor.Pending_Priority_Change then
  656.                   Abortion.Change_Base_Priority (Acceptor);
  657.                end if;
  658.  
  659.                exit when
  660.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  661.                Acceptor.Pending_Action := False;
  662.             end if;
  663.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  664.          end loop;
  665.  
  666.          if Acceptor.Pending_ATC_Level >= Acceptor.ATC_Nesting_Level then
  667.             Caller := Acceptor.Call.Self;
  668.             Uninterpreted_Data :=
  669.               Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data;
  670.          end if;
  671.  
  672.          --  If this task has been aborted, skip the Uninterpreted_Data load
  673.          --  (Caller will not be reliable) and fall through to
  674.          --  Undefer_Abortion which will allow the task to be killed.
  675.       end if;
  676.  
  677.       --  Acceptor.Call should already be updated by the Caller
  678.  
  679.       Unlock (Acceptor.L);
  680.       Undefer_Abortion;
  681.  
  682.       --  Start rendezvous
  683.    end Accept_Call;
  684.  
  685.    --------------------
  686.    -- Accept_Trivial --
  687.    --------------------
  688.  
  689.    procedure Accept_Trivial (E : Task_Entry_Index) is
  690.       Acceptor     : constant Task_ID := Self;
  691.       Caller       : Task_ID := null;
  692.       Open_Accepts : aliased Accept_List (1 .. 1);
  693.       Entry_Call   : Entry_Call_Link;
  694.       Error        : Boolean;
  695.  
  696.    begin
  697.       Defer_Abortion;
  698.       Write_Lock (Acceptor.L, Error);
  699.  
  700.       --  If someone is completing this task, it must be because they plan
  701.       --  to abort it. This task should not try to access its pending entry
  702.       --  calls or queues in this case, as they are being emptied. Wait for
  703.       --  abortion to kill us.
  704.  
  705.       if Acceptor.Stage >= Completing then
  706.  
  707.          loop
  708.             if Acceptor.Pending_Action then
  709.                if Acceptor.Pending_Priority_Change then
  710.                   Abortion.Change_Base_Priority (Acceptor);
  711.                end if;
  712.  
  713.                exit when
  714.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  715.                Acceptor.Pending_Action := False;
  716.             end if;
  717.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  718.          end loop;
  719.  
  720.          Unlock (Acceptor.L);
  721.          Undefer_Abortion;
  722.          pragma Assert (
  723.            Utilities.Runtime_Assert_Shutdown (
  724.              "Continuing execution after being aborted."));
  725.       end if;
  726.  
  727.       Dequeue_Head (Acceptor.Entry_Queues (E), Entry_Call);
  728.  
  729.       if Entry_Call = null then
  730.  
  731.          --  Need to wait for call
  732.  
  733.          Open_Accepts (1).Null_Body := False;
  734.          Open_Accepts (1).S := E;
  735.          Acceptor.Open_Accepts := Open_Accepts'Unchecked_Access;
  736.  
  737.          Acceptor.Accepting := Trivial_Accept;
  738.  
  739.          --  Wait for normal entry call
  740.  
  741.          while Acceptor.Accepting /= Not_Accepting loop
  742.             if Acceptor.Pending_Action then
  743.                if Acceptor.Pending_Priority_Change then
  744.                   Abortion.Change_Base_Priority (Acceptor);
  745.                end if;
  746.  
  747.                exit when
  748.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  749.                Acceptor.Pending_Action := False;
  750.             end if;
  751.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  752.          end loop;
  753.  
  754.  
  755.          if Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level then
  756.             Unlock (Acceptor.L);
  757.             Undefer_Abortion;
  758.             pragma Assert (
  759.               Utilities.Runtime_Assert_Shutdown (
  760.                 "Continuing after being aborted!"));
  761.          else
  762.             Entry_Call := Acceptor.Call;
  763.             Acceptor.Call := Entry_Call.Acceptor_Prev_Call;
  764.          end if;
  765.  
  766.       else
  767.          Entry_Call.Abortable := False;
  768.          --  No longer abortable.
  769.       end if;
  770.  
  771.       Unlock (Acceptor.L);
  772.       Caller := Entry_Call.Self;
  773.       Write_Lock (Caller.L, Error);
  774.  
  775.       Entry_Call.Done := True;
  776.       --  Done with mutex locked to make sure that signal is not lost.
  777.  
  778.       Unlock (Caller.L);
  779.  
  780.       if Entry_Call.Mode = Asynchronous_Call then
  781.          Utilities.Abort_To_Level (Caller, Entry_Call.Level - 1);
  782.       else
  783.          Cond_Signal (Caller.Cond);
  784.       end if;
  785.  
  786.       Undefer_Abortion;
  787.    end Accept_Trivial;
  788.  
  789.    -------------------------------------
  790.    -- Exceptional_Complete_Rendezvous --
  791.    -------------------------------------
  792.  
  793.    procedure Exceptional_Complete_Rendezvous
  794.      (Ex : Compiler_Exceptions.Exception_ID)
  795.    is
  796.       Acceptor      : constant Task_ID := Self;
  797.       Caller        : Task_ID;
  798.       Call          : Entry_Call_Link;
  799.       Prev_Priority : Rendezvous_Priority;
  800.       Error         : Boolean;
  801.  
  802.    begin
  803.       Defer_Abortion;
  804.       Call := Acceptor.Call;
  805.       Acceptor.Call := Call.Acceptor_Prev_Call;
  806.       Prev_Priority := Call.Acceptor_Prev_Priority;
  807.       Call.Exception_To_Raise := Ex;
  808.       Caller := Call.Self;
  809.       Write_Lock (Caller.L, Error);
  810.  
  811.       Call.Done := True;
  812.       --  Done with mutex locked to make sure that signal is not lost.
  813.  
  814.       Unlock (Caller.L);
  815.  
  816.       if Call.Mode = Asynchronous_Call then
  817.          Utilities.Abort_To_Level (Caller, Call.Level - 1);
  818.       else
  819.          Cond_Signal (Caller.Cond);
  820.       end if;
  821.  
  822.       Utilities.Reset_Priority (Prev_Priority, Acceptor);
  823.  
  824.       Acceptor.Exception_To_Raise := Ex;
  825.  
  826.       Undefer_Abortion;
  827.       Utilities.Check_Exception;
  828.    end Exceptional_Complete_Rendezvous;
  829.  
  830.    -------------------------
  831.    -- Complete_Rendezvous --
  832.    -------------------------
  833.  
  834.    procedure Complete_Rendezvous is
  835.    begin
  836.       Exceptional_Complete_Rendezvous (Compiler_Exceptions.Null_Exception);
  837.    end Complete_Rendezvous;
  838.  
  839.    --------------------
  840.    -- Selective_Wait --
  841.    --------------------
  842.  
  843.    procedure Selective_Wait
  844.      (Open_Accepts       : Accept_List_Access;
  845.       Select_Mode        : Select_Modes;
  846.       Uninterpreted_Data : out System.Address;
  847.       Index              : out Select_Index)
  848.    is
  849.       Acceptor   : constant Task_ID := Self;
  850.       Treatment  : Select_Treatment;
  851.       I_Result   : Integer;
  852.       Error      : Boolean;
  853.       Entry_Call : Entry_Call_Link;
  854.       Caller     : Task_ID;
  855.       Selection  : Select_Index;
  856.       Open_Alternative : Boolean;
  857.  
  858.    begin
  859.       Defer_Abortion;
  860.       Write_Lock (Acceptor.L, Error);
  861.  
  862.       --  If someone is completing this task, it must be because they plan
  863.       --  to abort it. This task should not try to access its pending entry
  864.       --  calls or queues in this case, as they are being emptied. Wait for
  865.       --  abortion to kill us.
  866.  
  867.       if Acceptor.Stage >= Completing then
  868.  
  869.          loop
  870.             if Acceptor.Pending_Action then
  871.                if Acceptor.Pending_Priority_Change then
  872.                   Abortion.Change_Base_Priority (Acceptor);
  873.                end if;
  874.  
  875.                exit when
  876.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  877.                Acceptor.Pending_Action := False;
  878.             end if;
  879.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  880.          end loop;
  881.  
  882.          Unlock (Acceptor.L);
  883.          Undefer_Abortion;
  884.          pragma Assert (
  885.            Utilities.Runtime_Assert_Shutdown (
  886.              "Continuing execution after being aborted."));
  887.       end if;
  888.  
  889.       Select_Task_Entry_Call
  890.         (Acceptor, Open_Accepts, Entry_Call, Selection, Open_Alternative);
  891.  
  892.       --  Determine the kind and disposition of the select.
  893.  
  894.       Treatment := Default_Treatment (Select_Mode);
  895.       Acceptor.Chosen_Index := No_Rendezvous;
  896.  
  897.       if Open_Alternative then
  898.          if Entry_Call /= null then
  899.             if Open_Accepts (Selection).Null_Body then
  900.                Treatment := Accept_Alternative_Completed;
  901.             else
  902.                Boost_Priority (Entry_Call, Acceptor);
  903.                Entry_Call.Acceptor_Prev_Call := Acceptor.Call;
  904.                Acceptor.Call := Entry_Call;
  905.                Treatment := Accept_Alternative_Selected;
  906.             end if;
  907.             Acceptor.Chosen_Index := Selection;
  908.          elsif Treatment = No_Alternative_Open then
  909.             Treatment := Accept_Alternative_Open;
  910.          end if;
  911.       end if;
  912.  
  913.       --  Handle the select according to the disposition selected above.
  914.  
  915.       case Treatment is
  916.  
  917.       when Accept_Alternative_Selected =>
  918.  
  919.          --  Ready to rendezvous already
  920.  
  921.          Unlock (Acceptor.L);
  922.          Uninterpreted_Data := Acceptor.Call.Uninterpreted_Data;
  923.  
  924.       when Accept_Alternative_Completed =>
  925.  
  926.          --  Rendezvous is over
  927.  
  928.          Unlock (Acceptor.L);
  929.          Caller := Entry_Call.Self;
  930.          Write_Lock (Caller.L, Error);
  931.          Entry_Call.Done := True;
  932.          Unlock (Caller.L);
  933.          if Entry_Call.Mode = Asynchronous_Call then
  934.             Utilities.Abort_To_Level (Caller, Entry_Call.Level - 1);
  935.          else
  936.             Cond_Signal (Caller.Cond);
  937.          end if;
  938.  
  939.       when Accept_Alternative_Open =>
  940.  
  941.          --  Wait for caller.
  942.  
  943.          Acceptor.Open_Accepts := Open_Accepts;
  944.  
  945.          Acceptor.Accepting := Select_Wait;
  946.  
  947.          while Acceptor.Accepting /= Not_Accepting
  948.          loop
  949.             if Acceptor.Pending_Action then
  950.                if Acceptor.Pending_Priority_Change then
  951.                   Abortion.Change_Base_Priority (Acceptor);
  952.                end if;
  953.  
  954.                exit when
  955.                   Acceptor.Pending_ATC_Level < Acceptor.ATC_Nesting_Level;
  956.                Acceptor.Pending_Action := False;
  957.             end if;
  958.             Cond_Wait (Acceptor.Cond, Acceptor.L);
  959.          end loop;
  960.  
  961.          --  Acceptor.Call should already be updated by the Caller if
  962.          --  not aborted.
  963.  
  964.          if Acceptor.Pending_ATC_Level >= Acceptor.ATC_Nesting_Level and then
  965.           not Open_Accepts (Acceptor.Chosen_Index).Null_Body then
  966.             Uninterpreted_Data := Acceptor.Call.Uninterpreted_Data;
  967.          end if;
  968.  
  969.          Unlock (Acceptor.L);
  970.  
  971.       when Else_Selected =>
  972.          Acceptor.Accepting := Not_Accepting;
  973.          Unlock (Acceptor.L);
  974.  
  975.       when Terminate_Selected =>
  976.  
  977.          --  Terminate alternative is open
  978.  
  979.          Acceptor.Open_Accepts := Open_Accepts;
  980.  
  981.          Acceptor.Accepting := Select_Wait;
  982.  
  983.          --  We need to check if a signal is pending on an open interrupt
  984.          --  entry. Otherwise this task would become passive (since terminate
  985.          --  alternative is open) and, if none of the siblings are active
  986.          --  any more, the task could not wake up any more, even though a
  987.          --  signal might be pending on an open interrupt entry.
  988.  
  989.          Unlock (Acceptor.L);
  990.          Utilities.Terminate_Alternative;
  991.  
  992.          --  Wait for normal entry call or termination
  993.  
  994.          --  consider letting Terminate_Alternative assume mutex L
  995.          --  is already locked, and return with it locked, so
  996.          --  this code could be simplified???
  997.  
  998.          --  No return here if Acceptor completes, otherwise
  999.          --  Acceptor.Call should already be updated by the Caller
  1000.  
  1001.          Index := Acceptor.Chosen_Index;
  1002.          if not Open_Accepts (Acceptor.Chosen_Index).Null_Body then
  1003.             Uninterpreted_Data := Acceptor.Call.Uninterpreted_Data;
  1004.          end if;
  1005.          Undefer_Abortion;
  1006.          return;
  1007.  
  1008.       when No_Alternative_Open =>
  1009.  
  1010.          --  In this case, Index will be No_Rendezvous on return, which
  1011.          --  should cause the compiler-generated code to raise
  1012.          --  Program_Error.
  1013.  
  1014.          Unlock (Acceptor.L);
  1015.  
  1016.       end case;
  1017.  
  1018.       --  Caller has been chosen
  1019.  
  1020.       --  Acceptor.Call should already be updated by the Caller
  1021.  
  1022.       --  Acceptor.Chosen_Index should either be updated by the Caller
  1023.       --  or by Test_Selective_Wait
  1024.  
  1025.       Index := Acceptor.Chosen_Index;
  1026.       Undefer_Abortion;
  1027.  
  1028.       --  Start rendezvous, if not already completed.
  1029.  
  1030.    end Selective_Wait;
  1031.  
  1032.    ----------------
  1033.    -- Task_Count --
  1034.    ----------------
  1035.  
  1036.    function Task_Count (E : Task_Entry_Index) return Natural is
  1037.       T            : constant Task_ID := Self;
  1038.       Return_Count : Natural;
  1039.       Error        : Boolean;
  1040.  
  1041.    begin
  1042.       Write_Lock (T.L, Error);
  1043.       Return_Count := Count_Waiting (T.Entry_Queues (E));
  1044.       Unlock (T.L);
  1045.       return Return_Count;
  1046.    end Task_Count;
  1047.  
  1048.    --------------
  1049.    -- Callable --
  1050.    --------------
  1051.  
  1052.    function Callable (T : Task_ID) return Boolean is
  1053.    begin
  1054.       return     T.Stage < Complete
  1055.         and then T.Pending_ATC_Level > ATC_Level_Base'First;
  1056.    end Callable;
  1057.  
  1058. end System.Tasking.Rendezvous;
  1059.