1 ------------------------------------------------------------------------------
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
5 -- S Y S T E M . T A S K I N G . Q U E U I N G --
9 -- Copyright (C) 1992-2006, Free Software Foundation, Inc. --
11 -- GNARL is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 2, or (at your option) any later ver- --
14 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNARL; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- GNARL was developed by the GNARL team at Florida State University. --
30 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
32 ------------------------------------------------------------------------------
34 -- This version of the body implements queueing policy according to the
35 -- policy specified by the pragma Queuing_Policy. When no such pragma
36 -- is specified FIFO policy is used as default.
38 with System.Task_Primitives.Operations;
39 -- used for Write_Lock
42 with System.Tasking.Initialization;
43 -- used for Wakeup_Entry_Caller
45 with System.Parameters;
46 -- used for Single_Lock
48 package body System.Tasking.Queuing is
51 use Task_Primitives.Operations;
52 use Protected_Objects;
53 use Protected_Objects.Entries;
55 -- Entry Queues implemented as doubly linked list
57 Queuing_Policy : Character;
58 pragma Import (C, Queuing_Policy, "__gl_queuing_policy");
60 Priority_Queuing : constant Boolean := Queuing_Policy = 'P';
62 procedure Send_Program_Error
64 Entry_Call : Entry_Call_Link);
65 -- Raise Program_Error in the caller of the specified entry call
67 function Check_Queue (E : Entry_Queue) return Boolean;
68 -- Check the validity of E.
69 -- Return True if E is valid, raise Assert_Failure if assertions are
70 -- enabled and False otherwise.
72 -----------------------------
73 -- Broadcast_Program_Error --
74 -----------------------------
76 procedure Broadcast_Program_Error
78 Object : Protection_Entries_Access;
79 Pending_Call : Entry_Call_Link;
80 RTS_Locked : Boolean := False)
82 Entry_Call : Entry_Call_Link;
84 if Single_Lock and then not RTS_Locked then
88 if Pending_Call /= null then
89 Send_Program_Error (Self_ID, Pending_Call);
92 for E in Object.Entry_Queues'Range loop
93 Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
95 while Entry_Call /= null loop
96 pragma Assert (Entry_Call.Mode /= Conditional_Call);
98 Send_Program_Error (Self_ID, Entry_Call);
99 Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
103 if Single_Lock and then not RTS_Locked then
106 end Broadcast_Program_Error;
112 function Check_Queue (E : Entry_Queue) return Boolean is
113 Valid : Boolean := True;
114 C, Prev : Entry_Call_Link;
117 if E.Head = null then
118 if E.Tail /= null then
120 pragma Assert (Valid);
124 or else E.Tail.Next /= E.Head
127 pragma Assert (Valid);
138 pragma Assert (Valid);
142 if Prev /= C.Prev then
144 pragma Assert (Valid);
148 exit when C = E.Head;
151 if Prev /= E.Tail then
153 pragma Assert (Valid);
165 -- Return number of calls on the waiting queue of E
167 function Count_Waiting (E : Entry_Queue) return Natural is
169 Temp : Entry_Call_Link;
172 pragma Assert (Check_Queue (E));
176 if E.Head /= null then
181 exit when E.Tail = Temp;
193 -- Dequeue call from entry_queue E
195 procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
197 pragma Assert (Check_Queue (E));
198 pragma Assert (Call /= null);
200 -- If empty queue, simply return
202 if E.Head = null then
206 pragma Assert (Call.Prev /= null);
207 pragma Assert (Call.Next /= null);
209 Call.Prev.Next := Call.Next;
210 Call.Next.Prev := Call.Prev;
212 if E.Head = Call then
214 -- Case of one element
216 if E.Tail = Call then
220 -- More than one element
226 elsif E.Tail = Call then
230 -- Successfully dequeued
234 pragma Assert (Check_Queue (E));
241 procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is
242 Called_PO : Protection_Entries_Access;
245 pragma Assert (Entry_Call /= null);
247 if Entry_Call.Called_Task /= null then
249 (Entry_Call.Called_Task.Entry_Queues
250 (Task_Entry_Index (Entry_Call.E)),
254 Called_PO := To_Protection (Entry_Call.Called_PO);
255 Dequeue (Called_PO.Entry_Queues
256 (Protected_Entry_Index (Entry_Call.E)),
265 -- Remove and return the head of entry_queue E
267 procedure Dequeue_Head
268 (E : in out Entry_Queue;
269 Call : out Entry_Call_Link)
271 Temp : Entry_Call_Link;
274 pragma Assert (Check_Queue (E));
275 -- If empty queue, return null pointer
277 if E.Head = null then
284 -- Case of one element
286 if E.Head = E.Tail then
290 -- More than one element
293 pragma Assert (Temp /= null);
294 pragma Assert (Temp.Next /= null);
295 pragma Assert (Temp.Prev /= null);
298 Temp.Prev.Next := Temp.Next;
299 Temp.Next.Prev := Temp.Prev;
302 -- Successfully dequeued
307 pragma Assert (Check_Queue (E));
314 -- Enqueue call at the end of entry_queue E, for FIFO queuing policy.
315 -- Enqueue call priority ordered, FIFO at same priority level, for
316 -- Priority queuing policy.
318 procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
319 Temp : Entry_Call_Link := E.Head;
322 pragma Assert (Check_Queue (E));
323 pragma Assert (Call /= null);
327 if Priority_Queuing then
336 -- Find the entry that the new guy should precede
338 exit when Call.Prio > Temp.Prio;
341 if Temp = E.Head then
355 Call.Prev := Temp.Prev;
360 if Temp = E.Head then
365 pragma Assert (Call.Prev /= null);
366 pragma Assert (Call.Next /= null);
368 Call.Prev.Next := Call;
369 Call.Next.Prev := Call;
372 pragma Assert (Check_Queue (E));
378 if E.Head = null then
388 pragma Assert (Check_Queue (E));
395 procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is
396 Called_PO : Protection_Entries_Access;
399 pragma Assert (Entry_Call /= null);
401 if Entry_Call.Called_Task /= null then
403 (Entry_Call.Called_Task.Entry_Queues
404 (Task_Entry_Index (Entry_Call.E)),
408 Called_PO := To_Protection (Entry_Call.Called_PO);
409 Enqueue (Called_PO.Entry_Queues
410 (Protected_Entry_Index (Entry_Call.E)),
419 -- Return the head of entry_queue E
421 function Head (E : Entry_Queue) return Entry_Call_Link is
423 pragma Assert (Check_Queue (E));
431 -- Return True if Call is on any entry_queue at all
433 function Onqueue (Call : Entry_Call_Link) return Boolean is
435 pragma Assert (Call /= null);
437 -- Utilize the fact that every queue is circular, so if Call
438 -- is on any queue at all, Call.Next must NOT be null.
440 return Call.Next /= null;
443 --------------------------------
444 -- Requeue_Call_With_New_Prio --
445 --------------------------------
447 procedure Requeue_Call_With_New_Prio
448 (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is
450 pragma Assert (Entry_Call /= null);
452 -- Perform a queue reordering only when the policy being used is the
455 if Priority_Queuing then
456 if Onqueue (Entry_Call) then
457 Dequeue_Call (Entry_Call);
458 Entry_Call.Prio := Prio;
459 Enqueue_Call (Entry_Call);
462 end Requeue_Call_With_New_Prio;
464 ---------------------------------
465 -- Select_Protected_Entry_Call --
466 ---------------------------------
468 -- Select an entry of a protected object. Selection depends on the
469 -- queuing policy being used.
471 procedure Select_Protected_Entry_Call
473 Object : Protection_Entries_Access;
474 Call : out Entry_Call_Link)
476 Entry_Call : Entry_Call_Link;
477 Temp_Call : Entry_Call_Link;
478 Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning
484 -- Priority queuing case
486 if Priority_Queuing then
487 for J in Object.Entry_Queues'Range loop
488 Temp_Call := Head (Object.Entry_Queues (J));
493 (Object.Find_Body_Index
494 (Object.Compiler_Info, J)).
495 Barrier (Object.Compiler_Info, J)
498 or else Entry_Call.Prio < Temp_Call.Prio
500 Entry_Call := Temp_Call;
506 -- FIFO queueing case
509 for J in Object.Entry_Queues'Range loop
510 Temp_Call := Head (Object.Entry_Queues (J));
515 (Object.Find_Body_Index
516 (Object.Compiler_Info, J)).
517 Barrier (Object.Compiler_Info, J)
519 Entry_Call := Temp_Call;
528 Broadcast_Program_Error (Self_ID, Object, null);
531 -- If a call was selected, dequeue it and return it for service
533 if Entry_Call /= null then
534 Temp_Call := Entry_Call;
535 Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);
536 pragma Assert (Temp_Call = Entry_Call);
540 end Select_Protected_Entry_Call;
542 ----------------------------
543 -- Select_Task_Entry_Call --
544 ----------------------------
546 -- Select an entry for rendezvous. Selection depends on the queuing policy
549 procedure Select_Task_Entry_Call
551 Open_Accepts : Accept_List_Access;
552 Call : out Entry_Call_Link;
553 Selection : out Select_Index;
554 Open_Alternative : out Boolean)
556 Entry_Call : Entry_Call_Link;
557 Temp_Call : Entry_Call_Link;
558 Entry_Index : Task_Entry_Index := Task_Entry_Index'First;
559 Temp_Entry : Task_Entry_Index;
562 Open_Alternative := False;
564 Selection := No_Rendezvous;
566 if Priority_Queuing then
567 -- Priority queueing case
569 for J in Open_Accepts'Range loop
570 Temp_Entry := Open_Accepts (J).S;
572 if Temp_Entry /= Null_Task_Entry then
573 Open_Alternative := True;
574 Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
577 and then (Entry_Call = null
578 or else Entry_Call.Prio < Temp_Call.Prio)
580 Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
581 Entry_Index := Temp_Entry;
590 for J in Open_Accepts'Range loop
591 Temp_Entry := Open_Accepts (J).S;
593 if Temp_Entry /= Null_Task_Entry then
594 Open_Alternative := True;
595 Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
597 if Temp_Call /= null then
598 Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
599 Entry_Index := Temp_Entry;
607 if Entry_Call /= null then
608 Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);
614 end Select_Task_Entry_Call;
616 ------------------------
617 -- Send_Program_Error --
618 ------------------------
620 procedure Send_Program_Error
622 Entry_Call : Entry_Call_Link)
626 Caller := Entry_Call.Self;
627 Entry_Call.Exception_To_Raise := Program_Error'Identity;
629 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
631 end Send_Program_Error;
633 end System.Tasking.Queuing;