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