------------------------------------------------------------------------------ -- -- -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- -- -- -- 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 . -- -- S I N G L E _ E N T R Y -- -- -- -- B o d y -- -- -- -- Copyright (C) 1998-2005, 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 2, or (at your option) any later ver- -- -- sion. GNARL 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. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- -- Public License distributed with GNARL; see file COPYING. If not, write -- -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- -- Boston, MA 02110-1301, USA. -- -- -- -- As a special exception, if other files instantiate generics from this -- -- unit, or you link this unit with other files to produce an executable, -- -- this unit does not by itself cause the resulting executable to be -- -- covered by the GNU General Public License. This exception does not -- -- however invalidate any other reasons why the executable file might be -- -- covered by the GNU Public License. -- -- -- -- GNARL was developed by the GNARL team at Florida State University. -- -- Extensive contributions were provided by Ada Core Technologies, Inc. -- -- -- ------------------------------------------------------------------------------ pragma Style_Checks (All_Checks); -- Turn off subprogram ordering check, since restricted GNARLI -- subprograms are gathered together at end. -- This package provides an optimized version of Protected_Objects.Operations -- and Protected_Objects.Entries making the following assumptions: -- PO has only one entry -- There is only one caller at a time (No_Entry_Queue) -- There is no dynamic priority support (No_Dynamic_Priorities) -- No Abort Statements -- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) -- PO are at library level -- No Requeue -- None of the tasks will terminate (no need for finalization) -- This interface is intended to be used in the ravenscar and restricted -- profiles, the compiler is responsible for ensuring that the conditions -- mentioned above are respected, except for the No_Entry_Queue restriction -- that is checked dynamically in this package, since the check cannot be -- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue, -- Service_Entry). pragma Polling (Off); -- Turn off polling, we do not want polling to take place during tasking -- operations. It can cause infinite loops and other problems. pragma Suppress (All_Checks); with System.Task_Primitives.Operations; -- used for Self -- Finalize_Lock -- Write_Lock -- Unlock with Ada.Exceptions; -- used for Exception_Id -- Raise_Exception with System.Parameters; -- used for Single_Lock package body System.Tasking.Protected_Objects.Single_Entry is package STPO renames System.Task_Primitives.Operations; use Parameters; ----------------------- -- Local Subprograms -- ----------------------- procedure Send_Program_Error (Self_Id : Task_Id; Entry_Call : Entry_Call_Link); pragma Inline (Send_Program_Error); -- Raise Program_Error in the caller of the specified entry call -------------------------- -- Entry Calls Handling -- -------------------------- procedure Wakeup_Entry_Caller (Self_ID : Task_Id; Entry_Call : Entry_Call_Link; New_State : Entry_Call_State); pragma Inline (Wakeup_Entry_Caller); -- This is called at the end of service of an entry call, -- to abort the caller if he is in an abortable part, and -- to wake up the caller if he is on Entry_Caller_Sleep. -- Call it holding the lock of Entry_Call.Self. -- -- Timed_Call or Simple_Call: -- The caller is waiting on Entry_Caller_Sleep, in -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); pragma Inline (Wait_For_Completion); -- This procedure suspends the calling task until the specified entry call -- has either been completed or cancelled. On exit, the call will not be -- queued. This waits for calls on protected entries. -- Call this only when holding Self_ID locked. procedure Wait_For_Completion_With_Timeout (Entry_Call : Entry_Call_Link; Wakeup_Time : Duration; Mode : Delay_Modes); -- Same as Wait_For_Completion but it waits for a timeout with the value -- specified in Wakeup_Time as well. procedure Check_Exception (Self_ID : Task_Id; Entry_Call : Entry_Call_Link); pragma Inline (Check_Exception); -- Raise any pending exception from the Entry_Call. -- This should be called at the end of every compiler interface procedure -- that implements an entry call. -- The caller should not be holding any locks, or there will be deadlock. procedure PO_Do_Or_Queue (Self_Id : Task_Id; Object : Protection_Entry_Access; Entry_Call : Entry_Call_Link); -- This procedure executes or queues an entry call, depending -- on the status of the corresponding barrier. It assumes that the -- specified object is locked. --------------------- -- Check_Exception -- --------------------- procedure Check_Exception (Self_ID : Task_Id; Entry_Call : Entry_Call_Link) is pragma Warnings (Off, Self_ID); procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); use type Ada.Exceptions.Exception_Id; E : constant Ada.Exceptions.Exception_Id := Entry_Call.Exception_To_Raise; begin if E /= Ada.Exceptions.Null_Id then Internal_Raise (E); end if; end Check_Exception; ------------------------ -- Send_Program_Error -- ------------------------ procedure Send_Program_Error (Self_Id : Task_Id; Entry_Call : Entry_Call_Link) is Caller : constant Task_Id := Entry_Call.Self; begin Entry_Call.Exception_To_Raise := Program_Error'Identity; if Single_Lock then STPO.Lock_RTS; end if; STPO.Write_Lock (Caller); Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); STPO.Unlock (Caller); if Single_Lock then STPO.Unlock_RTS; end if; end Send_Program_Error; ------------------------- -- Wait_For_Completion -- ------------------------- procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is Self_Id : constant Task_Id := Entry_Call.Self; begin Self_Id.Common.State := Entry_Caller_Sleep; STPO.Sleep (Self_Id, Entry_Caller_Sleep); Self_Id.Common.State := Runnable; end Wait_For_Completion; -------------------------------------- -- Wait_For_Completion_With_Timeout -- -------------------------------------- procedure Wait_For_Completion_With_Timeout (Entry_Call : Entry_Call_Link; Wakeup_Time : Duration; Mode : Delay_Modes) is Self_Id : constant Task_Id := Entry_Call.Self; Timedout : Boolean; Yielded : Boolean; use type Ada.Exceptions.Exception_Id; begin -- This procedure waits for the entry call to be served, with a timeout. -- It tries to cancel the call if the timeout expires before the call is -- served. -- If we wake up from the timed sleep operation here, it may be for the -- following possible reasons: -- 1) The entry call is done being served. -- 2) The timeout has expired (Timedout = True) -- Once the timeout has expired we may need to continue to wait if the -- call is already being serviced. In that case, we want to go back to -- sleep, but without any timeout. The variable Timedout is used to -- control this. If the Timedout flag is set, we do not need to Sleep -- with a timeout. We just sleep until we get a wakeup for some status -- change. pragma Assert (Entry_Call.Mode = Timed_Call); Self_Id.Common.State := Entry_Caller_Sleep; STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded); if Timedout then Entry_Call.State := Cancelled; else Entry_Call.State := Done; end if; Self_Id.Common.State := Runnable; end Wait_For_Completion_With_Timeout; ------------------------- -- Wakeup_Entry_Caller -- ------------------------- -- This is called at the end of service of an entry call, to abort the -- caller if he is in an abortable part, and to wake up the caller if it -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. -- (This enforces the rule that a task must be off-queue if its state is -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. -- Timed_Call or Simple_Call: -- The caller is waiting on Entry_Caller_Sleep, in -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. -- Conditional_Call: -- The caller might be in Wait_For_Completion, -- waiting for a rendezvous (possibly requeued without abort) -- to complete. procedure Wakeup_Entry_Caller (Self_ID : Task_Id; Entry_Call : Entry_Call_Link; New_State : Entry_Call_State) is pragma Warnings (Off, Self_ID); Caller : constant Task_Id := Entry_Call.Self; begin pragma Assert (New_State = Done or else New_State = Cancelled); pragma Assert (Caller.Common.State /= Terminated and then Caller.Common.State /= Unactivated); Entry_Call.State := New_State; STPO.Wakeup (Caller, Entry_Caller_Sleep); end Wakeup_Entry_Caller; ----------------------- -- Restricted GNARLI -- ----------------------- -------------------------------- -- Complete_Single_Entry_Body -- -------------------------------- procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is pragma Warnings (Off, Object); begin -- Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise -- has already been set to Null_Id). null; end Complete_Single_Entry_Body; -------------------------------------------- -- Exceptional_Complete_Single_Entry_Body -- -------------------------------------------- procedure Exceptional_Complete_Single_Entry_Body (Object : Protection_Entry_Access; Ex : Ada.Exceptions.Exception_Id) is begin Object.Call_In_Progress.Exception_To_Raise := Ex; end Exceptional_Complete_Single_Entry_Body; --------------------------------- -- Initialize_Protection_Entry -- --------------------------------- procedure Initialize_Protection_Entry (Object : Protection_Entry_Access; Ceiling_Priority : Integer; Compiler_Info : System.Address; Entry_Body : Entry_Body_Access) is Init_Priority : Integer := Ceiling_Priority; begin if Init_Priority = Unspecified_Priority then Init_Priority := System.Priority'Last; end if; STPO.Initialize_Lock (Init_Priority, Object.L'Access); Object.Ceiling := System.Any_Priority (Init_Priority); Object.Owner := Null_Task; Object.Compiler_Info := Compiler_Info; Object.Call_In_Progress := null; Object.Entry_Body := Entry_Body; Object.Entry_Queue := null; end Initialize_Protection_Entry; ---------------- -- Lock_Entry -- ---------------- -- Compiler interface only. -- Do not call this procedure from within the run-time system. procedure Lock_Entry (Object : Protection_Entry_Access) is Ceiling_Violation : Boolean; begin -- If pragma Detect_Blocking is active then, as described in the ARM -- 9.5.1, par. 15, we must check whether this is an external call on a -- protected subprogram with the same target object as that of the -- protected action that is currently in progress (i.e., if the caller -- is already the protected object's owner). If this is the case hence -- Program_Error must be raised. if Detect_Blocking and then Object.Owner = Self then raise Program_Error; end if; STPO.Write_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then raise Program_Error; end if; -- We are entering in a protected action, so that we increase the -- protected object nesting level (if pragma Detect_Blocking is -- active), and update the protected object's owner. if Detect_Blocking then declare Self_Id : constant Task_Id := Self; begin -- Update the protected object's owner Object.Owner := Self_Id; -- Increase protected object nesting level Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting + 1; end; end if; end Lock_Entry; -------------------------- -- Lock_Read_Only_Entry -- -------------------------- -- Compiler interface only -- Do not call this procedure from within the runtime system procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is Ceiling_Violation : Boolean; begin -- If pragma Detect_Blocking is active then, as described in the ARM -- 9.5.1, par. 15, we must check whether this is an external call on a -- protected subprogram with the same target object as that of the -- protected action that is currently in progress (i.e., if the caller -- is already the protected object's owner). If this is the case hence -- Program_Error must be raised. -- Note that in this case (getting read access), several tasks may -- have read ownership of the protected object, so that this method of -- storing the (single) protected object's owner does not work -- reliably for read locks. However, this is the approach taken for two -- major reasosn: first, this function is not currently being used (it -- is provided for possible future use), and second, it largely -- simplifies the implementation. if Detect_Blocking and then Object.Owner = Self then raise Program_Error; end if; STPO.Read_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then raise Program_Error; end if; -- We are entering in a protected action, so that we increase the -- protected object nesting level (if pragma Detect_Blocking is -- active), and update the protected object's owner. if Detect_Blocking then declare Self_Id : constant Task_Id := Self; begin -- Update the protected object's owner Object.Owner := Self_Id; -- Increase protected object nesting level Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting + 1; end; end if; end Lock_Read_Only_Entry; -------------------- -- PO_Do_Or_Queue -- -------------------- procedure PO_Do_Or_Queue (Self_Id : Task_Id; Object : Protection_Entry_Access; Entry_Call : Entry_Call_Link) is Barrier_Value : Boolean; begin -- When the Action procedure for an entry body returns, it must be -- completed (having called [Exceptional_]Complete_Entry_Body). Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1); if Barrier_Value then if Object.Call_In_Progress /= null then -- This violates the No_Entry_Queue restriction, send -- Program_Error to the caller. Send_Program_Error (Self_Id, Entry_Call); return; end if; Object.Call_In_Progress := Entry_Call; Object.Entry_Body.Action (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); Object.Call_In_Progress := null; if Single_Lock then STPO.Lock_RTS; end if; STPO.Write_Lock (Entry_Call.Self); Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); STPO.Unlock (Entry_Call.Self); if Single_Lock then STPO.Unlock_RTS; end if; elsif Entry_Call.Mode /= Conditional_Call then if Object.Entry_Queue /= null then -- This violates the No_Entry_Queue restriction, send -- Program_Error to the caller. Send_Program_Error (Self_Id, Entry_Call); return; else Object.Entry_Queue := Entry_Call; end if; else -- Conditional_Call if Single_Lock then STPO.Lock_RTS; end if; STPO.Write_Lock (Entry_Call.Self); 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 => Send_Program_Error (Self_Id, Entry_Call); end PO_Do_Or_Queue; ---------------------------- -- Protected_Single_Count -- ---------------------------- function Protected_Count_Entry (Object : Protection_Entry) return Natural is begin if Object.Entry_Queue /= null then return 1; else return 0; end if; end Protected_Count_Entry; --------------------------------- -- Protected_Single_Entry_Call -- --------------------------------- procedure Protected_Single_Entry_Call (Object : Protection_Entry_Access; Uninterpreted_Data : System.Address; Mode : Call_Modes) is Self_Id : constant Task_Id := STPO.Self; Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); Ceiling_Violation : Boolean; begin -- 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 Ada.Exceptions.Raise_Exception (Program_Error'Identity, "potentially blocking operation"); end if; STPO.Write_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then raise Program_Error; end if; Entry_Call.Mode := Mode; Entry_Call.State := Now_Abortable; Entry_Call.Uninterpreted_Data := Uninterpreted_Data; Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access); Unlock_Entry (Object); -- The call is either `Done' or not. It cannot be cancelled since there -- is no ATC construct. pragma Assert (Entry_Call.State /= Cancelled); if Entry_Call.State /= Done then if Single_Lock then STPO.Lock_RTS; end if; STPO.Write_Lock (Self_Id); Wait_For_Completion (Entry_Call'Access); STPO.Unlock (Self_Id); if Single_Lock then STPO.Unlock_RTS; end if; end if; Check_Exception (Self_Id, Entry_Call'Access); end Protected_Single_Entry_Call; ----------------------------------- -- Protected_Single_Entry_Caller -- ----------------------------------- function Protected_Single_Entry_Caller (Object : Protection_Entry) return Task_Id is begin return Object.Call_In_Progress.Self; end Protected_Single_Entry_Caller; ------------------- -- Service_Entry -- ------------------- procedure Service_Entry (Object : Protection_Entry_Access) is Self_Id : constant Task_Id := STPO.Self; Entry_Call : constant Entry_Call_Link := Object.Entry_Queue; Caller : Task_Id; begin if Entry_Call /= null and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1) then Object.Entry_Queue := null; if Object.Call_In_Progress /= null then -- Violation of No_Entry_Queue restriction, raise exception Send_Program_Error (Self_Id, Entry_Call); Unlock_Entry (Object); return; end if; Object.Call_In_Progress := Entry_Call; Object.Entry_Body.Action (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); Object.Call_In_Progress := null; Caller := Entry_Call.Self; Unlock_Entry (Object); if Single_Lock then STPO.Lock_RTS; end if; STPO.Write_Lock (Caller); Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); STPO.Unlock (Caller); if Single_Lock then STPO.Unlock_RTS; end if; else -- Just unlock the entry Unlock_Entry (Object); end if; exception when others => Send_Program_Error (Self_Id, Entry_Call); Unlock_Entry (Object); end Service_Entry; --------------------------------------- -- Timed_Protected_Single_Entry_Call -- --------------------------------------- -- Compiler interface only. Do not call from within the RTS. procedure Timed_Protected_Single_Entry_Call (Object : Protection_Entry_Access; Uninterpreted_Data : System.Address; Timeout : Duration; Mode : Delay_Modes; Entry_Call_Successful : out Boolean) is Self_Id : constant Task_Id := STPO.Self; Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); Ceiling_Violation : Boolean; begin -- 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 Ada.Exceptions.Raise_Exception (Program_Error'Identity, "potentially blocking operation"); end if; STPO.Write_Lock (Object.L'Access, Ceiling_Violation); if Ceiling_Violation then raise Program_Error; end if; Entry_Call.Mode := Timed_Call; Entry_Call.State := Now_Abortable; Entry_Call.Uninterpreted_Data := Uninterpreted_Data; Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access); Unlock_Entry (Object); -- Try to avoid waiting for completed calls. -- The call is either `Done' or not. It cannot be cancelled since there -- is no ATC construct and the timed wait has not started yet. pragma Assert (Entry_Call.State /= Cancelled); if Entry_Call.State = Done then Check_Exception (Self_Id, Entry_Call'Access); Entry_Call_Successful := True; return; end if; if Single_Lock then STPO.Lock_RTS; else STPO.Write_Lock (Self_Id); end if; Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode); if Single_Lock then STPO.Unlock_RTS; else STPO.Unlock (Self_Id); end if; pragma Assert (Entry_Call.State >= Done); Check_Exception (Self_Id, Entry_Call'Access); Entry_Call_Successful := Entry_Call.State = Done; end Timed_Protected_Single_Entry_Call; ------------------ -- Unlock_Entry -- ------------------ procedure Unlock_Entry (Object : Protection_Entry_Access) is begin -- We are exiting from a protected action, so that we decrease the -- protected object nesting level (if pragma Detect_Blocking is -- active), and remove ownership of the protected object. if Detect_Blocking then declare Self_Id : constant Task_Id := Self; begin -- Calls to this procedure can only take place when being within -- a protected action and when the caller is the protected -- object's owner. pragma Assert (Self_Id.Common.Protected_Action_Nesting > 0 and then Object.Owner = Self_Id); -- Remove ownership of the protected object Object.Owner := Null_Task; Self_Id.Common.Protected_Action_Nesting := Self_Id.Common.Protected_Action_Nesting - 1; end; end if; STPO.Unlock (Object.L'Access); end Unlock_Entry; end System.Tasking.Protected_Objects.Single_Entry;