1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2011, 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 32with System.Task_Primitives.Operations; 33with System.Tasking.Initialization; 34with System.Tasking.Protected_Objects.Entries; 35with System.Tasking.Protected_Objects.Operations; 36with System.Tasking.Queuing; 37with System.Tasking.Utilities; 38with System.Parameters; 39with System.Traces; 40 41package body System.Tasking.Entry_Calls is 42 43 package STPO renames System.Task_Primitives.Operations; 44 45 use Parameters; 46 use Task_Primitives; 47 use Protected_Objects.Entries; 48 use Protected_Objects.Operations; 49 use System.Traces; 50 51 -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock 52 -- internally. Those operations will raise Program_Error, which 53 -- we are not prepared to handle inside the RTS. Instead, use 54 -- System.Task_Primitives lock operations directly on Protection.L. 55 56 ----------------------- 57 -- Local Subprograms -- 58 ----------------------- 59 60 procedure Lock_Server (Entry_Call : Entry_Call_Link); 61 62 -- This locks the server targeted by Entry_Call 63 -- 64 -- This may be a task or a protected object, depending on the target of the 65 -- original call or any subsequent requeues. 66 -- 67 -- This routine is needed because the field specifying the server for this 68 -- call must be protected by the server's mutex. If it were protected by 69 -- the caller's mutex, accessing the server's queues would require locking 70 -- the caller to get the server, locking the server, and then accessing the 71 -- queues. This involves holding two ATCB locks at once, something which we 72 -- can guarantee that it will always be done in the same order, or locking 73 -- a protected object while we hold an ATCB lock, something which is not 74 -- permitted. Since the server cannot be obtained reliably, it must be 75 -- obtained unreliably and then checked again once it has been locked. 76 -- 77 -- If Single_Lock and server is a PO, release RTS_Lock 78 -- 79 -- This should only be called by the Entry_Call.Self. 80 -- It should be holding no other ATCB locks at the time. 81 82 procedure Unlock_Server (Entry_Call : Entry_Call_Link); 83 -- STPO.Unlock the server targeted by Entry_Call. The server must 84 -- be locked before calling this. 85 -- 86 -- If Single_Lock and server is a PO, take RTS_Lock on exit. 87 88 procedure Unlock_And_Update_Server 89 (Self_ID : Task_Id; 90 Entry_Call : Entry_Call_Link); 91 -- Similar to Unlock_Server, but services entry calls if the 92 -- server is a protected object. 93 -- 94 -- If Single_Lock and server is a PO, take RTS_Lock on exit. 95 96 procedure Check_Pending_Actions_For_Entry_Call 97 (Self_ID : Task_Id; 98 Entry_Call : Entry_Call_Link); 99 -- This procedure performs priority change of a queued call and dequeuing 100 -- of an entry call when the call is cancelled. If the call is dequeued the 101 -- state should be set to Cancelled. Call only with abort deferred and 102 -- holding lock of Self_ID. This is a bit of common code for all entry 103 -- calls. The effect is to do any deferred base priority change operation, 104 -- in case some other task called STPO.Set_Priority while the current task 105 -- had abort deferred, and to dequeue the call if the call has been 106 -- aborted. 107 108 procedure Poll_Base_Priority_Change_At_Entry_Call 109 (Self_ID : Task_Id; 110 Entry_Call : Entry_Call_Link); 111 pragma Inline (Poll_Base_Priority_Change_At_Entry_Call); 112 -- A specialized version of Poll_Base_Priority_Change, that does the 113 -- optional entry queue reordering. Has to be called with the Self_ID's 114 -- ATCB write-locked. May temporarily release the lock. 115 116 --------------------- 117 -- Check_Exception -- 118 --------------------- 119 120 procedure Check_Exception 121 (Self_ID : Task_Id; 122 Entry_Call : Entry_Call_Link) 123 is 124 pragma Warnings (Off, Self_ID); 125 126 use type Ada.Exceptions.Exception_Id; 127 128 procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); 129 pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); 130 131 E : constant Ada.Exceptions.Exception_Id := 132 Entry_Call.Exception_To_Raise; 133 begin 134 -- pragma Assert (Self_ID.Deferral_Level = 0); 135 136 -- The above may be useful for debugging, but the Florist packages 137 -- contain critical sections that defer abort and then do entry calls, 138 -- which causes the above Assert to trip. 139 140 if E /= Ada.Exceptions.Null_Id then 141 Internal_Raise (E); 142 end if; 143 end Check_Exception; 144 145 ------------------------------------------ 146 -- Check_Pending_Actions_For_Entry_Call -- 147 ------------------------------------------ 148 149 procedure Check_Pending_Actions_For_Entry_Call 150 (Self_ID : Task_Id; 151 Entry_Call : Entry_Call_Link) 152 is 153 begin 154 pragma Assert (Self_ID = Entry_Call.Self); 155 156 Poll_Base_Priority_Change_At_Entry_Call (Self_ID, Entry_Call); 157 158 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 159 and then Entry_Call.State = Now_Abortable 160 then 161 STPO.Unlock (Self_ID); 162 Lock_Server (Entry_Call); 163 164 if Queuing.Onqueue (Entry_Call) 165 and then Entry_Call.State = Now_Abortable 166 then 167 Queuing.Dequeue_Call (Entry_Call); 168 Entry_Call.State := 169 (if Entry_Call.Cancellation_Attempted then Cancelled else Done); 170 Unlock_And_Update_Server (Self_ID, Entry_Call); 171 172 else 173 Unlock_Server (Entry_Call); 174 end if; 175 176 STPO.Write_Lock (Self_ID); 177 end if; 178 end Check_Pending_Actions_For_Entry_Call; 179 180 ----------------- 181 -- Lock_Server -- 182 ----------------- 183 184 procedure Lock_Server (Entry_Call : Entry_Call_Link) is 185 Test_Task : Task_Id; 186 Test_PO : Protection_Entries_Access; 187 Ceiling_Violation : Boolean; 188 Failures : Integer := 0; 189 190 begin 191 Test_Task := Entry_Call.Called_Task; 192 193 loop 194 if Test_Task = null then 195 196 -- Entry_Call was queued on a protected object, or in transition, 197 -- when we last fetched Test_Task. 198 199 Test_PO := To_Protection (Entry_Call.Called_PO); 200 201 if Test_PO = null then 202 203 -- We had very bad luck, interleaving with TWO different 204 -- requeue operations. Go around the loop and try again. 205 206 if Single_Lock then 207 STPO.Unlock_RTS; 208 STPO.Yield; 209 STPO.Lock_RTS; 210 else 211 STPO.Yield; 212 end if; 213 214 else 215 if Single_Lock then 216 STPO.Unlock_RTS; 217 end if; 218 219 Lock_Entries_With_Status (Test_PO, Ceiling_Violation); 220 221 -- ??? 222 223 -- The following code allows Lock_Server to be called when 224 -- cancelling a call, to allow for the possibility that the 225 -- priority of the caller has been raised beyond that of the 226 -- protected entry call by Ada.Dynamic_Priorities.Set_Priority. 227 228 -- If the current task has a higher priority than the ceiling 229 -- of the protected object, temporarily lower it. It will 230 -- be reset in Unlock. 231 232 if Ceiling_Violation then 233 declare 234 Current_Task : constant Task_Id := STPO.Self; 235 Old_Base_Priority : System.Any_Priority; 236 237 begin 238 if Single_Lock then 239 STPO.Lock_RTS; 240 end if; 241 242 STPO.Write_Lock (Current_Task); 243 Old_Base_Priority := Current_Task.Common.Base_Priority; 244 Current_Task.New_Base_Priority := Test_PO.Ceiling; 245 System.Tasking.Initialization.Change_Base_Priority 246 (Current_Task); 247 STPO.Unlock (Current_Task); 248 249 if Single_Lock then 250 STPO.Unlock_RTS; 251 end if; 252 253 -- Following lock should not fail 254 255 Lock_Entries (Test_PO); 256 257 Test_PO.Old_Base_Priority := Old_Base_Priority; 258 Test_PO.Pending_Action := True; 259 end; 260 end if; 261 262 exit when To_Address (Test_PO) = Entry_Call.Called_PO; 263 Unlock_Entries (Test_PO); 264 265 if Single_Lock then 266 STPO.Lock_RTS; 267 end if; 268 end if; 269 270 else 271 STPO.Write_Lock (Test_Task); 272 exit when Test_Task = Entry_Call.Called_Task; 273 STPO.Unlock (Test_Task); 274 end if; 275 276 Test_Task := Entry_Call.Called_Task; 277 Failures := Failures + 1; 278 pragma Assert (Failures <= 5); 279 end loop; 280 end Lock_Server; 281 282 --------------------------------------------- 283 -- Poll_Base_Priority_Change_At_Entry_Call -- 284 --------------------------------------------- 285 286 procedure Poll_Base_Priority_Change_At_Entry_Call 287 (Self_ID : Task_Id; 288 Entry_Call : Entry_Call_Link) 289 is 290 begin 291 if Self_ID.Pending_Priority_Change then 292 293 -- Check for ceiling violations ??? 294 295 Self_ID.Pending_Priority_Change := False; 296 297 -- Requeue the entry call at the new priority. We need to requeue 298 -- even if the new priority is the same than the previous (see ACATS 299 -- test cxd4006). 300 301 STPO.Unlock (Self_ID); 302 Lock_Server (Entry_Call); 303 Queuing.Requeue_Call_With_New_Prio 304 (Entry_Call, STPO.Get_Priority (Self_ID)); 305 Unlock_And_Update_Server (Self_ID, Entry_Call); 306 STPO.Write_Lock (Self_ID); 307 end if; 308 end Poll_Base_Priority_Change_At_Entry_Call; 309 310 -------------------- 311 -- Reset_Priority -- 312 -------------------- 313 314 procedure Reset_Priority 315 (Acceptor : Task_Id; 316 Acceptor_Prev_Priority : Rendezvous_Priority) 317 is 318 begin 319 pragma Assert (Acceptor = STPO.Self); 320 321 -- Since we limit this kind of "active" priority change to be done 322 -- by the task for itself, we don't need to lock Acceptor. 323 324 if Acceptor_Prev_Priority /= Priority_Not_Boosted then 325 STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority, 326 Loss_Of_Inheritance => True); 327 end if; 328 end Reset_Priority; 329 330 ------------------------------ 331 -- Try_To_Cancel_Entry_Call -- 332 ------------------------------ 333 334 procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is 335 Entry_Call : Entry_Call_Link; 336 Self_ID : constant Task_Id := STPO.Self; 337 338 use type Ada.Exceptions.Exception_Id; 339 340 begin 341 Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; 342 343 -- Experimentation has shown that abort is sometimes (but not 344 -- always) already deferred when Cancel_xxx_Entry_Call is called. 345 -- That may indicate an error. Find out what is going on. ??? 346 347 pragma Assert (Entry_Call.Mode = Asynchronous_Call); 348 Initialization.Defer_Abort_Nestable (Self_ID); 349 350 if Single_Lock then 351 STPO.Lock_RTS; 352 end if; 353 354 STPO.Write_Lock (Self_ID); 355 Entry_Call.Cancellation_Attempted := True; 356 357 if Self_ID.Pending_ATC_Level >= Entry_Call.Level then 358 Self_ID.Pending_ATC_Level := Entry_Call.Level - 1; 359 end if; 360 361 Entry_Calls.Wait_For_Completion (Entry_Call); 362 STPO.Unlock (Self_ID); 363 364 if Single_Lock then 365 STPO.Unlock_RTS; 366 end if; 367 368 Succeeded := Entry_Call.State = Cancelled; 369 370 Initialization.Undefer_Abort_Nestable (Self_ID); 371 372 -- Ideally, abort should no longer be deferred at this point, so we 373 -- should be able to call Check_Exception. The loop below should be 374 -- considered temporary, to work around the possibility that abort 375 -- may be deferred more than one level deep ??? 376 377 if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then 378 while Self_ID.Deferral_Level > 0 loop 379 System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID); 380 end loop; 381 382 Entry_Calls.Check_Exception (Self_ID, Entry_Call); 383 end if; 384 end Try_To_Cancel_Entry_Call; 385 386 ------------------------------ 387 -- Unlock_And_Update_Server -- 388 ------------------------------ 389 390 procedure Unlock_And_Update_Server 391 (Self_ID : Task_Id; 392 Entry_Call : Entry_Call_Link) 393 is 394 Called_PO : Protection_Entries_Access; 395 Caller : Task_Id; 396 397 begin 398 if Entry_Call.Called_Task /= null then 399 STPO.Unlock (Entry_Call.Called_Task); 400 else 401 Called_PO := To_Protection (Entry_Call.Called_PO); 402 PO_Service_Entries (Self_ID, Called_PO, False); 403 404 if Called_PO.Pending_Action then 405 Called_PO.Pending_Action := False; 406 Caller := STPO.Self; 407 408 if Single_Lock then 409 STPO.Lock_RTS; 410 end if; 411 412 STPO.Write_Lock (Caller); 413 Caller.New_Base_Priority := Called_PO.Old_Base_Priority; 414 Initialization.Change_Base_Priority (Caller); 415 STPO.Unlock (Caller); 416 417 if Single_Lock then 418 STPO.Unlock_RTS; 419 end if; 420 end if; 421 422 Unlock_Entries (Called_PO); 423 424 if Single_Lock then 425 STPO.Lock_RTS; 426 end if; 427 end if; 428 end Unlock_And_Update_Server; 429 430 ------------------- 431 -- Unlock_Server -- 432 ------------------- 433 434 procedure Unlock_Server (Entry_Call : Entry_Call_Link) is 435 Caller : Task_Id; 436 Called_PO : Protection_Entries_Access; 437 438 begin 439 if Entry_Call.Called_Task /= null then 440 STPO.Unlock (Entry_Call.Called_Task); 441 else 442 Called_PO := To_Protection (Entry_Call.Called_PO); 443 444 if Called_PO.Pending_Action then 445 Called_PO.Pending_Action := False; 446 Caller := STPO.Self; 447 448 if Single_Lock then 449 STPO.Lock_RTS; 450 end if; 451 452 STPO.Write_Lock (Caller); 453 Caller.New_Base_Priority := Called_PO.Old_Base_Priority; 454 Initialization.Change_Base_Priority (Caller); 455 STPO.Unlock (Caller); 456 457 if Single_Lock then 458 STPO.Unlock_RTS; 459 end if; 460 end if; 461 462 Unlock_Entries (Called_PO); 463 464 if Single_Lock then 465 STPO.Lock_RTS; 466 end if; 467 end if; 468 end Unlock_Server; 469 470 ------------------------- 471 -- Wait_For_Completion -- 472 ------------------------- 473 474 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is 475 Self_Id : constant Task_Id := Entry_Call.Self; 476 477 begin 478 -- If this is a conditional call, it should be cancelled when it 479 -- becomes abortable. This is checked in the loop below. 480 481 if Parameters.Runtime_Traces then 482 Send_Trace_Info (W_Completion); 483 end if; 484 485 Self_Id.Common.State := Entry_Caller_Sleep; 486 487 -- Try to remove calls to Sleep in the loop below by letting the caller 488 -- a chance of getting ready immediately, using Unlock & Yield. 489 -- See similar action in Wait_For_Call & Timed_Selective_Wait. 490 491 if Single_Lock then 492 STPO.Unlock_RTS; 493 else 494 STPO.Unlock (Self_Id); 495 end if; 496 497 if Entry_Call.State < Done then 498 STPO.Yield; 499 end if; 500 501 if Single_Lock then 502 STPO.Lock_RTS; 503 else 504 STPO.Write_Lock (Self_Id); 505 end if; 506 507 loop 508 Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); 509 510 exit when Entry_Call.State >= Done; 511 512 STPO.Sleep (Self_Id, Entry_Caller_Sleep); 513 end loop; 514 515 Self_Id.Common.State := Runnable; 516 Utilities.Exit_One_ATC_Level (Self_Id); 517 518 if Parameters.Runtime_Traces then 519 Send_Trace_Info (M_Call_Complete); 520 end if; 521 end Wait_For_Completion; 522 523 -------------------------------------- 524 -- Wait_For_Completion_With_Timeout -- 525 -------------------------------------- 526 527 procedure Wait_For_Completion_With_Timeout 528 (Entry_Call : Entry_Call_Link; 529 Wakeup_Time : Duration; 530 Mode : Delay_Modes; 531 Yielded : out Boolean) 532 is 533 Self_Id : constant Task_Id := Entry_Call.Self; 534 Timedout : Boolean := False; 535 536 use type Ada.Exceptions.Exception_Id; 537 538 begin 539 -- This procedure waits for the entry call to be served, with a timeout. 540 -- It tries to cancel the call if the timeout expires before the call is 541 -- served. 542 543 -- If we wake up from the timed sleep operation here, it may be for 544 -- several possible reasons: 545 546 -- 1) The entry call is done being served. 547 -- 2) There is an abort or priority change to be served. 548 -- 3) The timeout has expired (Timedout = True) 549 -- 4) There has been a spurious wakeup. 550 551 -- Once the timeout has expired we may need to continue to wait if the 552 -- call is already being serviced. In that case, we want to go back to 553 -- sleep, but without any timeout. The variable Timedout is used to 554 -- control this. If the Timedout flag is set, we do not need to 555 -- STPO.Sleep with a timeout. We just sleep until we get a wakeup for 556 -- some status change. 557 558 -- The original call may have become abortable after waking up. We want 559 -- to check Check_Pending_Actions_For_Entry_Call again in any case. 560 561 pragma Assert (Entry_Call.Mode = Timed_Call); 562 563 Yielded := False; 564 Self_Id.Common.State := Entry_Caller_Sleep; 565 566 -- Looping is necessary in case the task wakes up early from the timed 567 -- sleep, due to a "spurious wakeup". Spurious wakeups are a weakness of 568 -- POSIX condition variables. A thread waiting for a condition variable 569 -- is allowed to wake up at any time, not just when the condition is 570 -- signaled. See same loop in the ordinary Wait_For_Completion, above. 571 572 if Parameters.Runtime_Traces then 573 Send_Trace_Info (WT_Completion, Wakeup_Time); 574 end if; 575 576 loop 577 Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); 578 exit when Entry_Call.State >= Done; 579 580 STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode, 581 Entry_Caller_Sleep, Timedout, Yielded); 582 583 if Timedout then 584 if Parameters.Runtime_Traces then 585 Send_Trace_Info (E_Timeout); 586 end if; 587 588 -- Try to cancel the call (see Try_To_Cancel_Entry_Call for 589 -- corresponding code in the ATC case). 590 591 Entry_Call.Cancellation_Attempted := True; 592 593 -- Reset Entry_Call.State so that the call is marked as cancelled 594 -- by Check_Pending_Actions_For_Entry_Call below. 595 596 if Entry_Call.State < Was_Abortable then 597 Entry_Call.State := Now_Abortable; 598 end if; 599 600 if Self_Id.Pending_ATC_Level >= Entry_Call.Level then 601 Self_Id.Pending_ATC_Level := Entry_Call.Level - 1; 602 end if; 603 604 -- The following loop is the same as the loop and exit code 605 -- from the ordinary Wait_For_Completion. If we get here, we 606 -- have timed out but we need to keep waiting until the call 607 -- has actually completed or been cancelled successfully. 608 609 loop 610 Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); 611 exit when Entry_Call.State >= Done; 612 STPO.Sleep (Self_Id, Entry_Caller_Sleep); 613 end loop; 614 615 Self_Id.Common.State := Runnable; 616 Utilities.Exit_One_ATC_Level (Self_Id); 617 618 return; 619 end if; 620 end loop; 621 622 -- This last part is the same as ordinary Wait_For_Completion, 623 -- and is only executed if the call completed without timing out. 624 625 if Parameters.Runtime_Traces then 626 Send_Trace_Info (M_Call_Complete); 627 end if; 628 629 Self_Id.Common.State := Runnable; 630 Utilities.Exit_One_ATC_Level (Self_Id); 631 end Wait_For_Completion_With_Timeout; 632 633 -------------------------- 634 -- Wait_Until_Abortable -- 635 -------------------------- 636 637 procedure Wait_Until_Abortable 638 (Self_ID : Task_Id; 639 Call : Entry_Call_Link) 640 is 641 begin 642 pragma Assert (Self_ID.ATC_Nesting_Level > 0); 643 pragma Assert (Call.Mode = Asynchronous_Call); 644 645 if Parameters.Runtime_Traces then 646 Send_Trace_Info (W_Completion); 647 end if; 648 649 STPO.Write_Lock (Self_ID); 650 Self_ID.Common.State := Entry_Caller_Sleep; 651 652 loop 653 Check_Pending_Actions_For_Entry_Call (Self_ID, Call); 654 exit when Call.State >= Was_Abortable; 655 STPO.Sleep (Self_ID, Async_Select_Sleep); 656 end loop; 657 658 Self_ID.Common.State := Runnable; 659 STPO.Unlock (Self_ID); 660 661 if Parameters.Runtime_Traces then 662 Send_Trace_Info (M_Call_Complete); 663 end if; 664 end Wait_Until_Abortable; 665 666end System.Tasking.Entry_Calls; 667