626 lines
17 KiB
Ada
626 lines
17 KiB
Ada
|
------------------------------------------------------------------------------
|
||
|
|
-- --
|
||
|
|
-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
|
||
|
|
-- --
|
||
|
|
-- S Y S T E M . T A S K I N G . Q U E U I N G --
|
||
|
|
-- --
|
||
|
|
-- B o d y --
|
||
|
|
-- --
|
||
|
|
-- Copyright (C) 1992-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 version of the body implements queueing policy according to the policy
|
||
|
|
-- specified by the pragma Queuing_Policy. When no such pragma is specified
|
||
|
|
-- FIFO policy is used as default.
|
||
|
|
|
||
|
|
with System.Task_Primitives.Operations;
|
||
|
|
with System.Tasking.Initialization;
|
||
|
|
with System.Parameters;
|
||
|
|
|
||
|
|
package body System.Tasking.Queuing is
|
||
|
|
|
||
|
|
use Parameters;
|
||
|
|
use Task_Primitives.Operations;
|
||
|
|
use Protected_Objects;
|
||
|
|
use Protected_Objects.Entries;
|
||
|
|
|
||
|
|
-- Entry Queues implemented as doubly linked list
|
||
|
|
|
||
|
|
Queuing_Policy : Character;
|
||
|
|
pragma Import (C, Queuing_Policy, "__gl_queuing_policy");
|
||
|
|
|
||
|
|
Priority_Queuing : constant Boolean := Queuing_Policy = 'P';
|
||
|
|
|
||
|
|
procedure Send_Program_Error
|
||
|
|
(Self_ID : Task_Id;
|
||
|
|
Entry_Call : Entry_Call_Link);
|
||
|
|
-- Raise Program_Error in the caller of the specified entry call
|
||
|
|
|
||
|
|
function Check_Queue (E : Entry_Queue) return Boolean;
|
||
|
|
-- Check the validity of E.
|
||
|
|
-- Return True if E is valid, raise Assert_Failure if assertions are
|
||
|
|
-- enabled and False otherwise.
|
||
|
|
|
||
|
|
-----------------------------
|
||
|
|
-- Broadcast_Program_Error --
|
||
|
|
-----------------------------
|
||
|
|
|
||
|
|
procedure Broadcast_Program_Error
|
||
|
|
(Self_ID : Task_Id;
|
||
|
|
Object : Protection_Entries_Access;
|
||
|
|
Pending_Call : Entry_Call_Link;
|
||
|
|
RTS_Locked : Boolean := False)
|
||
|
|
is
|
||
|
|
Entry_Call : Entry_Call_Link;
|
||
|
|
begin
|
||
|
|
if Single_Lock and then not RTS_Locked then
|
||
|
|
Lock_RTS;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
if Pending_Call /= null then
|
||
|
|
Send_Program_Error (Self_ID, Pending_Call);
|
||
|
|
end if;
|
||
|
|
|
||
|
|
for E in Object.Entry_Queues'Range loop
|
||
|
|
Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
|
||
|
|
|
||
|
|
while Entry_Call /= null loop
|
||
|
|
pragma Assert (Entry_Call.Mode /= Conditional_Call);
|
||
|
|
|
||
|
|
Send_Program_Error (Self_ID, Entry_Call);
|
||
|
|
Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
|
||
|
|
end loop;
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
if Single_Lock and then not RTS_Locked then
|
||
|
|
Unlock_RTS;
|
||
|
|
end if;
|
||
|
|
end Broadcast_Program_Error;
|
||
|
|
|
||
|
|
-----------------
|
||
|
|
-- Check_Queue --
|
||
|
|
-----------------
|
||
|
|
|
||
|
|
function Check_Queue (E : Entry_Queue) return Boolean is
|
||
|
|
Valid : Boolean := True;
|
||
|
|
C, Prev : Entry_Call_Link;
|
||
|
|
|
||
|
|
begin
|
||
|
|
if E.Head = null then
|
||
|
|
if E.Tail /= null then
|
||
|
|
Valid := False;
|
||
|
|
pragma Assert (Valid);
|
||
|
|
end if;
|
||
|
|
else
|
||
|
|
if E.Tail = null
|
||
|
|
or else E.Tail.Next /= E.Head
|
||
|
|
then
|
||
|
|
Valid := False;
|
||
|
|
pragma Assert (Valid);
|
||
|
|
|
||
|
|
else
|
||
|
|
C := E.Head;
|
||
|
|
|
||
|
|
loop
|
||
|
|
Prev := C;
|
||
|
|
C := C.Next;
|
||
|
|
|
||
|
|
if C = null then
|
||
|
|
Valid := False;
|
||
|
|
pragma Assert (Valid);
|
||
|
|
exit;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
if Prev /= C.Prev then
|
||
|
|
Valid := False;
|
||
|
|
pragma Assert (Valid);
|
||
|
|
exit;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
exit when C = E.Head;
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
if Prev /= E.Tail then
|
||
|
|
Valid := False;
|
||
|
|
pragma Assert (Valid);
|
||
|
|
end if;
|
||
|
|
end if;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
return Valid;
|
||
|
|
end Check_Queue;
|
||
|
|
|
||
|
|
-------------------
|
||
|
|
-- Count_Waiting --
|
||
|
|
-------------------
|
||
|
|
|
||
|
|
-- Return number of calls on the waiting queue of E
|
||
|
|
|
||
|
|
function Count_Waiting (E : Entry_Queue) return Natural is
|
||
|
|
Count : Natural;
|
||
|
|
Temp : Entry_Call_Link;
|
||
|
|
|
||
|
|
begin
|
||
|
|
pragma Assert (Check_Queue (E));
|
||
|
|
|
||
|
|
Count := 0;
|
||
|
|
|
||
|
|
if E.Head /= null then
|
||
|
|
Temp := E.Head;
|
||
|
|
|
||
|
|
loop
|
||
|
|
Count := Count + 1;
|
||
|
|
exit when E.Tail = Temp;
|
||
|
|
Temp := Temp.Next;
|
||
|
|
end loop;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
return Count;
|
||
|
|
end Count_Waiting;
|
||
|
|
|
||
|
|
-------------
|
||
|
|
-- Dequeue --
|
||
|
|
-------------
|
||
|
|
|
||
|
|
-- Dequeue call from entry_queue E
|
||
|
|
|
||
|
|
procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
|
||
|
|
begin
|
||
|
|
pragma Assert (Check_Queue (E));
|
||
|
|
pragma Assert (Call /= null);
|
||
|
|
|
||
|
|
-- If empty queue, simply return
|
||
|
|
|
||
|
|
if E.Head = null then
|
||
|
|
return;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
pragma Assert (Call.Prev /= null);
|
||
|
|
pragma Assert (Call.Next /= null);
|
||
|
|
|
||
|
|
Call.Prev.Next := Call.Next;
|
||
|
|
Call.Next.Prev := Call.Prev;
|
||
|
|
|
||
|
|
if E.Head = Call then
|
||
|
|
|
||
|
|
-- Case of one element
|
||
|
|
|
||
|
|
if E.Tail = Call then
|
||
|
|
E.Head := null;
|
||
|
|
E.Tail := null;
|
||
|
|
|
||
|
|
-- More than one element
|
||
|
|
|
||
|
|
else
|
||
|
|
E.Head := Call.Next;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
elsif E.Tail = Call then
|
||
|
|
E.Tail := Call.Prev;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
-- Successfully dequeued
|
||
|
|
|
||
|
|
Call.Prev := null;
|
||
|
|
Call.Next := null;
|
||
|
|
pragma Assert (Check_Queue (E));
|
||
|
|
end Dequeue;
|
||
|
|
|
||
|
|
------------------
|
||
|
|
-- Dequeue_Call --
|
||
|
|
------------------
|
||
|
|
|
||
|
|
procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is
|
||
|
|
Called_PO : Protection_Entries_Access;
|
||
|
|
|
||
|
|
begin
|
||
|
|
pragma Assert (Entry_Call /= null);
|
||
|
|
|
||
|
|
if Entry_Call.Called_Task /= null then
|
||
|
|
Dequeue
|
||
|
|
(Entry_Call.Called_Task.Entry_Queues
|
||
|
|
(Task_Entry_Index (Entry_Call.E)),
|
||
|
|
Entry_Call);
|
||
|
|
|
||
|
|
else
|
||
|
|
Called_PO := To_Protection (Entry_Call.Called_PO);
|
||
|
|
Dequeue (Called_PO.Entry_Queues
|
||
|
|
(Protected_Entry_Index (Entry_Call.E)),
|
||
|
|
Entry_Call);
|
||
|
|
end if;
|
||
|
|
end Dequeue_Call;
|
||
|
|
|
||
|
|
------------------
|
||
|
|
-- Dequeue_Head --
|
||
|
|
------------------
|
||
|
|
|
||
|
|
-- Remove and return the head of entry_queue E
|
||
|
|
|
||
|
|
procedure Dequeue_Head
|
||
|
|
(E : in out Entry_Queue;
|
||
|
|
Call : out Entry_Call_Link)
|
||
|
|
is
|
||
|
|
Temp : Entry_Call_Link;
|
||
|
|
|
||
|
|
begin
|
||
|
|
pragma Assert (Check_Queue (E));
|
||
|
|
-- If empty queue, return null pointer
|
||
|
|
|
||
|
|
if E.Head = null then
|
||
|
|
Call := null;
|
||
|
|
return;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
Temp := E.Head;
|
||
|
|
|
||
|
|
-- Case of one element
|
||
|
|
|
||
|
|
if E.Head = E.Tail then
|
||
|
|
E.Head := null;
|
||
|
|
E.Tail := null;
|
||
|
|
|
||
|
|
-- More than one element
|
||
|
|
|
||
|
|
else
|
||
|
|
pragma Assert (Temp /= null);
|
||
|
|
pragma Assert (Temp.Next /= null);
|
||
|
|
pragma Assert (Temp.Prev /= null);
|
||
|
|
|
||
|
|
E.Head := Temp.Next;
|
||
|
|
Temp.Prev.Next := Temp.Next;
|
||
|
|
Temp.Next.Prev := Temp.Prev;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
-- Successfully dequeued
|
||
|
|
|
||
|
|
Temp.Prev := null;
|
||
|
|
Temp.Next := null;
|
||
|
|
Call := Temp;
|
||
|
|
pragma Assert (Check_Queue (E));
|
||
|
|
end Dequeue_Head;
|
||
|
|
|
||
|
|
-------------
|
||
|
|
-- Enqueue --
|
||
|
|
-------------
|
||
|
|
|
||
|
|
-- Enqueue call at the end of entry_queue E, for FIFO queuing policy.
|
||
|
|
-- Enqueue call priority ordered, FIFO at same priority level, for
|
||
|
|
-- Priority queuing policy.
|
||
|
|
|
||
|
|
procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
|
||
|
|
Temp : Entry_Call_Link := E.Head;
|
||
|
|
|
||
|
|
begin
|
||
|
|
pragma Assert (Check_Queue (E));
|
||
|
|
pragma Assert (Call /= null);
|
||
|
|
|
||
|
|
-- Priority Queuing
|
||
|
|
|
||
|
|
if Priority_Queuing then
|
||
|
|
if Temp = null then
|
||
|
|
Call.Prev := Call;
|
||
|
|
Call.Next := Call;
|
||
|
|
E.Head := Call;
|
||
|
|
E.Tail := Call;
|
||
|
|
|
||
|
|
else
|
||
|
|
loop
|
||
|
|
-- Find the entry that the new guy should precede
|
||
|
|
|
||
|
|
exit when Call.Prio > Temp.Prio;
|
||
|
|
Temp := Temp.Next;
|
||
|
|
|
||
|
|
if Temp = E.Head then
|
||
|
|
Temp := null;
|
||
|
|
exit;
|
||
|
|
end if;
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
if Temp = null then
|
||
|
|
-- Insert at tail
|
||
|
|
|
||
|
|
Call.Prev := E.Tail;
|
||
|
|
Call.Next := E.Head;
|
||
|
|
E.Tail := Call;
|
||
|
|
|
||
|
|
else
|
||
|
|
Call.Prev := Temp.Prev;
|
||
|
|
Call.Next := Temp;
|
||
|
|
|
||
|
|
-- Insert at head
|
||
|
|
|
||
|
|
if Temp = E.Head then
|
||
|
|
E.Head := Call;
|
||
|
|
end if;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
pragma Assert (Call.Prev /= null);
|
||
|
|
pragma Assert (Call.Next /= null);
|
||
|
|
|
||
|
|
Call.Prev.Next := Call;
|
||
|
|
Call.Next.Prev := Call;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
pragma Assert (Check_Queue (E));
|
||
|
|
return;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
-- FIFO Queuing
|
||
|
|
|
||
|
|
if E.Head = null then
|
||
|
|
E.Head := Call;
|
||
|
|
else
|
||
|
|
E.Tail.Next := Call;
|
||
|
|
Call.Prev := E.Tail;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
E.Head.Prev := Call;
|
||
|
|
E.Tail := Call;
|
||
|
|
Call.Next := E.Head;
|
||
|
|
pragma Assert (Check_Queue (E));
|
||
|
|
end Enqueue;
|
||
|
|
|
||
|
|
------------------
|
||
|
|
-- Enqueue_Call --
|
||
|
|
------------------
|
||
|
|
|
||
|
|
procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is
|
||
|
|
Called_PO : Protection_Entries_Access;
|
||
|
|
|
||
|
|
begin
|
||
|
|
pragma Assert (Entry_Call /= null);
|
||
|
|
|
||
|
|
if Entry_Call.Called_Task /= null then
|
||
|
|
Enqueue
|
||
|
|
(Entry_Call.Called_Task.Entry_Queues
|
||
|
|
(Task_Entry_Index (Entry_Call.E)),
|
||
|
|
Entry_Call);
|
||
|
|
|
||
|
|
else
|
||
|
|
Called_PO := To_Protection (Entry_Call.Called_PO);
|
||
|
|
Enqueue (Called_PO.Entry_Queues
|
||
|
|
(Protected_Entry_Index (Entry_Call.E)),
|
||
|
|
Entry_Call);
|
||
|
|
end if;
|
||
|
|
end Enqueue_Call;
|
||
|
|
|
||
|
|
----------
|
||
|
|
-- Head --
|
||
|
|
----------
|
||
|
|
|
||
|
|
-- Return the head of entry_queue E
|
||
|
|
|
||
|
|
function Head (E : Entry_Queue) return Entry_Call_Link is
|
||
|
|
begin
|
||
|
|
pragma Assert (Check_Queue (E));
|
||
|
|
return E.Head;
|
||
|
|
end Head;
|
||
|
|
|
||
|
|
-------------
|
||
|
|
-- Onqueue --
|
||
|
|
-------------
|
||
|
|
|
||
|
|
-- Return True if Call is on any entry_queue at all
|
||
|
|
|
||
|
|
function Onqueue (Call : Entry_Call_Link) return Boolean is
|
||
|
|
begin
|
||
|
|
pragma Assert (Call /= null);
|
||
|
|
|
||
|
|
-- Utilize the fact that every queue is circular, so if Call
|
||
|
|
-- is on any queue at all, Call.Next must NOT be null.
|
||
|
|
|
||
|
|
return Call.Next /= null;
|
||
|
|
end Onqueue;
|
||
|
|
|
||
|
|
--------------------------------
|
||
|
|
-- Requeue_Call_With_New_Prio --
|
||
|
|
--------------------------------
|
||
|
|
|
||
|
|
procedure Requeue_Call_With_New_Prio
|
||
|
|
(Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is
|
||
|
|
begin
|
||
|
|
pragma Assert (Entry_Call /= null);
|
||
|
|
|
||
|
|
-- Perform a queue reordering only when the policy being used is the
|
||
|
|
-- Priority Queuing.
|
||
|
|
|
||
|
|
if Priority_Queuing then
|
||
|
|
if Onqueue (Entry_Call) then
|
||
|
|
Dequeue_Call (Entry_Call);
|
||
|
|
Entry_Call.Prio := Prio;
|
||
|
|
Enqueue_Call (Entry_Call);
|
||
|
|
end if;
|
||
|
|
end if;
|
||
|
|
end Requeue_Call_With_New_Prio;
|
||
|
|
|
||
|
|
---------------------------------
|
||
|
|
-- Select_Protected_Entry_Call --
|
||
|
|
---------------------------------
|
||
|
|
|
||
|
|
-- Select an entry of a protected object. Selection depends on the
|
||
|
|
-- queuing policy being used.
|
||
|
|
|
||
|
|
procedure Select_Protected_Entry_Call
|
||
|
|
(Self_ID : Task_Id;
|
||
|
|
Object : Protection_Entries_Access;
|
||
|
|
Call : out Entry_Call_Link)
|
||
|
|
is
|
||
|
|
Entry_Call : Entry_Call_Link;
|
||
|
|
Temp_Call : Entry_Call_Link;
|
||
|
|
Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning
|
||
|
|
|
||
|
|
begin
|
||
|
|
Entry_Call := null;
|
||
|
|
|
||
|
|
begin
|
||
|
|
-- Priority queuing case
|
||
|
|
|
||
|
|
if Priority_Queuing then
|
||
|
|
for J in Object.Entry_Queues'Range loop
|
||
|
|
Temp_Call := Head (Object.Entry_Queues (J));
|
||
|
|
|
||
|
|
if Temp_Call /= null
|
||
|
|
and then
|
||
|
|
Object.Entry_Bodies
|
||
|
|
(Object.Find_Body_Index
|
||
|
|
(Object.Compiler_Info, J)).
|
||
|
|
Barrier (Object.Compiler_Info, J)
|
||
|
|
then
|
||
|
|
if Entry_Call = null
|
||
|
|
or else Entry_Call.Prio < Temp_Call.Prio
|
||
|
|
then
|
||
|
|
Entry_Call := Temp_Call;
|
||
|
|
Entry_Index := J;
|
||
|
|
end if;
|
||
|
|
end if;
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
-- FIFO queueing case
|
||
|
|
|
||
|
|
else
|
||
|
|
for J in Object.Entry_Queues'Range loop
|
||
|
|
Temp_Call := Head (Object.Entry_Queues (J));
|
||
|
|
|
||
|
|
if Temp_Call /= null
|
||
|
|
and then
|
||
|
|
Object.Entry_Bodies
|
||
|
|
(Object.Find_Body_Index
|
||
|
|
(Object.Compiler_Info, J)).
|
||
|
|
Barrier (Object.Compiler_Info, J)
|
||
|
|
then
|
||
|
|
Entry_Call := Temp_Call;
|
||
|
|
Entry_Index := J;
|
||
|
|
exit;
|
||
|
|
end if;
|
||
|
|
end loop;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
exception
|
||
|
|
when others =>
|
||
|
|
Broadcast_Program_Error (Self_ID, Object, null);
|
||
|
|
end;
|
||
|
|
|
||
|
|
-- If a call was selected, dequeue it and return it for service
|
||
|
|
|
||
|
|
if Entry_Call /= null then
|
||
|
|
Temp_Call := Entry_Call;
|
||
|
|
Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);
|
||
|
|
pragma Assert (Temp_Call = Entry_Call);
|
||
|
|
end if;
|
||
|
|
|
||
|
|
Call := Entry_Call;
|
||
|
|
end Select_Protected_Entry_Call;
|
||
|
|
|
||
|
|
----------------------------
|
||
|
|
-- Select_Task_Entry_Call --
|
||
|
|
----------------------------
|
||
|
|
|
||
|
|
-- Select an entry for rendezvous. Selection depends on the queuing policy
|
||
|
|
-- being used.
|
||
|
|
|
||
|
|
procedure Select_Task_Entry_Call
|
||
|
|
(Acceptor : Task_Id;
|
||
|
|
Open_Accepts : Accept_List_Access;
|
||
|
|
Call : out Entry_Call_Link;
|
||
|
|
Selection : out Select_Index;
|
||
|
|
Open_Alternative : out Boolean)
|
||
|
|
is
|
||
|
|
Entry_Call : Entry_Call_Link;
|
||
|
|
Temp_Call : Entry_Call_Link;
|
||
|
|
Entry_Index : Task_Entry_Index := Task_Entry_Index'First;
|
||
|
|
Temp_Entry : Task_Entry_Index;
|
||
|
|
|
||
|
|
begin
|
||
|
|
Open_Alternative := False;
|
||
|
|
Entry_Call := null;
|
||
|
|
Selection := No_Rendezvous;
|
||
|
|
|
||
|
|
if Priority_Queuing then
|
||
|
|
-- Priority queueing case
|
||
|
|
|
||
|
|
for J in Open_Accepts'Range loop
|
||
|
|
Temp_Entry := Open_Accepts (J).S;
|
||
|
|
|
||
|
|
if Temp_Entry /= Null_Task_Entry then
|
||
|
|
Open_Alternative := True;
|
||
|
|
Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
|
||
|
|
|
||
|
|
if Temp_Call /= null
|
||
|
|
and then (Entry_Call = null
|
||
|
|
or else Entry_Call.Prio < Temp_Call.Prio)
|
||
|
|
then
|
||
|
|
Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
|
||
|
|
Entry_Index := Temp_Entry;
|
||
|
|
Selection := J;
|
||
|
|
end if;
|
||
|
|
end if;
|
||
|
|
end loop;
|
||
|
|
|
||
|
|
else
|
||
|
|
-- FIFO Queuing case
|
||
|
|
|
||
|
|
for J in Open_Accepts'Range loop
|
||
|
|
Temp_Entry := Open_Accepts (J).S;
|
||
|
|
|
||
|
|
if Temp_Entry /= Null_Task_Entry then
|
||
|
|
Open_Alternative := True;
|
||
|
|
Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
|
||
|
|
|
||
|
|
if Temp_Call /= null then
|
||
|
|
Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
|
||
|
|
Entry_Index := Temp_Entry;
|
||
|
|
Selection := J;
|
||
|
|
exit;
|
||
|
|
end if;
|
||
|
|
end if;
|
||
|
|
end loop;
|
||
|
|
end if;
|
||
|
|
|
||
|
|
if Entry_Call /= null then
|
||
|
|
Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);
|
||
|
|
|
||
|
|
-- Guard is open
|
||
|
|
end if;
|
||
|
|
|
||
|
|
Call := Entry_Call;
|
||
|
|
end Select_Task_Entry_Call;
|
||
|
|
|
||
|
|
------------------------
|
||
|
|
-- Send_Program_Error --
|
||
|
|
------------------------
|
||
|
|
|
||
|
|
procedure Send_Program_Error
|
||
|
|
(Self_ID : Task_Id;
|
||
|
|
Entry_Call : Entry_Call_Link)
|
||
|
|
is
|
||
|
|
Caller : Task_Id;
|
||
|
|
begin
|
||
|
|
Caller := Entry_Call.Self;
|
||
|
|
Entry_Call.Exception_To_Raise := Program_Error'Identity;
|
||
|
|
Write_Lock (Caller);
|
||
|
|
Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
|
||
|
|
Unlock (Caller);
|
||
|
|
end Send_Program_Error;
|
||
|
|
|
||
|
|
end System.Tasking.Queuing;
|