|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - downloadIndex: B T
Length: 33612 (0x834c)
Types: TextFile
Names: »B«
└─⟦afbc8121e⟧ Bits:30000532 8mm tape, Rational 1000, MC68020_OS2000 7_2_2
└─⟦77aa8350c⟧ »DATA«
└─⟦f794ecd1d⟧
└─⟦24d1ddd49⟧
└─⟦this⟧
-- The use of this system is subject to the software license terms and
-- conditions agreed upon between Rational and the Customer.
--
-- Copyright 1988 by Rational.
--
-- RESTRICTED RIGHTS LEGEND
--
-- Use, duplication, or disclosure by the Government is subject to
-- restrictions as set forth in subdivision (b)(3)(ii) of the Rights in
-- Technical Data and Computer Software clause at 52.227-7013.
--
--
-- Rational
-- 3320 Scott Boulevard
-- Santa Clara, California 95054-3197
--
-- PROPRIETARY AND CONFIDENTIAL INFORMATION OF RATIONAL;
-- USE OR COPYING WITHOUT EXPRESS WRITTEN AUTHORIZATION
-- IS STRICTLY PROHIBITED. THIS MATERIAL IS PROTECTED AS
-- AN UNPUBLISHED WORK UNDER THE U.S. COPYRIGHT ACT OF
-- 1976. CREATED 1988. ALL RIGHTS RESERVED.
--
--
separate (Task_Management)
package body Termination_And_Abortion is
pragma Suppress_All;
function "=" (X, Y : Tt.Wait_List_Link) return Boolean renames Tt."=";
procedure Delete_Entry_Queues
(The_Task : Task_Id; Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Next_Caller : Task_Id;
Message : Entry_Call_Message;
Status : Mq.Stratus;
begin
if Debug_Mode then
Debugging.Put_Message ("Entered Delete_Entry_Queues");
end if;
-- if Safety_Check then
-- Checking.Check_Task (The_Task, "Delete_Entry_Queues",
-- Current_Task => Current_Task);
-- end if;
-- mark the task as non_callable
The_Task.Action_State (Non_Callable) := True;
if The_Task.Queues.Wait_List /= null then
for I in First_Entry_Index ..
The_Task.Queues.Wait_List.List'Last loop
declare
The_Wait_Item : Mq.Wait_Item
renames The_Task.Queues.Wait_List.List (I);
The_Queue : Mq.Id renames The_Wait_Item.Wait_Queue;
begin
-- Only evacuate if the current task. PRS 9723630-0120-1
if The_Wait_Item.Ipc_Queue and The_Task = Current_Task then
Ipc.Evacuate_Queue
(The_Queue => The_Queue,
Queue_Data => Message_Queue_Utilities.
Get_Associated_Data
(The_Queue, The_Task));
end if;
-- Only delete if necessary.
if (not The_Wait_Item.Ipc_Queue) or
(The_Task = Current_Task) then
Delete_A_Queue:
loop
Mq.Delete_If_Empty (The_Queue, Status);
if Status /= Mq.Q_Notemp then
if Safety_Check then
Checking.Check_Message_Queue_Status
(Status,
Err.Bad_Status_From_Delete_If_Empty,
Current_Task => Current_Task);
end if;
-- The_Queue := Mq.Null_Id;
The_Queue.Upper := 0;
The_Queue.Lower := 0;
exit Delete_A_Queue;
end if;
Cause_Tasking_Error:
loop
Mq.Retrieve_If_Available
(The_Queue, Message'Address,
Entry_Call_Message_Size, Status);
exit when Status = Mq.Q_Nomess;
Message_Queue_Utilities.Cancel_Timer
(Message.Timer_Id,
Current_Task => Current_Task);
Next_Caller := To_Task_Id
(Message.Caller);
Next_Caller.Exception_Id :=
Exceptions.Tasking_Error;
Next_Caller.Action_State
(Exception_Pending) := True;
Message_Queue_Utilities.Send_Reply
(Next_Caller, Rendezvous_Done,
Current_Task => Current_Task);
end loop Cause_Tasking_Error;
end loop Delete_A_Queue;
end if;
end;
end loop;
end if;
end Delete_Entry_Queues;
procedure Prepare_For_Aborted_Entry_Caller_Reply
(Abortee : Task_Id; Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
-- There is a comment in Abort_Multiple_Tasks that explains all of this
Aborted_While_Calling_Entry : Integer
renames Current_Task.Activations_In_Progress;
function Convert is new Unchecked_Conversion
(System.Address, Group_Ref);
Aborter_Id : Task_Id
renames Convert (Abortee.Activations_In_Progress'Address).all;
begin
Aborted_While_Calling_Entry := Aborted_While_Calling_Entry + 1;
Aborter_Id := Current_Task;
end Prepare_For_Aborted_Entry_Caller_Reply;
procedure Forced_Termination (The_Task : Task_Id;
Term_Via_Abort : Boolean;
Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Forced_Termination, The_Task =" &
-- Integer'Image (The_Task.Os9_Process_Id));
-- end if;
if Safety_Check then
Checking.Check_Task (The_Task, "Forced_Termination",
Current_Task => Current_Task);
end if;
if The_Task.Action_State (Abnormal) or else
The_Task.Suspension_State = Terminated then
return;
end if;
if Term_Via_Abort then
The_Task.Action_State (Abnormal) := True;
-- mark task as non_callable and delete queues
Delete_Entry_Queues (The_Task, Current_Task => Current_Task);
end if;
if The_Task.Suspension_State = Not_Activated then
The_Task.Suspension_State := Terminated;
The_Task.Action_State (Parent_Or_Child_Ok_Tcb_Reclamation) := True;
The_Task.Master_Block.Non_Terminated :=
The_Task.Master_Block.Non_Terminated - 1;
The_Task.Master_Block.Non_Terminable :=
The_Task.Master_Block.Non_Terminable - 1;
if not Term_Via_Abort then
Delete_Entry_Queues (The_Task, Current_Task => Current_Task);
end if;
elsif The_Task.Suspension_State = Calling_Entry or else
The_Task.Suspension_State = Awaiting_Entry_Call or else
The_Task.Suspension_State = Delaying or else
The_Task.Suspension_State = Not_Suspended then
-- A task that calls Collective_Termination will
-- be in Not_Suspended state, but it still needs a reply;
-- other non-suspended tasks do not get a reply.
if (The_Task.Suspension_State /= Not_Suspended) or else
((The_Task = Current_Task) and then (not Term_Via_Abort)) then
if Term_Via_Abort then
if The_Task.Suspension_State = Calling_Entry then
Prepare_For_Aborted_Entry_Caller_Reply
(Abortee => The_Task, Current_Task => Current_Task);
end if;
Message_Queue_Utilities.Send_Reply
(The_Task, Task_Aborted, Current_Task => Current_Task);
else
Message_Queue_Utilities.Send_Reply
(The_Task, Termination_Selected,
Current_Task => Current_Task);
end if;
end if;
end if;
end Forced_Termination;
procedure Collective_Termination
(For_Layer : Layer_Id; Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Next_Task : Task_Id;
Next_Layer : Layer_Id;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Collective_Termination");
-- end if;
-- Because Collective_Termination is recursive, and the runtime
-- does not have stack_checks enabled, we verify here that the
-- stack has not overflowed. If it has, a fatal error is reported
-- and the process terminates. This will generally cause program
-- deadlock, but the program cannot safely proceed, since there
-- is insufficient stack to complete the termination sequence.
Process_Ops.Verify_Stack;
if For_Layer.Non_Terminated > 0 then
Next_Task := For_Layer.Dependent_Task_List.Next;
while Next_Task /= null loop
if Next_Task.Suspension_State /= Terminated then
Next_Layer := Next_Task.Current_Layer;
while Next_Layer /= null loop
Collective_Termination (Next_Layer,
Current_Task => Current_Task);
Next_Layer := Next_Layer.Layer_Link;
end loop;
Forced_Termination (Next_Task,
Term_Via_Abort => False,
Current_Task => Current_Task);
end if;
Next_Task := Next_Task.Layer_Link.Next;
end loop;
end if;
end Collective_Termination;
procedure Wait_Until_Really_Dead
(Child : Task_Id; Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Reply : Reply_Kind;
begin
if not Child.Action_State (Parent_Or_Child_Ok_Tcb_Reclamation) then
Child.Action_State (Parent_Or_Child_Ok_Tcb_Reclamation) := True;
Message_Queue_Utilities.Await_Reply
(Awaiting_Tcb_Reclamation_Ok, Reply,
Current_Task => Current_Task);
if Safety_Check then
Checking.Check_Reply (Reply, Child_Tcb_Reclaimable,
Current_Task => Current_Task);
end if;
end if;
end Wait_Until_Really_Dead;
procedure Do_Await_Dependents (Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Current_Layer : Layer_Id := Current_Task.Current_Layer;
Next_Dependent : Task_Id;
Next_Next_Task : Task_Id;
Reply : Reply_Kind;
begin
if Current_Layer /= null then
-- if Safety_Check then
-- Checking.Check_Layer (Current_Layer, "Await_Dependents",
-- Current_Task => Current_Task);
-- end if;
if Current_Layer.Non_Terminable > 0 then
Message_Queue_Utilities.Await_Reply
(Awaiting_Dependent_Termination, Reply,
Current_Task => Current_Task);
if Safety_Check then
Checking.Check_Reply (Reply, Dependents_Terminated,
Current_Task => Current_Task);
end if;
elsif Current_Layer.Non_Terminated > 0 then
Collective_Termination (Current_Layer,
Current_Task => Current_Task);
end if;
Next_Dependent := Current_Layer.Dependent_Task_List.Next;
while Next_Dependent /= null loop
if Safety_Check then
Checking.Check_Task (Next_Dependent, "Await_Dependents",
Current_Task => Current_Task);
end if;
Next_Next_Task := Next_Dependent.Layer_Link.Next;
Wait_Until_Really_Dead (Child => Next_Dependent,
Current_Task => Current_Task);
Storage_Manager.Free_Queues (Next_Dependent.Queues,
Current_Task => Current_Task);
Storage_Manager.Free_Tcb (Next_Dependent);
Next_Dependent := Next_Next_Task;
end loop;
Current_Task.Current_Layer := Current_Layer.Layer_Link;
Runtime_Exceptions.Check_For_Abnormality
(Current_Task => Current_Task);
-- else
-- if Debug_Mode then
-- Debugging.Put_Message
-- ("*** Warning: Await_Dependents called but Current_Layer is null");
-- end if;
end if;
end Do_Await_Dependents;
procedure Await_Dependents is
pragma Routine_Number (Runtime_Ids.Await_Dependents);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
begin
if Debug_Mode then
Debugging.Put_Message ("Entered Await_Dependents");
end if;
Do_Await_Dependents (Current_Task);
Release_Lock;
end Await_Dependents;
procedure Make_Masters_Cold (The_Task : Task_Id; Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Next_Layer : Layer_Id;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Make_Masters_Cold");
-- end if;
-- if Safety_Check then
-- Checking.Check_Task (The_Task, "Make_Masters_Cold",
-- Current_Task => Current_Task);
-- Checking.Check_Layer (The_Task.Master_Block, "Make_Masters_Cold",
-- Current_Task => Current_Task);
-- end if;
-- Because Make_Masters_Cold is recursive, and the runtime
-- does not have stack_checks enabled, we verify here that the
-- stack has not overflowed. If it has, a fatal error is reported
-- and the process terminates. This will generally cause program
-- deadlock, but the program cannot safely proceed, since there
-- is insufficient stack to complete the termination sequence.
Process_Ops.Verify_Stack;
--
declare
Master_Layer : Layer_Id renames The_Task.Master_Block;
Master_Task : Task_Id renames Master_Layer.Master_Task;
begin
if The_Task.Suspension_State = Terminated then
-- if Safety_Check and then (Master_Layer.Non_Terminated = 0) then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Make_Masters_Cold",
-- "decrementing non_terminated count below zero",
-- Err.Layer_State_Inconsistency,
-- Current_Task => Current_Task);
-- end if;
Master_Layer.Non_Terminated := Master_Layer.Non_Terminated - 1;
end if;
-- if Safety_Check and then (Master_Layer.Non_Terminable = 0) then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Make_Masters_Cold",
-- "decrementing non_terminable count below zero",
-- Err.Layer_State_Inconsistency,
-- Current_Task => Current_Task);
-- end if;
Master_Layer.Non_Terminable := Master_Layer.Non_Terminable - 1;
if Master_Layer.Non_Terminable > 0 then
return;
elsif Master_Task.Suspension_State =
Awaiting_Dependent_Termination and then
(The_Task.Master_Block = Master_Task.Current_Layer) then
if Master_Layer.Non_Terminated > 0 then
Collective_Termination (Master_Layer,
Current_Task => Current_Task);
end if;
Message_Queue_Utilities.Send_Reply
(Master_Task, Dependents_Terminated,
Current_Task => Current_Task);
elsif Master_Layer.Coldness = Cool then
Master_Layer.Coldness := Cold;
Next_Layer := Master_Layer.Layer_Link;
while Next_Layer /= null loop
if Next_Layer.Non_Terminable <= 0 then
Next_Layer.Coldness := Cold;
Next_Layer := Next_Layer.Layer_Link;
else
Next_Layer.Coldness := Cool;
exit;
end if;
end loop;
if Next_Layer = null then
Make_Masters_Cold (Master_Task,
Current_Task => Current_Task);
end if;
end if;
end;
end Make_Masters_Cold;
procedure Task_Completion is
pragma Routine_Number (Runtime_Ids.Task_Completion);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
begin
if Debug_Mode then
Debugging.Put_Message ("Entered Task_Completion");
end if;
if not Current_Task.Action_State (Abnormal) then
-- If abnormal, then aborter has already deleted entry queues
-- mark task as non_callable and delete entry queues
Delete_Entry_Queues (The_Task => Current_Task,
Current_Task => Current_Task);
end if;
Do_Await_Dependents (Current_Task);
Release_Lock;
end Task_Completion;
procedure Task_End is
pragma Routine_Number (Runtime_Ids.Task_End);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
begin
if Debug_Mode then
Debugging.Put_Message ("Entered Task_End");
end if;
if not Current_Task.Action_State (Activation_Done) then
Creation_And_Activation.Notify_Parent_Internal
(Tasking_Error_Found => (Current_Task.Exception_Id /= null),
Current_Task => Current_Task);
end if;
if not Current_Task.Action_State (Non_Callable) then
-- If Non_Callable, then aborter has already deleted entry queues
-- else mark task as non_callable and delete entry queues
Delete_Entry_Queues (Current_Task, Current_Task => Current_Task);
end if;
-- if Safety_Check and then (Current_Task.Current_Layer /= null) then
-- -- Tartan called Await_Dependents here instead
-- -- of Raise_Runtime_Error.
--
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Task_End", "Current layer is non-null",
-- Err.Layer_State_Inconsistency,
-- Current_Task => Current_Task);
-- end if;
Current_Task.Suspension_State := Terminated;
if not Current_Task.Action_State (Selecting_Termination) then
-- If terminating via a select-with-terminate-alternative, then
-- already made masters cold.
Make_Masters_Cold (Current_Task, Current_Task => Current_Task);
end if;
if Current_Task.Action_State (Parent_Or_Child_Ok_Tcb_Reclamation) then
Message_Queue_Utilities.Send_Reply
(Current_Task.Master_Block.Master_Task, Child_Tcb_Reclaimable,
Current_Task => Current_Task);
else
Current_Task.Action_State (Parent_Or_Child_Ok_Tcb_Reclamation) :=
True;
end if;
-- if Debug_Mode then
-- Debugging.Put_Message
-- ("In Task_Management.Task_End, about to call OS9_Ops.Suicide");
-- end if;
Release_Lock;
Process_Ops.Suicide;
-- if Debug_Mode then
-- Debugging.Put_Message ("*** ERROR - Task_End returning to caller");
-- end if;
end Task_End;
procedure Terminate_Activation_Group
(First_In_Group : Task_Id; Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Next_Task : Task_Id := First_In_Group;
begin
if (First_In_Group /= null) and then
(First_In_Group.Suspension_State = Not_Activated) then
loop
-- if Safety_Check and then
-- (Next_Task.Suspension_State /= Not_Activated) then
--
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Terminate_Activation_Group",
-- "Group member has been activated",
-- Err.Suspension_State_Inconsistency,
-- Current_Task => Current_Task);
-- end if;
Forced_Termination (Next_Task,
Term_Via_Abort => False,
Current_Task => Current_Task);
-- Until a task is activated, the Callers_Link field is
-- used to store the link to the next member of the
-- activation group.
--
Next_Task := Next_Task.Callers_Link.Next;
exit when Next_Task = null;
end loop;
end if;
end Terminate_Activation_Group;
procedure Terminate_Allocated_Offspring (Activation_Group : Group_Ref) is
pragma Routine_Number (Runtime_Ids.Terminate_Allocated_Offspring);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
First_In_Group : Task_Id := Activation_Group.all;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Terminate_Allocated_Offspring");
-- end if;
Activation_Group.all := null;
Terminate_Activation_Group (First_In_Group => First_In_Group,
Current_Task => Current_Task);
Release_Lock;
end Terminate_Allocated_Offspring;
procedure Terminate_Dependent_Offspring is
pragma Routine_Number (Runtime_Ids.Terminate_Dependent_Offspring);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
First_In_Group : Task_Id :=
Current_Task.Current_Layer.Dependent_Task_List.Next;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Terminate_Dependent_Offspring");
-- end if;
while First_In_Group /= null loop
if First_In_Group.Suspension_State = Not_Activated then
Terminate_Activation_Group (First_In_Group => First_In_Group,
Current_Task => Current_Task);
end if;
First_In_Group := First_In_Group.Layer_Link.Next;
end loop;
Release_Lock;
end Terminate_Dependent_Offspring;
procedure Abortion (The_Task : Task_Id; Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Next_Layer : Layer_Id;
Next_Child : Task_Id;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Abortion");
-- end if;
--
-- if Safety_Check then
-- Checking.Check_Task (The_Task, "Abortion",
-- Current_Task => Current_Task);
-- if The_Task.Current_Layer /= null then
-- Checking.Check_Layer (The_Task.Current_Layer, "Abortion",
-- Current_Task => Current_Task);
-- end if;
-- end if;
Next_Layer := The_Task.Current_Layer;
while Next_Layer /= null loop
Next_Child := Next_Layer.Dependent_Task_List.Next;
while Next_Child /= null loop
Abortion (Next_Child, Current_Task => Current_Task);
Next_Child := Next_Child.Layer_Link.Next;
end loop;
Next_Layer := Next_Layer.Layer_Link;
end loop;
Forced_Termination (The_Task,
Term_Via_Abort => True,
Current_Task => Current_Task);
end Abortion;
procedure Abort_Main_Program is
pragma Routine_Number (Runtime_Ids.Internal);
-- The call to abort the main program is made from
-- serialization, so the lock is already held.
Current_Task : constant Task_Id := Task_Map.Get_Current_Task_Id;
begin
Abort_Main_Program_Flag := False;
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Abort_Main_Program");
-- end if;
Abortion (Root_Task_Ptr, Current_Task);
-- do not release the lock
end Abort_Main_Program;
procedure Abort_Multiple_Tasks
(Task_Count : Positive; The_First_Task : Task_Id) is
pragma Routine_Number
(Runtime_Ids.Abort_Multiple_Tasks, Pop_Params => False);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
type Task_Array is array (1 .. Task_Count) of Task_Id;
type Task_Array_Ref is access Task_Array;
for Task_Array_Ref'Storage_Size use 0;
function Convert is new Unchecked_Conversion
(System.Address, Task_Array_Ref);
Abortees : Task_Array renames Convert (The_First_Task'Address).all;
-- LRM 9.10(5) requires that if a task is blocked on an unaccepted
-- entry call at the time that it is aborted, then it must be
-- removed from the entry queue before the completion of the
-- execution of the abort statement. To implement this, the
-- Activations_In_Progress field of the TCB is flagrantly abused.
-- In the case of the abortee, this field is used to store the
-- Task_Id of the aborter; in the case of the aborter, this field
-- is used to store the count of abortees that were in this state
-- at the time of their abortion. If the count is non-zero, then
-- the aborter blocks, awaiting a reply. The count is decremented by
-- each of the "special" abortees after they have removed themselves
-- from the appropriate entry queue; the abortee who decrements
-- the count to zero sends a reply to unblock the aborter.
Aborted_While_Calling_Entry : Integer
renames Current_Task.Activations_In_Progress;
Reply : Reply_Kind;
begin
-- if Debug_Mode then
-- if Task_Count = 1 then
-- Debugging.Put_Message ("Entered Abort_Task");
-- else
-- Debugging.Put_Message ("Entered Abort_Multiple_Tasks");
-- end if;
-- end if;
Runtime_Exceptions.Check_For_Abnormality (Current_Task => Current_Task);
Aborted_While_Calling_Entry := 0;
for I in Abortees'Range loop
if Safety_Check then
Checking.Check_Task (Abortees (I), "Abort_Multiple_Tasks",
Current_Task => Current_Task);
end if;
Abortion (Abortees (I), Current_Task => Current_Task);
end loop;
if Aborted_While_Calling_Entry /= 0 then
Message_Queue_Utilities.Await_Reply
(Awaiting_Abortee_Reply, Reply, Current_Task => Current_Task);
if Safety_Check then
Checking.Check_Reply (Reply, Abortion_Acknowledged,
Current_Task => Current_Task);
-- if Aborted_While_Calling_Entry /= 0 then
-- Runtime_Exceptions.Raise_Runtime_Error
-- ("Abort_Multiple_Tasks",
-- "Aborter awakened with non-zero pending reply count: " &
-- Integer'Image (Aborted_While_Calling_Entry),
-- Err.Suspension_State_Inconsistency,
-- Current_Task => Current_Task);
-- end if;
end if;
end if;
Runtime_Exceptions.Check_For_Abnormality (Current_Task => Current_Task);
Release_Lock;
end Abort_Multiple_Tasks;
procedure Make_Eligible_For_Termination (Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Terminable : Boolean := True;
Next_Layer : Layer_Id := Current_Task.Current_Layer;
begin
-- if Safety_Check and then (Next_Layer /= null) then
-- Checking.Check_Layer (Next_Layer, "Make_Eligible_For_Termination",
-- Current_Task => Current_Task);
-- end if;
while Terminable and then Next_Layer /= null loop
if Next_Layer.Non_Terminable > 0 then
Terminable := False;
Next_Layer.Coldness := Cool;
else
Next_Layer.Coldness := Cold;
Next_Layer := Next_Layer.Layer_Link;
end if;
end loop;
if Terminable then
Termination_And_Abortion.Make_Masters_Cold
(Current_Task, Current_Task => Current_Task);
end if;
end Make_Eligible_For_Termination;
procedure Make_Ineligible_For_Termination (Current_Task : Task_Id) is
pragma Routine_Number (Runtime_Ids.Internal);
Next_Master : Task_Id := Current_Task;
Next_Layer : Layer_Id := Current_Task.Current_Layer;
begin
loop
-- if Safety_Check and then (Next_Layer /= null) then
-- Checking.Check_Layer (Next_Layer,
-- "Make_Ineligible_For_Termination",
-- Current_Task => Current_Task);
-- end if;
while Next_Layer /= null loop
if Next_Layer.Coldness = Cold then
Next_Layer.Coldness := Warm;
Next_Layer := Next_Layer.Layer_Link;
elsif Next_Layer.Coldness = Cool then
Next_Layer.Coldness := Warm;
return;
elsif Next_Layer.Coldness = Warm then
return;
else -- root or illegal
Runtime_Exceptions.Raise_Runtime_Error
("MIFT", "bad layer inner loop",
Err.Layer_State_Inconsistency,
Current_Task => Current_Task);
end if;
end loop;
Next_Layer := Next_Master.Master_Block;
Next_Master := Next_Layer.Master_Task;
Next_Layer.Non_Terminable := Next_Layer.Non_Terminable + 1;
if Next_Layer.Coldness = Cold then
Next_Layer.Coldness := Cool;
Next_Layer := Next_Layer.Layer_Link;
elsif Next_Layer.Coldness = Cool or else
Next_Layer.Coldness = Warm then
return;
else -- Root
Runtime_Exceptions.Raise_Runtime_Error
("MIFT", "root layer outer loop",
Err.Layer_State_Inconsistency,
Current_Task => Current_Task);
end if;
end loop;
end Make_Ineligible_For_Termination;
function Check_Return_Task
(The_Task : Task_Id; Ptr_Stack_Frame : System_Address)
return Boolean is
pragma Routine_Number (Runtime_Ids.Check_Return_Task);
Current_Task : constant Task_Id := Get_Current_Task_And_Acquire_Lock;
Result : Boolean;
begin
-- if Debug_Mode then
-- Debugging.Put_Message ("Entered Check_Return_Task");
-- end if;
--
-- if Safety_Check then
-- Checking.Check_Task (The_Task, "Check_Return_Task",
-- Current_Task => Current_Task);
-- end if;
-- Result := Addressing.Is_Contained
-- (The_Task.Master_Block,
-- Frame_Begin => Ptr_Stack_Frame,
-- Frame_End => Current_Task.Stack_Bounds.First);
--
declare
Middle : System_Address := The_Task.Master_Block.all'Address;
begin
--return (Frame_End <= Middle) and then (Middle < Frame_Begin);
Result := (Le (Current_Task.Stack_Bounds.First, Middle)) and then
(Lt (Middle, Ptr_Stack_Frame));
end;
Release_Lock;
return Result;
end Check_Return_Task;
end Termination_And_Abortion;
pragma Runtime_Unit (Unit_Number => Runtime_Ids.Runtime_Compunit,
Elab_Routine_Number => Runtime_Ids.Internal);