Geek Gadgets 1

home *** CD-ROM | disk | FTP | other *** search

/ Geek Gadgets 1 / ADE-1.bin / ade-bin / lib / gcc-lib / m68k-amigaos / 2.7.2.1 / adainclude / s-taprob.adb < prev next >

Wrap

Text File | 1995-10-17 | 17.6 KB | 538 lines

----------------------------------------------------------------------------- -- -- -- GNU ADA RUNTIME 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 -- -- -- -- B o d y -- -- -- -- $Revision: 1.34 $ -- -- -- -- Copyright (c) 1991,1992,1993,1994,1995 FSU, All Rights Reserved -- -- -- -- GNARL is free software; you can redistribute it and/or modify it under -- -- terms of the GNU Library General Public License as published by the -- -- Free Software Foundation; either version 2, or (at your option) any -- -- later version. GNARL is distributed in the hope that it will be use- -- -- ful, but but WITHOUT ANY WARRANTY; without even the implied warranty of -- -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Gen- -- -- eral Library Public License for more details. You should have received -- -- a copy of the GNU Library General Public License along with GNARL; see -- -- file COPYING.LIB. If not, write to the Free Software Foundation, 675 -- -- Mass Ave, Cambridge, MA 02139, USA. -- -- -- ------------------------------------------------------------------------------ with System.Compiler_Exceptions; -- Used for, "=" -- Raise_Exceptions -- Exception_ID -- Compiler_Exceptions.Null_Exception -- Program_Error_ID with System.Tasking.Abortion; -- Used for, Abortion.Defer_Abortion, -- Abortion.Undefer_Abortion, -- Abortion.Change_Base_Priority with System.Task_Primitives; use System.Task_Primitives; with System.Tasking.Queuing; use System.Tasking.Queuing; -- Used for, Queuing.Enqueue, -- Queuing.Dequeue, -- Queuing.Head, -- Queuing.Dequeue_Head, -- Queuing.Count_Waiting, -- Queuing.Select_Protected_Entry_Call with System.Tasking.Utilities; -- Used for, Utilities.Abort_To_Level with System.Tasking.Entry_Calls; -- Used for, Internal_Lock -- Internal_Lock_Read_Only -- Wait_For_Completion -- Wait_Until_Abortable with System.Tasking.Initialization; pragma Elaborate_All (System.Tasking.Initialization); -- This insures that tasking is initialized if any protected objects are -- created. with Unchecked_Conversion; package body System.Tasking.Protected_Objects is procedure Defer_Abortion renames Abortion.Defer_Abortion; procedure Undefer_Abortion renames Abortion.Undefer_Abortion; function "=" (L, R : System.Compiler_Exceptions.Exception_ID) return Boolean renames System.Compiler_Exceptions."="; procedure Do_Or_Queue (Object : access Protection; Entry_Call : Entry_Call_Link); -- This procedure either executes or queues an entry call, depending -- on the status of the corresponding barrier. It assumes that abortion -- is deferred and that the specified object is locked. pragma Inline (Do_Or_Queue); -------------- -- Enqueued -- -------------- function Enqueued (Block : Communication_Block) return Boolean is begin return Block.Enqueued; end Enqueued; --------------- -- Cancelled -- --------------- function Cancelled (Block : Communication_Block) return Boolean is begin return Block.Cancelled; end Cancelled; --------------------------- -- Initialize_Protection -- --------------------------- procedure Initialize_Protection (Object : access Protection; Ceiling_Priority : Integer; Compiler_Info : System.Address; Entry_Bodies : access Protected_Entry_Body_Array) is Init_Priority : Integer := Ceiling_Priority; First_Entry_Index : Protected_Entry_Index := 1; Last_Entry_Index : Protected_Entry_Index := Object.Num_Entries; begin if Init_Priority = Unspecified_Priority then Init_Priority := System.Default_Priority; end if; Initialize_Lock (Init_Priority, Object.L); Object.Ceiling := System.Priority (Init_Priority); Object.Compiler_Info := Compiler_Info; Object.Pending_Action := False; Object.Call_In_Progress := null; Object.Entry_Bodies := Entry_Bodies; for E in Object.Entry_Queues'Range loop Object.Entry_Queues (E).Head := null; Object.Entry_Queues (E).Tail := null; end loop; end Initialize_Protection; ---------- -- Lock -- ---------- procedure Lock (Object : access Protection) is Ceiling_Violation : Boolean; begin System.Tasking.Entry_Calls.Internal_Lock (Object, Ceiling_Violation); if Ceiling_Violation then raise Program_Error; end if; end Lock; -------------------- -- Lock_Read_Only -- -------------------- procedure Lock_Read_Only (Object : access Protection) is Ceiling_Violation : Boolean; begin System.Tasking.Entry_Calls.Internal_Lock_Read_Only (Object, Ceiling_Violation); if Ceiling_Violation then raise Program_Error; end if; end Lock_Read_Only; ------------ -- Unlock -- ------------ procedure Unlock (Object : access Protection) is Caller : Task_ID := Self; Error : Boolean; begin if Object.Pending_Action then Object.Pending_Action := False; Write_Lock (Caller.L, Error); Caller.New_Base_Priority := Object.Old_Base_Priority; Abortion.Change_Base_Priority (Caller); Unlock (Caller.L); end if; Unlock (Object.L); end Unlock; ----------------- -- Do_Or_Queue -- ----------------- procedure Do_Or_Queue (Object : access Protection; Entry_Call : Entry_Call_Link) is E : Protected_Entry_Index := Protected_Entry_Index (Entry_Call.E); Caller : Task_ID := Entry_Call.Self; TAS_Result : Boolean; Ceiling_Violation : 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. if Object.Entry_Bodies (E).Barrier (Object.Compiler_Info, E) then Entry_Call.Abortable := False; -- Not abortable while in progress. Object.Call_In_Progress := Entry_Call; Object.Entry_Bodies (E).Action ( Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); elsif Entry_Call.Mode /= Conditional_Call then Entry_Call.Has_Been_Abortable := True; Enqueue (Object.Entry_Queues (E), Entry_Call); end if; exception when others => Broadcast_Program_Error (Object, Entry_Call); end Do_Or_Queue; --------------------- -- Service_Entries -- --------------------- procedure Service_Entries (Object : access Protection) is Entry_Call : Entry_Call_Link; E : Protected_Entry_Index; begin loop Select_Protected_Entry_Call (Object, Entry_Call); if Entry_Call /= null then E := Protected_Entry_Index (Entry_Call.E); Object.Call_In_Progress := Entry_Call; Object.Entry_Bodies (E).Action ( Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); else exit; end if; end loop; end Service_Entries; -------------------------- -- Protected_Entry_Call -- -------------------------- procedure Protected_Entry_Call (Object : access Protection; E : Protected_Entry_Index; Uninterpreted_Data : System.Address; Mode : Call_Modes; Block : out Communication_Block) is Caller : Task_ID := Self; Level : ATC_Level; Entry_Call : Entry_Call_Link; TAS_Result : Boolean; Ceiling_Violation : Boolean; Initially_Abortable : Boolean; begin Defer_Abortion; Lock (Object); Block.Self := Caller; Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level + 1; Level := Caller.ATC_Nesting_Level; Entry_Call := Caller.Entry_Calls (Level)'Access; -- The caller's lock is not needed here. The call record does not -- need protection, since other tasks only access these records -- when they are queued, which this one is not. Entry_Call.Next := null; Entry_Call.Mode := Mode; Entry_Call.Abortable := True; Entry_Call.Done := False; Entry_Call.Has_Been_Abortable := False; Entry_Call.E := Entry_Index (E); Entry_Call.Prio := Caller.Current_Priority; Entry_Call.Uninterpreted_Data := Uninterpreted_Data; Entry_Call.Called_PO := Object; Entry_Call.Called_Task := Null_Task; Entry_Call.Exception_To_Raise := System.Compiler_Exceptions.Null_Exception; Do_Or_Queue (Object, Entry_Call); Initially_Abortable := Entry_Call.Abortable; Service_Entries (Object); -- Indicate whether the call has been cancelled or not. -- A call cannot be in progress at this point, since the caller -- (this task) cannot be executing it, and we haven't given up -- the object lock yet, so no other task can be executing it. -- Therefore a call that is not on a queue but not complete must -- have been cancelled. Similarly, no other task can be looking -- at the entry call record at this point, so we can check -- Entry_Call.Done without locking the caller's mutex. Block.Cancelled := not Entry_Call.Done and then not Onqueue (Entry_Call); Block.Enqueued := Entry_Call.Has_Been_Abortable; -- Set the Enqueued flag. -- Try to avoid waiting for completed or cancelled calls. if not (Entry_Call.Done or else Block.Cancelled) then Unlock (Object); case Mode is when Simple_Call | Conditional_Call => System.Tasking.Entry_Calls.Wait_For_Completion (Entry_Call); when Asynchronous_Call => -- If the call was never enqueued, it is complete or -- cancelled at this point. The compiler-generated code -- avoids calling Cancel_Protected_Entry_Call in this case, -- so we need to pop the entry call from the call stack -- at this point. -- ??? This complicates the interface, making it illegal -- to call Cancel_Protected_Entry_Call in this case, -- but mandatory to call it in other cases. Consider -- making it mandatory in all cases. if not Block.Enqueued then Caller.ATC_Nesting_Level := Caller.ATC_Nesting_Level - 1; else -- If the call was not queued abortably, we need to wait -- until it is before proceeding with the abortable part. -- Wait_Until_Abortable can be called unconditionally here, -- but it is expensive. if not Initially_Abortable then System.Tasking.Entry_Calls.Wait_Until_Abortable (Caller, Entry_Call); end if; end if; end case; else Unlock (Object); end if; Undefer_Abortion; System.Tasking.Utilities.Check_Exception; end Protected_Entry_Call; --------------------------------- -- Cancel_Protected_Entry_Call -- --------------------------------- procedure Cancel_Protected_Entry_Call (Block : in out Communication_Block) is Caller : Task_ID := Block.Self; Call : Entry_Call_Link; begin pragma Assert (Caller.ATC_Nesting_Level > ATC_Level_Base'First or else Utilities.Runtime_Assert_Shutdown ( "Attempt to cancel nonexistent task entry call.")); Call := Caller.Entry_Calls (Caller.ATC_Nesting_Level)'Access; pragma Assert (Call.Mode = Asynchronous_Call or else Utilities.Runtime_Assert_Shutdown ( "Attempt to perform ATC on non-asynchronous protected entry call")); pragma Assert (Call.Called_Task = Null_Task or else Utilities.Runtime_Assert_Shutdown ( "Attempt to use Cancel_Protected_Entry_Call on task entry call.")); Defer_Abortion; Utilities.Abort_To_Level (Caller, Call.Level - 1); System.Tasking.Entry_Calls.Wait_For_Completion (Call); -- This allows the triggered statements to be skipped. -- We can check Call.Done 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. Block.Cancelled := not Call.Done; Undefer_Abortion; System.Tasking.Utilities.Check_Exception; end Cancel_Protected_Entry_Call; ------------------------- -- Complete_Entry_Body -- ------------------------- procedure Complete_Entry_Body (Object : access Protection) is begin Exceptional_Complete_Entry_Body (Object, System.Compiler_Exceptions.Null_Exception); end Complete_Entry_Body; ------------------------------------- -- Exceptional_Complete_Entry_Body -- ------------------------------------- procedure Exceptional_Complete_Entry_Body (Object : access Protection; Ex : System.Compiler_Exceptions.Exception_ID) is Caller : Task_ID := Object.Call_In_Progress.Self; Error : Boolean; begin Object.Call_In_Progress.Exception_To_Raise := Ex; Write_Lock (Caller.L, Error); Object.Call_In_Progress.Done := True; Unlock (Caller.L); if Object.Call_In_Progress.Mode = Asynchronous_Call then -- If the asynchronous call has never been queued abortably, the -- abortable part will have been skipped; there is no need to abort -- it. if Object.Call_In_Progress.Has_Been_Abortable then Utilities.Abort_To_Level ( Caller, Object.Call_In_Progress.Level - 1); end if; else Cond_Signal (Caller.Cond); end if; end Exceptional_Complete_Entry_Body; ----------------------------- -- Requeue_Protected_Entry -- ----------------------------- procedure Requeue_Protected_Entry (Object : access Protection; New_Object : access Protection; E : Protected_Entry_Index; With_Abort : Boolean) is Entry_Call : Entry_Call_Link := Object.Call_In_Progress; Caller : Task_ID := Entry_Call.Self; Ceiling_Violation : Boolean; Call_Cancelled : Boolean := False; Error : Boolean; begin -- We have to check if the requeue is internal one. -- If it is an internal one, no need to lock. if (Object /= New_Object) then Lock (New_Object); end if; Entry_Call.Abortable := With_Abort; Entry_Call.Has_Been_Abortable := With_Abort or Entry_Call.Has_Been_Abortable; Entry_Call.E := Entry_Index (E); Entry_Call.Called_PO := New_Object; if Object = New_Object and then (not With_Abort or else Entry_Call.Mode /= Conditional_Call) then Enqueue (New_Object.Entry_Queues (E), Entry_Call); else Do_Or_Queue (New_Object, Entry_Call); end if; if (Object /= New_Object) then Object.Call_In_Progress := null; Service_Entries (New_Object); Unlock (New_Object); end if; Write_Lock (Caller.L, Error); Caller.Pending_Action := True; Cond_Signal (Caller.Cond); -- If this is a conditional entry call, and has just become -- abortable, the caller should be awakened to cancel the call. Unlock (Caller.L); end Requeue_Protected_Entry; ------------------------------------- -- Requeue_Task_To_Protected_Entry -- ------------------------------------- procedure Requeue_Task_To_Protected_Entry (New_Object : access Protection; E : Protected_Entry_Index; With_Abort : Boolean) is Old_Acceptor : Task_ID := Self; Entry_Call : Entry_Call_Link; Error : Boolean; begin Lock (New_Object); Write_Lock (Old_Acceptor.L, Error); Entry_Call := Old_Acceptor.Call; Old_Acceptor.Call := null; Entry_Call.Called_PO := New_Object; Entry_Call.Called_Task := Null_Task; Unlock (Old_Acceptor.L); Entry_Call.Abortable := With_Abort; Entry_Call.Has_Been_Abortable := With_Abort or Entry_Call.Has_Been_Abortable; Entry_Call.E := Entry_Index (E); Do_Or_Queue (New_Object, Entry_Call); Service_Entries (New_Object); Unlock (New_Object); end Requeue_Task_To_Protected_Entry; --------------------- -- Protected_Count -- --------------------- function Protected_Count (Object : Protection; E : Protected_Entry_Index) return Natural is begin return Count_Waiting (Object.Entry_Queues (E)); end Protected_Count; end System.Tasking.Protected_Objects;