Subversion Repositories openrisc_me

------------------------------------------------------------------------------

--                                                                          --

--                 GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS                 --

--                                                                          --

--               SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS                --

--                                                                          --

--                                  B o d y                                 --

--                                                                          --

--         Copyright (C) 1998-2009, Free Software Foundation, Inc.          --

--                                                                          --

-- GNARL is free software; you can  redistribute it  and/or modify it under --

-- terms of the  GNU General Public License as published  by the Free Soft- --

-- ware  Foundation;  either version 3,  or (at your option) any later ver- --

-- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --

-- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --

-- or FITNESS FOR A PARTICULAR PURPOSE.                                     --

--                                                                          --

-- As a special exception under Section 7 of GPL version 3, you are granted --

-- additional permissions described in the GCC Runtime Library Exception,   --

-- version 3.1, as published by the Free Software Foundation.               --

--                                                                          --

-- You should have received a copy of the GNU General Public License and    --

-- a copy of the GCC Runtime Library Exception along with this program;     --

-- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --

-- <http://www.gnu.org/licenses/>.                                          --

--                                                                          --

-- GNARL was developed by the GNARL team at Florida State University.       --

-- Extensive contributions were provided by Ada Core Technologies, Inc.     --

--                                                                          --

------------------------------------------------------------------------------

--  This package contains all extended primitives related to Protected_Objects

--  with entries.

--  The handling of protected objects with no entries is done in

--  System.Tasking.Protected_Objects, the simple routines for protected

--  objects with entries in System.Tasking.Protected_Objects.Entries.

--  The split between Entries and Operations is needed to break circular

--  dependencies inside the run time.

--  This package contains all primitives related to Protected_Objects.

--  Note: the compiler generates direct calls to this interface, via Rtsfind.

with System.Task_Primitives.Operations;

with System.Tasking.Entry_Calls;

with System.Tasking.Queuing;

with System.Tasking.Rendezvous;

with System.Tasking.Utilities;

with System.Tasking.Debug;

with System.Parameters;

with System.Traces.Tasking;

with System.Restrictions;

with System.Tasking.Initialization;

pragma Elaborate_All (System.Tasking.Initialization);

--  Insures that tasking is initialized if any protected objects are created

package body System.Tasking.Protected_Objects.Operations is

   package STPO renames System.Task_Primitives.Operations;

   use Parameters;

   use Task_Primitives;

   use Ada.Exceptions;

   use Entries;

   use System.Restrictions;

   use System.Restrictions.Rident;

   use System.Traces;

   use System.Traces.Tasking;

   -----------------------

   -- Local Subprograms --

   -----------------------

   procedure Update_For_Queue_To_PO

     (Entry_Call : Entry_Call_Link;

      With_Abort : Boolean);

   pragma Inline (Update_For_Queue_To_PO);

   --  Update the state of an existing entry call to reflect the fact that it

   --  is being enqueued, based on whether the current queuing action is with

   --  or without abort. Call this only while holding the PO's lock. It returns

   --  with the PO's lock still held.

   procedure Requeue_Call

     (Self_Id    : Task_Id;

      Object     : Protection_Entries_Access;

      Entry_Call : Entry_Call_Link);

   --  Handle requeue of Entry_Call.

   --  In particular, queue the call if needed, or service it immediately

   --  if possible.

   ---------------------------------

   -- Cancel_Protected_Entry_Call --

   ---------------------------------

   --  Compiler interface only (do not call from within the RTS)

   --  This should have analogous effect to Cancel_Task_Entry_Call, setting

   --  the value of Block.Cancelled instead of returning the parameter value

   --  Cancelled.

   --  The effect should be idempotent, since the call may already have been

   --  dequeued.

   --  Source code:

   --      select r.e;

   --         ...A...

   --      then abort

   --         ...B...

   --      end select;

   --  Expanded code:

   --      declare

   --         X : protected_entry_index := 1;

   --         B80b : communication_block;

   --         communication_blockIP (B80b);

   --      begin

   --         begin

   --            A79b : label

   --            A79b : declare

   --               procedure _clean is

   --               begin

   --                  if enqueued (B80b) then

   --                     cancel_protected_entry_call (B80b);

   --                  end if;

   --                  return;

   --               end _clean;

   --            begin

   --               protected_entry_call (rTV!(r)._object'unchecked_access, X,

   --                 null_address, asynchronous_call, B80b, objectF => 0);

   --               if enqueued (B80b) then

   --                  ...B...

   --               end if;

   --            at end

   --               _clean;

   --            end A79b;

   --         exception

   --            when _abort_signal =>

   --               abort_undefer.all;

   --               null;

   --         end;

   --         if not cancelled (B80b) then

   --            x := ...A...

   --         end if;

   --      end;

   --  If the entry call completes after we get into the abortable part,

   --  Abort_Signal should be raised and ATC will take us to the at-end

   --  handler, which will call _clean.

   --  If the entry call returns with the call already completed, we can skip

   --  this, and use the "if enqueued()" to go past the at-end handler, but we

   --  will still call _clean.

   --  If the abortable part completes before the entry call is Done, it will

   --  call _clean.

   --  If the entry call or the abortable part raises an exception,

   --  we will still call _clean, but the value of Cancelled should not matter.

   --  Whoever calls _clean first gets to decide whether the call

   --  has been "cancelled".

   --  Enqueued should be true if there is any chance that the call is still on

   --  a queue. It seems to be safe to make it True if the call was Onqueue at

   --  some point before return from Protected_Entry_Call.

   --  Cancelled should be true iff the abortable part completed

   --  and succeeded in cancelling the entry call before it completed.

   --  ?????

   --  The need for Enqueued is less obvious. The "if enqueued ()" tests are

   --  not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call

   --  must do the same test internally, with locking. The one that makes

   --  cancellation conditional may be a useful heuristic since at least 1/2

   --  the time the call should be off-queue by that point. The other one seems

   --  totally useless, since Protected_Entry_Call must do the same check and

   --  then possibly wait for the call to be abortable, internally.

   --  We can check Call.State here without locking the caller's mutex,

   --  since the call must be over after returning from Wait_For_Completion.

   --  No other task can access the call record at this point.

   procedure Cancel_Protected_Entry_Call

     (Block : in out Communication_Block) is

   begin

      Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled);

   end Cancel_Protected_Entry_Call;

   ---------------

   -- Cancelled --

   ---------------

   function Cancelled (Block : Communication_Block) return Boolean is

   begin

      return Block.Cancelled;

   end Cancelled;

   -------------------------

   -- Complete_Entry_Body --

   -------------------------

   procedure Complete_Entry_Body (Object : Protection_Entries_Access) is

   begin

      Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id);

   end Complete_Entry_Body;

   --------------

   -- Enqueued --

   --------------

   function Enqueued (Block : Communication_Block) return Boolean is

   begin

      return Block.Enqueued;

   end Enqueued;

   -------------------------------------

   -- Exceptional_Complete_Entry_Body --

   -------------------------------------

   procedure Exceptional_Complete_Entry_Body

     (Object : Protection_Entries_Access;

      Ex     : Ada.Exceptions.Exception_Id)

   is

      procedure Transfer_Occurrence

        (Target : Ada.Exceptions.Exception_Occurrence_Access;

         Source : Ada.Exceptions.Exception_Occurrence);

      pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence");

      Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress;

      Self_Id    : Task_Id;

   begin

      pragma Debug

       (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P'));

      --  We must have abort deferred, since we are inside a protected

      --  operation.

      if Entry_Call /= null then

         --  The call was not requeued

         Entry_Call.Exception_To_Raise := Ex;

         if Ex /= Ada.Exceptions.Null_Id then

            --  An exception was raised and abort was deferred, so adjust

            --  before propagating, otherwise the task will stay with deferral

            --  enabled for its remaining life.

            Self_Id := STPO.Self;

            Initialization.Undefer_Abort_Nestable (Self_Id);

            Transfer_Occurrence

              (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access,

               Self_Id.Common.Compiler_Data.Current_Excep);

         end if;

         --  Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or

         --  PO_Service_Entries on return.

      end if;

      if Runtime_Traces then

         Send_Trace_Info (PO_Done, Entry_Call.Self);

      end if;

   end Exceptional_Complete_Entry_Body;

   --------------------

   -- PO_Do_Or_Queue --

   --------------------

   procedure PO_Do_Or_Queue

     (Self_ID    : Task_Id;

      Object     : Protection_Entries_Access;

      Entry_Call : Entry_Call_Link)

   is

      E             : constant Protected_Entry_Index :=

                        Protected_Entry_Index (Entry_Call.E);

      Barrier_Value : Boolean;

   begin

      --  When the Action procedure for an entry body returns, it is either

      --  completed (having called [Exceptional_]Complete_Entry_Body) or it

      --  is queued, having executed a requeue statement.

      Barrier_Value :=

        Object.Entry_Bodies (

          Object.Find_Body_Index (Object.Compiler_Info, E)).

            Barrier (Object.Compiler_Info, E);

      if Barrier_Value then

         --  Not abortable while service is in progress

         if Entry_Call.State = Now_Abortable then

            Entry_Call.State := Was_Abortable;

         end if;

         Object.Call_In_Progress := Entry_Call;

         pragma Debug

          (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P'));

         Object.Entry_Bodies (

           Object.Find_Body_Index (Object.Compiler_Info, E)).Action (

             Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);

         if Object.Call_In_Progress /= null then

            --  Body of current entry served call to completion

            Object.Call_In_Progress := null;

            if Single_Lock then

               STPO.Lock_RTS;

            end if;

            STPO.Write_Lock (Entry_Call.Self);

            Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);

            STPO.Unlock (Entry_Call.Self);

            if Single_Lock then

               STPO.Unlock_RTS;

            end if;

         else

            Requeue_Call (Self_ID, Object, Entry_Call);

         end if;

      elsif Entry_Call.Mode /= Conditional_Call

        or else not Entry_Call.With_Abort

      then

         if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)

              and then

            Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=

              Queuing.Count_Waiting (Object.Entry_Queues (E))

         then

            --  This violates the Max_Entry_Queue_Length restriction,

            --  raise Program_Error.

            Entry_Call.Exception_To_Raise := Program_Error'Identity;

            if Single_Lock then

               STPO.Lock_RTS;

            end if;

            STPO.Write_Lock (Entry_Call.Self);

            Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);

            STPO.Unlock (Entry_Call.Self);

            if Single_Lock then

               STPO.Unlock_RTS;

            end if;

         else

            Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call);

            Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);

         end if;

      else

         --  Conditional_Call and With_Abort

         if Single_Lock then

            STPO.Lock_RTS;

         end if;

         STPO.Write_Lock (Entry_Call.Self);

         pragma Assert (Entry_Call.State >= Was_Abortable);

         Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled);

         STPO.Unlock (Entry_Call.Self);

         if Single_Lock then

            STPO.Unlock_RTS;

         end if;

      end if;

   exception

      when others =>

         Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call);

   end PO_Do_Or_Queue;

   ------------------------

   -- PO_Service_Entries --

   ------------------------

   procedure PO_Service_Entries

     (Self_ID       : Task_Id;

      Object        : Entries.Protection_Entries_Access;

      Unlock_Object : Boolean := True)

   is

      E          : Protected_Entry_Index;

      Caller     : Task_Id;

      Entry_Call : Entry_Call_Link;

   begin

      loop

         Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call);

         exit when Entry_Call = null;

         E := Protected_Entry_Index (Entry_Call.E);

         --  Not abortable while service is in progress

         if Entry_Call.State = Now_Abortable then

            Entry_Call.State := Was_Abortable;

         end if;

         Object.Call_In_Progress := Entry_Call;

         begin

            if Runtime_Traces then

               Send_Trace_Info (PO_Run, Self_ID,

                                Entry_Call.Self, Entry_Index (E));

            end if;

            pragma Debug

              (Debug.Trace (Self_ID, "POSE: start entry body", 'P'));

            Object.Entry_Bodies

              (Object.Find_Body_Index (Object.Compiler_Info, E)).Action

                (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E);

         exception

            when others =>

               Queuing.Broadcast_Program_Error

                 (Self_ID, Object, Entry_Call);

         end;

         if Object.Call_In_Progress = null then

            Requeue_Call (Self_ID, Object, Entry_Call);

            exit when Entry_Call.State = Cancelled;

         else

            Object.Call_In_Progress := null;

            Caller := Entry_Call.Self;

            if Single_Lock then

               STPO.Lock_RTS;

            end if;

            STPO.Write_Lock (Caller);

            Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);

            STPO.Unlock (Caller);

            if Single_Lock then

               STPO.Unlock_RTS;

            end if;

         end if;

      end loop;

      if Unlock_Object then

         Unlock_Entries (Object);

      end if;

   end PO_Service_Entries;

   ---------------------

   -- Protected_Count --

   ---------------------

   function Protected_Count

     (Object : Protection_Entries'Class;

      E      : Protected_Entry_Index) return Natural

   is

   begin

      return Queuing.Count_Waiting (Object.Entry_Queues (E));

   end Protected_Count;

   --------------------------

   -- Protected_Entry_Call --

   --------------------------

   --  Compiler interface only (do not call from within the RTS)

   --  select r.e;

   --     ...A...

   --  else

   --     ...B...

   --  end select;

   --  declare

   --     X : protected_entry_index := 1;

   --     B85b : communication_block;

   --     communication_blockIP (B85b);

   --  begin

   --     protected_entry_call (rTV!(r)._object'unchecked_access, X,

   --       null_address, conditional_call, B85b, objectF => 0);

   --     if cancelled (B85b) then

   --        ...B...

   --     else

   --        ...A...

   --     end if;

   --  end;

   --  See also Cancel_Protected_Entry_Call for code expansion of asynchronous

   --  entry call.

   --  The initial part of this procedure does not need to lock the calling

   --  task's ATCB, up to the point where the call record first may be queued

   --  (PO_Do_Or_Queue), since before that no other task will have access to

   --  the record.

   --  If this is a call made inside of an abort deferred region, the call

   --  should be never abortable.

   --  If the call was not queued abortably, we need to wait until it is before

   --  proceeding with the abortable part.

   --  There are some heuristics here, just to save time for frequently

   --  occurring cases. For example, we check Initially_Abortable to try to

   --  avoid calling the procedure Wait_Until_Abortable, since the normal case

   --  for async. entry calls is to be queued abortably.

   --  Another heuristic uses the Block.Enqueued to try to avoid calling

   --  Cancel_Protected_Entry_Call if the call can be served immediately.

   procedure Protected_Entry_Call

     (Object              : Protection_Entries_Access;

      E                   : Protected_Entry_Index;

      Uninterpreted_Data  : System.Address;

      Mode                : Call_Modes;

      Block               : out Communication_Block)

   is

      Self_ID             : constant Task_Id := STPO.Self;

      Entry_Call          : Entry_Call_Link;

      Initially_Abortable : Boolean;

      Ceiling_Violation   : Boolean;

   begin

      pragma Debug

        (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P'));

      if Runtime_Traces then

         Send_Trace_Info (PO_Call, Entry_Index (E));

      end if;

      if Self_ID.ATC_Nesting_Level = ATC_Level'Last then

         raise Storage_Error with "not enough ATC nesting levels";

      end if;

      --  If pragma Detect_Blocking is active then Program_Error must be

      --  raised if this potentially blocking operation is called from a

      --  protected action.

      if Detect_Blocking

        and then Self_ID.Common.Protected_Action_Nesting > 0

      then

         raise Program_Error with "potentially blocking operation";

      end if;

      --  Self_ID.Deferral_Level should be 0, except when called from Finalize,

      --  where abort is already deferred.

      Initialization.Defer_Abort_Nestable (Self_ID);

      Lock_Entries (Object, Ceiling_Violation);

      if Ceiling_Violation then

         --  Failed ceiling check

         Initialization.Undefer_Abort_Nestable (Self_ID);

         raise Program_Error;

      end if;

      Block.Self := Self_ID;

      Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1;

      pragma Debug

        (Debug.Trace (Self_ID, "PEC: entered ATC level: " &

         ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A'));

      Entry_Call :=

         Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access;

      Entry_Call.Next := null;

      Entry_Call.Mode := Mode;

      Entry_Call.Cancellation_Attempted := False;

      Entry_Call.State :=

        (if Self_ID.Deferral_Level > 1

         then Never_Abortable else Now_Abortable);

      Entry_Call.E := Entry_Index (E);

      Entry_Call.Prio := STPO.Get_Priority (Self_ID);

      Entry_Call.Uninterpreted_Data := Uninterpreted_Data;

      Entry_Call.Called_PO := To_Address (Object);

      Entry_Call.Called_Task := null;

      Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id;

      Entry_Call.With_Abort := True;

      PO_Do_Or_Queue (Self_ID, Object, Entry_Call);

      Initially_Abortable := Entry_Call.State = Now_Abortable;

      PO_Service_Entries (Self_ID, Object);

      --  Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call)

      --  for completed or cancelled calls.  (This is a heuristic, only.)

      if Entry_Call.State >= Done then

         --  Once State >= Done it will not change any more

         if Single_Lock then

            STPO.Lock_RTS;

         end if;

         STPO.Write_Lock (Self_ID);

         Utilities.Exit_One_ATC_Level (Self_ID);

         STPO.Unlock (Self_ID);

         if Single_Lock then

            STPO.Unlock_RTS;

         end if;

         Block.Enqueued := False;

         Block.Cancelled := Entry_Call.State = Cancelled;

         Initialization.Undefer_Abort_Nestable (Self_ID);

         Entry_Calls.Check_Exception (Self_ID, Entry_Call);

         return;

      else

         --  In this case we cannot conclude anything, since State can change

         --  concurrently.

         null;

      end if;

      --  Now for the general case

      if Mode = Asynchronous_Call then

         --  Try to avoid an expensive call

         if not Initially_Abortable then

            if Single_Lock then

               STPO.Lock_RTS;

               Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);

               STPO.Unlock_RTS;

            else

               Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call);

            end if;

         end if;

      elsif Mode < Asynchronous_Call then

         --  Simple_Call or Conditional_Call

         if Single_Lock then

            STPO.Lock_RTS;

            Entry_Calls.Wait_For_Completion (Entry_Call);

            STPO.Unlock_RTS;

         else

            STPO.Write_Lock (Self_ID);

            Entry_Calls.Wait_For_Completion (Entry_Call);

            STPO.Unlock (Self_ID);

         end if;

         Block.Cancelled := Entry_Call.State = Cancelled;

      else

         pragma Assert (False);

         null;

      end if;

      Initialization.Undefer_Abort_Nestable (Self_ID);

      Entry_Calls.Check_Exception (Self_ID, Entry_Call);

   end Protected_Entry_Call;

   ------------------

   -- Requeue_Call --

   ------------------

   procedure Requeue_Call

     (Self_Id    : Task_Id;

      Object     : Protection_Entries_Access;

      Entry_Call : Entry_Call_Link)

   is

      New_Object        : Protection_Entries_Access;

      Ceiling_Violation : Boolean;

      Result            : Boolean;

      E                 : Protected_Entry_Index;

   begin

      New_Object := To_Protection (Entry_Call.Called_PO);

      if New_Object = null then

         --  Call is to be requeued to a task entry

         if Single_Lock then

            STPO.Lock_RTS;

         end if;

         Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call);

         if not Result then

            Queuing.Broadcast_Program_Error

              (Self_Id, Object, Entry_Call, RTS_Locked => True);

         end if;

         if Single_Lock then

            STPO.Unlock_RTS;

         end if;

      else

         --  Call should be requeued to a PO

         if Object /= New_Object then

            --  Requeue is to different PO

            Lock_Entries (New_Object, Ceiling_Violation);

            if Ceiling_Violation then

               Object.Call_In_Progress := null;

               Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call);

            else

               PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call);

               PO_Service_Entries (Self_Id, New_Object);

            end if;

         else

            --  Requeue is to same protected object

            --  ??? Try to compensate apparent failure of the scheduler on some

            --  OS (e.g VxWorks) to give higher priority tasks a chance to run

            --  (see CXD6002).

            STPO.Yield (False);

            if Entry_Call.With_Abort

              and then Entry_Call.Cancellation_Attempted

            then

               --  If this is a requeue with abort and someone tried to cancel

               --  this call, cancel it at this point.

               Entry_Call.State := Cancelled;

               return;

            end if;

            if not Entry_Call.With_Abort

              or else Entry_Call.Mode /= Conditional_Call

            then

               E := Protected_Entry_Index (Entry_Call.E);

               if Run_Time_Restrictions.Set (Max_Entry_Queue_Length)

                    and then

                  Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <=

                    Queuing.Count_Waiting (Object.Entry_Queues (E))

               then

                  --  This violates the Max_Entry_Queue_Length restriction,

                  --  raise Program_Error.

                  Entry_Call.Exception_To_Raise := Program_Error'Identity;

                  if Single_Lock then

                     STPO.Lock_RTS;

                  end if;

                  STPO.Write_Lock (Entry_Call.Self);

                  Initialization.Wakeup_Entry_Caller

                    (Self_Id, Entry_Call, Done);

                  STPO.Unlock (Entry_Call.Self);

                  if Single_Lock then

                     STPO.Unlock_RTS;

                  end if;

               else

                  Queuing.Enqueue

                    (New_Object.Entry_Queues (E), Entry_Call);

                  Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort);

               end if;

            else

               PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call);

            end if;

         end if;

      end if;

   end Requeue_Call;

   ----------------------------

   -- Protected_Entry_Caller --

   ----------------------------