Daily bump.
[official-gcc.git] / gcc / ada / s-tasque.adb
blob5116c88c0e46ec6cc3640bd192eff86472983e40
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS --
4 -- --
5 -- S Y S T E M . T A S K I N G . Q U E U I N G --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 1992-2009, Free Software Foundation, Inc. --
10 -- --
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 3, or (at your option) any later ver- --
14 -- sion. GNAT 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. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNARL was developed by the GNARL team at Florida State University. --
28 -- Extensive contributions were provided by Ada Core Technologies, Inc. --
29 -- --
30 ------------------------------------------------------------------------------
32 -- This version of the body implements queueing policy according to the policy
33 -- specified by the pragma Queuing_Policy. When no such pragma is specified
34 -- FIFO policy is used as default.
36 with System.Task_Primitives.Operations;
37 with System.Tasking.Initialization;
38 with System.Parameters;
40 package body System.Tasking.Queuing is
42 use Parameters;
43 use Task_Primitives.Operations;
44 use Protected_Objects;
45 use Protected_Objects.Entries;
47 -- Entry Queues implemented as doubly linked list
49 Queuing_Policy : Character;
50 pragma Import (C, Queuing_Policy, "__gl_queuing_policy");
52 Priority_Queuing : constant Boolean := Queuing_Policy = 'P';
54 procedure Send_Program_Error
55 (Self_ID : Task_Id;
56 Entry_Call : Entry_Call_Link);
57 -- Raise Program_Error in the caller of the specified entry call
59 function Check_Queue (E : Entry_Queue) return Boolean;
60 -- Check the validity of E.
61 -- Return True if E is valid, raise Assert_Failure if assertions are
62 -- enabled and False otherwise.
64 -----------------------------
65 -- Broadcast_Program_Error --
66 -----------------------------
68 procedure Broadcast_Program_Error
69 (Self_ID : Task_Id;
70 Object : Protection_Entries_Access;
71 Pending_Call : Entry_Call_Link;
72 RTS_Locked : Boolean := False)
74 Entry_Call : Entry_Call_Link;
75 begin
76 if Single_Lock and then not RTS_Locked then
77 Lock_RTS;
78 end if;
80 if Pending_Call /= null then
81 Send_Program_Error (Self_ID, Pending_Call);
82 end if;
84 for E in Object.Entry_Queues'Range loop
85 Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
87 while Entry_Call /= null loop
88 pragma Assert (Entry_Call.Mode /= Conditional_Call);
90 Send_Program_Error (Self_ID, Entry_Call);
91 Dequeue_Head (Object.Entry_Queues (E), Entry_Call);
92 end loop;
93 end loop;
95 if Single_Lock and then not RTS_Locked then
96 Unlock_RTS;
97 end if;
98 end Broadcast_Program_Error;
100 -----------------
101 -- Check_Queue --
102 -----------------
104 function Check_Queue (E : Entry_Queue) return Boolean is
105 Valid : Boolean := True;
106 C, Prev : Entry_Call_Link;
108 begin
109 if E.Head = null then
110 if E.Tail /= null then
111 Valid := False;
112 pragma Assert (Valid);
113 end if;
114 else
115 if E.Tail = null
116 or else E.Tail.Next /= E.Head
117 then
118 Valid := False;
119 pragma Assert (Valid);
121 else
122 C := E.Head;
124 loop
125 Prev := C;
126 C := C.Next;
128 if C = null then
129 Valid := False;
130 pragma Assert (Valid);
131 exit;
132 end if;
134 if Prev /= C.Prev then
135 Valid := False;
136 pragma Assert (Valid);
137 exit;
138 end if;
140 exit when C = E.Head;
141 end loop;
143 if Prev /= E.Tail then
144 Valid := False;
145 pragma Assert (Valid);
146 end if;
147 end if;
148 end if;
150 return Valid;
151 end Check_Queue;
153 -------------------
154 -- Count_Waiting --
155 -------------------
157 -- Return number of calls on the waiting queue of E
159 function Count_Waiting (E : Entry_Queue) return Natural is
160 Count : Natural;
161 Temp : Entry_Call_Link;
163 begin
164 pragma Assert (Check_Queue (E));
166 Count := 0;
168 if E.Head /= null then
169 Temp := E.Head;
171 loop
172 Count := Count + 1;
173 exit when E.Tail = Temp;
174 Temp := Temp.Next;
175 end loop;
176 end if;
178 return Count;
179 end Count_Waiting;
181 -------------
182 -- Dequeue --
183 -------------
185 -- Dequeue call from entry_queue E
187 procedure Dequeue (E : in out Entry_Queue; Call : Entry_Call_Link) is
188 begin
189 pragma Assert (Check_Queue (E));
190 pragma Assert (Call /= null);
192 -- If empty queue, simply return
194 if E.Head = null then
195 return;
196 end if;
198 pragma Assert (Call.Prev /= null);
199 pragma Assert (Call.Next /= null);
201 Call.Prev.Next := Call.Next;
202 Call.Next.Prev := Call.Prev;
204 if E.Head = Call then
206 -- Case of one element
208 if E.Tail = Call then
209 E.Head := null;
210 E.Tail := null;
212 -- More than one element
214 else
215 E.Head := Call.Next;
216 end if;
218 elsif E.Tail = Call then
219 E.Tail := Call.Prev;
220 end if;
222 -- Successfully dequeued
224 Call.Prev := null;
225 Call.Next := null;
226 pragma Assert (Check_Queue (E));
227 end Dequeue;
229 ------------------
230 -- Dequeue_Call --
231 ------------------
233 procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is
234 Called_PO : Protection_Entries_Access;
236 begin
237 pragma Assert (Entry_Call /= null);
239 if Entry_Call.Called_Task /= null then
240 Dequeue
241 (Entry_Call.Called_Task.Entry_Queues
242 (Task_Entry_Index (Entry_Call.E)),
243 Entry_Call);
245 else
246 Called_PO := To_Protection (Entry_Call.Called_PO);
247 Dequeue (Called_PO.Entry_Queues
248 (Protected_Entry_Index (Entry_Call.E)),
249 Entry_Call);
250 end if;
251 end Dequeue_Call;
253 ------------------
254 -- Dequeue_Head --
255 ------------------
257 -- Remove and return the head of entry_queue E
259 procedure Dequeue_Head
260 (E : in out Entry_Queue;
261 Call : out Entry_Call_Link)
263 Temp : Entry_Call_Link;
265 begin
266 pragma Assert (Check_Queue (E));
267 -- If empty queue, return null pointer
269 if E.Head = null then
270 Call := null;
271 return;
272 end if;
274 Temp := E.Head;
276 -- Case of one element
278 if E.Head = E.Tail then
279 E.Head := null;
280 E.Tail := null;
282 -- More than one element
284 else
285 pragma Assert (Temp /= null);
286 pragma Assert (Temp.Next /= null);
287 pragma Assert (Temp.Prev /= null);
289 E.Head := Temp.Next;
290 Temp.Prev.Next := Temp.Next;
291 Temp.Next.Prev := Temp.Prev;
292 end if;
294 -- Successfully dequeued
296 Temp.Prev := null;
297 Temp.Next := null;
298 Call := Temp;
299 pragma Assert (Check_Queue (E));
300 end Dequeue_Head;
302 -------------
303 -- Enqueue --
304 -------------
306 -- Enqueue call at the end of entry_queue E, for FIFO queuing policy.
307 -- Enqueue call priority ordered, FIFO at same priority level, for
308 -- Priority queuing policy.
310 procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is
311 Temp : Entry_Call_Link := E.Head;
313 begin
314 pragma Assert (Check_Queue (E));
315 pragma Assert (Call /= null);
317 -- Priority Queuing
319 if Priority_Queuing then
320 if Temp = null then
321 Call.Prev := Call;
322 Call.Next := Call;
323 E.Head := Call;
324 E.Tail := Call;
326 else
327 loop
328 -- Find the entry that the new guy should precede
330 exit when Call.Prio > Temp.Prio;
331 Temp := Temp.Next;
333 if Temp = E.Head then
334 Temp := null;
335 exit;
336 end if;
337 end loop;
339 if Temp = null then
340 -- Insert at tail
342 Call.Prev := E.Tail;
343 Call.Next := E.Head;
344 E.Tail := Call;
346 else
347 Call.Prev := Temp.Prev;
348 Call.Next := Temp;
350 -- Insert at head
352 if Temp = E.Head then
353 E.Head := Call;
354 end if;
355 end if;
357 pragma Assert (Call.Prev /= null);
358 pragma Assert (Call.Next /= null);
360 Call.Prev.Next := Call;
361 Call.Next.Prev := Call;
362 end if;
364 pragma Assert (Check_Queue (E));
365 return;
366 end if;
368 -- FIFO Queuing
370 if E.Head = null then
371 E.Head := Call;
372 else
373 E.Tail.Next := Call;
374 Call.Prev := E.Tail;
375 end if;
377 E.Head.Prev := Call;
378 E.Tail := Call;
379 Call.Next := E.Head;
380 pragma Assert (Check_Queue (E));
381 end Enqueue;
383 ------------------
384 -- Enqueue_Call --
385 ------------------
387 procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is
388 Called_PO : Protection_Entries_Access;
390 begin
391 pragma Assert (Entry_Call /= null);
393 if Entry_Call.Called_Task /= null then
394 Enqueue
395 (Entry_Call.Called_Task.Entry_Queues
396 (Task_Entry_Index (Entry_Call.E)),
397 Entry_Call);
399 else
400 Called_PO := To_Protection (Entry_Call.Called_PO);
401 Enqueue (Called_PO.Entry_Queues
402 (Protected_Entry_Index (Entry_Call.E)),
403 Entry_Call);
404 end if;
405 end Enqueue_Call;
407 ----------
408 -- Head --
409 ----------
411 -- Return the head of entry_queue E
413 function Head (E : Entry_Queue) return Entry_Call_Link is
414 begin
415 pragma Assert (Check_Queue (E));
416 return E.Head;
417 end Head;
419 -------------
420 -- Onqueue --
421 -------------
423 -- Return True if Call is on any entry_queue at all
425 function Onqueue (Call : Entry_Call_Link) return Boolean is
426 begin
427 pragma Assert (Call /= null);
429 -- Utilize the fact that every queue is circular, so if Call
430 -- is on any queue at all, Call.Next must NOT be null.
432 return Call.Next /= null;
433 end Onqueue;
435 --------------------------------
436 -- Requeue_Call_With_New_Prio --
437 --------------------------------
439 procedure Requeue_Call_With_New_Prio
440 (Entry_Call : Entry_Call_Link; Prio : System.Any_Priority) is
441 begin
442 pragma Assert (Entry_Call /= null);
444 -- Perform a queue reordering only when the policy being used is the
445 -- Priority Queuing.
447 if Priority_Queuing then
448 if Onqueue (Entry_Call) then
449 Dequeue_Call (Entry_Call);
450 Entry_Call.Prio := Prio;
451 Enqueue_Call (Entry_Call);
452 end if;
453 end if;
454 end Requeue_Call_With_New_Prio;
456 ---------------------------------
457 -- Select_Protected_Entry_Call --
458 ---------------------------------
460 -- Select an entry of a protected object. Selection depends on the
461 -- queuing policy being used.
463 procedure Select_Protected_Entry_Call
464 (Self_ID : Task_Id;
465 Object : Protection_Entries_Access;
466 Call : out Entry_Call_Link)
468 Entry_Call : Entry_Call_Link;
469 Temp_Call : Entry_Call_Link;
470 Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning
472 begin
473 Entry_Call := null;
475 begin
476 -- Priority queuing case
478 if Priority_Queuing then
479 for J in Object.Entry_Queues'Range loop
480 Temp_Call := Head (Object.Entry_Queues (J));
482 if Temp_Call /= null
483 and then
484 Object.Entry_Bodies
485 (Object.Find_Body_Index
486 (Object.Compiler_Info, J)).
487 Barrier (Object.Compiler_Info, J)
488 then
489 if Entry_Call = null
490 or else Entry_Call.Prio < Temp_Call.Prio
491 then
492 Entry_Call := Temp_Call;
493 Entry_Index := J;
494 end if;
495 end if;
496 end loop;
498 -- FIFO queueing case
500 else
501 for J in Object.Entry_Queues'Range loop
502 Temp_Call := Head (Object.Entry_Queues (J));
504 if Temp_Call /= null
505 and then
506 Object.Entry_Bodies
507 (Object.Find_Body_Index
508 (Object.Compiler_Info, J)).
509 Barrier (Object.Compiler_Info, J)
510 then
511 Entry_Call := Temp_Call;
512 Entry_Index := J;
513 exit;
514 end if;
515 end loop;
516 end if;
518 exception
519 when others =>
520 Broadcast_Program_Error (Self_ID, Object, null);
521 end;
523 -- If a call was selected, dequeue it and return it for service
525 if Entry_Call /= null then
526 Temp_Call := Entry_Call;
527 Dequeue_Head (Object.Entry_Queues (Entry_Index), Entry_Call);
528 pragma Assert (Temp_Call = Entry_Call);
529 end if;
531 Call := Entry_Call;
532 end Select_Protected_Entry_Call;
534 ----------------------------
535 -- Select_Task_Entry_Call --
536 ----------------------------
538 -- Select an entry for rendezvous. Selection depends on the queuing policy
539 -- being used.
541 procedure Select_Task_Entry_Call
542 (Acceptor : Task_Id;
543 Open_Accepts : Accept_List_Access;
544 Call : out Entry_Call_Link;
545 Selection : out Select_Index;
546 Open_Alternative : out Boolean)
548 Entry_Call : Entry_Call_Link;
549 Temp_Call : Entry_Call_Link;
550 Entry_Index : Task_Entry_Index := Task_Entry_Index'First;
551 Temp_Entry : Task_Entry_Index;
553 begin
554 Open_Alternative := False;
555 Entry_Call := null;
556 Selection := No_Rendezvous;
558 if Priority_Queuing then
559 -- Priority queueing case
561 for J in Open_Accepts'Range loop
562 Temp_Entry := Open_Accepts (J).S;
564 if Temp_Entry /= Null_Task_Entry then
565 Open_Alternative := True;
566 Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
568 if Temp_Call /= null
569 and then (Entry_Call = null
570 or else Entry_Call.Prio < Temp_Call.Prio)
571 then
572 Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
573 Entry_Index := Temp_Entry;
574 Selection := J;
575 end if;
576 end if;
577 end loop;
579 else
580 -- FIFO Queuing case
582 for J in Open_Accepts'Range loop
583 Temp_Entry := Open_Accepts (J).S;
585 if Temp_Entry /= Null_Task_Entry then
586 Open_Alternative := True;
587 Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
589 if Temp_Call /= null then
590 Entry_Call := Head (Acceptor.Entry_Queues (Temp_Entry));
591 Entry_Index := Temp_Entry;
592 Selection := J;
593 exit;
594 end if;
595 end if;
596 end loop;
597 end if;
599 if Entry_Call /= null then
600 Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call);
602 -- Guard is open
603 end if;
605 Call := Entry_Call;
606 end Select_Task_Entry_Call;
608 ------------------------
609 -- Send_Program_Error --
610 ------------------------
612 procedure Send_Program_Error
613 (Self_ID : Task_Id;
614 Entry_Call : Entry_Call_Link)
616 Caller : Task_Id;
617 begin
618 Caller := Entry_Call.Self;
619 Entry_Call.Exception_To_Raise := Program_Error'Identity;
620 Write_Lock (Caller);
621 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done);
622 Unlock (Caller);
623 end Send_Program_Error;
625 end System.Tasking.Queuing;