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