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