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-taprob.adb < prev    next >
Text File  |  1996-09-28  |  18KB  |  538 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 . P R O T E C T E D _ O B J E C T 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.Compiler_Exceptions;
  27. --  Used for, "="
  28. --            Raise_Exceptions
  29. --            Exception_ID
  30. --            Compiler_Exceptions.Null_Exception
  31. --            Program_Error_ID
  32.  
  33. with System.Tasking.Abortion;
  34. --  Used for, Abortion.Defer_Abortion,
  35. --            Abortion.Undefer_Abortion,
  36. --            Abortion.Change_Base_Priority
  37.  
  38. with System.Task_Primitives; use System.Task_Primitives;
  39.  
  40. with System.Tasking.Queuing; use System.Tasking.Queuing;
  41. --  Used for, Queuing.Enqueue,
  42. --            Queuing.Dequeue,
  43. --            Queuing.Head,
  44. --            Queuing.Dequeue_Head,
  45. --            Queuing.Count_Waiting,
  46. --            Queuing.Select_Protected_Entry_Call
  47.  
  48. with System.Tasking.Utilities;
  49. --  Used for, Utilities.Abort_To_Level
  50.  
  51. with System.Tasking.Entry_Calls;
  52. --  Used for, Internal_Lock
  53. --            Internal_Lock_Read_Only
  54. --            Wait_For_Completion
  55. --            Wait_Until_Abortable
  56.  
  57. with System.Tasking.Initialization;
  58. pragma Elaborate_All (System.Tasking.Initialization);
  59. --  This insures that tasking is initialized if any protected objects are
  60. --  created.
  61.  
  62. with Unchecked_Conversion;
  63.  
  64. package body System.Tasking.Protected_Objects is
  65.  
  66.    procedure Defer_Abortion
  67.      renames Abortion.Defer_Abortion;
  68.  
  69.    procedure Undefer_Abortion
  70.      renames Abortion.Undefer_Abortion;
  71.  
  72.    function "=" (L, R : System.Compiler_Exceptions.Exception_ID) return Boolean
  73.      renames System.Compiler_Exceptions."=";
  74.  
  75.    procedure Do_Or_Queue
  76.      (Object : access Protection;
  77.       Entry_Call : Entry_Call_Link);
  78.    --  This procedure either executes or queues an entry call, depending
  79.    --  on the status of the corresponding barrier. It assumes that abortion
  80.    --  is deferred and that the specified object is locked.
  81.  
  82.    pragma Inline (Do_Or_Queue);
  83.  
  84.    --------------
  85.    -- Enqueued --
  86.    --------------
  87.  
  88.    function Enqueued (Block : Communication_Block) return Boolean is
  89.    begin
  90.       return Block.Enqueued;
  91.    end Enqueued;
  92.  
  93.    ---------------
  94.    -- Cancelled --
  95.    ---------------
  96.  
  97.    function Cancelled (Block : Communication_Block) return Boolean is
  98.    begin
  99.       return Block.Cancelled;
  100.    end Cancelled;
  101.  
  102.    ---------------------------
  103.    -- Initialize_Protection --
  104.    ---------------------------
  105.  
  106.    procedure Initialize_Protection
  107.      (Object            : access Protection;
  108.       Ceiling_Priority  : Integer;
  109.       Compiler_Info     : System.Address;
  110.       Entry_Bodies      : access Protected_Entry_Body_Array)
  111.    is
  112.       Init_Priority : Integer := Ceiling_Priority;
  113.  
  114.       First_Entry_Index : Protected_Entry_Index := 1;
  115.       Last_Entry_Index : Protected_Entry_Index := Object.Num_Entries;
  116.  
  117.    begin
  118.       if Init_Priority = Unspecified_Priority then
  119.          Init_Priority := System.Default_Priority;
  120.       end if;
  121.  
  122.       Initialize_Lock (Init_Priority, Object.L);
  123.       Object.Ceiling := System.Priority (Init_Priority);
  124.       Object.Compiler_Info := Compiler_Info;
  125.       Object.Pending_Action := False;
  126.       Object.Call_In_Progress := null;
  127.       Object.Entry_Bodies := Entry_Bodies;
  128.  
  129.       for E in Object.Entry_Queues'Range loop
  130.          Object.Entry_Queues (E).Head := null;
  131.          Object.Entry_Queues (E).Tail := null;
  132.       end loop;
  133.    end Initialize_Protection;
  134.  
  135.    ----------
  136.    -- Lock --
  137.    ----------
  138.  
  139.    procedure Lock (Object : access Protection) is
  140.       Ceiling_Violation : Boolean;
  141.    begin
  142.       System.Tasking.Entry_Calls.Internal_Lock (Object, Ceiling_Violation);
  143.       if Ceiling_Violation then
  144.          raise Program_Error;
  145.       end if;
  146.    end Lock;
  147.  
  148.    --------------------
  149.    -- Lock_Read_Only --
  150.    --------------------
  151.  
  152.    procedure Lock_Read_Only (Object : access Protection) is
  153.       Ceiling_Violation : Boolean;
  154.    begin
  155.       System.Tasking.Entry_Calls.Internal_Lock_Read_Only
  156.         (Object, Ceiling_Violation);
  157.       if Ceiling_Violation then
  158.          raise Program_Error;
  159.       end if;
  160.    end Lock_Read_Only;
  161.  
  162.    ------------
  163.    -- Unlock --
  164.    ------------
  165.  
  166.    procedure Unlock (Object : access Protection) is
  167.       Caller : Task_ID := Self;
  168.       Error  : Boolean;
  169.    begin
  170.       if Object.Pending_Action then
  171.          Object.Pending_Action := False;
  172.          Write_Lock (Caller.L, Error);
  173.          Caller.New_Base_Priority := Object.Old_Base_Priority;
  174.          Abortion.Change_Base_Priority (Caller);
  175.          Unlock (Caller.L);
  176.       end if;
  177.       Unlock (Object.L);
  178.    end Unlock;
  179.  
  180.    -----------------
  181.    -- Do_Or_Queue --
  182.    -----------------
  183.  
  184.    procedure Do_Or_Queue
  185.      (Object     : access Protection;
  186.       Entry_Call : Entry_Call_Link)
  187.    is
  188.       E                 : Protected_Entry_Index :=
  189.         Protected_Entry_Index (Entry_Call.E);
  190.       Caller            : Task_ID               := Entry_Call.Self;
  191.       TAS_Result        : Boolean;
  192.       Ceiling_Violation : Boolean;
  193.  
  194.    begin
  195.  
  196.       --  When the Action procedure for an entry body returns, it is either
  197.       --  completed (having called [Exceptional_]Complete_Entry_Body) or it
  198.       --  is queued, having executed a requeue statement.
  199.  
  200.       if Object.Entry_Bodies (E).Barrier (Object.Compiler_Info, E) then
  201.  
  202.          Entry_Call.Abortable := False;
  203.          --  Not abortable while in progress.
  204.  
  205.          Object.Call_In_Progress := Entry_Call;
  206.          Object.Entry_Bodies (E).Action (
  207.            Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
  208.       elsif Entry_Call.Mode /= Conditional_Call then
  209.          Entry_Call.Has_Been_Abortable := True;
  210.          Enqueue (Object.Entry_Queues (E), Entry_Call);
  211.       end if;
  212.  
  213.    exception
  214.    when others =>
  215.       Broadcast_Program_Error (Object, Entry_Call);
  216.    end Do_Or_Queue;
  217.  
  218.    ---------------------
  219.    -- Service_Entries --
  220.    ---------------------
  221.  
  222.    procedure Service_Entries (Object : access Protection) is
  223.       Entry_Call : Entry_Call_Link;
  224.       E          : Protected_Entry_Index;
  225.    begin
  226.       loop
  227.          Select_Protected_Entry_Call (Object, Entry_Call);
  228.          if Entry_Call /= null then
  229.             E := Protected_Entry_Index (Entry_Call.E);
  230.             Object.Call_In_Progress := Entry_Call;
  231.             Object.Entry_Bodies (E).Action (
  232.               Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);
  233.          else
  234.             exit;
  235.          end if;
  236.       end loop;
  237.    end Service_Entries;
  238.  
  239.  
  240.    --------------------------
  241.    -- Protected_Entry_Call --
  242.    --------------------------
  243.  
  244.    procedure Protected_Entry_Call
  245.      (Object             : access Protection;
  246.       E                  : Protected_Entry_Index;
  247.       Uninterpreted_Data : System.Address;
  248.       Mode               : Call_Modes;
  249.       Block              : out Communication_Block)
  250.    is
  251.       Caller             : Task_ID  := Self;
  252.       Level              : ATC_Level;
  253.       Entry_Call         : Entry_Call_Link;
  254.       TAS_Result         : Boolean;
  255.       Ceiling_Violation  : Boolean;
  256.       Initially_Abortable : Boolean;
  257.  
  258.    begin
  259.       Defer_Abortion;
  260.       Lock (Object);
  261.  
  262.       Block.Self := Caller;
  263.       Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1;
  264.  
  265.       Level := Caller.ATC_Nesting_Level;
  266.       Entry_Call := Caller.Entry_Calls (Level)'Access;
  267.  
  268.       --  The caller's lock is not needed here. The call record does not
  269.       --  need protection, since other tasks only access these records
  270.       --  when they are queued, which this one is not.
  271.  
  272.       Entry_Call.Next := null;
  273.       Entry_Call.Mode := Mode;
  274.       Entry_Call.Abortable := True;
  275.       Entry_Call.Done := False;
  276.       Entry_Call.Has_Been_Abortable := False;
  277.       Entry_Call.E := Entry_Index (E);
  278.       Entry_Call.Prio := Caller.Current_Priority;
  279.       Entry_Call.Uninterpreted_Data := Uninterpreted_Data;
  280.       Entry_Call.Called_PO := Object;
  281.       Entry_Call.Called_Task := Null_Task;
  282.       Entry_Call.Exception_To_Raise :=
  283.         System.Compiler_Exceptions.Null_Exception;
  284.  
  285.       Do_Or_Queue (Object, Entry_Call);
  286.       Initially_Abortable := Entry_Call.Abortable;
  287.       Service_Entries (Object);
  288.  
  289.       --  Indicate whether the call has been cancelled or not.
  290.       --  A call cannot be in progress at this point, since the caller
  291.       --  (this task) cannot be executing it, and we haven't given up
  292.       --  the object lock yet, so no other task can be executing it.
  293.       --  Therefore a call that is not on a queue but not complete must
  294.       --  have been cancelled.  Similarly, no other task can be looking
  295.       --  at the entry call record at this point, so we can check
  296.       --  Entry_Call.Done without locking the caller's mutex.
  297.  
  298.       Block.Cancelled := not Entry_Call.Done and then not Onqueue (Entry_Call);
  299.  
  300.       Block.Enqueued := Entry_Call.Has_Been_Abortable;
  301.       --  Set the Enqueued flag.
  302.  
  303.       --  Try to avoid waiting for completed or cancelled calls.
  304.  
  305.       if not (Entry_Call.Done or else Block.Cancelled) then
  306.  
  307.          Unlock (Object);
  308.  
  309.          case Mode is
  310.             when Simple_Call | Conditional_Call =>
  311.                System.Tasking.Entry_Calls.Wait_For_Completion (Entry_Call);
  312.             when Asynchronous_Call =>
  313.  
  314.                --  If the call was never enqueued, it is complete or
  315.                --  cancelled at this point.  The compiler-generated code
  316.                --  avoids calling Cancel_Protected_Entry_Call in this case,
  317.                --  so we need to pop the entry call from the call stack
  318.                --  at this point.
  319.  
  320.                --  ??? This complicates the interface, making it illegal
  321.                --      to call Cancel_Protected_Entry_Call in this case,
  322.                --      but mandatory to call it in other cases.  Consider
  323.                --      making it mandatory in all cases.
  324.  
  325.                if not Block.Enqueued then
  326.                   Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1;
  327.  
  328.                else
  329.  
  330.                   --  If the call was not queued abortably, we need to wait
  331.                   --  until it is before proceeding with the abortable part.
  332.                   --  Wait_Until_Abortable can be called unconditionally here,
  333.                   --  but it is expensive.
  334.  
  335.                   if not Initially_Abortable then
  336.                      System.Tasking.Entry_Calls.Wait_Until_Abortable
  337.                        (Caller, Entry_Call);
  338.                   end if;
  339.                end if;
  340.          end case;
  341.  
  342.       else
  343.          Unlock (Object);
  344.       end if;
  345.  
  346.       Undefer_Abortion;
  347.       System.Tasking.Utilities.Check_Exception;
  348.  
  349.    end Protected_Entry_Call;
  350.  
  351.    ---------------------------------
  352.    -- Cancel_Protected_Entry_Call --
  353.    ---------------------------------
  354.  
  355.    procedure Cancel_Protected_Entry_Call (Block : in out Communication_Block)
  356.    is
  357.       Caller : Task_ID := Block.Self;
  358.       Call   : Entry_Call_Link;
  359.  
  360.    begin
  361.       pragma Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First or else
  362.         Utilities.Runtime_Assert_Shutdown (
  363.           "Attempt to cancel nonexistent task entry call."));
  364.  
  365.       Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access;
  366.  
  367.       pragma Assert (Call.Mode = Asynchronous_Call or else
  368.         Utilities.Runtime_Assert_Shutdown (
  369.           "Attempt to perform ATC on non-asynchronous protected entry call"));
  370.  
  371.       pragma Assert (Call.Called_Task = Null_Task or else
  372.         Utilities.Runtime_Assert_Shutdown (
  373.           "Attempt to use Cancel_Protected_Entry_Call on task entry call."));
  374.  
  375.       Defer_Abortion;
  376.  
  377.       Utilities.Abort_To_Level (Caller, Call.Level - 1);
  378.       System.Tasking.Entry_Calls.Wait_For_Completion (Call);
  379.  
  380.       --  This allows the triggered statements to be skipped.
  381.       --  We can check Call.Done here without locking the caller's mutex,
  382.       --  since the call must be over after returning from Wait_For_Completion.
  383.       --  No other task can access the call record at this point.
  384.  
  385.       Block.Cancelled := not Call.Done;
  386.  
  387.       Undefer_Abortion;
  388.       System.Tasking.Utilities.Check_Exception;
  389.  
  390.    end Cancel_Protected_Entry_Call;
  391.  
  392.    -------------------------
  393.    -- Complete_Entry_Body --
  394.    -------------------------
  395.  
  396.    procedure Complete_Entry_Body (Object : access Protection) is
  397.  
  398.    begin
  399.       Exceptional_Complete_Entry_Body
  400.         (Object, System.Compiler_Exceptions.Null_Exception);
  401.    end Complete_Entry_Body;
  402.  
  403.    -------------------------------------
  404.    -- Exceptional_Complete_Entry_Body --
  405.    -------------------------------------
  406.  
  407.    procedure Exceptional_Complete_Entry_Body
  408.      (Object : access Protection;
  409.       Ex     : System.Compiler_Exceptions.Exception_ID)
  410.    is
  411.       Caller : Task_ID := Object.Call_In_Progress.Self;
  412.       Error  : Boolean;
  413.  
  414.    begin
  415.       Object.Call_In_Progress.Exception_To_Raise := Ex;
  416.  
  417.       Write_Lock (Caller.L, Error);
  418.       Object.Call_In_Progress.Done := True;
  419.       Unlock (Caller.L);
  420.  
  421.       if Object.Call_In_Progress.Mode = Asynchronous_Call then
  422.  
  423.          --  If the asynchronous call has never been queued abortably, the
  424.          --  abortable part will have been skipped; there is no need to abort
  425.          --  it.
  426.  
  427.          if Object.Call_In_Progress.Has_Been_Abortable then
  428.             Utilities.Abort_To_Level (
  429.               Caller, Object.Call_In_Progress.Level - 1);
  430.          end if;
  431.  
  432.       else
  433.          Cond_Signal (Caller.Cond);
  434.       end if;
  435.    end Exceptional_Complete_Entry_Body;
  436.  
  437.    -----------------------------
  438.    -- Requeue_Protected_Entry --
  439.    -----------------------------
  440.  
  441.    procedure Requeue_Protected_Entry
  442.      (Object     : access Protection;
  443.       New_Object : access Protection;
  444.       E          : Protected_Entry_Index;
  445.       With_Abort : Boolean)
  446.    is
  447.       Entry_Call        : Entry_Call_Link := Object.Call_In_Progress;
  448.       Caller            : Task_ID         := Entry_Call.Self;
  449.       Ceiling_Violation : Boolean;
  450.       Call_Cancelled    : Boolean := False;
  451.       Error             : Boolean;
  452.  
  453.    begin
  454.       --  We have to check if the requeue is internal one.
  455.       --  If it is an internal one, no need to lock.
  456.       if (Object /= New_Object) then
  457.          Lock (New_Object);
  458.       end if;
  459.  
  460.       Entry_Call.Abortable := With_Abort;
  461.       Entry_Call.Has_Been_Abortable :=
  462.         With_Abort or Entry_Call.Has_Been_Abortable;
  463.       Entry_Call.E := Entry_Index (E);
  464.       Entry_Call.Called_PO := New_Object;
  465.  
  466.       if Object = New_Object
  467.         and then (not With_Abort or else Entry_Call.Mode /= Conditional_Call)
  468.       then
  469.          Enqueue (New_Object.Entry_Queues (E), Entry_Call);
  470.       else
  471.          Do_Or_Queue (New_Object, Entry_Call);
  472.       end if;
  473.  
  474.       if (Object /= New_Object) then
  475.          Object.Call_In_Progress := null;
  476.          Service_Entries (New_Object);
  477.          Unlock (New_Object);
  478.       end if;
  479.  
  480.       Write_Lock (Caller.L, Error);
  481.       Caller.Pending_Action := True;
  482.  
  483.       Cond_Signal (Caller.Cond);
  484.       --  If this is a conditional entry call, and has just become
  485.       --  abortable, the caller should be awakened to cancel the call.
  486.  
  487.       Unlock (Caller.L);
  488.    end Requeue_Protected_Entry;
  489.  
  490.    -------------------------------------
  491.    -- Requeue_Task_To_Protected_Entry --
  492.    -------------------------------------
  493.  
  494.    procedure Requeue_Task_To_Protected_Entry
  495.      (New_Object : access Protection;
  496.       E          : Protected_Entry_Index;
  497.       With_Abort : Boolean)
  498.    is
  499.       Old_Acceptor : Task_ID := Self;
  500.       Entry_Call : Entry_Call_Link;
  501.       Error : Boolean;
  502.  
  503.    begin
  504.       Lock (New_Object);
  505.  
  506.       Write_Lock (Old_Acceptor.L, Error);
  507.       Entry_Call := Old_Acceptor.Call;
  508.       Old_Acceptor.Call := null;
  509.       Entry_Call.Called_PO := New_Object;
  510.       Entry_Call.Called_Task := Null_Task;
  511.       Unlock (Old_Acceptor.L);
  512.  
  513.       Entry_Call.Abortable := With_Abort;
  514.       Entry_Call.Has_Been_Abortable :=
  515.         With_Abort or Entry_Call.Has_Been_Abortable;
  516.       Entry_Call.E := Entry_Index (E);
  517.  
  518.       Do_Or_Queue (New_Object, Entry_Call);
  519.       Service_Entries (New_Object);
  520.  
  521.       Unlock (New_Object);
  522.    end Requeue_Task_To_Protected_Entry;
  523.  
  524.    ---------------------
  525.    -- Protected_Count --
  526.    ---------------------
  527.  
  528.    function Protected_Count
  529.      (Object : Protection;
  530.       E      : Protected_Entry_Index)
  531.       return   Natural
  532.    is
  533.    begin
  534.       return Count_Waiting (Object.Entry_Queues (E));
  535.    end Protected_Count;
  536.  
  537. end System.Tasking.Protected_Objects;
  538.