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-taenca.adb < prev    next >
Text File  |  1996-09-28  |  12KB  |  353 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 . E N T R Y _ C A L L S          --
  6. --                                                                          --
  7. --                                  B o d y                                 --
  8. --                                                                          --
  9. --                             $Revision: 1.1 $                             --
  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. --  This package provides internal RTS calls implementing operations
  27. --  that apply to general entry calls, that is, calls to either
  28. --  protected or task entries.
  29. --  These declarations are not part of the GNARLI
  30.  
  31. with System.Task_Primitives;  use System.Task_Primitives;
  32.  
  33. with System.Tasking.Queuing; use System.Tasking.Queuing;
  34. --  Used for, Queuing.Dequeue,
  35. --            Queuing.Enqueue
  36.  
  37. with System.Tasking.Protected_Objects;
  38. --  Used for, Unlock,
  39. --            Service_Entries
  40.  
  41. with System.Tasking.Utilities;
  42. --  Used for, Runtime_Assert_Shutdown
  43.  
  44. with System.Tasking.Abortion;
  45. --  Used for, Change_Base_Priority
  46.  
  47. package body System.Tasking.Entry_Calls is
  48.  
  49.    -------------------
  50.    -- Internal_Lock --
  51.    -------------------
  52.  
  53.    procedure Internal_Lock
  54.      (Object : access Protection;
  55.       Ceiling_Violation : out Boolean) is
  56.    begin
  57.       Write_Lock (Object.L, Ceiling_Violation);
  58.    end Internal_Lock;
  59.  
  60.    -----------------------------
  61.    -- Internal_Lock_Read_Only --
  62.    -----------------------------
  63.  
  64.    procedure Internal_Lock_Read_Only
  65.      (Object : access Protection;
  66.       Ceiling_Violation : out Boolean) is
  67.    begin
  68.       Read_Lock (Object.L, Ceiling_Violation);
  69.    end Internal_Lock_Read_Only;
  70.  
  71.    -----------------
  72.    -- Lock_Server --
  73.    -----------------
  74.  
  75.    procedure Lock_Server
  76.      (Entry_Call : Entry_Call_Link;
  77.       No_Server  : out Boolean)
  78.    is
  79.       Test_Task         : Task_ID;
  80.       Test_PO           : Protection_Access;
  81.       Ceiling_Violation : Boolean;
  82.  
  83.    begin
  84.       Test_Task := Entry_Call.Called_Task;
  85.       --  This must be atomic.
  86.  
  87.       loop
  88.          if Test_Task = Null_Task then
  89.  
  90.             Test_PO := Entry_Call.Called_PO;
  91.             --  This must be atomic.
  92.  
  93.             Test_Task := Entry_Call.Called_Task;
  94.             --  Check the task again, just in case a transition between
  95.             --  task and protected entry calls is taking place.
  96.  
  97.             if Test_PO = Null_PO and then Test_Task = Null_Task then
  98.                No_Server := True;
  99.                return;
  100.             end if;
  101.  
  102.             Internal_Lock (Test_PO, Ceiling_Violation);
  103.  
  104.             --  ??? The following code allows Lock_Server to be called
  105.             --      when cancelling a call, to allow for the possibility
  106.             --      that the priority of the caller has been raised
  107.             --      beyond that of the protected entry call by
  108.             --      Ada.Dynamic_Priorities.Set_Priority.  This test
  109.             --      for other cases, resulting in slightly improved
  110.             --      performance.
  111.  
  112.             --  If the current task has a higher priority than the ceiling
  113.             --  of the protected object, temporarily lower it.  It will
  114.             --  be reset in Unlock.
  115.  
  116.             if Ceiling_Violation then
  117.                declare
  118.                   Current_Task : Task_ID := Self;
  119.                   Old_Base_Priority : System.Priority;
  120.                begin
  121.                   Write_Lock (Current_Task.L, Ceiling_Violation);
  122.                   Old_Base_Priority := Current_Task.Base_Priority;
  123.                   Current_Task.New_Base_Priority := Test_PO.Ceiling;
  124.                   System.Tasking.Abortion.Change_Base_Priority (Current_Task);
  125.                   Unlock (Current_Task.L);
  126.                   Internal_Lock (Test_PO, Ceiling_Violation);
  127.                   Test_PO.Old_Base_Priority := Old_Base_Priority;
  128.                   Test_PO.Pending_Action := True;
  129.                end;
  130.             end if;
  131.  
  132.             exit when Test_PO = Entry_Call.Called_PO;
  133.             System.Tasking.Protected_Objects.Unlock (Test_PO);
  134.          else
  135.             Write_Lock (Test_Task.L, Ceiling_Violation);
  136.             exit when Test_Task = Entry_Call.Called_Task;
  137.             Unlock (Test_Task.L);
  138.          end if;
  139.  
  140.          Test_Task := Entry_Call.Called_Task;
  141.          --  This must be atomic.
  142.  
  143.       end loop;
  144.  
  145.       No_Server := False;
  146.  
  147.    end Lock_Server;
  148.  
  149.    -------------------
  150.    -- Unlock_Server --
  151.    -------------------
  152.  
  153.    procedure Unlock_Server (Entry_Call : Entry_Call_Link) is
  154.    begin
  155.       if Entry_Call.Called_Task /= Null_Task then
  156.          Unlock (Entry_Call.Called_Task.L);
  157.       else
  158.          System.Tasking.Protected_Objects.Unlock (Entry_Call.Called_PO);
  159.       end if;
  160.    end Unlock_Server;
  161.  
  162.    ------------------------------
  163.    -- Unlock_And_Update_Server --
  164.    ------------------------------
  165.  
  166.    procedure Unlock_And_Update_Server (Entry_Call : Entry_Call_Link) is
  167.    begin
  168.       if Entry_Call.Called_Task /= Null_Task then
  169.          Unlock (Entry_Call.Called_Task.L);
  170.       else
  171.          System.Tasking.Protected_Objects.Service_Entries
  172.            (Entry_Call.Called_PO);
  173.          System.Tasking.Protected_Objects.Unlock (Entry_Call.Called_PO);
  174.       end if;
  175.    end Unlock_And_Update_Server;
  176.  
  177.    ------------------
  178.    -- Enqueue_Call --
  179.    ------------------
  180.  
  181.    procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is
  182.    begin
  183.       if Entry_Call.Called_Task /= Null_Task then
  184.          Enqueue
  185.            (Entry_Call.Called_Task.Entry_Queues
  186.               (Task_Entry_Index (Entry_Call.E)),
  187.            Entry_Call);
  188.       else
  189.          Enqueue
  190.            (Entry_Call.Called_PO.Entry_Queues
  191.              (Protected_Entry_Index (Entry_Call.E)),
  192.            Entry_Call);
  193.       end if;
  194.    end Enqueue_Call;
  195.  
  196.    ------------------
  197.    -- Dequeue_Call --
  198.    ------------------
  199.  
  200.    procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is
  201.    begin
  202.       if Entry_Call.Called_Task /= Null_Task then
  203.          Dequeue
  204.            (Entry_Call.Called_Task.Entry_Queues
  205.              (Task_Entry_Index (Entry_Call.E)),
  206.            Entry_Call);
  207.       else
  208.          Dequeue
  209.            (Entry_Call.Called_PO.Entry_Queues
  210.              (Protected_Entry_Index (Entry_Call.E)),
  211.            Entry_Call);
  212.       end if;
  213.    end Dequeue_Call;
  214.  
  215.    -------------------------
  216.    -- Wait_For_Completion--
  217.    -------------------------
  218.  
  219.    procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is
  220.       Caller    : Task_ID := Entry_Call.Self;
  221.       Cancelled : Boolean := False;
  222.       Error     : Boolean;
  223.       No_Server : Boolean;
  224.    begin
  225.       Write_Lock (Caller.L, Error);
  226.  
  227.       --  If this is a conditional call, it should be cancelled when it
  228.       --  becomes abortable.  This is checked in the loop below, but
  229.       --  only when Caller.Pending_Action is True.  For conditional
  230.       --  calls, enable this check the first time through the loop.
  231.  
  232.       if Entry_Call.Mode = Conditional_Call then
  233.          Caller.Pending_Action := True;
  234.       end if;
  235.  
  236.       while not Entry_Call.Done and then not Cancelled loop
  237.          if Caller.Pending_Action then
  238.             Caller.Pending_Action := False;
  239.             if Caller.Pending_Priority_Change then
  240.                Abortion.Change_Base_Priority (Caller);
  241.  
  242.                --  Requeue the entry call at the new priority. This only
  243.                --  needs to be done if the caller is blocked waiting
  244.                --  for the call (D.5(16)).
  245.  
  246.                Unlock (Caller.L);
  247.                Lock_Server (Entry_Call, No_Server);
  248.                if Onqueue (Entry_Call) then
  249.                   Dequeue_Call (Entry_Call);
  250.                   Enqueue_Call (Entry_Call);
  251.                end if;
  252.                Unlock_Server (Entry_Call);
  253.                Write_Lock (Caller.L, Error);
  254.  
  255.             end if;
  256.  
  257.             if Entry_Call.Mode = Conditional_Call
  258.               or else Caller.Pending_ATC_Level < Caller.ATC_Nesting_Level
  259.             then
  260.                Unlock (Caller.L);
  261.                Lock_Server (Entry_Call, No_Server);
  262.                
  263.                if Entry_Call.Abortable then
  264.                   if Onqueue (Entry_Call) then
  265.                      Dequeue_Call (Entry_Call);
  266.                   end if;
  267.                   Cancelled := True;
  268.                   Unlock_And_Update_Server (Entry_Call);
  269.                else
  270.                   Unlock_Server (Entry_Call);
  271.                end if;
  272.  
  273.                Write_Lock (Caller.L, Error);
  274.             end if;
  275.  
  276.          else
  277.             Cond_Wait (Caller.Cond, Caller.L);
  278.          end if;
  279.       end loop;
  280.  
  281.       Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1;
  282.  
  283.       --  If we have reached the desired ATC nesting level, reset the
  284.       --  requested level to effective infinity, to allow further calls.
  285.  
  286.       if Caller.Pending_ATC_Level = Caller.ATC_Nesting_Level then
  287.          Caller.Pending_ATC_Level := ATC_Level_Infinity;
  288.          Caller.Aborting := False;
  289.       end if;
  290.  
  291.       --  If there is a pending abortion, the above loop may have
  292.       --  reset the Pending_Action flag.  This flag must be regenerated
  293.       --  here so that Undefer_Abortion will complete the abortion.
  294.  
  295.       if Caller.Pending_ATC_Level < Caller.ATC_Nesting_Level then
  296.          Caller.Pending_Action := True;
  297.       end if;
  298.  
  299.       Caller.Exception_To_Raise := Entry_Call.Exception_To_Raise;
  300.  
  301.       Unlock (Caller.L);
  302.    end Wait_For_Completion;
  303.  
  304.    --------------------------
  305.    -- Wait_Until_Abortable --
  306.    --------------------------
  307.  
  308.    procedure Wait_Until_Abortable
  309.      (Caller : Task_ID;
  310.       Call   : Entry_Call_Link)
  311.    is
  312.       Abortable : Boolean := False;
  313.       Error     : Boolean;
  314.       No_Server : Boolean;
  315.  
  316.    begin
  317.       pragma Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First
  318.         or else System.Tasking.Utilities.Runtime_Assert_Shutdown
  319.           ("Attempt to wait for a nonexistent call to be abortable."));
  320.       pragma Assert (Call.Mode = Asynchronous_Call
  321.         or else System.Tasking.Utilities.Runtime_Assert_Shutdown
  322.           ("Attempt to wait for a non-asynchronous call to be abortable"));
  323.  
  324.       Write_Lock (Caller.L, Error);
  325.  
  326.       if Call.Mode = Conditional_Call then
  327.          Caller.Pending_Action := True;
  328.       end if;
  329.  
  330.       while not Call.Done and then not Abortable loop
  331.          if Caller.Pending_Action then
  332.             Unlock (Caller.L);
  333.             Lock_Server (Call, No_Server);
  334.  
  335.             pragma Assert (not No_Server
  336.               or else System.Tasking.Utilities.Runtime_Assert_Shutdown (
  337.                 "Entry call has no target"));
  338.  
  339.             if Call.Abortable then
  340.                Abortable := True;
  341.             end if;
  342.             Unlock_Server (Call);
  343.             Write_Lock (Caller.L, Error);
  344.          else
  345.             Cond_Wait (Caller.Cond, Caller.L);
  346.          end if;
  347.       end loop;
  348.  
  349.       Unlock (Caller.L);
  350.    end Wait_Until_Abortable;
  351.  
  352. end System.Tasking.Entry_Calls;
  353.