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