1 ------------------------------------------------------------------------------
3 -- GNU ADA 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 --
10 -- Copyright (C) 1992-2002, Free Software Foundation, Inc. --
12 -- GNARL is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNARL; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
21 -- MA 02111-1307, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- GNARL was developed by the GNARL team at Florida State University. It is --
31 -- now maintained by Ada Core Technologies, Inc. (http://www.gnat.com). --
33 ------------------------------------------------------------------------------
35 -- This version of the body implements queueing policy according to the
36 -- policy specified by the pragma Queuing_Policy. When no such pragma
37 -- is specified FIFO policy is used as default.
39 with System.Task_Primitives.Operations;
40 -- used for Write_Lock
43 with System.Tasking.Initialization;
44 -- used for Wakeup_Entry_Caller
46 with System.Parameters;
47 -- used for Single_Lock
49 package body System.Tasking.Queuing is
52 use Task_Primitives.Operations;
53 use Protected_Objects;
54 use Protected_Objects.Entries;
56 -- Entry Queues implemented as doubly linked list.
58 Queuing_Policy : Character;
59 pragma Import (C, Queuing_Policy, "__gl_queuing_policy");
61 Priority_Queuing : constant Boolean := Queuing_Policy = 'P';
63 procedure Send_Program_Error
65 Entry_Call : Entry_Call_Link);
66 -- Raise Program_Error in the caller of the specified entry call
68 function Check_Queue (E : Entry_Queue) return Boolean;
69 -- Check the validity of E.
70 -- Return True if E is valid, raise Assert_Failure if assertions are
71 -- enabled and False otherwise.
73 -----------------------------
74 -- Broadcast_Program_Error --
75 -----------------------------
77 procedure Broadcast_Program_Error
79 Object : Protection_Entries_Access;
80 Pending_Call : Entry_Call_Link;
81 RTS_Locked : Boolean := False)
83 Entry_Call : Entry_Call_Link;
85 if Single_Lock and then not RTS_Locked then
89 if Pending_Call /= null then
90 Send_Program_Error (Self_ID, Pending_Call);
93 for E in Object.Entry_Queues'Range loop
94 Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
96 while Entry_Call /= null loop
97 pragma Assert (Entry_Call.Mode /= Conditional_Call);
99 Send_Program_Error (Self_ID, Entry_Call);
100 Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
104 if Single_Lock and then not RTS_Locked then
107 end Broadcast_Program_Error;
113 function Check_Queue (E : Entry_Queue) return Boolean is
114 Valid : Boolean := True;
115 C, Prev : Entry_Call_Link;
118 if E.Head = null then
119 if E.Tail /= null then
121 pragma Assert (Valid);
125 or else E.Tail.Next /= E.Head
128 pragma Assert (Valid);
139 pragma Assert (Valid);
143 if Prev /= C.Prev then
145 pragma Assert (Valid);
149 exit when C = E.Head;
152 if Prev /= E.Tail then
154 pragma Assert (Valid);
166 -- Return number of calls on the waiting queue of E
168 function Count_Waiting (E : in Entry_Queue) return Natural is
170 Temp : Entry_Call_Link;
173 pragma Assert (Check_Queue (E));
177 if E.Head /= null then
182 exit when E.Tail = Temp;
194 -- Dequeue call from entry_queue E
196 procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
198 pragma Assert (Check_Queue (E));
199 pragma Assert (Call /= null);
201 -- If empty queue, simply return
203 if E.Head = null then
207 pragma Assert (Call.Prev /= null);
208 pragma Assert (Call.Next /= null);
210 Call.Prev.Next := Call.Next;
211 Call.Next.Prev := Call.Prev;
213 if E.Head = Call then
215 -- Case of one element
217 if E.Tail = Call then
221 -- More than one element
227 elsif E.Tail = Call then
231 -- Successfully dequeued
235 pragma Assert (Check_Queue (E));
242 procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is
243 Called_PO : Protection_Entries_Access;
246 pragma Assert (Entry_Call /= null);
248 if Entry_Call.Called_Task /= null then
250 (Entry_Call.Called_Task.Entry_Queues
251 (Task_Entry_Index (Entry_Call.E)),
255 Called_PO := To_Protection (Entry_Call.Called_PO);
256 Dequeue (Called_PO.Entry_Queues
257 (Protected_Entry_Index (Entry_Call.E)),
266 -- Remove and return the head of entry_queue E
268 procedure Dequeue_Head
269 (E : in out Entry_Queue;
270 Call : out Entry_Call_Link)
272 Temp : Entry_Call_Link;
275 pragma Assert (Check_Queue (E));
276 -- If empty queue, return null pointer
278 if E.Head = null then
285 -- Case of one element
287 if E.Head = E.Tail then
291 -- More than one element
294 pragma Assert (Temp /= null);
295 pragma Assert (Temp.Next /= null);
296 pragma Assert (Temp.Prev /= null);
299 Temp.Prev.Next := Temp.Next;
300 Temp.Next.Prev := Temp.Prev;
303 -- Successfully dequeued
308 pragma Assert (Check_Queue (E));
315 -- Enqueue call at the end of entry_queue E, for FIFO queuing policy.
316 -- Enqueue call priority ordered, FIFO at same priority level, for
317 -- Priority queuing policy.
319 procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
320 Temp : Entry_Call_Link := E.Head;
323 pragma Assert (Check_Queue (E));
324 pragma Assert (Call /= null);
328 if Priority_Queuing then
337 -- Find the entry that the new guy should precede
339 exit when Call.Prio > Temp.Prio;
342 if Temp = E.Head then
356 Call.Prev := Temp.Prev;
361 if Temp = E.Head then
366 pragma Assert (Call.Prev /= null);
367 pragma Assert (Call.Next /= null);
369 Call.Prev.Next := Call;
370 Call.Next.Prev := Call;
373 pragma Assert (Check_Queue (E));
379 if E.Head = null then
389 pragma Assert (Check_Queue (E));
396 procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is
397 Called_PO : Protection_Entries_Access;
400 pragma Assert (Entry_Call /= null);
402 if Entry_Call.Called_Task /= null then
404 (Entry_Call.Called_Task.Entry_Queues
405 (Task_Entry_Index (Entry_Call.E)),
409 Called_PO := To_Protection (Entry_Call.Called_PO);
410 Enqueue (Called_PO.Entry_Queues
411 (Protected_Entry_Index (Entry_Call.E)),
420 -- Return the head of entry_queue E
422 function Head (E : in Entry_Queue) return Entry_Call_Link is
424 pragma Assert (Check_Queue (E));
432 -- Return True if Call is on any entry_queue at all
434 function Onqueue (Call : Entry_Call_Link) return Boolean is
436 pragma Assert (Call /= null);
438 -- Utilize the fact that every queue is circular, so if Call
439 -- is on any queue at all, Call.Next must NOT be null.
441 return Call.Next /= null;
444 --------------------------------
445 -- Requeue_Call_With_New_Prio --
446 --------------------------------
448 procedure Requeue_Call_With_New_Prio
449 (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is
451 pragma Assert (Entry_Call /= null);
453 -- Perform a queue reordering only when the policy being used is the
456 if Priority_Queuing then
457 if Onqueue (Entry_Call) then
458 Dequeue_Call (Entry_Call);
459 Entry_Call.Prio := Prio;
460 Enqueue_Call (Entry_Call);
463 end Requeue_Call_With_New_Prio;
465 ---------------------------------
466 -- Select_Protected_Entry_Call --
467 ---------------------------------
469 -- Select an entry of a protected object. Selection depends on the
470 -- queuing policy being used.
472 procedure Select_Protected_Entry_Call
474 Object : Protection_Entries_Access;
475 Call : out Entry_Call_Link)
477 Entry_Call : Entry_Call_Link;
478 Temp_Call : Entry_Call_Link;
479 Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning
481 -- ??? should add comment as to why Entry_Index is always initialized
487 if Priority_Queuing then
491 for J in Object.Entry_Queues'Range loop
492 Temp_Call := Head (Object.Entry_Queues (J));
497 (Object.Find_Body_Index
498 (Object.Compiler_Info, J)).
499 Barrier (Object.Compiler_Info, J)
501 if (Entry_Call = null or else
502 Entry_Call.Prio < Temp_Call.Prio)
504 Entry_Call := Temp_Call;
513 for J in Object.Entry_Queues'Range loop
514 Temp_Call := Head (Object.Entry_Queues (J));
519 (Object.Find_Body_Index
520 (Object.Compiler_Info, J)).
521 Barrier (Object.Compiler_Info, J)
523 Entry_Call := Temp_Call;
532 Broadcast_Program_Error (Self_ID, Object, null);
535 -- If a call was selected, dequeue it and return it for service.
537 if Entry_Call /= null then
538 Temp_Call := Entry_Call;
539 Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);
540 pragma Assert (Temp_Call = Entry_Call);
544 end Select_Protected_Entry_Call;
546 ----------------------------
547 -- Select_Task_Entry_Call --
548 ----------------------------
550 -- Select an entry for rendezvous. Selection depends on the queuing policy
553 procedure Select_Task_Entry_Call
555 Open_Accepts : Accept_List_Access;
556 Call : out Entry_Call_Link;
557 Selection : out Select_Index;
558 Open_Alternative : out Boolean)
560 Entry_Call : Entry_Call_Link;
561 Temp_Call : Entry_Call_Link;
562 Entry_Index : Task_Entry_Index := Task_Entry_Index'First;
563 Temp_Entry : Task_Entry_Index;
566 Open_Alternative := False;
568 Selection := No_Rendezvous;
570 if Priority_Queuing then
571 -- Priority queueing case
573 for J in Open_Accepts'Range loop
574 Temp_Entry := Open_Accepts (J).S;
576 if Temp_Entry /= Null_Task_Entry then
577 Open_Alternative := True;
578 Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
581 and then (Entry_Call = null
582 or else Entry_Call.Prio < Temp_Call.Prio)
584 Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
585 Entry_Index := Temp_Entry;
594 for J in Open_Accepts'Range loop
595 Temp_Entry := Open_Accepts (J).S;
597 if Temp_Entry /= Null_Task_Entry then
598 Open_Alternative := True;
599 Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
601 if Temp_Call /= null then
602 Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
603 Entry_Index := Temp_Entry;
611 if Entry_Call /= null then
612 Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);
618 end Select_Task_Entry_Call;
620 ------------------------
621 -- Send_Program_Error --
622 ------------------------
624 procedure Send_Program_Error
626 Entry_Call : Entry_Call_Link)
630 Caller := Entry_Call.Self;
631 Entry_Call.Exception_To_Raise := Program_Error'Identity;
633 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
635 end Send_Program_Error;
637 end System.Tasking.Queuing;