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-2008, 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 policy
35 -- specified by the pragma Queuing_Policy. When no such pragma is specified
36 -- FIFO policy is used as default.
38 with System.Task_Primitives.Operations;
39 with System.Tasking.Initialization;
40 with System.Parameters;
42 package body System.Tasking.Queuing is
45 use Task_Primitives.Operations;
46 use Protected_Objects;
47 use Protected_Objects.Entries;
49 -- Entry Queues implemented as doubly linked list
51 Queuing_Policy : Character;
52 pragma Import (C, Queuing_Policy, "__gl_queuing_policy");
54 Priority_Queuing : constant Boolean := Queuing_Policy = 'P';
56 procedure Send_Program_Error
58 Entry_Call : Entry_Call_Link);
59 -- Raise Program_Error in the caller of the specified entry call
61 function Check_Queue (E : Entry_Queue) return Boolean;
62 -- Check the validity of E.
63 -- Return True if E is valid, raise Assert_Failure if assertions are
64 -- enabled and False otherwise.
66 -----------------------------
67 -- Broadcast_Program_Error --
68 -----------------------------
70 procedure Broadcast_Program_Error
72 Object : Protection_Entries_Access;
73 Pending_Call : Entry_Call_Link;
74 RTS_Locked : Boolean := False)
76 Entry_Call : Entry_Call_Link;
78 if Single_Lock and then not RTS_Locked then
82 if Pending_Call /= null then
83 Send_Program_Error (Self_ID, Pending_Call);
86 for E in Object.Entry_Queues'Range loop
87 Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
89 while Entry_Call /= null loop
90 pragma Assert (Entry_Call.Mode /= Conditional_Call);
92 Send_Program_Error (Self_ID, Entry_Call);
93 Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
97 if Single_Lock and then not RTS_Locked then
100 end Broadcast_Program_Error;
106 function Check_Queue (E : Entry_Queue) return Boolean is
107 Valid : Boolean := True;
108 C, Prev : Entry_Call_Link;
111 if E.Head = null then
112 if E.Tail /= null then
114 pragma Assert (Valid);
118 or else E.Tail.Next /= E.Head
121 pragma Assert (Valid);
132 pragma Assert (Valid);
136 if Prev /= C.Prev then
138 pragma Assert (Valid);
142 exit when C = E.Head;
145 if Prev /= E.Tail then
147 pragma Assert (Valid);
159 -- Return number of calls on the waiting queue of E
161 function Count_Waiting (E : Entry_Queue) return Natural is
163 Temp : Entry_Call_Link;
166 pragma Assert (Check_Queue (E));
170 if E.Head /= null then
175 exit when E.Tail = Temp;
187 -- Dequeue call from entry_queue E
189 procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
191 pragma Assert (Check_Queue (E));
192 pragma Assert (Call /= null);
194 -- If empty queue, simply return
196 if E.Head = null then
200 pragma Assert (Call.Prev /= null);
201 pragma Assert (Call.Next /= null);
203 Call.Prev.Next := Call.Next;
204 Call.Next.Prev := Call.Prev;
206 if E.Head = Call then
208 -- Case of one element
210 if E.Tail = Call then
214 -- More than one element
220 elsif E.Tail = Call then
224 -- Successfully dequeued
228 pragma Assert (Check_Queue (E));
235 procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is
236 Called_PO : Protection_Entries_Access;
239 pragma Assert (Entry_Call /= null);
241 if Entry_Call.Called_Task /= null then
243 (Entry_Call.Called_Task.Entry_Queues
244 (Task_Entry_Index (Entry_Call.E)),
248 Called_PO := To_Protection (Entry_Call.Called_PO);
249 Dequeue (Called_PO.Entry_Queues
250 (Protected_Entry_Index (Entry_Call.E)),
259 -- Remove and return the head of entry_queue E
261 procedure Dequeue_Head
262 (E : in out Entry_Queue;
263 Call : out Entry_Call_Link)
265 Temp : Entry_Call_Link;
268 pragma Assert (Check_Queue (E));
269 -- If empty queue, return null pointer
271 if E.Head = null then
278 -- Case of one element
280 if E.Head = E.Tail then
284 -- More than one element
287 pragma Assert (Temp /= null);
288 pragma Assert (Temp.Next /= null);
289 pragma Assert (Temp.Prev /= null);
292 Temp.Prev.Next := Temp.Next;
293 Temp.Next.Prev := Temp.Prev;
296 -- Successfully dequeued
301 pragma Assert (Check_Queue (E));
308 -- Enqueue call at the end of entry_queue E, for FIFO queuing policy.
309 -- Enqueue call priority ordered, FIFO at same priority level, for
310 -- Priority queuing policy.
312 procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
313 Temp : Entry_Call_Link := E.Head;
316 pragma Assert (Check_Queue (E));
317 pragma Assert (Call /= null);
321 if Priority_Queuing then
330 -- Find the entry that the new guy should precede
332 exit when Call.Prio > Temp.Prio;
335 if Temp = E.Head then
349 Call.Prev := Temp.Prev;
354 if Temp = E.Head then
359 pragma Assert (Call.Prev /= null);
360 pragma Assert (Call.Next /= null);
362 Call.Prev.Next := Call;
363 Call.Next.Prev := Call;
366 pragma Assert (Check_Queue (E));
372 if E.Head = null then
382 pragma Assert (Check_Queue (E));
389 procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is
390 Called_PO : Protection_Entries_Access;
393 pragma Assert (Entry_Call /= null);
395 if Entry_Call.Called_Task /= null then
397 (Entry_Call.Called_Task.Entry_Queues
398 (Task_Entry_Index (Entry_Call.E)),
402 Called_PO := To_Protection (Entry_Call.Called_PO);
403 Enqueue (Called_PO.Entry_Queues
404 (Protected_Entry_Index (Entry_Call.E)),
413 -- Return the head of entry_queue E
415 function Head (E : Entry_Queue) return Entry_Call_Link is
417 pragma Assert (Check_Queue (E));
425 -- Return True if Call is on any entry_queue at all
427 function Onqueue (Call : Entry_Call_Link) return Boolean is
429 pragma Assert (Call /= null);
431 -- Utilize the fact that every queue is circular, so if Call
432 -- is on any queue at all, Call.Next must NOT be null.
434 return Call.Next /= null;
437 --------------------------------
438 -- Requeue_Call_With_New_Prio --
439 --------------------------------
441 procedure Requeue_Call_With_New_Prio
442 (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is
444 pragma Assert (Entry_Call /= null);
446 -- Perform a queue reordering only when the policy being used is the
449 if Priority_Queuing then
450 if Onqueue (Entry_Call) then
451 Dequeue_Call (Entry_Call);
452 Entry_Call.Prio := Prio;
453 Enqueue_Call (Entry_Call);
456 end Requeue_Call_With_New_Prio;
458 ---------------------------------
459 -- Select_Protected_Entry_Call --
460 ---------------------------------
462 -- Select an entry of a protected object. Selection depends on the
463 -- queuing policy being used.
465 procedure Select_Protected_Entry_Call
467 Object : Protection_Entries_Access;
468 Call : out Entry_Call_Link)
470 Entry_Call : Entry_Call_Link;
471 Temp_Call : Entry_Call_Link;
472 Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning
478 -- Priority queuing case
480 if Priority_Queuing then
481 for J in Object.Entry_Queues'Range loop
482 Temp_Call := Head (Object.Entry_Queues (J));
487 (Object.Find_Body_Index
488 (Object.Compiler_Info, J)).
489 Barrier (Object.Compiler_Info, J)
492 or else Entry_Call.Prio < Temp_Call.Prio
494 Entry_Call := Temp_Call;
500 -- FIFO queueing case
503 for J in Object.Entry_Queues'Range loop
504 Temp_Call := Head (Object.Entry_Queues (J));
509 (Object.Find_Body_Index
510 (Object.Compiler_Info, J)).
511 Barrier (Object.Compiler_Info, J)
513 Entry_Call := Temp_Call;
522 Broadcast_Program_Error (Self_ID, Object, null);
525 -- If a call was selected, dequeue it and return it for service
527 if Entry_Call /= null then
528 Temp_Call := Entry_Call;
529 Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);
530 pragma Assert (Temp_Call = Entry_Call);
534 end Select_Protected_Entry_Call;
536 ----------------------------
537 -- Select_Task_Entry_Call --
538 ----------------------------
540 -- Select an entry for rendezvous. Selection depends on the queuing policy
543 procedure Select_Task_Entry_Call
545 Open_Accepts : Accept_List_Access;
546 Call : out Entry_Call_Link;
547 Selection : out Select_Index;
548 Open_Alternative : out Boolean)
550 Entry_Call : Entry_Call_Link;
551 Temp_Call : Entry_Call_Link;
552 Entry_Index : Task_Entry_Index := Task_Entry_Index'First;
553 Temp_Entry : Task_Entry_Index;
556 Open_Alternative := False;
558 Selection := No_Rendezvous;
560 if Priority_Queuing then
561 -- Priority queueing case
563 for J in Open_Accepts'Range loop
564 Temp_Entry := Open_Accepts (J).S;
566 if Temp_Entry /= Null_Task_Entry then
567 Open_Alternative := True;
568 Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
571 and then (Entry_Call = null
572 or else Entry_Call.Prio < Temp_Call.Prio)
574 Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
575 Entry_Index := Temp_Entry;
584 for J in Open_Accepts'Range loop
585 Temp_Entry := Open_Accepts (J).S;
587 if Temp_Entry /= Null_Task_Entry then
588 Open_Alternative := True;
589 Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
591 if Temp_Call /= null then
592 Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
593 Entry_Index := Temp_Entry;
601 if Entry_Call /= null then
602 Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);
608 end Select_Task_Entry_Call;
610 ------------------------
611 -- Send_Program_Error --
612 ------------------------
614 procedure Send_Program_Error
616 Entry_Call : Entry_Call_Link)
620 Caller := Entry_Call.Self;
621 Entry_Call.Exception_To_Raise := Program_Error'Identity;
623 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
625 end Send_Program_Error;
627 end System.Tasking.Queuing;