1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . T A S K I N G . R E N D E Z V O U S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2020, 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.Entry_Calls; 34with System.Tasking.Initialization; 35with System.Tasking.Queuing; 36with System.Tasking.Utilities; 37with System.Tasking.Protected_Objects.Operations; 38with System.Tasking.Debug; 39with System.Restrictions; 40 41package body System.Tasking.Rendezvous is 42 43 package STPO renames System.Task_Primitives.Operations; 44 package POO renames Protected_Objects.Operations; 45 package POE renames Protected_Objects.Entries; 46 47 use Task_Primitives.Operations; 48 49 type Select_Treatment is ( 50 Accept_Alternative_Selected, -- alternative with non-null body 51 Accept_Alternative_Completed, -- alternative with null body 52 Else_Selected, 53 Terminate_Selected, 54 Accept_Alternative_Open, 55 No_Alternative_Open); 56 57 ---------------- 58 -- Local Data -- 59 ---------------- 60 61 Default_Treatment : constant array (Select_Modes) of Select_Treatment := 62 (Simple_Mode => No_Alternative_Open, 63 Else_Mode => Else_Selected, 64 Terminate_Mode => Terminate_Selected, 65 Delay_Mode => No_Alternative_Open); 66 67 New_State : constant array (Boolean, Entry_Call_State) 68 of Entry_Call_State := 69 (True => 70 (Never_Abortable => Never_Abortable, 71 Not_Yet_Abortable => Now_Abortable, 72 Was_Abortable => Now_Abortable, 73 Now_Abortable => Now_Abortable, 74 Done => Done, 75 Cancelled => Cancelled), 76 False => 77 (Never_Abortable => Never_Abortable, 78 Not_Yet_Abortable => Not_Yet_Abortable, 79 Was_Abortable => Was_Abortable, 80 Now_Abortable => Now_Abortable, 81 Done => Done, 82 Cancelled => Cancelled) 83 ); 84 85 ----------------------- 86 -- Local Subprograms -- 87 ----------------------- 88 89 procedure Local_Defer_Abort (Self_Id : Task_Id) renames 90 System.Tasking.Initialization.Defer_Abort_Nestable; 91 92 procedure Local_Undefer_Abort (Self_Id : Task_Id) renames 93 System.Tasking.Initialization.Undefer_Abort_Nestable; 94 95 -- Florist defers abort around critical sections that make entry calls 96 -- to the Interrupt_Manager task, which violates the general rule about 97 -- top-level runtime system calls from abort-deferred regions. It is not 98 -- that this is unsafe, but when it occurs in "normal" programs it usually 99 -- means either the user is trying to do a potentially blocking operation 100 -- from within a protected object, or there is a runtime system/compiler 101 -- error that has failed to undefer an earlier abort deferral. Thus, for 102 -- debugging it may be wise to modify the above renamings to the 103 -- non-nestable forms. 104 105 procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id); 106 -- Internal version of Complete_Rendezvous, used to implement 107 -- Complete_Rendezvous and Exceptional_Complete_Rendezvous. 108 -- Should be called holding no locks, generally with abort 109 -- not yet deferred. 110 111 procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id); 112 pragma Inline (Boost_Priority); 113 -- Call this only with abort deferred and holding lock of Acceptor 114 115 procedure Call_Synchronous 116 (Acceptor : Task_Id; 117 E : Task_Entry_Index; 118 Uninterpreted_Data : System.Address; 119 Mode : Call_Modes; 120 Rendezvous_Successful : out Boolean); 121 pragma Inline (Call_Synchronous); 122 -- This call is used to make a simple or conditional entry call. 123 -- Called from Call_Simple and Task_Entry_Call. 124 125 procedure Setup_For_Rendezvous_With_Body 126 (Entry_Call : Entry_Call_Link; 127 Acceptor : Task_Id); 128 pragma Inline (Setup_For_Rendezvous_With_Body); 129 -- Call this only with abort deferred and holding lock of Acceptor. When 130 -- a rendezvous selected (ready for rendezvous) we need to save previous 131 -- caller and adjust the priority. Also we need to make this call not 132 -- Abortable (Cancellable) since the rendezvous has already been started. 133 134 procedure Wait_For_Call (Self_Id : Task_Id); 135 pragma Inline (Wait_For_Call); 136 -- Call this only with abort deferred and holding lock of Self_Id. An 137 -- accepting task goes into Sleep by calling this routine waiting for a 138 -- call from the caller or waiting for an abort. Make sure Self_Id is 139 -- locked before calling this routine. 140 141 ----------------- 142 -- Accept_Call -- 143 ----------------- 144 145 procedure Accept_Call 146 (E : Task_Entry_Index; 147 Uninterpreted_Data : out System.Address) 148 is 149 Self_Id : constant Task_Id := STPO.Self; 150 Caller : Task_Id := null; 151 Open_Accepts : aliased Accept_List (1 .. 1); 152 Entry_Call : Entry_Call_Link; 153 154 begin 155 Initialization.Defer_Abort (Self_Id); 156 STPO.Write_Lock (Self_Id); 157 158 if not Self_Id.Callable then 159 pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task); 160 161 pragma Assert (Self_Id.Pending_Action); 162 163 STPO.Unlock (Self_Id); 164 Initialization.Undefer_Abort (Self_Id); 165 166 -- Should never get here ??? 167 168 pragma Assert (False); 169 raise Standard'Abort_Signal; 170 end if; 171 172 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); 173 174 if Entry_Call /= null then 175 Caller := Entry_Call.Self; 176 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); 177 Uninterpreted_Data := Entry_Call.Uninterpreted_Data; 178 179 else 180 -- Wait for a caller 181 182 Open_Accepts (1).Null_Body := False; 183 Open_Accepts (1).S := E; 184 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; 185 186 -- Wait for normal call 187 188 pragma Debug 189 (Debug.Trace (Self_Id, "Accept_Call: wait", 'R')); 190 Wait_For_Call (Self_Id); 191 192 pragma Assert (Self_Id.Open_Accepts = null); 193 194 if Self_Id.Common.Call /= null then 195 Caller := Self_Id.Common.Call.Self; 196 197 pragma Assert (Caller.ATC_Nesting_Level > Level_No_ATC_Occurring); 198 199 Uninterpreted_Data := 200 Caller.Entry_Calls (Caller.ATC_Nesting_Level).Uninterpreted_Data; 201 else 202 -- Case of an aborted task 203 204 Uninterpreted_Data := System.Null_Address; 205 end if; 206 end if; 207 208 -- Self_Id.Common.Call should already be updated by the Caller. On 209 -- return, we will start the rendezvous. 210 211 STPO.Unlock (Self_Id); 212 Initialization.Undefer_Abort (Self_Id); 213 end Accept_Call; 214 215 -------------------- 216 -- Accept_Trivial -- 217 -------------------- 218 219 procedure Accept_Trivial (E : Task_Entry_Index) is 220 Self_Id : constant Task_Id := STPO.Self; 221 Caller : Task_Id := null; 222 Open_Accepts : aliased Accept_List (1 .. 1); 223 Entry_Call : Entry_Call_Link; 224 225 begin 226 Initialization.Defer_Abort_Nestable (Self_Id); 227 STPO.Write_Lock (Self_Id); 228 229 if not Self_Id.Callable then 230 pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task); 231 232 pragma Assert (Self_Id.Pending_Action); 233 234 STPO.Unlock (Self_Id); 235 Initialization.Undefer_Abort_Nestable (Self_Id); 236 237 -- Should never get here ??? 238 239 pragma Assert (False); 240 raise Standard'Abort_Signal; 241 end if; 242 243 Queuing.Dequeue_Head (Self_Id.Entry_Queues (E), Entry_Call); 244 245 if Entry_Call = null then 246 247 -- Need to wait for entry call 248 249 Open_Accepts (1).Null_Body := True; 250 Open_Accepts (1).S := E; 251 Self_Id.Open_Accepts := Open_Accepts'Unrestricted_Access; 252 253 pragma Debug 254 (Debug.Trace (Self_Id, "Accept_Trivial: wait", 'R')); 255 256 Wait_For_Call (Self_Id); 257 258 pragma Assert (Self_Id.Open_Accepts = null); 259 260 -- No need to do anything special here for pending abort. 261 -- Abort_Signal will be raised by Undefer on exit. 262 263 STPO.Unlock (Self_Id); 264 265 -- Found caller already waiting 266 267 else 268 pragma Assert (Entry_Call.State < Done); 269 270 STPO.Unlock (Self_Id); 271 Caller := Entry_Call.Self; 272 273 STPO.Write_Lock (Caller); 274 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); 275 STPO.Unlock (Caller); 276 end if; 277 278 Initialization.Undefer_Abort_Nestable (Self_Id); 279 end Accept_Trivial; 280 281 -------------------- 282 -- Boost_Priority -- 283 -------------------- 284 285 procedure Boost_Priority (Call : Entry_Call_Link; Acceptor : Task_Id) is 286 Caller : constant Task_Id := Call.Self; 287 Caller_Prio : constant System.Any_Priority := Get_Priority (Caller); 288 Acceptor_Prio : constant System.Any_Priority := Get_Priority (Acceptor); 289 begin 290 if Caller_Prio > Acceptor_Prio then 291 Call.Acceptor_Prev_Priority := Acceptor_Prio; 292 Set_Priority (Acceptor, Caller_Prio); 293 else 294 Call.Acceptor_Prev_Priority := Priority_Not_Boosted; 295 end if; 296 end Boost_Priority; 297 298 ----------------- 299 -- Call_Simple -- 300 ----------------- 301 302 procedure Call_Simple 303 (Acceptor : Task_Id; 304 E : Task_Entry_Index; 305 Uninterpreted_Data : System.Address) 306 is 307 Rendezvous_Successful : Boolean; 308 pragma Unreferenced (Rendezvous_Successful); 309 310 begin 311 -- If pragma Detect_Blocking is active then Program_Error must be 312 -- raised if this potentially blocking operation is called from a 313 -- protected action. 314 315 if System.Tasking.Detect_Blocking 316 and then STPO.Self.Common.Protected_Action_Nesting > 0 317 then 318 raise Program_Error with 319 "potentially blocking operation"; 320 end if; 321 322 Call_Synchronous 323 (Acceptor, E, Uninterpreted_Data, Simple_Call, Rendezvous_Successful); 324 end Call_Simple; 325 326 ---------------------- 327 -- Call_Synchronous -- 328 ---------------------- 329 330 procedure Call_Synchronous 331 (Acceptor : Task_Id; 332 E : Task_Entry_Index; 333 Uninterpreted_Data : System.Address; 334 Mode : Call_Modes; 335 Rendezvous_Successful : out Boolean) 336 is 337 Self_Id : constant Task_Id := STPO.Self; 338 Level : ATC_Level; 339 Entry_Call : Entry_Call_Link; 340 341 begin 342 pragma Assert (Mode /= Asynchronous_Call); 343 344 Local_Defer_Abort (Self_Id); 345 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; 346 pragma Debug 347 (Debug.Trace (Self_Id, "CS: entered ATC level: " & 348 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); 349 Level := Self_Id.ATC_Nesting_Level; 350 Entry_Call := Self_Id.Entry_Calls (Level)'Access; 351 Entry_Call.Next := null; 352 Entry_Call.Mode := Mode; 353 Entry_Call.Cancellation_Attempted := False; 354 355 -- If this is a call made inside of an abort deferred region, 356 -- the call should be never abortable. 357 358 Entry_Call.State := 359 (if Self_Id.Deferral_Level > 1 360 then Never_Abortable 361 else Now_Abortable); 362 363 Entry_Call.E := Entry_Index (E); 364 Entry_Call.Prio := Get_Priority (Self_Id); 365 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 366 Entry_Call.Called_Task := Acceptor; 367 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 368 Entry_Call.With_Abort := True; 369 370 -- Note: the caller will undefer abort on return (see WARNING above) 371 372 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then 373 STPO.Write_Lock (Self_Id); 374 Utilities.Exit_One_ATC_Level (Self_Id); 375 STPO.Unlock (Self_Id); 376 Local_Undefer_Abort (Self_Id); 377 378 raise Tasking_Error; 379 end if; 380 381 STPO.Write_Lock (Self_Id); 382 pragma Debug 383 (Debug.Trace (Self_Id, "Call_Synchronous: wait", 'R')); 384 Entry_Calls.Wait_For_Completion (Entry_Call); 385 pragma Debug 386 (Debug.Trace (Self_Id, "Call_Synchronous: done waiting", 'R')); 387 Rendezvous_Successful := Entry_Call.State = Done; 388 STPO.Unlock (Self_Id); 389 Local_Undefer_Abort (Self_Id); 390 Entry_Calls.Check_Exception (Self_Id, Entry_Call); 391 end Call_Synchronous; 392 393 -------------- 394 -- Callable -- 395 -------------- 396 397 function Callable (T : Task_Id) return Boolean is 398 Result : Boolean; 399 Self_Id : constant Task_Id := STPO.Self; 400 401 begin 402 Initialization.Defer_Abort_Nestable (Self_Id); 403 STPO.Write_Lock (T); 404 Result := T.Callable; 405 STPO.Unlock (T); 406 Initialization.Undefer_Abort_Nestable (Self_Id); 407 408 return Result; 409 end Callable; 410 411 ---------------------------- 412 -- Cancel_Task_Entry_Call -- 413 ---------------------------- 414 415 procedure Cancel_Task_Entry_Call (Cancelled : out Boolean) is 416 begin 417 Entry_Calls.Try_To_Cancel_Entry_Call (Cancelled); 418 end Cancel_Task_Entry_Call; 419 420 ------------------------- 421 -- Complete_Rendezvous -- 422 ------------------------- 423 424 procedure Complete_Rendezvous is 425 begin 426 Local_Complete_Rendezvous (Ada.Exceptions.Null_Id); 427 end Complete_Rendezvous; 428 429 ------------------------------------- 430 -- Exceptional_Complete_Rendezvous -- 431 ------------------------------------- 432 433 procedure Exceptional_Complete_Rendezvous 434 (Ex : Ada.Exceptions.Exception_Id) 435 is 436 procedure Internal_Reraise; 437 pragma No_Return (Internal_Reraise); 438 pragma Import (C, Internal_Reraise, "__gnat_reraise"); 439 440 begin 441 Local_Complete_Rendezvous (Ex); 442 Internal_Reraise; 443 444 -- ??? Do we need to give precedence to Program_Error that might be 445 -- raised due to failure of finalization, over Tasking_Error from 446 -- failure of requeue? 447 end Exceptional_Complete_Rendezvous; 448 449 ------------------------------- 450 -- Local_Complete_Rendezvous -- 451 ------------------------------- 452 453 procedure Local_Complete_Rendezvous (Ex : Ada.Exceptions.Exception_Id) is 454 Self_Id : constant Task_Id := STPO.Self; 455 Entry_Call : Entry_Call_Link := Self_Id.Common.Call; 456 Caller : Task_Id; 457 Called_PO : STPE.Protection_Entries_Access; 458 Acceptor_Prev_Priority : Integer; 459 460 Ceiling_Violation : Boolean; 461 462 use type Ada.Exceptions.Exception_Id; 463 procedure Transfer_Occurrence 464 (Target : Ada.Exceptions.Exception_Occurrence_Access; 465 Source : Ada.Exceptions.Exception_Occurrence); 466 pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); 467 468 begin 469 -- The deferral level is critical here, since we want to raise an 470 -- exception or allow abort to take place, if there is an exception or 471 -- abort pending. 472 473 pragma Debug 474 (Debug.Trace (Self_Id, "Local_Complete_Rendezvous", 'R')); 475 476 Initialization.Defer_Abort (Self_Id); 477 478 -- We need to clean up any accepts which Self may have been serving when 479 -- it was aborted. 480 481 if Ex = Standard'Abort_Signal'Identity then 482 while Entry_Call /= null loop 483 Entry_Call.Exception_To_Raise := Tasking_Error'Identity; 484 485 -- All forms of accept make sure that the acceptor is not 486 -- completed, before accepting further calls, so that we 487 -- can be sure that no further calls are made after the 488 -- current calls are purged. 489 490 Caller := Entry_Call.Self; 491 492 -- Take write lock. This follows the lock precedence rule that 493 -- Caller may be locked while holding lock of Acceptor. Complete 494 -- the call abnormally, with exception. 495 496 STPO.Write_Lock (Caller); 497 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); 498 STPO.Unlock (Caller); 499 Entry_Call := Entry_Call.Acceptor_Prev_Call; 500 end loop; 501 else 502 Caller := Entry_Call.Self; 503 504 if Entry_Call.Needs_Requeue then 505 506 -- We dare not lock Self_Id at the same time as Caller, for fear 507 -- of deadlock. 508 509 Entry_Call.Needs_Requeue := False; 510 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; 511 512 if Entry_Call.Called_Task /= null then 513 514 -- Requeue to another task entry 515 516 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then 517 Initialization.Undefer_Abort (Self_Id); 518 raise Tasking_Error; 519 end if; 520 else 521 -- Requeue to a protected entry 522 523 Called_PO := POE.To_Protection (Entry_Call.Called_PO); 524 STPE.Lock_Entries_With_Status (Called_PO, Ceiling_Violation); 525 526 if Ceiling_Violation then 527 pragma Assert (Ex = Ada.Exceptions.Null_Id); 528 Entry_Call.Exception_To_Raise := Program_Error'Identity; 529 STPO.Write_Lock (Caller); 530 Initialization.Wakeup_Entry_Caller 531 (Self_Id, Entry_Call, Done); 532 STPO.Unlock (Caller); 533 534 else 535 POO.PO_Do_Or_Queue (Self_Id, Called_PO, Entry_Call); 536 POO.PO_Service_Entries (Self_Id, Called_PO); 537 end if; 538 end if; 539 540 Entry_Calls.Reset_Priority 541 (Self_Id, Entry_Call.Acceptor_Prev_Priority); 542 543 else 544 -- The call does not need to be requeued 545 546 Self_Id.Common.Call := Entry_Call.Acceptor_Prev_Call; 547 Entry_Call.Exception_To_Raise := Ex; 548 STPO.Write_Lock (Caller); 549 550 -- Done with Caller locked to make sure that Wakeup is not lost 551 552 if Ex /= Ada.Exceptions.Null_Id then 553 Transfer_Occurrence 554 (Caller.Common.Compiler_Data.Current_Excep'Access, 555 Self_Id.Common.Compiler_Data.Current_Excep); 556 end if; 557 558 Acceptor_Prev_Priority := Entry_Call.Acceptor_Prev_Priority; 559 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); 560 561 STPO.Unlock (Caller); 562 Entry_Calls.Reset_Priority (Self_Id, Acceptor_Prev_Priority); 563 end if; 564 end if; 565 566 Initialization.Undefer_Abort (Self_Id); 567 end Local_Complete_Rendezvous; 568 569 ------------------------------------- 570 -- Requeue_Protected_To_Task_Entry -- 571 ------------------------------------- 572 573 procedure Requeue_Protected_To_Task_Entry 574 (Object : STPE.Protection_Entries_Access; 575 Acceptor : Task_Id; 576 E : Task_Entry_Index; 577 With_Abort : Boolean) 578 is 579 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; 580 begin 581 pragma Assert (STPO.Self.Deferral_Level > 0); 582 583 Entry_Call.E := Entry_Index (E); 584 Entry_Call.Called_Task := Acceptor; 585 Entry_Call.Called_PO := Null_Address; 586 Entry_Call.With_Abort := With_Abort; 587 Object.Call_In_Progress := null; 588 end Requeue_Protected_To_Task_Entry; 589 590 ------------------------ 591 -- Requeue_Task_Entry -- 592 ------------------------ 593 594 procedure Requeue_Task_Entry 595 (Acceptor : Task_Id; 596 E : Task_Entry_Index; 597 With_Abort : Boolean) 598 is 599 Self_Id : constant Task_Id := STPO.Self; 600 Entry_Call : constant Entry_Call_Link := Self_Id.Common.Call; 601 begin 602 Initialization.Defer_Abort (Self_Id); 603 Entry_Call.Needs_Requeue := True; 604 Entry_Call.With_Abort := With_Abort; 605 Entry_Call.E := Entry_Index (E); 606 Entry_Call.Called_Task := Acceptor; 607 Initialization.Undefer_Abort (Self_Id); 608 end Requeue_Task_Entry; 609 610 -------------------- 611 -- Selective_Wait -- 612 -------------------- 613 614 procedure Selective_Wait 615 (Open_Accepts : Accept_List_Access; 616 Select_Mode : Select_Modes; 617 Uninterpreted_Data : out System.Address; 618 Index : out Select_Index) 619 is 620 Self_Id : constant Task_Id := STPO.Self; 621 Entry_Call : Entry_Call_Link; 622 Treatment : Select_Treatment; 623 Caller : Task_Id; 624 Selection : Select_Index; 625 Open_Alternative : Boolean; 626 627 begin 628 Initialization.Defer_Abort (Self_Id); 629 STPO.Write_Lock (Self_Id); 630 631 if not Self_Id.Callable then 632 pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task); 633 634 pragma Assert (Self_Id.Pending_Action); 635 636 STPO.Unlock (Self_Id); 637 638 -- ??? In some cases abort is deferred more than once. Need to 639 -- figure out why this happens. 640 641 if Self_Id.Deferral_Level > 1 then 642 Self_Id.Deferral_Level := 1; 643 end if; 644 645 Initialization.Undefer_Abort (Self_Id); 646 647 -- Should never get here ??? 648 649 pragma Assert (False); 650 raise Standard'Abort_Signal; 651 end if; 652 653 pragma Assert (Open_Accepts /= null); 654 655 Uninterpreted_Data := Null_Address; 656 657 Queuing.Select_Task_Entry_Call 658 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); 659 660 -- Determine the kind and disposition of the select 661 662 Treatment := Default_Treatment (Select_Mode); 663 Self_Id.Chosen_Index := No_Rendezvous; 664 665 if Open_Alternative then 666 if Entry_Call /= null then 667 if Open_Accepts (Selection).Null_Body then 668 Treatment := Accept_Alternative_Completed; 669 else 670 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); 671 Treatment := Accept_Alternative_Selected; 672 end if; 673 674 Self_Id.Chosen_Index := Selection; 675 676 elsif Treatment = No_Alternative_Open then 677 Treatment := Accept_Alternative_Open; 678 end if; 679 end if; 680 681 -- Handle the select according to the disposition selected above 682 683 case Treatment is 684 when Accept_Alternative_Selected => 685 686 -- Ready to rendezvous 687 688 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; 689 690 -- In this case the accept body is not Null_Body. Defer abort 691 -- until it gets into the accept body. The compiler has inserted 692 -- a call to Abort_Undefer as part of the entry expansion. 693 694 pragma Assert (Self_Id.Deferral_Level = 1); 695 696 Initialization.Defer_Abort_Nestable (Self_Id); 697 STPO.Unlock (Self_Id); 698 699 when Accept_Alternative_Completed => 700 701 -- Accept body is null, so rendezvous is over immediately 702 703 STPO.Unlock (Self_Id); 704 Caller := Entry_Call.Self; 705 706 STPO.Write_Lock (Caller); 707 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); 708 STPO.Unlock (Caller); 709 710 when Accept_Alternative_Open => 711 712 -- Wait for caller 713 714 Self_Id.Open_Accepts := Open_Accepts; 715 pragma Debug 716 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); 717 718 Wait_For_Call (Self_Id); 719 720 pragma Assert (Self_Id.Open_Accepts = null); 721 722 -- Self_Id.Common.Call should already be updated by the Caller if 723 -- not aborted. It might also be ready to do rendezvous even if 724 -- this wakes up due to an abort. Therefore, if the call is not 725 -- empty we need to do the rendezvous if the accept body is not 726 -- Null_Body. 727 728 -- Aren't the first two conditions below redundant??? 729 730 if Self_Id.Chosen_Index /= No_Rendezvous 731 and then Self_Id.Common.Call /= null 732 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body 733 then 734 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; 735 736 pragma Assert 737 (Self_Id.Deferral_Level = 1 738 or else 739 (Self_Id.Deferral_Level = 0 740 and then not Restrictions.Abort_Allowed)); 741 742 Initialization.Defer_Abort_Nestable (Self_Id); 743 744 -- Leave abort deferred until the accept body 745 -- The compiler has inserted a call to Abort_Undefer as part of 746 -- the entry expansion. 747 end if; 748 749 STPO.Unlock (Self_Id); 750 751 when Else_Selected => 752 pragma Assert (Self_Id.Open_Accepts = null); 753 754 STPO.Unlock (Self_Id); 755 756 when Terminate_Selected => 757 758 -- Terminate alternative is open 759 760 Self_Id.Open_Accepts := Open_Accepts; 761 Self_Id.Common.State := Acceptor_Sleep; 762 763 -- Notify ancestors that this task is on a terminate alternative 764 765 STPO.Unlock (Self_Id); 766 Utilities.Make_Passive (Self_Id, Task_Completed => False); 767 STPO.Write_Lock (Self_Id); 768 769 -- Wait for normal entry call or termination 770 771 Wait_For_Call (Self_Id); 772 773 pragma Assert (Self_Id.Open_Accepts = null); 774 775 if Self_Id.Terminate_Alternative then 776 777 -- An entry call should have reset this to False, so we must be 778 -- aborted. We cannot be in an async. select, since that is not 779 -- legal, so the abort must be of the entire task. Therefore, 780 -- we do not need to cancel the terminate alternative. The 781 -- cleanup will be done in Complete_Master. 782 783 pragma Assert 784 (Self_Id.Pending_ATC_Level = Level_Completed_Task); 785 pragma Assert (Self_Id.Awake_Count = 0); 786 787 STPO.Unlock (Self_Id); 788 789 Index := Self_Id.Chosen_Index; 790 Initialization.Undefer_Abort_Nestable (Self_Id); 791 792 if Self_Id.Pending_Action then 793 Initialization.Do_Pending_Action (Self_Id); 794 end if; 795 796 return; 797 798 else 799 -- Self_Id.Common.Call and Self_Id.Chosen_Index 800 -- should already be updated by the Caller. 801 802 if Self_Id.Chosen_Index /= No_Rendezvous 803 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body 804 then 805 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; 806 807 pragma Assert (Self_Id.Deferral_Level = 1); 808 809 -- We need an extra defer here, to keep abort 810 -- deferred until we get into the accept body 811 -- The compiler has inserted a call to Abort_Undefer as part 812 -- of the entry expansion. 813 814 Initialization.Defer_Abort_Nestable (Self_Id); 815 end if; 816 end if; 817 818 STPO.Unlock (Self_Id); 819 820 when No_Alternative_Open => 821 822 -- In this case, Index will be No_Rendezvous on return, which 823 -- should cause a Program_Error if it is not a Delay_Mode. 824 825 -- If delay alternative exists (Delay_Mode) we should suspend 826 -- until the delay expires. 827 828 Self_Id.Open_Accepts := null; 829 830 if Select_Mode = Delay_Mode then 831 Self_Id.Common.State := Delay_Sleep; 832 833 loop 834 exit when 835 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; 836 Sleep (Self_Id, Delay_Sleep); 837 end loop; 838 839 Self_Id.Common.State := Runnable; 840 STPO.Unlock (Self_Id); 841 842 else 843 STPO.Unlock (Self_Id); 844 Initialization.Undefer_Abort (Self_Id); 845 raise Program_Error with "entry call not a delay mode"; 846 end if; 847 end case; 848 849 -- Caller has been chosen 850 851 -- Self_Id.Common.Call should already be updated by the Caller. 852 853 -- Self_Id.Chosen_Index should either be updated by the Caller 854 -- or by Test_Selective_Wait. 855 856 -- On return, we sill start rendezvous unless the accept body is 857 -- null. In the latter case, we will have already completed the RV. 858 859 Index := Self_Id.Chosen_Index; 860 Initialization.Undefer_Abort_Nestable (Self_Id); 861 end Selective_Wait; 862 863 ------------------------------------ 864 -- Setup_For_Rendezvous_With_Body -- 865 ------------------------------------ 866 867 procedure Setup_For_Rendezvous_With_Body 868 (Entry_Call : Entry_Call_Link; 869 Acceptor : Task_Id) is 870 begin 871 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call; 872 Acceptor.Common.Call := Entry_Call; 873 874 if Entry_Call.State = Now_Abortable then 875 Entry_Call.State := Was_Abortable; 876 end if; 877 878 Boost_Priority (Entry_Call, Acceptor); 879 end Setup_For_Rendezvous_With_Body; 880 881 ---------------- 882 -- Task_Count -- 883 ---------------- 884 885 function Task_Count (E : Task_Entry_Index) return Natural is 886 Self_Id : constant Task_Id := STPO.Self; 887 Return_Count : Natural; 888 889 begin 890 Initialization.Defer_Abort (Self_Id); 891 STPO.Write_Lock (Self_Id); 892 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E)); 893 STPO.Unlock (Self_Id); 894 Initialization.Undefer_Abort (Self_Id); 895 896 return Return_Count; 897 end Task_Count; 898 899 ---------------------- 900 -- Task_Do_Or_Queue -- 901 ---------------------- 902 903 function Task_Do_Or_Queue 904 (Self_ID : Task_Id; 905 Entry_Call : Entry_Call_Link) return Boolean 906 is 907 E : constant Task_Entry_Index := 908 Task_Entry_Index (Entry_Call.E); 909 Old_State : constant Entry_Call_State := Entry_Call.State; 910 Acceptor : constant Task_Id := Entry_Call.Called_Task; 911 Parent : constant Task_Id := Acceptor.Common.Parent; 912 Null_Body : Boolean; 913 914 begin 915 -- Find out whether Entry_Call can be accepted immediately 916 917 -- If the Acceptor is not callable, return False. 918 -- If the rendezvous can start, initiate it. 919 -- If the accept-body is trivial, also complete the rendezvous. 920 -- If the acceptor is not ready, enqueue the call. 921 922 -- This should have a special case for Accept_Call and Accept_Trivial, 923 -- so that we don't have the loop setup overhead, below. 924 925 -- The call state Done is used here and elsewhere to include both the 926 -- case of normal successful completion, and the case of an exception 927 -- being raised. The difference is that if an exception is raised no one 928 -- will pay attention to the fact that State = Done. Instead the 929 -- exception will be raised in Undefer_Abort, and control will skip past 930 -- the place where we normally would resume from an entry call. 931 932 pragma Assert (not Queuing.Onqueue (Entry_Call)); 933 934 -- We rely that the call is off-queue for protection, that the caller 935 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call 936 -- record for another call. We rely on the Caller's lock for call State 937 -- mod's. 938 939 -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and 940 -- Acceptor, in that order; otherwise, we only need a lock on Acceptor. 941 -- However, we can't check Acceptor.Terminate_Alternative until Acceptor 942 -- is locked. Therefore, we need to lock both. Attempts to avoid locking 943 -- Parent tend to result in race conditions. It would work to unlock 944 -- Parent immediately upon finding Acceptor.Terminate_Alternative to be 945 -- False, but that violates the rule of properly nested locking (see 946 -- System.Tasking). 947 948 STPO.Write_Lock (Parent); 949 STPO.Write_Lock (Acceptor); 950 951 -- If the acceptor is not callable, abort the call and return False 952 953 if not Acceptor.Callable then 954 STPO.Unlock (Acceptor); 955 STPO.Unlock (Parent); 956 957 pragma Assert (Entry_Call.State < Done); 958 959 -- In case we are not the caller, set up the caller 960 -- to raise Tasking_Error when it wakes up. 961 962 STPO.Write_Lock (Entry_Call.Self); 963 Entry_Call.Exception_To_Raise := Tasking_Error'Identity; 964 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); 965 STPO.Unlock (Entry_Call.Self); 966 967 return False; 968 end if; 969 970 -- Try to serve the call immediately 971 972 if Acceptor.Open_Accepts /= null then 973 for J in Acceptor.Open_Accepts'Range loop 974 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then 975 976 -- Commit acceptor to rendezvous with us 977 978 Acceptor.Chosen_Index := J; 979 Null_Body := Acceptor.Open_Accepts (J).Null_Body; 980 Acceptor.Open_Accepts := null; 981 982 -- Prevent abort while call is being served 983 984 if Entry_Call.State = Now_Abortable then 985 Entry_Call.State := Was_Abortable; 986 end if; 987 988 if Acceptor.Terminate_Alternative then 989 990 -- Cancel terminate alternative. See matching code in 991 -- Selective_Wait and Vulnerable_Complete_Master. 992 993 Acceptor.Terminate_Alternative := False; 994 Acceptor.Awake_Count := Acceptor.Awake_Count + 1; 995 996 if Acceptor.Awake_Count = 1 then 997 998 -- Notify parent that acceptor is awake 999 1000 pragma Assert (Parent.Awake_Count > 0); 1001 1002 Parent.Awake_Count := Parent.Awake_Count + 1; 1003 1004 if Parent.Common.State = Master_Completion_Sleep 1005 and then Acceptor.Master_Of_Task = Parent.Master_Within 1006 then 1007 Parent.Common.Wait_Count := 1008 Parent.Common.Wait_Count + 1; 1009 end if; 1010 end if; 1011 end if; 1012 1013 if Null_Body then 1014 1015 -- Rendezvous is over immediately 1016 1017 STPO.Wakeup (Acceptor, Acceptor_Sleep); 1018 STPO.Unlock (Acceptor); 1019 STPO.Unlock (Parent); 1020 1021 STPO.Write_Lock (Entry_Call.Self); 1022 Initialization.Wakeup_Entry_Caller 1023 (Self_ID, Entry_Call, Done); 1024 STPO.Unlock (Entry_Call.Self); 1025 1026 else 1027 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor); 1028 1029 -- For terminate_alternative, acceptor may not be asleep 1030 -- yet, so we skip the wakeup 1031 1032 if Acceptor.Common.State /= Runnable then 1033 STPO.Wakeup (Acceptor, Acceptor_Sleep); 1034 end if; 1035 1036 STPO.Unlock (Acceptor); 1037 STPO.Unlock (Parent); 1038 end if; 1039 1040 return True; 1041 end if; 1042 end loop; 1043 1044 -- The acceptor is accepting, but not this entry 1045 end if; 1046 1047 -- If the acceptor was ready to accept this call, 1048 -- we would not have gotten this far, so now we should 1049 -- (re)enqueue the call, if the mode permits that. 1050 1051 -- If the call is timed, it may have timed out before the requeue, 1052 -- in the unusual case where the current accept has taken longer than 1053 -- the given delay. In that case the requeue is cancelled, and the 1054 -- outer timed call will be aborted. 1055 1056 if Entry_Call.Mode = Conditional_Call 1057 or else 1058 (Entry_Call.Mode = Timed_Call 1059 and then Entry_Call.With_Abort 1060 and then Entry_Call.Cancellation_Attempted) 1061 then 1062 STPO.Unlock (Acceptor); 1063 STPO.Unlock (Parent); 1064 1065 STPO.Write_Lock (Entry_Call.Self); 1066 1067 pragma Assert (Entry_Call.State >= Was_Abortable); 1068 1069 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); 1070 STPO.Unlock (Entry_Call.Self); 1071 1072 else 1073 -- Timed_Call, Simple_Call, or Asynchronous_Call 1074 1075 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call); 1076 1077 -- Update abortability of call 1078 1079 pragma Assert (Old_State < Done); 1080 1081 Entry_Call.State := 1082 New_State (Entry_Call.With_Abort, Entry_Call.State); 1083 1084 STPO.Unlock (Acceptor); 1085 STPO.Unlock (Parent); 1086 1087 if Old_State /= Entry_Call.State 1088 and then Entry_Call.State = Now_Abortable 1089 and then Entry_Call.Mode /= Simple_Call 1090 and then Entry_Call.Self /= Self_ID 1091 1092 -- Asynchronous_Call or Conditional_Call 1093 1094 then 1095 -- Because of ATCB lock ordering rule 1096 1097 STPO.Write_Lock (Entry_Call.Self); 1098 1099 if Entry_Call.Self.Common.State = Async_Select_Sleep then 1100 1101 -- Caller may not yet have reached wait-point 1102 1103 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); 1104 end if; 1105 1106 STPO.Unlock (Entry_Call.Self); 1107 end if; 1108 end if; 1109 1110 return True; 1111 end Task_Do_Or_Queue; 1112 1113 --------------------- 1114 -- Task_Entry_Call -- 1115 --------------------- 1116 1117 procedure Task_Entry_Call 1118 (Acceptor : Task_Id; 1119 E : Task_Entry_Index; 1120 Uninterpreted_Data : System.Address; 1121 Mode : Call_Modes; 1122 Rendezvous_Successful : out Boolean) 1123 is 1124 Self_Id : constant Task_Id := STPO.Self; 1125 Entry_Call : Entry_Call_Link; 1126 1127 begin 1128 -- If pragma Detect_Blocking is active then Program_Error must be 1129 -- raised if this potentially blocking operation is called from a 1130 -- protected action. 1131 1132 if System.Tasking.Detect_Blocking 1133 and then Self_Id.Common.Protected_Action_Nesting > 0 1134 then 1135 raise Program_Error with 1136 "potentially blocking operation"; 1137 end if; 1138 1139 if Mode = Simple_Call or else Mode = Conditional_Call then 1140 Call_Synchronous 1141 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful); 1142 1143 else 1144 -- This is an asynchronous call 1145 1146 -- Abort must already be deferred by the compiler-generated code. 1147 -- Without this, an abort that occurs between the time that this 1148 -- call is made and the time that the abortable part's cleanup 1149 -- handler is set up might miss the cleanup handler and leave the 1150 -- call pending. 1151 1152 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; 1153 pragma Debug 1154 (Debug.Trace (Self_Id, "TEC: entered ATC level: " & 1155 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); 1156 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; 1157 Entry_Call.Next := null; 1158 Entry_Call.Mode := Mode; 1159 Entry_Call.Cancellation_Attempted := False; 1160 Entry_Call.State := Not_Yet_Abortable; 1161 Entry_Call.E := Entry_Index (E); 1162 Entry_Call.Prio := Get_Priority (Self_Id); 1163 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 1164 Entry_Call.Called_Task := Acceptor; 1165 Entry_Call.Called_PO := Null_Address; 1166 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 1167 Entry_Call.With_Abort := True; 1168 1169 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then 1170 STPO.Write_Lock (Self_Id); 1171 Utilities.Exit_One_ATC_Level (Self_Id); 1172 STPO.Unlock (Self_Id); 1173 Initialization.Undefer_Abort (Self_Id); 1174 1175 raise Tasking_Error; 1176 end if; 1177 1178 -- The following is special for async. entry calls. If the call was 1179 -- not queued abortably, we need to wait until it is before 1180 -- proceeding with the abortable part. 1181 1182 -- Wait_Until_Abortable can be called unconditionally here, but it is 1183 -- expensive. 1184 1185 if Entry_Call.State < Was_Abortable then 1186 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call); 1187 end if; 1188 1189 -- Note: following assignment needs to be atomic 1190 1191 Rendezvous_Successful := Entry_Call.State = Done; 1192 end if; 1193 end Task_Entry_Call; 1194 1195 ----------------------- 1196 -- Task_Entry_Caller -- 1197 ----------------------- 1198 1199 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is 1200 Self_Id : constant Task_Id := STPO.Self; 1201 Entry_Call : Entry_Call_Link; 1202 1203 begin 1204 Entry_Call := Self_Id.Common.Call; 1205 1206 for Depth in 1 .. D loop 1207 Entry_Call := Entry_Call.Acceptor_Prev_Call; 1208 pragma Assert (Entry_Call /= null); 1209 end loop; 1210 1211 return Entry_Call.Self; 1212 end Task_Entry_Caller; 1213 1214 -------------------------- 1215 -- Timed_Selective_Wait -- 1216 -------------------------- 1217 1218 procedure Timed_Selective_Wait 1219 (Open_Accepts : Accept_List_Access; 1220 Select_Mode : Select_Modes; 1221 Uninterpreted_Data : out System.Address; 1222 Timeout : Duration; 1223 Mode : Delay_Modes; 1224 Index : out Select_Index) 1225 is 1226 Self_Id : constant Task_Id := STPO.Self; 1227 Treatment : Select_Treatment; 1228 Entry_Call : Entry_Call_Link; 1229 Caller : Task_Id; 1230 Selection : Select_Index; 1231 Open_Alternative : Boolean; 1232 Timedout : Boolean := False; 1233 Yielded : Boolean := True; 1234 1235 begin 1236 pragma Assert (Select_Mode = Delay_Mode); 1237 1238 Initialization.Defer_Abort (Self_Id); 1239 1240 -- If we are aborted here, the effect will be pending 1241 1242 STPO.Write_Lock (Self_Id); 1243 1244 if not Self_Id.Callable then 1245 pragma Assert (Self_Id.Pending_ATC_Level = Level_Completed_Task); 1246 1247 pragma Assert (Self_Id.Pending_Action); 1248 1249 STPO.Unlock (Self_Id); 1250 Initialization.Undefer_Abort (Self_Id); 1251 1252 -- Should never get here ??? 1253 1254 pragma Assert (False); 1255 raise Standard'Abort_Signal; 1256 end if; 1257 1258 Uninterpreted_Data := Null_Address; 1259 1260 pragma Assert (Open_Accepts /= null); 1261 1262 Queuing.Select_Task_Entry_Call 1263 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); 1264 1265 -- Determine the kind and disposition of the select 1266 1267 Treatment := Default_Treatment (Select_Mode); 1268 Self_Id.Chosen_Index := No_Rendezvous; 1269 1270 if Open_Alternative then 1271 if Entry_Call /= null then 1272 if Open_Accepts (Selection).Null_Body then 1273 Treatment := Accept_Alternative_Completed; 1274 1275 else 1276 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); 1277 Treatment := Accept_Alternative_Selected; 1278 end if; 1279 1280 Self_Id.Chosen_Index := Selection; 1281 1282 elsif Treatment = No_Alternative_Open then 1283 Treatment := Accept_Alternative_Open; 1284 end if; 1285 end if; 1286 1287 -- Handle the select according to the disposition selected above 1288 1289 case Treatment is 1290 when Accept_Alternative_Selected => 1291 1292 -- Ready to rendezvous. In this case the accept body is not 1293 -- Null_Body. Defer abort until it gets into the accept body. 1294 1295 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; 1296 Initialization.Defer_Abort_Nestable (Self_Id); 1297 STPO.Unlock (Self_Id); 1298 1299 when Accept_Alternative_Completed => 1300 1301 -- Rendezvous is over 1302 1303 STPO.Unlock (Self_Id); 1304 Caller := Entry_Call.Self; 1305 1306 STPO.Write_Lock (Caller); 1307 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); 1308 STPO.Unlock (Caller); 1309 1310 when Accept_Alternative_Open => 1311 1312 -- Wait for caller 1313 1314 Self_Id.Open_Accepts := Open_Accepts; 1315 1316 -- Wait for a normal call and a pending action until the 1317 -- Wakeup_Time is reached. 1318 1319 Self_Id.Common.State := Acceptor_Delay_Sleep; 1320 1321 -- Try to remove calls to Sleep in the loop below by letting the 1322 -- caller a chance of getting ready immediately, using Unlock 1323 -- Yield. See similar action in Wait_For_Completion/Wait_For_Call. 1324 1325 Unlock (Self_Id); 1326 1327 if Self_Id.Open_Accepts /= null then 1328 Yield; 1329 end if; 1330 1331 Write_Lock (Self_Id); 1332 1333 -- Check if this task has been aborted while the lock was released 1334 1335 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then 1336 Self_Id.Open_Accepts := null; 1337 end if; 1338 1339 loop 1340 exit when Self_Id.Open_Accepts = null; 1341 1342 if Timedout then 1343 Sleep (Self_Id, Acceptor_Delay_Sleep); 1344 else 1345 STPO.Timed_Sleep (Self_Id, Timeout, Mode, 1346 Acceptor_Delay_Sleep, Timedout, Yielded); 1347 end if; 1348 1349 if Timedout then 1350 Self_Id.Open_Accepts := null; 1351 end if; 1352 end loop; 1353 1354 Self_Id.Common.State := Runnable; 1355 1356 -- Self_Id.Common.Call should already be updated by the Caller if 1357 -- not aborted. It might also be ready to do rendezvous even if 1358 -- this wakes up due to an abort. Therefore, if the call is not 1359 -- empty we need to do the rendezvous if the accept body is not 1360 -- Null_Body. 1361 1362 if Self_Id.Chosen_Index /= No_Rendezvous 1363 and then Self_Id.Common.Call /= null 1364 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body 1365 then 1366 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; 1367 1368 pragma Assert (Self_Id.Deferral_Level = 1); 1369 1370 Initialization.Defer_Abort_Nestable (Self_Id); 1371 1372 -- Leave abort deferred until the accept body 1373 end if; 1374 1375 STPO.Unlock (Self_Id); 1376 1377 when No_Alternative_Open => 1378 1379 -- In this case, Index will be No_Rendezvous on return. We sleep 1380 -- for the time we need to. 1381 1382 -- Wait for a signal or timeout. A wakeup can be made 1383 -- for several reasons: 1384 -- 1) Delay is expired 1385 -- 2) Pending_Action needs to be checked 1386 -- (Abort, Priority change) 1387 -- 3) Spurious wakeup 1388 1389 Self_Id.Open_Accepts := null; 1390 Self_Id.Common.State := Acceptor_Delay_Sleep; 1391 1392 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep, 1393 Timedout, Yielded); 1394 1395 Self_Id.Common.State := Runnable; 1396 1397 STPO.Unlock (Self_Id); 1398 1399 when others => 1400 1401 -- Should never get here 1402 1403 pragma Assert (False); 1404 null; 1405 end case; 1406 1407 if not Yielded then 1408 Yield; 1409 end if; 1410 1411 -- Caller has been chosen 1412 1413 -- Self_Id.Common.Call should already be updated by the Caller 1414 1415 -- Self_Id.Chosen_Index should either be updated by the Caller 1416 -- or by Test_Selective_Wait 1417 1418 Index := Self_Id.Chosen_Index; 1419 Initialization.Undefer_Abort_Nestable (Self_Id); 1420 1421 -- Start rendezvous, if not already completed 1422 end Timed_Selective_Wait; 1423 1424 --------------------------- 1425 -- Timed_Task_Entry_Call -- 1426 --------------------------- 1427 1428 procedure Timed_Task_Entry_Call 1429 (Acceptor : Task_Id; 1430 E : Task_Entry_Index; 1431 Uninterpreted_Data : System.Address; 1432 Timeout : Duration; 1433 Mode : Delay_Modes; 1434 Rendezvous_Successful : out Boolean) 1435 is 1436 Self_Id : constant Task_Id := STPO.Self; 1437 Level : ATC_Level; 1438 Entry_Call : Entry_Call_Link; 1439 1440 Yielded : Boolean; 1441 pragma Unreferenced (Yielded); 1442 1443 begin 1444 -- If pragma Detect_Blocking is active then Program_Error must be 1445 -- raised if this potentially blocking operation is called from a 1446 -- protected action. 1447 1448 if System.Tasking.Detect_Blocking 1449 and then Self_Id.Common.Protected_Action_Nesting > 0 1450 then 1451 raise Program_Error with 1452 "potentially blocking operation"; 1453 end if; 1454 1455 Initialization.Defer_Abort (Self_Id); 1456 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; 1457 1458 pragma Debug 1459 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " & 1460 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); 1461 1462 Level := Self_Id.ATC_Nesting_Level; 1463 Entry_Call := Self_Id.Entry_Calls (Level)'Access; 1464 Entry_Call.Next := null; 1465 Entry_Call.Mode := Timed_Call; 1466 Entry_Call.Cancellation_Attempted := False; 1467 1468 -- If this is a call made inside of an abort deferred region, 1469 -- the call should be never abortable. 1470 1471 Entry_Call.State := 1472 (if Self_Id.Deferral_Level > 1 1473 then Never_Abortable 1474 else Now_Abortable); 1475 1476 Entry_Call.E := Entry_Index (E); 1477 Entry_Call.Prio := Get_Priority (Self_Id); 1478 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 1479 Entry_Call.Called_Task := Acceptor; 1480 Entry_Call.Called_PO := Null_Address; 1481 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 1482 Entry_Call.With_Abort := True; 1483 1484 -- Note: the caller will undefer abort on return (see WARNING above) 1485 1486 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then 1487 STPO.Write_Lock (Self_Id); 1488 Utilities.Exit_One_ATC_Level (Self_Id); 1489 STPO.Unlock (Self_Id); 1490 Initialization.Undefer_Abort (Self_Id); 1491 1492 raise Tasking_Error; 1493 end if; 1494 1495 Write_Lock (Self_Id); 1496 Entry_Calls.Wait_For_Completion_With_Timeout 1497 (Entry_Call, Timeout, Mode, Yielded); 1498 Unlock (Self_Id); 1499 1500 -- ??? Do we need to yield in case Yielded is False 1501 1502 Rendezvous_Successful := Entry_Call.State = Done; 1503 Initialization.Undefer_Abort (Self_Id); 1504 Entry_Calls.Check_Exception (Self_Id, Entry_Call); 1505 end Timed_Task_Entry_Call; 1506 1507 ------------------- 1508 -- Wait_For_Call -- 1509 ------------------- 1510 1511 procedure Wait_For_Call (Self_Id : Task_Id) is 1512 begin 1513 Self_Id.Common.State := Acceptor_Sleep; 1514 1515 -- Try to remove calls to Sleep in the loop below by letting the caller 1516 -- a chance of getting ready immediately, using Unlock & Yield. 1517 -- See similar action in Wait_For_Completion & Timed_Selective_Wait. 1518 1519 Unlock (Self_Id); 1520 1521 if Self_Id.Open_Accepts /= null then 1522 Yield; 1523 end if; 1524 1525 Write_Lock (Self_Id); 1526 1527 -- Check if this task has been aborted while the lock was released 1528 1529 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then 1530 Self_Id.Open_Accepts := null; 1531 end if; 1532 1533 loop 1534 exit when Self_Id.Open_Accepts = null; 1535 Sleep (Self_Id, Acceptor_Sleep); 1536 end loop; 1537 1538 Self_Id.Common.State := Runnable; 1539 end Wait_For_Call; 1540 1541end System.Tasking.Rendezvous; 1542