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------------------------------------------------------------------------------ 31 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. 35 36with System.Task_Primitives.Operations; 37with System.Tasking.Initialization; 38with System.Parameters; 39 40package body System.Tasking.Queuing is 41 42 use Parameters; 43 use Task_Primitives.Operations; 44 use Protected_Objects; 45 use Protected_Objects.Entries; 46 47 -- Entry Queues implemented as doubly linked list 48 49 Queuing_Policy : Character; 50 pragma Import (C, Queuing_Policy, "__gl_queuing_policy"); 51 52 Priority_Queuing : constant Boolean := Queuing_Policy = 'P'; 53 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 58 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. 63 64 ----------------------------- 65 -- Broadcast_Program_Error -- 66 ----------------------------- 67 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) 73 is 74 Entry_Call : Entry_Call_Link; 75 begin 76 if Single_Lock and then not RTS_Locked then 77 Lock_RTS; 78 end if; 79 80 if Pending_Call /= null then 81 Send_Program_Error (Self_ID, Pending_Call); 82 end if; 83 84 for E in Object.Entry_Queues'Range loop 85 Dequeue_Head (Object.Entry_Queues (E), Entry_Call); 86 87 while Entry_Call /= null loop 88 pragma Assert (Entry_Call.Mode /= Conditional_Call); 89 90 Send_Program_Error (Self_ID, Entry_Call); 91 Dequeue_Head (Object.Entry_Queues (E), Entry_Call); 92 end loop; 93 end loop; 94 95 if Single_Lock and then not RTS_Locked then 96 Unlock_RTS; 97 end if; 98 end Broadcast_Program_Error; 99 100 ----------------- 101 -- Check_Queue -- 102 ----------------- 103 104 function Check_Queue (E : Entry_Queue) return Boolean is 105 Valid : Boolean := True; 106 C, Prev : Entry_Call_Link; 107 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); 120 121 else 122 C := E.Head; 123 124 loop 125 Prev := C; 126 C := C.Next; 127 128 if C = null then 129 Valid := False; 130 pragma Assert (Valid); 131 exit; 132 end if; 133 134 if Prev /= C.Prev then 135 Valid := False; 136 pragma Assert (Valid); 137 exit; 138 end if; 139 140 exit when C = E.Head; 141 end loop; 142 143 if Prev /= E.Tail then 144 Valid := False; 145 pragma Assert (Valid); 146 end if; 147 end if; 148 end if; 149 150 return Valid; 151 end Check_Queue; 152 153 ------------------- 154 -- Count_Waiting -- 155 ------------------- 156 157 -- Return number of calls on the waiting queue of E 158 159 function Count_Waiting (E : Entry_Queue) return Natural is 160 Count : Natural; 161 Temp : Entry_Call_Link; 162 163 begin 164 pragma Assert (Check_Queue (E)); 165 166 Count := 0; 167 168 if E.Head /= null then 169 Temp := E.Head; 170 171 loop 172 Count := Count + 1; 173 exit when E.Tail = Temp; 174 Temp := Temp.Next; 175 end loop; 176 end if; 177 178 return Count; 179 end Count_Waiting; 180 181 ------------- 182 -- Dequeue -- 183 ------------- 184 185 -- Dequeue call from entry_queue E 186 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); 191 192 -- If empty queue, simply return 193 194 if E.Head = null then 195 return; 196 end if; 197 198 pragma Assert (Call.Prev /= null); 199 pragma Assert (Call.Next /= null); 200 201 Call.Prev.Next := Call.Next; 202 Call.Next.Prev := Call.Prev; 203 204 if E.Head = Call then 205 206 -- Case of one element 207 208 if E.Tail = Call then 209 E.Head := null; 210 E.Tail := null; 211 212 -- More than one element 213 214 else 215 E.Head := Call.Next; 216 end if; 217 218 elsif E.Tail = Call then 219 E.Tail := Call.Prev; 220 end if; 221 222 -- Successfully dequeued 223 224 Call.Prev := null; 225 Call.Next := null; 226 pragma Assert (Check_Queue (E)); 227 end Dequeue; 228 229 ------------------ 230 -- Dequeue_Call -- 231 ------------------ 232 233 procedure Dequeue_Call (Entry_Call : Entry_Call_Link) is 234 Called_PO : Protection_Entries_Access; 235 236 begin 237 pragma Assert (Entry_Call /= null); 238 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); 244 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; 252 253 ------------------ 254 -- Dequeue_Head -- 255 ------------------ 256 257 -- Remove and return the head of entry_queue E 258 259 procedure Dequeue_Head 260 (E : in out Entry_Queue; 261 Call : out Entry_Call_Link) 262 is 263 Temp : Entry_Call_Link; 264 265 begin 266 pragma Assert (Check_Queue (E)); 267 -- If empty queue, return null pointer 268 269 if E.Head = null then 270 Call := null; 271 return; 272 end if; 273 274 Temp := E.Head; 275 276 -- Case of one element 277 278 if E.Head = E.Tail then 279 E.Head := null; 280 E.Tail := null; 281 282 -- More than one element 283 284 else 285 pragma Assert (Temp /= null); 286 pragma Assert (Temp.Next /= null); 287 pragma Assert (Temp.Prev /= null); 288 289 E.Head := Temp.Next; 290 Temp.Prev.Next := Temp.Next; 291 Temp.Next.Prev := Temp.Prev; 292 end if; 293 294 -- Successfully dequeued 295 296 Temp.Prev := null; 297 Temp.Next := null; 298 Call := Temp; 299 pragma Assert (Check_Queue (E)); 300 end Dequeue_Head; 301 302 ------------- 303 -- Enqueue -- 304 ------------- 305 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. 309 310 procedure Enqueue (E : in out Entry_Queue; Call : Entry_Call_Link) is 311 Temp : Entry_Call_Link := E.Head; 312 313 begin 314 pragma Assert (Check_Queue (E)); 315 pragma Assert (Call /= null); 316 317 -- Priority Queuing 318 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; 325 326 else 327 loop 328 -- Find the entry that the new guy should precede 329 330 exit when Call.Prio > Temp.Prio; 331 Temp := Temp.Next; 332 333 if Temp = E.Head then 334 Temp := null; 335 exit; 336 end if; 337 end loop; 338 339 if Temp = null then 340 -- Insert at tail 341 342 Call.Prev := E.Tail; 343 Call.Next := E.Head; 344 E.Tail := Call; 345 346 else 347 Call.Prev := Temp.Prev; 348 Call.Next := Temp; 349 350 -- Insert at head 351 352 if Temp = E.Head then 353 E.Head := Call; 354 end if; 355 end if; 356 357 pragma Assert (Call.Prev /= null); 358 pragma Assert (Call.Next /= null); 359 360 Call.Prev.Next := Call; 361 Call.Next.Prev := Call; 362 end if; 363 364 pragma Assert (Check_Queue (E)); 365 return; 366 end if; 367 368 -- FIFO Queuing 369 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; 376 377 E.Head.Prev := Call; 378 E.Tail := Call; 379 Call.Next := E.Head; 380 pragma Assert (Check_Queue (E)); 381 end Enqueue; 382 383 ------------------ 384 -- Enqueue_Call -- 385 ------------------ 386 387 procedure Enqueue_Call (Entry_Call : Entry_Call_Link) is 388 Called_PO : Protection_Entries_Access; 389 390 begin 391 pragma Assert (Entry_Call /= null); 392 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); 398 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; 406 407 ---------- 408 -- Head -- 409 ---------- 410 411 -- Return the head of entry_queue E 412 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; 418 419 ------------- 420 -- Onqueue -- 421 ------------- 422 423 -- Return True if Call is on any entry_queue at all 424 425 function Onqueue (Call : Entry_Call_Link) return Boolean is 426 begin 427 pragma Assert (Call /= null); 428 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. 431 432 return Call.Next /= null; 433 end Onqueue; 434 435 -------------------------------- 436 -- Requeue_Call_With_New_Prio -- 437 -------------------------------- 438 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); 443 444 -- Perform a queue reordering only when the policy being used is the 445 -- Priority Queuing. 446 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; 455 456 --------------------------------- 457 -- Select_Protected_Entry_Call -- 458 --------------------------------- 459 460 -- Select an entry of a protected object. Selection depends on the 461 -- queuing policy being used. 462 463 procedure Select_Protected_Entry_Call 464 (Self_ID : Task_Id; 465 Object : Protection_Entries_Access; 466 Call : out Entry_Call_Link) 467 is 468 Entry_Call : Entry_Call_Link; 469 Temp_Call : Entry_Call_Link; 470 Entry_Index : Protected_Entry_Index := Null_Entry; -- stop warning 471 472 begin 473 Entry_Call := null; 474 475 begin 476 -- Priority queuing case 477 478 if Priority_Queuing then 479 for J in Object.Entry_Queues'Range loop 480 Temp_Call := Head (Object.Entry_Queues (J)); 481 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; 497 498 -- FIFO queueing case 499 500 else 501 for J in Object.Entry_Queues'Range loop 502 Temp_Call := Head (Object.Entry_Queues (J)); 503 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; 517 518 exception 519 when others => 520 Broadcast_Program_Error (Self_ID, Object, null); 521 end; 522 523 -- If a call was selected, dequeue it and return it for service 524 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; 530 531 Call := Entry_Call; 532 end Select_Protected_Entry_Call; 533 534 ---------------------------- 535 -- Select_Task_Entry_Call -- 536 ---------------------------- 537 538 -- Select an entry for rendezvous. Selection depends on the queuing policy 539 -- being used. 540 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) 547 is 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; 552 553 begin 554 Open_Alternative := False; 555 Entry_Call := null; 556 Selection := No_Rendezvous; 557 558 if Priority_Queuing then 559 -- Priority queueing case 560 561 for J in Open_Accepts'Range loop 562 Temp_Entry := Open_Accepts (J).S; 563 564 if Temp_Entry /= Null_Task_Entry then 565 Open_Alternative := True; 566 Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); 567 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; 578 579 else 580 -- FIFO Queuing case 581 582 for J in Open_Accepts'Range loop 583 Temp_Entry := Open_Accepts (J).S; 584 585 if Temp_Entry /= Null_Task_Entry then 586 Open_Alternative := True; 587 Temp_Call := Head (Acceptor.Entry_Queues (Temp_Entry)); 588 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; 598 599 if Entry_Call /= null then 600 Dequeue_Head (Acceptor.Entry_Queues (Entry_Index), Entry_Call); 601 602 -- Guard is open 603 end if; 604 605 Call := Entry_Call; 606 end Select_Task_Entry_Call; 607 608 ------------------------ 609 -- Send_Program_Error -- 610 ------------------------ 611 612 procedure Send_Program_Error 613 (Self_ID : Task_Id; 614 Entry_Call : Entry_Call_Link) 615 is 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; 624 625end System.Tasking.Queuing; 626