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