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-2012, 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_Nestable (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_Nestable (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. 841 842 pragma Assert (Self_Id.Deferral_Level = 1); 843 844 Initialization.Defer_Abort_Nestable (Self_Id); 845 STPO.Unlock (Self_Id); 846 847 when Accept_Alternative_Completed => 848 849 -- Accept body is null, so rendezvous is over immediately 850 851 if Parameters.Runtime_Traces then 852 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); 853 end if; 854 855 STPO.Unlock (Self_Id); 856 Caller := Entry_Call.Self; 857 858 STPO.Write_Lock (Caller); 859 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); 860 STPO.Unlock (Caller); 861 862 when Accept_Alternative_Open => 863 864 -- Wait for caller 865 866 Self_Id.Open_Accepts := Open_Accepts; 867 pragma Debug 868 (Debug.Trace (Self_Id, "Selective_Wait: wait", 'R')); 869 870 if Parameters.Runtime_Traces then 871 Send_Trace_Info (W_Select, Self_Id, 872 Integer (Open_Accepts'Length)); 873 end if; 874 875 Wait_For_Call (Self_Id); 876 877 pragma Assert (Self_Id.Open_Accepts = null); 878 879 -- Self_Id.Common.Call should already be updated by the Caller if 880 -- not aborted. It might also be ready to do rendezvous even if 881 -- this wakes up due to an abort. Therefore, if the call is not 882 -- empty we need to do the rendezvous if the accept body is not 883 -- Null_Body. 884 885 -- Aren't the first two conditions below redundant??? 886 887 if Self_Id.Chosen_Index /= No_Rendezvous 888 and then Self_Id.Common.Call /= null 889 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body 890 then 891 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; 892 893 pragma Assert 894 (Self_Id.Deferral_Level = 1 895 or else 896 (Self_Id.Deferral_Level = 0 897 and then not Restrictions.Abort_Allowed)); 898 899 Initialization.Defer_Abort_Nestable (Self_Id); 900 901 -- Leave abort deferred until the accept body 902 end if; 903 904 STPO.Unlock (Self_Id); 905 906 when Else_Selected => 907 pragma Assert (Self_Id.Open_Accepts = null); 908 909 if Parameters.Runtime_Traces then 910 Send_Trace_Info (M_Select_Else); 911 end if; 912 913 STPO.Unlock (Self_Id); 914 915 when Terminate_Selected => 916 917 -- Terminate alternative is open 918 919 Self_Id.Open_Accepts := Open_Accepts; 920 Self_Id.Common.State := Acceptor_Sleep; 921 922 -- Notify ancestors that this task is on a terminate alternative 923 924 STPO.Unlock (Self_Id); 925 Utilities.Make_Passive (Self_Id, Task_Completed => False); 926 STPO.Write_Lock (Self_Id); 927 928 -- Wait for normal entry call or termination 929 930 Wait_For_Call (Self_Id); 931 932 pragma Assert (Self_Id.Open_Accepts = null); 933 934 if Self_Id.Terminate_Alternative then 935 936 -- An entry call should have reset this to False, so we must be 937 -- aborted. We cannot be in an async. select, since that is not 938 -- legal, so the abort must be of the entire task. Therefore, 939 -- we do not need to cancel the terminate alternative. The 940 -- cleanup will be done in Complete_Master. 941 942 pragma Assert (Self_Id.Pending_ATC_Level = 0); 943 pragma Assert (Self_Id.Awake_Count = 0); 944 945 STPO.Unlock (Self_Id); 946 947 if Single_Lock then 948 Unlock_RTS; 949 end if; 950 951 Index := Self_Id.Chosen_Index; 952 Initialization.Undefer_Abort_Nestable (Self_Id); 953 954 if Self_Id.Pending_Action then 955 Initialization.Do_Pending_Action (Self_Id); 956 end if; 957 958 return; 959 960 else 961 -- Self_Id.Common.Call and Self_Id.Chosen_Index 962 -- should already be updated by the Caller. 963 964 if Self_Id.Chosen_Index /= No_Rendezvous 965 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body 966 then 967 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; 968 969 pragma Assert (Self_Id.Deferral_Level = 1); 970 971 -- We need an extra defer here, to keep abort 972 -- deferred until we get into the accept body 973 974 Initialization.Defer_Abort_Nestable (Self_Id); 975 end if; 976 end if; 977 978 STPO.Unlock (Self_Id); 979 980 when No_Alternative_Open => 981 982 -- In this case, Index will be No_Rendezvous on return, which 983 -- should cause a Program_Error if it is not a Delay_Mode. 984 985 -- If delay alternative exists (Delay_Mode) we should suspend 986 -- until the delay expires. 987 988 Self_Id.Open_Accepts := null; 989 990 if Select_Mode = Delay_Mode then 991 Self_Id.Common.State := Delay_Sleep; 992 993 loop 994 exit when 995 Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level; 996 Sleep (Self_Id, Delay_Sleep); 997 end loop; 998 999 Self_Id.Common.State := Runnable; 1000 STPO.Unlock (Self_Id); 1001 1002 else 1003 STPO.Unlock (Self_Id); 1004 1005 if Single_Lock then 1006 Unlock_RTS; 1007 end if; 1008 1009 Initialization.Undefer_Abort (Self_Id); 1010 raise Program_Error with "Entry call not a delay mode"; 1011 end if; 1012 end case; 1013 1014 if Single_Lock then 1015 Unlock_RTS; 1016 end if; 1017 1018 -- Caller has been chosen 1019 1020 -- Self_Id.Common.Call should already be updated by the Caller. 1021 1022 -- Self_Id.Chosen_Index should either be updated by the Caller 1023 -- or by Test_Selective_Wait. 1024 1025 -- On return, we sill start rendezvous unless the accept body is 1026 -- null. In the latter case, we will have already completed the RV. 1027 1028 Index := Self_Id.Chosen_Index; 1029 Initialization.Undefer_Abort_Nestable (Self_Id); 1030 end Selective_Wait; 1031 1032 ------------------------------------ 1033 -- Setup_For_Rendezvous_With_Body -- 1034 ------------------------------------ 1035 1036 procedure Setup_For_Rendezvous_With_Body 1037 (Entry_Call : Entry_Call_Link; 1038 Acceptor : Task_Id) is 1039 begin 1040 Entry_Call.Acceptor_Prev_Call := Acceptor.Common.Call; 1041 Acceptor.Common.Call := Entry_Call; 1042 1043 if Entry_Call.State = Now_Abortable then 1044 Entry_Call.State := Was_Abortable; 1045 end if; 1046 1047 Boost_Priority (Entry_Call, Acceptor); 1048 end Setup_For_Rendezvous_With_Body; 1049 1050 ---------------- 1051 -- Task_Count -- 1052 ---------------- 1053 1054 function Task_Count (E : Task_Entry_Index) return Natural is 1055 Self_Id : constant Task_Id := STPO.Self; 1056 Return_Count : Natural; 1057 1058 begin 1059 Initialization.Defer_Abort (Self_Id); 1060 1061 if Single_Lock then 1062 Lock_RTS; 1063 end if; 1064 1065 STPO.Write_Lock (Self_Id); 1066 Return_Count := Queuing.Count_Waiting (Self_Id.Entry_Queues (E)); 1067 STPO.Unlock (Self_Id); 1068 1069 if Single_Lock then 1070 Unlock_RTS; 1071 end if; 1072 1073 Initialization.Undefer_Abort (Self_Id); 1074 1075 return Return_Count; 1076 end Task_Count; 1077 1078 ---------------------- 1079 -- Task_Do_Or_Queue -- 1080 ---------------------- 1081 1082 function Task_Do_Or_Queue 1083 (Self_ID : Task_Id; 1084 Entry_Call : Entry_Call_Link) return Boolean 1085 is 1086 E : constant Task_Entry_Index := 1087 Task_Entry_Index (Entry_Call.E); 1088 Old_State : constant Entry_Call_State := Entry_Call.State; 1089 Acceptor : constant Task_Id := Entry_Call.Called_Task; 1090 Parent : constant Task_Id := Acceptor.Common.Parent; 1091 Null_Body : Boolean; 1092 1093 begin 1094 -- Find out whether Entry_Call can be accepted immediately 1095 1096 -- If the Acceptor is not callable, return False. 1097 -- If the rendezvous can start, initiate it. 1098 -- If the accept-body is trivial, also complete the rendezvous. 1099 -- If the acceptor is not ready, enqueue the call. 1100 1101 -- This should have a special case for Accept_Call and Accept_Trivial, 1102 -- so that we don't have the loop setup overhead, below. 1103 1104 -- The call state Done is used here and elsewhere to include both the 1105 -- case of normal successful completion, and the case of an exception 1106 -- being raised. The difference is that if an exception is raised no one 1107 -- will pay attention to the fact that State = Done. Instead the 1108 -- exception will be raised in Undefer_Abort, and control will skip past 1109 -- the place where we normally would resume from an entry call. 1110 1111 pragma Assert (not Queuing.Onqueue (Entry_Call)); 1112 1113 -- We rely that the call is off-queue for protection, that the caller 1114 -- will not exit the Entry_Caller_Sleep, and so will not reuse the call 1115 -- record for another call. We rely on the Caller's lock for call State 1116 -- mod's. 1117 1118 -- If Acceptor.Terminate_Alternative is True, we need to lock Parent and 1119 -- Acceptor, in that order; otherwise, we only need a lock on Acceptor. 1120 -- However, we can't check Acceptor.Terminate_Alternative until Acceptor 1121 -- is locked. Therefore, we need to lock both. Attempts to avoid locking 1122 -- Parent tend to result in race conditions. It would work to unlock 1123 -- Parent immediately upon finding Acceptor.Terminate_Alternative to be 1124 -- False, but that violates the rule of properly nested locking (see 1125 -- System.Tasking). 1126 1127 STPO.Write_Lock (Parent); 1128 STPO.Write_Lock (Acceptor); 1129 1130 -- If the acceptor is not callable, abort the call and return False 1131 1132 if not Acceptor.Callable then 1133 STPO.Unlock (Acceptor); 1134 STPO.Unlock (Parent); 1135 1136 pragma Assert (Entry_Call.State < Done); 1137 1138 -- In case we are not the caller, set up the caller 1139 -- to raise Tasking_Error when it wakes up. 1140 1141 STPO.Write_Lock (Entry_Call.Self); 1142 Entry_Call.Exception_To_Raise := Tasking_Error'Identity; 1143 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); 1144 STPO.Unlock (Entry_Call.Self); 1145 1146 return False; 1147 end if; 1148 1149 -- Try to serve the call immediately 1150 1151 if Acceptor.Open_Accepts /= null then 1152 for J in Acceptor.Open_Accepts'Range loop 1153 if Entry_Call.E = Entry_Index (Acceptor.Open_Accepts (J).S) then 1154 1155 -- Commit acceptor to rendezvous with us 1156 1157 Acceptor.Chosen_Index := J; 1158 Null_Body := Acceptor.Open_Accepts (J).Null_Body; 1159 Acceptor.Open_Accepts := null; 1160 1161 -- Prevent abort while call is being served 1162 1163 if Entry_Call.State = Now_Abortable then 1164 Entry_Call.State := Was_Abortable; 1165 end if; 1166 1167 if Acceptor.Terminate_Alternative then 1168 1169 -- Cancel terminate alternative. See matching code in 1170 -- Selective_Wait and Vulnerable_Complete_Master. 1171 1172 Acceptor.Terminate_Alternative := False; 1173 Acceptor.Awake_Count := Acceptor.Awake_Count + 1; 1174 1175 if Acceptor.Awake_Count = 1 then 1176 1177 -- Notify parent that acceptor is awake 1178 1179 pragma Assert (Parent.Awake_Count > 0); 1180 1181 Parent.Awake_Count := Parent.Awake_Count + 1; 1182 1183 if Parent.Common.State = Master_Completion_Sleep 1184 and then Acceptor.Master_of_Task = Parent.Master_Within 1185 then 1186 Parent.Common.Wait_Count := 1187 Parent.Common.Wait_Count + 1; 1188 end if; 1189 end if; 1190 end if; 1191 1192 if Null_Body then 1193 1194 -- Rendezvous is over immediately 1195 1196 STPO.Wakeup (Acceptor, Acceptor_Sleep); 1197 STPO.Unlock (Acceptor); 1198 STPO.Unlock (Parent); 1199 1200 STPO.Write_Lock (Entry_Call.Self); 1201 Initialization.Wakeup_Entry_Caller 1202 (Self_ID, Entry_Call, Done); 1203 STPO.Unlock (Entry_Call.Self); 1204 1205 else 1206 Setup_For_Rendezvous_With_Body (Entry_Call, Acceptor); 1207 1208 -- For terminate_alternative, acceptor may not be asleep 1209 -- yet, so we skip the wakeup 1210 1211 if Acceptor.Common.State /= Runnable then 1212 STPO.Wakeup (Acceptor, Acceptor_Sleep); 1213 end if; 1214 1215 STPO.Unlock (Acceptor); 1216 STPO.Unlock (Parent); 1217 end if; 1218 1219 return True; 1220 end if; 1221 end loop; 1222 1223 -- The acceptor is accepting, but not this entry 1224 end if; 1225 1226 -- If the acceptor was ready to accept this call, 1227 -- we would not have gotten this far, so now we should 1228 -- (re)enqueue the call, if the mode permits that. 1229 1230 -- If the call is timed, it may have timed out before the requeue, 1231 -- in the unusual case where the current accept has taken longer than 1232 -- the given delay. In that case the requeue is cancelled, and the 1233 -- outer timed call will be aborted. 1234 1235 if Entry_Call.Mode = Conditional_Call 1236 or else 1237 (Entry_Call.Mode = Timed_Call 1238 and then Entry_Call.With_Abort 1239 and then Entry_Call.Cancellation_Attempted) 1240 then 1241 STPO.Unlock (Acceptor); 1242 STPO.Unlock (Parent); 1243 1244 STPO.Write_Lock (Entry_Call.Self); 1245 1246 pragma Assert (Entry_Call.State >= Was_Abortable); 1247 1248 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); 1249 STPO.Unlock (Entry_Call.Self); 1250 1251 else 1252 -- Timed_Call, Simple_Call, or Asynchronous_Call 1253 1254 Queuing.Enqueue (Acceptor.Entry_Queues (E), Entry_Call); 1255 1256 -- Update abortability of call 1257 1258 pragma Assert (Old_State < Done); 1259 1260 Entry_Call.State := 1261 New_State (Entry_Call.With_Abort, Entry_Call.State); 1262 1263 STPO.Unlock (Acceptor); 1264 STPO.Unlock (Parent); 1265 1266 if Old_State /= Entry_Call.State 1267 and then Entry_Call.State = Now_Abortable 1268 and then Entry_Call.Mode /= Simple_Call 1269 and then Entry_Call.Self /= Self_ID 1270 1271 -- Asynchronous_Call or Conditional_Call 1272 1273 then 1274 -- Because of ATCB lock ordering rule 1275 1276 STPO.Write_Lock (Entry_Call.Self); 1277 1278 if Entry_Call.Self.Common.State = Async_Select_Sleep then 1279 1280 -- Caller may not yet have reached wait-point 1281 1282 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); 1283 end if; 1284 1285 STPO.Unlock (Entry_Call.Self); 1286 end if; 1287 end if; 1288 1289 return True; 1290 end Task_Do_Or_Queue; 1291 1292 --------------------- 1293 -- Task_Entry_Call -- 1294 --------------------- 1295 1296 procedure Task_Entry_Call 1297 (Acceptor : Task_Id; 1298 E : Task_Entry_Index; 1299 Uninterpreted_Data : System.Address; 1300 Mode : Call_Modes; 1301 Rendezvous_Successful : out Boolean) 1302 is 1303 Self_Id : constant Task_Id := STPO.Self; 1304 Entry_Call : Entry_Call_Link; 1305 1306 begin 1307 -- If pragma Detect_Blocking is active then Program_Error must be 1308 -- raised if this potentially blocking operation is called from a 1309 -- protected action. 1310 1311 if System.Tasking.Detect_Blocking 1312 and then Self_Id.Common.Protected_Action_Nesting > 0 1313 then 1314 raise Program_Error with "potentially blocking operation"; 1315 end if; 1316 1317 if Parameters.Runtime_Traces then 1318 Send_Trace_Info (W_Call, Acceptor, Entry_Index (E)); 1319 end if; 1320 1321 if Mode = Simple_Call or else Mode = Conditional_Call then 1322 Call_Synchronous 1323 (Acceptor, E, Uninterpreted_Data, Mode, Rendezvous_Successful); 1324 1325 else 1326 -- This is an asynchronous call 1327 1328 -- Abort must already be deferred by the compiler-generated code. 1329 -- Without this, an abort that occurs between the time that this 1330 -- call is made and the time that the abortable part's cleanup 1331 -- handler is set up might miss the cleanup handler and leave the 1332 -- call pending. 1333 1334 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; 1335 pragma Debug 1336 (Debug.Trace (Self_Id, "TEC: entered ATC level: " & 1337 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); 1338 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; 1339 Entry_Call.Next := null; 1340 Entry_Call.Mode := Mode; 1341 Entry_Call.Cancellation_Attempted := False; 1342 Entry_Call.State := Not_Yet_Abortable; 1343 Entry_Call.E := Entry_Index (E); 1344 Entry_Call.Prio := Get_Priority (Self_Id); 1345 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 1346 Entry_Call.Called_Task := Acceptor; 1347 Entry_Call.Called_PO := Null_Address; 1348 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 1349 Entry_Call.With_Abort := True; 1350 1351 if Single_Lock then 1352 Lock_RTS; 1353 end if; 1354 1355 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then 1356 STPO.Write_Lock (Self_Id); 1357 Utilities.Exit_One_ATC_Level (Self_Id); 1358 STPO.Unlock (Self_Id); 1359 1360 if Single_Lock then 1361 Unlock_RTS; 1362 end if; 1363 1364 Initialization.Undefer_Abort (Self_Id); 1365 1366 if Parameters.Runtime_Traces then 1367 Send_Trace_Info (E_Missed, Acceptor); 1368 end if; 1369 1370 raise Tasking_Error; 1371 end if; 1372 1373 -- The following is special for async. entry calls. If the call was 1374 -- not queued abortably, we need to wait until it is before 1375 -- proceeding with the abortable part. 1376 1377 -- Wait_Until_Abortable can be called unconditionally here, but it is 1378 -- expensive. 1379 1380 if Entry_Call.State < Was_Abortable then 1381 Entry_Calls.Wait_Until_Abortable (Self_Id, Entry_Call); 1382 end if; 1383 1384 if Single_Lock then 1385 Unlock_RTS; 1386 end if; 1387 1388 -- Note: following assignment needs to be atomic 1389 1390 Rendezvous_Successful := Entry_Call.State = Done; 1391 end if; 1392 end Task_Entry_Call; 1393 1394 ----------------------- 1395 -- Task_Entry_Caller -- 1396 ----------------------- 1397 1398 function Task_Entry_Caller (D : Task_Entry_Nesting_Depth) return Task_Id is 1399 Self_Id : constant Task_Id := STPO.Self; 1400 Entry_Call : Entry_Call_Link; 1401 1402 begin 1403 Entry_Call := Self_Id.Common.Call; 1404 1405 for Depth in 1 .. D loop 1406 Entry_Call := Entry_Call.Acceptor_Prev_Call; 1407 pragma Assert (Entry_Call /= null); 1408 end loop; 1409 1410 return Entry_Call.Self; 1411 end Task_Entry_Caller; 1412 1413 -------------------------- 1414 -- Timed_Selective_Wait -- 1415 -------------------------- 1416 1417 procedure Timed_Selective_Wait 1418 (Open_Accepts : Accept_List_Access; 1419 Select_Mode : Select_Modes; 1420 Uninterpreted_Data : out System.Address; 1421 Timeout : Duration; 1422 Mode : Delay_Modes; 1423 Index : out Select_Index) 1424 is 1425 Self_Id : constant Task_Id := STPO.Self; 1426 Treatment : Select_Treatment; 1427 Entry_Call : Entry_Call_Link; 1428 Caller : Task_Id; 1429 Selection : Select_Index; 1430 Open_Alternative : Boolean; 1431 Timedout : Boolean := False; 1432 Yielded : Boolean := True; 1433 1434 begin 1435 pragma Assert (Select_Mode = Delay_Mode); 1436 1437 Initialization.Defer_Abort (Self_Id); 1438 1439 -- If we are aborted here, the effect will be pending 1440 1441 if Single_Lock then 1442 Lock_RTS; 1443 end if; 1444 1445 STPO.Write_Lock (Self_Id); 1446 1447 if not Self_Id.Callable then 1448 pragma Assert (Self_Id.Pending_ATC_Level = 0); 1449 1450 pragma Assert (Self_Id.Pending_Action); 1451 1452 STPO.Unlock (Self_Id); 1453 1454 if Single_Lock then 1455 Unlock_RTS; 1456 end if; 1457 1458 Initialization.Undefer_Abort (Self_Id); 1459 1460 -- Should never get here ??? 1461 1462 pragma Assert (False); 1463 raise Standard'Abort_Signal; 1464 end if; 1465 1466 Uninterpreted_Data := Null_Address; 1467 1468 pragma Assert (Open_Accepts /= null); 1469 1470 Queuing.Select_Task_Entry_Call 1471 (Self_Id, Open_Accepts, Entry_Call, Selection, Open_Alternative); 1472 1473 -- Determine the kind and disposition of the select 1474 1475 Treatment := Default_Treatment (Select_Mode); 1476 Self_Id.Chosen_Index := No_Rendezvous; 1477 1478 if Open_Alternative then 1479 if Entry_Call /= null then 1480 if Open_Accepts (Selection).Null_Body then 1481 Treatment := Accept_Alternative_Completed; 1482 1483 else 1484 Setup_For_Rendezvous_With_Body (Entry_Call, Self_Id); 1485 Treatment := Accept_Alternative_Selected; 1486 end if; 1487 1488 Self_Id.Chosen_Index := Selection; 1489 1490 elsif Treatment = No_Alternative_Open then 1491 Treatment := Accept_Alternative_Open; 1492 end if; 1493 end if; 1494 1495 -- Handle the select according to the disposition selected above 1496 1497 case Treatment is 1498 when Accept_Alternative_Selected => 1499 1500 -- Ready to rendezvous. In this case the accept body is not 1501 -- Null_Body. Defer abort until it gets into the accept body. 1502 1503 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; 1504 Initialization.Defer_Abort_Nestable (Self_Id); 1505 STPO.Unlock (Self_Id); 1506 1507 when Accept_Alternative_Completed => 1508 1509 -- Rendezvous is over 1510 1511 if Parameters.Runtime_Traces then 1512 Send_Trace_Info (M_RDV_Complete, Entry_Call.Self); 1513 end if; 1514 1515 STPO.Unlock (Self_Id); 1516 Caller := Entry_Call.Self; 1517 1518 STPO.Write_Lock (Caller); 1519 Initialization.Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); 1520 STPO.Unlock (Caller); 1521 1522 when Accept_Alternative_Open => 1523 1524 -- Wait for caller 1525 1526 Self_Id.Open_Accepts := Open_Accepts; 1527 1528 -- Wait for a normal call and a pending action until the 1529 -- Wakeup_Time is reached. 1530 1531 Self_Id.Common.State := Acceptor_Delay_Sleep; 1532 1533 -- Try to remove calls to Sleep in the loop below by letting the 1534 -- caller a chance of getting ready immediately, using Unlock 1535 -- Yield. See similar action in Wait_For_Completion/Wait_For_Call. 1536 1537 if Single_Lock then 1538 Unlock_RTS; 1539 else 1540 Unlock (Self_Id); 1541 end if; 1542 1543 if Self_Id.Open_Accepts /= null then 1544 Yield; 1545 end if; 1546 1547 if Single_Lock then 1548 Lock_RTS; 1549 else 1550 Write_Lock (Self_Id); 1551 end if; 1552 1553 -- Check if this task has been aborted while the lock was released 1554 1555 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then 1556 Self_Id.Open_Accepts := null; 1557 end if; 1558 1559 loop 1560 exit when Self_Id.Open_Accepts = null; 1561 1562 if Timedout then 1563 Sleep (Self_Id, Acceptor_Delay_Sleep); 1564 else 1565 if Parameters.Runtime_Traces then 1566 Send_Trace_Info (WT_Select, 1567 Self_Id, 1568 Integer (Open_Accepts'Length), 1569 Timeout); 1570 end if; 1571 1572 STPO.Timed_Sleep (Self_Id, Timeout, Mode, 1573 Acceptor_Delay_Sleep, Timedout, Yielded); 1574 end if; 1575 1576 if Timedout then 1577 Self_Id.Open_Accepts := null; 1578 1579 if Parameters.Runtime_Traces then 1580 Send_Trace_Info (E_Timeout); 1581 end if; 1582 end if; 1583 end loop; 1584 1585 Self_Id.Common.State := Runnable; 1586 1587 -- Self_Id.Common.Call should already be updated by the Caller if 1588 -- not aborted. It might also be ready to do rendezvous even if 1589 -- this wakes up due to an abort. Therefore, if the call is not 1590 -- empty we need to do the rendezvous if the accept body is not 1591 -- Null_Body. 1592 1593 if Self_Id.Chosen_Index /= No_Rendezvous 1594 and then Self_Id.Common.Call /= null 1595 and then not Open_Accepts (Self_Id.Chosen_Index).Null_Body 1596 then 1597 Uninterpreted_Data := Self_Id.Common.Call.Uninterpreted_Data; 1598 1599 pragma Assert (Self_Id.Deferral_Level = 1); 1600 1601 Initialization.Defer_Abort_Nestable (Self_Id); 1602 1603 -- Leave abort deferred until the accept body 1604 end if; 1605 1606 STPO.Unlock (Self_Id); 1607 1608 when No_Alternative_Open => 1609 1610 -- In this case, Index will be No_Rendezvous on return. We sleep 1611 -- for the time we need to. 1612 1613 -- Wait for a signal or timeout. A wakeup can be made 1614 -- for several reasons: 1615 -- 1) Delay is expired 1616 -- 2) Pending_Action needs to be checked 1617 -- (Abort, Priority change) 1618 -- 3) Spurious wakeup 1619 1620 Self_Id.Open_Accepts := null; 1621 Self_Id.Common.State := Acceptor_Delay_Sleep; 1622 1623 STPO.Timed_Sleep (Self_Id, Timeout, Mode, Acceptor_Delay_Sleep, 1624 Timedout, Yielded); 1625 1626 Self_Id.Common.State := Runnable; 1627 1628 STPO.Unlock (Self_Id); 1629 1630 when others => 1631 1632 -- Should never get here 1633 1634 pragma Assert (False); 1635 null; 1636 end case; 1637 1638 if Single_Lock then 1639 Unlock_RTS; 1640 end if; 1641 1642 if not Yielded then 1643 Yield; 1644 end if; 1645 1646 -- Caller has been chosen 1647 1648 -- Self_Id.Common.Call should already be updated by the Caller 1649 1650 -- Self_Id.Chosen_Index should either be updated by the Caller 1651 -- or by Test_Selective_Wait 1652 1653 Index := Self_Id.Chosen_Index; 1654 Initialization.Undefer_Abort_Nestable (Self_Id); 1655 1656 -- Start rendezvous, if not already completed 1657 end Timed_Selective_Wait; 1658 1659 --------------------------- 1660 -- Timed_Task_Entry_Call -- 1661 --------------------------- 1662 1663 procedure Timed_Task_Entry_Call 1664 (Acceptor : Task_Id; 1665 E : Task_Entry_Index; 1666 Uninterpreted_Data : System.Address; 1667 Timeout : Duration; 1668 Mode : Delay_Modes; 1669 Rendezvous_Successful : out Boolean) 1670 is 1671 Self_Id : constant Task_Id := STPO.Self; 1672 Level : ATC_Level; 1673 Entry_Call : Entry_Call_Link; 1674 1675 Yielded : Boolean; 1676 pragma Unreferenced (Yielded); 1677 1678 begin 1679 -- If pragma Detect_Blocking is active then Program_Error must be 1680 -- raised if this potentially blocking operation is called from a 1681 -- protected action. 1682 1683 if System.Tasking.Detect_Blocking 1684 and then Self_Id.Common.Protected_Action_Nesting > 0 1685 then 1686 raise Program_Error with "potentially blocking operation"; 1687 end if; 1688 1689 Initialization.Defer_Abort (Self_Id); 1690 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; 1691 1692 pragma Debug 1693 (Debug.Trace (Self_Id, "TTEC: entered ATC level: " & 1694 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); 1695 1696 if Parameters.Runtime_Traces then 1697 Send_Trace_Info (WT_Call, Acceptor, 1698 Entry_Index (E), Timeout); 1699 end if; 1700 1701 Level := Self_Id.ATC_Nesting_Level; 1702 Entry_Call := Self_Id.Entry_Calls (Level)'Access; 1703 Entry_Call.Next := null; 1704 Entry_Call.Mode := Timed_Call; 1705 Entry_Call.Cancellation_Attempted := False; 1706 1707 -- If this is a call made inside of an abort deferred region, 1708 -- the call should be never abortable. 1709 1710 Entry_Call.State := 1711 (if Self_Id.Deferral_Level > 1 1712 then Never_Abortable 1713 else Now_Abortable); 1714 1715 Entry_Call.E := Entry_Index (E); 1716 Entry_Call.Prio := Get_Priority (Self_Id); 1717 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 1718 Entry_Call.Called_Task := Acceptor; 1719 Entry_Call.Called_PO := Null_Address; 1720 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 1721 Entry_Call.With_Abort := True; 1722 1723 -- Note: the caller will undefer abort on return (see WARNING above) 1724 1725 if Single_Lock then 1726 Lock_RTS; 1727 end if; 1728 1729 if not Task_Do_Or_Queue (Self_Id, Entry_Call) then 1730 STPO.Write_Lock (Self_Id); 1731 Utilities.Exit_One_ATC_Level (Self_Id); 1732 STPO.Unlock (Self_Id); 1733 1734 if Single_Lock then 1735 Unlock_RTS; 1736 end if; 1737 1738 Initialization.Undefer_Abort (Self_Id); 1739 1740 if Parameters.Runtime_Traces then 1741 Send_Trace_Info (E_Missed, Acceptor); 1742 end if; 1743 raise Tasking_Error; 1744 end if; 1745 1746 Write_Lock (Self_Id); 1747 Entry_Calls.Wait_For_Completion_With_Timeout 1748 (Entry_Call, Timeout, Mode, Yielded); 1749 Unlock (Self_Id); 1750 1751 if Single_Lock then 1752 Unlock_RTS; 1753 end if; 1754 1755 -- ??? Do we need to yield in case Yielded is False 1756 1757 Rendezvous_Successful := Entry_Call.State = Done; 1758 Initialization.Undefer_Abort (Self_Id); 1759 Entry_Calls.Check_Exception (Self_Id, Entry_Call); 1760 end Timed_Task_Entry_Call; 1761 1762 ------------------- 1763 -- Wait_For_Call -- 1764 ------------------- 1765 1766 procedure Wait_For_Call (Self_Id : Task_Id) is 1767 begin 1768 Self_Id.Common.State := Acceptor_Sleep; 1769 1770 -- Try to remove calls to Sleep in the loop below by letting the caller 1771 -- a chance of getting ready immediately, using Unlock & Yield. 1772 -- See similar action in Wait_For_Completion & Timed_Selective_Wait. 1773 1774 if Single_Lock then 1775 Unlock_RTS; 1776 else 1777 Unlock (Self_Id); 1778 end if; 1779 1780 if Self_Id.Open_Accepts /= null then 1781 Yield; 1782 end if; 1783 1784 if Single_Lock then 1785 Lock_RTS; 1786 else 1787 Write_Lock (Self_Id); 1788 end if; 1789 1790 -- Check if this task has been aborted while the lock was released 1791 1792 if Self_Id.Pending_ATC_Level < Self_Id.ATC_Nesting_Level then 1793 Self_Id.Open_Accepts := null; 1794 end if; 1795 1796 loop 1797 exit when Self_Id.Open_Accepts = null; 1798 Sleep (Self_Id, Acceptor_Sleep); 1799 end loop; 1800 1801 Self_Id.Common.State := Runnable; 1802 end Wait_For_Call; 1803 1804end System.Tasking.Rendezvous; 1805