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