1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- SYSTEM.TASKING.PROTECTED_OBJECTS.OPERATIONS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2018, Free Software Foundation, Inc. -- 10-- -- 11-- GNARL is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNARL was developed by the GNARL team at Florida State University. -- 28-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32-- This package contains all extended primitives related to Protected_Objects 33-- with entries. 34 35-- The handling of protected objects with no entries is done in 36-- System.Tasking.Protected_Objects, the simple routines for protected 37-- objects with entries in System.Tasking.Protected_Objects.Entries. 38 39-- The split between Entries and Operations is needed to break circular 40-- dependencies inside the run time. 41 42-- This package contains all primitives related to Protected_Objects. 43-- Note: the compiler generates direct calls to this interface, via Rtsfind. 44 45with System.Task_Primitives.Operations; 46with System.Tasking.Entry_Calls; 47with System.Tasking.Queuing; 48with System.Tasking.Rendezvous; 49with System.Tasking.Utilities; 50with System.Tasking.Debug; 51with System.Parameters; 52with System.Restrictions; 53 54with System.Tasking.Initialization; 55pragma Elaborate_All (System.Tasking.Initialization); 56-- Insures that tasking is initialized if any protected objects are created 57 58package body System.Tasking.Protected_Objects.Operations is 59 60 package STPO renames System.Task_Primitives.Operations; 61 62 use Parameters; 63 use Ada.Exceptions; 64 use Entries; 65 66 use System.Restrictions; 67 use System.Restrictions.Rident; 68 69 ----------------------- 70 -- Local Subprograms -- 71 ----------------------- 72 73 procedure Update_For_Queue_To_PO 74 (Entry_Call : Entry_Call_Link; 75 With_Abort : Boolean); 76 pragma Inline (Update_For_Queue_To_PO); 77 -- Update the state of an existing entry call to reflect the fact that it 78 -- is being enqueued, based on whether the current queuing action is with 79 -- or without abort. Call this only while holding the PO's lock. It returns 80 -- with the PO's lock still held. 81 82 procedure Requeue_Call 83 (Self_Id : Task_Id; 84 Object : Protection_Entries_Access; 85 Entry_Call : Entry_Call_Link); 86 -- Handle requeue of Entry_Call. 87 -- In particular, queue the call if needed, or service it immediately 88 -- if possible. 89 90 --------------------------------- 91 -- Cancel_Protected_Entry_Call -- 92 --------------------------------- 93 94 -- Compiler interface only (do not call from within the RTS) 95 96 -- This should have analogous effect to Cancel_Task_Entry_Call, setting 97 -- the value of Block.Cancelled instead of returning the parameter value 98 -- Cancelled. 99 100 -- The effect should be idempotent, since the call may already have been 101 -- dequeued. 102 103 -- Source code: 104 105 -- select r.e; 106 -- ...A... 107 -- then abort 108 -- ...B... 109 -- end select; 110 111 -- Expanded code: 112 113 -- declare 114 -- X : protected_entry_index := 1; 115 -- B80b : communication_block; 116 -- communication_blockIP (B80b); 117 118 -- begin 119 -- begin 120 -- A79b : label 121 -- A79b : declare 122 -- procedure _clean is 123 -- begin 124 -- if enqueued (B80b) then 125 -- cancel_protected_entry_call (B80b); 126 -- end if; 127 -- return; 128 -- end _clean; 129 130 -- begin 131 -- protected_entry_call (rTV!(r)._object'unchecked_access, X, 132 -- null_address, asynchronous_call, B80b, objectF => 0); 133 -- if enqueued (B80b) then 134 -- ...B... 135 -- end if; 136 -- at end 137 -- _clean; 138 -- end A79b; 139 140 -- exception 141 -- when _abort_signal => 142 -- abort_undefer.all; 143 -- null; 144 -- end; 145 146 -- if not cancelled (B80b) then 147 -- x := ...A... 148 -- end if; 149 -- end; 150 151 -- If the entry call completes after we get into the abortable part, 152 -- Abort_Signal should be raised and ATC will take us to the at-end 153 -- handler, which will call _clean. 154 155 -- If the entry call returns with the call already completed, we can skip 156 -- this, and use the "if enqueued()" to go past the at-end handler, but we 157 -- will still call _clean. 158 159 -- If the abortable part completes before the entry call is Done, it will 160 -- call _clean. 161 162 -- If the entry call or the abortable part raises an exception, 163 -- we will still call _clean, but the value of Cancelled should not matter. 164 165 -- Whoever calls _clean first gets to decide whether the call 166 -- has been "cancelled". 167 168 -- Enqueued should be true if there is any chance that the call is still on 169 -- a queue. It seems to be safe to make it True if the call was Onqueue at 170 -- some point before return from Protected_Entry_Call. 171 172 -- Cancelled should be true iff the abortable part completed 173 -- and succeeded in cancelling the entry call before it completed. 174 175 -- ????? 176 -- The need for Enqueued is less obvious. The "if enqueued ()" tests are 177 -- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call 178 -- must do the same test internally, with locking. The one that makes 179 -- cancellation conditional may be a useful heuristic since at least 1/2 180 -- the time the call should be off-queue by that point. The other one seems 181 -- totally useless, since Protected_Entry_Call must do the same check and 182 -- then possibly wait for the call to be abortable, internally. 183 184 -- We can check Call.State here without locking the caller's mutex, 185 -- since the call must be over after returning from Wait_For_Completion. 186 -- No other task can access the call record at this point. 187 188 procedure Cancel_Protected_Entry_Call 189 (Block : in out Communication_Block) is 190 begin 191 Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled); 192 end Cancel_Protected_Entry_Call; 193 194 --------------- 195 -- Cancelled -- 196 --------------- 197 198 function Cancelled (Block : Communication_Block) return Boolean is 199 begin 200 return Block.Cancelled; 201 end Cancelled; 202 203 ------------------------- 204 -- Complete_Entry_Body -- 205 ------------------------- 206 207 procedure Complete_Entry_Body (Object : Protection_Entries_Access) is 208 begin 209 Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id); 210 end Complete_Entry_Body; 211 212 -------------- 213 -- Enqueued -- 214 -------------- 215 216 function Enqueued (Block : Communication_Block) return Boolean is 217 begin 218 return Block.Enqueued; 219 end Enqueued; 220 221 ------------------------------------- 222 -- Exceptional_Complete_Entry_Body -- 223 ------------------------------------- 224 225 procedure Exceptional_Complete_Entry_Body 226 (Object : Protection_Entries_Access; 227 Ex : Ada.Exceptions.Exception_Id) 228 is 229 procedure Transfer_Occurrence 230 (Target : Ada.Exceptions.Exception_Occurrence_Access; 231 Source : Ada.Exceptions.Exception_Occurrence); 232 pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); 233 234 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; 235 Self_Id : Task_Id; 236 237 begin 238 pragma Debug 239 (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P')); 240 241 -- We must have abort deferred, since we are inside a protected 242 -- operation. 243 244 if Entry_Call /= null then 245 246 -- The call was not requeued 247 248 Entry_Call.Exception_To_Raise := Ex; 249 250 if Ex /= Ada.Exceptions.Null_Id then 251 252 -- An exception was raised and abort was deferred, so adjust 253 -- before propagating, otherwise the task will stay with deferral 254 -- enabled for its remaining life. 255 256 Self_Id := STPO.Self; 257 258 if not ZCX_By_Default then 259 Initialization.Undefer_Abort_Nestable (Self_Id); 260 end if; 261 262 Transfer_Occurrence 263 (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access, 264 Self_Id.Common.Compiler_Data.Current_Excep); 265 end if; 266 267 -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or 268 -- PO_Service_Entries on return. 269 270 end if; 271 end Exceptional_Complete_Entry_Body; 272 273 -------------------- 274 -- PO_Do_Or_Queue -- 275 -------------------- 276 277 procedure PO_Do_Or_Queue 278 (Self_ID : Task_Id; 279 Object : Protection_Entries_Access; 280 Entry_Call : Entry_Call_Link) 281 is 282 E : constant Protected_Entry_Index := 283 Protected_Entry_Index (Entry_Call.E); 284 Index : constant Protected_Entry_Index := 285 Object.Find_Body_Index (Object.Compiler_Info, E); 286 Barrier_Value : Boolean; 287 Queue_Length : Natural; 288 begin 289 -- When the Action procedure for an entry body returns, it is either 290 -- completed (having called [Exceptional_]Complete_Entry_Body) or it 291 -- is queued, having executed a requeue statement. 292 293 Barrier_Value := 294 Object.Entry_Bodies (Index).Barrier (Object.Compiler_Info, E); 295 296 if Barrier_Value then 297 298 -- Not abortable while service is in progress 299 300 if Entry_Call.State = Now_Abortable then 301 Entry_Call.State := Was_Abortable; 302 end if; 303 304 Object.Call_In_Progress := Entry_Call; 305 306 pragma Debug 307 (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P')); 308 Object.Entry_Bodies (Index).Action ( 309 Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); 310 311 if Object.Call_In_Progress /= null then 312 313 -- Body of current entry served call to completion 314 315 Object.Call_In_Progress := null; 316 317 if Single_Lock then 318 STPO.Lock_RTS; 319 end if; 320 321 STPO.Write_Lock (Entry_Call.Self); 322 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); 323 STPO.Unlock (Entry_Call.Self); 324 325 if Single_Lock then 326 STPO.Unlock_RTS; 327 end if; 328 329 else 330 Requeue_Call (Self_ID, Object, Entry_Call); 331 end if; 332 333 elsif Entry_Call.Mode /= Conditional_Call 334 or else not Entry_Call.With_Abort 335 then 336 if Run_Time_Restrictions.Set (Max_Entry_Queue_Length) 337 or else Object.Entry_Queue_Maxes /= null 338 then 339 -- Need to check the queue length. Computing the length is an 340 -- unusual case and is slow (need to walk the queue). 341 342 Queue_Length := Queuing.Count_Waiting (Object.Entry_Queues (E)); 343 344 if (Run_Time_Restrictions.Set (Max_Entry_Queue_Length) 345 and then Queue_Length >= 346 Run_Time_Restrictions.Value (Max_Entry_Queue_Length)) 347 or else 348 (Object.Entry_Queue_Maxes /= null 349 and then Object.Entry_Queue_Maxes (Index) /= 0 350 and then Queue_Length >= Object.Entry_Queue_Maxes (Index)) 351 then 352 -- This violates the Max_Entry_Queue_Length restriction or the 353 -- Max_Queue_Length bound, raise Program_Error. 354 355 Entry_Call.Exception_To_Raise := Program_Error'Identity; 356 357 if Single_Lock then 358 STPO.Lock_RTS; 359 end if; 360 361 STPO.Write_Lock (Entry_Call.Self); 362 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); 363 STPO.Unlock (Entry_Call.Self); 364 365 if Single_Lock then 366 STPO.Unlock_RTS; 367 end if; 368 369 return; 370 end if; 371 end if; 372 373 -- Do the work: queue the call 374 375 Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call); 376 Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort); 377 378 return; 379 else 380 -- Conditional_Call and With_Abort 381 382 if Single_Lock then 383 STPO.Lock_RTS; 384 end if; 385 386 STPO.Write_Lock (Entry_Call.Self); 387 pragma Assert (Entry_Call.State /= Not_Yet_Abortable); 388 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); 389 STPO.Unlock (Entry_Call.Self); 390 391 if Single_Lock then 392 STPO.Unlock_RTS; 393 end if; 394 end if; 395 396 exception 397 when others => 398 Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call); 399 end PO_Do_Or_Queue; 400 401 ------------------------ 402 -- PO_Service_Entries -- 403 ------------------------ 404 405 procedure PO_Service_Entries 406 (Self_ID : Task_Id; 407 Object : Entries.Protection_Entries_Access; 408 Unlock_Object : Boolean := True) 409 is 410 E : Protected_Entry_Index; 411 Caller : Task_Id; 412 Entry_Call : Entry_Call_Link; 413 414 begin 415 loop 416 Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call); 417 418 exit when Entry_Call = null; 419 420 E := Protected_Entry_Index (Entry_Call.E); 421 422 -- Not abortable while service is in progress 423 424 if Entry_Call.State = Now_Abortable then 425 Entry_Call.State := Was_Abortable; 426 end if; 427 428 Object.Call_In_Progress := Entry_Call; 429 430 begin 431 pragma Debug 432 (Debug.Trace (Self_ID, "POSE: start entry body", 'P')); 433 434 Object.Entry_Bodies 435 (Object.Find_Body_Index (Object.Compiler_Info, E)).Action 436 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); 437 438 exception 439 when others => 440 Queuing.Broadcast_Program_Error 441 (Self_ID, Object, Entry_Call); 442 end; 443 444 if Object.Call_In_Progress = null then 445 Requeue_Call (Self_ID, Object, Entry_Call); 446 exit when Entry_Call.State = Cancelled; 447 448 else 449 Object.Call_In_Progress := null; 450 Caller := Entry_Call.Self; 451 452 if Single_Lock then 453 STPO.Lock_RTS; 454 end if; 455 456 STPO.Write_Lock (Caller); 457 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); 458 STPO.Unlock (Caller); 459 460 if Single_Lock then 461 STPO.Unlock_RTS; 462 end if; 463 end if; 464 end loop; 465 466 if Unlock_Object then 467 Unlock_Entries (Object); 468 end if; 469 end PO_Service_Entries; 470 471 --------------------- 472 -- Protected_Count -- 473 --------------------- 474 475 function Protected_Count 476 (Object : Protection_Entries'Class; 477 E : Protected_Entry_Index) return Natural 478 is 479 begin 480 return Queuing.Count_Waiting (Object.Entry_Queues (E)); 481 end Protected_Count; 482 483 -------------------------- 484 -- Protected_Entry_Call -- 485 -------------------------- 486 487 -- Compiler interface only (do not call from within the RTS) 488 489 -- select r.e; 490 -- ...A... 491 -- else 492 -- ...B... 493 -- end select; 494 495 -- declare 496 -- X : protected_entry_index := 1; 497 -- B85b : communication_block; 498 -- communication_blockIP (B85b); 499 500 -- begin 501 -- protected_entry_call (rTV!(r)._object'unchecked_access, X, 502 -- null_address, conditional_call, B85b, objectF => 0); 503 504 -- if cancelled (B85b) then 505 -- ...B... 506 -- else 507 -- ...A... 508 -- end if; 509 -- end; 510 511 -- See also Cancel_Protected_Entry_Call for code expansion of asynchronous 512 -- entry call. 513 514 -- The initial part of this procedure does not need to lock the calling 515 -- task's ATCB, up to the point where the call record first may be queued 516 -- (PO_Do_Or_Queue), since before that no other task will have access to 517 -- the record. 518 519 -- If this is a call made inside of an abort deferred region, the call 520 -- should be never abortable. 521 522 -- If the call was not queued abortably, we need to wait until it is before 523 -- proceeding with the abortable part. 524 525 -- There are some heuristics here, just to save time for frequently 526 -- occurring cases. For example, we check Initially_Abortable to try to 527 -- avoid calling the procedure Wait_Until_Abortable, since the normal case 528 -- for async. entry calls is to be queued abortably. 529 530 -- Another heuristic uses the Block.Enqueued to try to avoid calling 531 -- Cancel_Protected_Entry_Call if the call can be served immediately. 532 533 procedure Protected_Entry_Call 534 (Object : Protection_Entries_Access; 535 E : Protected_Entry_Index; 536 Uninterpreted_Data : System.Address; 537 Mode : Call_Modes; 538 Block : out Communication_Block) 539 is 540 Self_ID : constant Task_Id := STPO.Self; 541 Entry_Call : Entry_Call_Link; 542 Initially_Abortable : Boolean; 543 Ceiling_Violation : Boolean; 544 545 begin 546 pragma Debug 547 (Debug.Trace (Self_ID, "Protected_Entry_Call", 'P')); 548 549 if Self_ID.ATC_Nesting_Level = ATC_Level'Last then 550 raise Storage_Error with "not enough ATC nesting levels"; 551 end if; 552 553 -- If pragma Detect_Blocking is active then Program_Error must be 554 -- raised if this potentially blocking operation is called from a 555 -- protected action. 556 557 if Detect_Blocking 558 and then Self_ID.Common.Protected_Action_Nesting > 0 559 then 560 raise Program_Error with "potentially blocking operation"; 561 end if; 562 563 -- Self_ID.Deferral_Level should be 0, except when called from Finalize, 564 -- where abort is already deferred. 565 566 Initialization.Defer_Abort_Nestable (Self_ID); 567 Lock_Entries_With_Status (Object, Ceiling_Violation); 568 569 if Ceiling_Violation then 570 571 -- Failed ceiling check 572 573 Initialization.Undefer_Abort_Nestable (Self_ID); 574 raise Program_Error; 575 end if; 576 577 Block.Self := Self_ID; 578 Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1; 579 pragma Debug 580 (Debug.Trace (Self_ID, "PEC: entered ATC level: " & 581 ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); 582 Entry_Call := 583 Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; 584 Entry_Call.Next := null; 585 Entry_Call.Mode := Mode; 586 Entry_Call.Cancellation_Attempted := False; 587 588 Entry_Call.State := 589 (if Self_ID.Deferral_Level > 1 590 then Never_Abortable else Now_Abortable); 591 592 Entry_Call.E := Entry_Index (E); 593 Entry_Call.Prio := STPO.Get_Priority (Self_ID); 594 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 595 Entry_Call.Called_PO := To_Address (Object); 596 Entry_Call.Called_Task := null; 597 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 598 Entry_Call.With_Abort := True; 599 600 PO_Do_Or_Queue (Self_ID, Object, Entry_Call); 601 Initially_Abortable := Entry_Call.State = Now_Abortable; 602 PO_Service_Entries (Self_ID, Object); 603 604 -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call) 605 -- for completed or cancelled calls. (This is a heuristic, only.) 606 607 if Entry_Call.State >= Done then 608 609 -- Once State >= Done it will not change any more 610 611 if Single_Lock then 612 STPO.Lock_RTS; 613 end if; 614 615 STPO.Write_Lock (Self_ID); 616 Utilities.Exit_One_ATC_Level (Self_ID); 617 STPO.Unlock (Self_ID); 618 619 if Single_Lock then 620 STPO.Unlock_RTS; 621 end if; 622 623 Block.Enqueued := False; 624 Block.Cancelled := Entry_Call.State = Cancelled; 625 Initialization.Undefer_Abort_Nestable (Self_ID); 626 Entry_Calls.Check_Exception (Self_ID, Entry_Call); 627 return; 628 629 else 630 -- In this case we cannot conclude anything, since State can change 631 -- concurrently. 632 633 null; 634 end if; 635 636 -- Now for the general case 637 638 if Mode = Asynchronous_Call then 639 640 -- Try to avoid an expensive call 641 642 if not Initially_Abortable then 643 if Single_Lock then 644 STPO.Lock_RTS; 645 Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); 646 STPO.Unlock_RTS; 647 else 648 Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); 649 end if; 650 end if; 651 652 else 653 case Mode is 654 when Conditional_Call 655 | Simple_Call 656 => 657 if Single_Lock then 658 STPO.Lock_RTS; 659 Entry_Calls.Wait_For_Completion (Entry_Call); 660 STPO.Unlock_RTS; 661 662 else 663 STPO.Write_Lock (Self_ID); 664 Entry_Calls.Wait_For_Completion (Entry_Call); 665 STPO.Unlock (Self_ID); 666 end if; 667 668 Block.Cancelled := Entry_Call.State = Cancelled; 669 670 when Asynchronous_Call 671 | Timed_Call 672 => 673 pragma Assert (False); 674 null; 675 end case; 676 end if; 677 678 Initialization.Undefer_Abort_Nestable (Self_ID); 679 Entry_Calls.Check_Exception (Self_ID, Entry_Call); 680 end Protected_Entry_Call; 681 682 ------------------ 683 -- Requeue_Call -- 684 ------------------ 685 686 procedure Requeue_Call 687 (Self_Id : Task_Id; 688 Object : Protection_Entries_Access; 689 Entry_Call : Entry_Call_Link) 690 is 691 New_Object : Protection_Entries_Access; 692 Ceiling_Violation : Boolean; 693 Result : Boolean; 694 E : Protected_Entry_Index; 695 696 begin 697 New_Object := To_Protection (Entry_Call.Called_PO); 698 699 if New_Object = null then 700 701 -- Call is to be requeued to a task entry 702 703 if Single_Lock then 704 STPO.Lock_RTS; 705 end if; 706 707 Result := Rendezvous.Task_Do_Or_Queue (Self_Id, Entry_Call); 708 709 if not Result then 710 Queuing.Broadcast_Program_Error 711 (Self_Id, Object, Entry_Call, RTS_Locked => True); 712 end if; 713 714 if Single_Lock then 715 STPO.Unlock_RTS; 716 end if; 717 718 else 719 -- Call should be requeued to a PO 720 721 if Object /= New_Object then 722 723 -- Requeue is to different PO 724 725 Lock_Entries_With_Status (New_Object, Ceiling_Violation); 726 727 if Ceiling_Violation then 728 Object.Call_In_Progress := null; 729 Queuing.Broadcast_Program_Error (Self_Id, Object, Entry_Call); 730 731 else 732 PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call); 733 PO_Service_Entries (Self_Id, New_Object); 734 end if; 735 736 else 737 -- Requeue is to same protected object 738 739 -- ??? Try to compensate apparent failure of the scheduler on some 740 -- OS (e.g VxWorks) to give higher priority tasks a chance to run 741 -- (see CXD6002). 742 743 STPO.Yield (Do_Yield => False); 744 745 if Entry_Call.With_Abort 746 and then Entry_Call.Cancellation_Attempted 747 then 748 -- If this is a requeue with abort and someone tried to cancel 749 -- this call, cancel it at this point. 750 751 Entry_Call.State := Cancelled; 752 return; 753 end if; 754 755 if not Entry_Call.With_Abort 756 or else Entry_Call.Mode /= Conditional_Call 757 then 758 E := Protected_Entry_Index (Entry_Call.E); 759 760 if Run_Time_Restrictions.Set (Max_Entry_Queue_Length) 761 and then 762 Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <= 763 Queuing.Count_Waiting (Object.Entry_Queues (E)) 764 then 765 -- This violates the Max_Entry_Queue_Length restriction, 766 -- raise Program_Error. 767 768 Entry_Call.Exception_To_Raise := Program_Error'Identity; 769 770 if Single_Lock then 771 STPO.Lock_RTS; 772 end if; 773 774 STPO.Write_Lock (Entry_Call.Self); 775 Initialization.Wakeup_Entry_Caller 776 (Self_Id, Entry_Call, Done); 777 STPO.Unlock (Entry_Call.Self); 778 779 if Single_Lock then 780 STPO.Unlock_RTS; 781 end if; 782 783 else 784 Queuing.Enqueue 785 (New_Object.Entry_Queues (E), Entry_Call); 786 Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort); 787 end if; 788 789 else 790 PO_Do_Or_Queue (Self_Id, New_Object, Entry_Call); 791 end if; 792 end if; 793 end if; 794 end Requeue_Call; 795 796 ---------------------------- 797 -- Protected_Entry_Caller -- 798 ---------------------------- 799 800 function Protected_Entry_Caller 801 (Object : Protection_Entries'Class) return Task_Id is 802 begin 803 return Object.Call_In_Progress.Self; 804 end Protected_Entry_Caller; 805 806 ----------------------------- 807 -- Requeue_Protected_Entry -- 808 ----------------------------- 809 810 -- Compiler interface only (do not call from within the RTS) 811 812 -- entry e when b is 813 -- begin 814 -- b := false; 815 -- ...A... 816 -- requeue e2; 817 -- end e; 818 819 -- procedure rPT__E10b (O : address; P : address; E : 820 -- protected_entry_index) is 821 -- type rTVP is access rTV; 822 -- freeze rTVP [] 823 -- _object : rTVP := rTVP!(O); 824 -- begin 825 -- declare 826 -- rR : protection renames _object._object; 827 -- vP : integer renames _object.v; 828 -- bP : boolean renames _object.b; 829 -- begin 830 -- b := false; 831 -- ...A... 832 -- requeue_protected_entry (rR'unchecked_access, rR' 833 -- unchecked_access, 2, false, objectF => 0, new_objectF => 834 -- 0); 835 -- return; 836 -- end; 837 -- complete_entry_body (_object._object'unchecked_access, objectF => 838 -- 0); 839 -- return; 840 -- exception 841 -- when others => 842 -- abort_undefer.all; 843 -- exceptional_complete_entry_body (_object._object' 844 -- unchecked_access, current_exception, objectF => 0); 845 -- return; 846 -- end rPT__E10b; 847 848 procedure Requeue_Protected_Entry 849 (Object : Protection_Entries_Access; 850 New_Object : Protection_Entries_Access; 851 E : Protected_Entry_Index; 852 With_Abort : Boolean) 853 is 854 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; 855 856 begin 857 pragma Debug 858 (Debug.Trace (STPO.Self, "Requeue_Protected_Entry", 'P')); 859 pragma Assert (STPO.Self.Deferral_Level > 0); 860 861 Entry_Call.E := Entry_Index (E); 862 Entry_Call.Called_PO := To_Address (New_Object); 863 Entry_Call.Called_Task := null; 864 Entry_Call.With_Abort := With_Abort; 865 Object.Call_In_Progress := null; 866 end Requeue_Protected_Entry; 867 868 ------------------------------------- 869 -- Requeue_Task_To_Protected_Entry -- 870 ------------------------------------- 871 872 -- Compiler interface only (do not call from within the RTS) 873 874 -- accept e1 do 875 -- ...A... 876 -- requeue r.e2; 877 -- end e1; 878 879 -- A79b : address; 880 -- L78b : label 881 882 -- begin 883 -- accept_call (1, A79b); 884 -- ...A... 885 -- requeue_task_to_protected_entry (rTV!(r)._object' 886 -- unchecked_access, 2, false, new_objectF => 0); 887 -- goto L78b; 888 -- <<L78b>> 889 -- complete_rendezvous; 890 891 -- exception 892 -- when all others => 893 -- exceptional_complete_rendezvous (get_gnat_exception); 894 -- end; 895 896 procedure Requeue_Task_To_Protected_Entry 897 (New_Object : Protection_Entries_Access; 898 E : Protected_Entry_Index; 899 With_Abort : Boolean) 900 is 901 Self_ID : constant Task_Id := STPO.Self; 902 Entry_Call : constant Entry_Call_Link := Self_ID.Common.Call; 903 904 begin 905 Initialization.Defer_Abort (Self_ID); 906 907 -- We do not need to lock Self_ID here since the call is not abortable 908 -- at this point, and therefore, the caller cannot cancel the call. 909 910 Entry_Call.Needs_Requeue := True; 911 Entry_Call.With_Abort := With_Abort; 912 Entry_Call.Called_PO := To_Address (New_Object); 913 Entry_Call.Called_Task := null; 914 Entry_Call.E := Entry_Index (E); 915 Initialization.Undefer_Abort (Self_ID); 916 end Requeue_Task_To_Protected_Entry; 917 918 --------------------- 919 -- Service_Entries -- 920 --------------------- 921 922 procedure Service_Entries (Object : Protection_Entries_Access) is 923 Self_ID : constant Task_Id := STPO.Self; 924 begin 925 PO_Service_Entries (Self_ID, Object); 926 end Service_Entries; 927 928 -------------------------------- 929 -- Timed_Protected_Entry_Call -- 930 -------------------------------- 931 932 -- Compiler interface only (do not call from within the RTS) 933 934 procedure Timed_Protected_Entry_Call 935 (Object : Protection_Entries_Access; 936 E : Protected_Entry_Index; 937 Uninterpreted_Data : System.Address; 938 Timeout : Duration; 939 Mode : Delay_Modes; 940 Entry_Call_Successful : out Boolean) 941 is 942 Self_Id : constant Task_Id := STPO.Self; 943 Entry_Call : Entry_Call_Link; 944 Ceiling_Violation : Boolean; 945 946 Yielded : Boolean; 947 pragma Unreferenced (Yielded); 948 949 begin 950 if Self_Id.ATC_Nesting_Level = ATC_Level'Last then 951 raise Storage_Error with "not enough ATC nesting levels"; 952 end if; 953 954 -- If pragma Detect_Blocking is active then Program_Error must be 955 -- raised if this potentially blocking operation is called from a 956 -- protected action. 957 958 if Detect_Blocking 959 and then Self_Id.Common.Protected_Action_Nesting > 0 960 then 961 raise Program_Error with "potentially blocking operation"; 962 end if; 963 964 Initialization.Defer_Abort_Nestable (Self_Id); 965 Lock_Entries_With_Status (Object, Ceiling_Violation); 966 967 if Ceiling_Violation then 968 Initialization.Undefer_Abort (Self_Id); 969 raise Program_Error; 970 end if; 971 972 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; 973 pragma Debug 974 (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " & 975 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); 976 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; 977 Entry_Call.Next := null; 978 Entry_Call.Mode := Timed_Call; 979 Entry_Call.Cancellation_Attempted := False; 980 981 Entry_Call.State := 982 (if Self_Id.Deferral_Level > 1 983 then Never_Abortable 984 else Now_Abortable); 985 986 Entry_Call.E := Entry_Index (E); 987 Entry_Call.Prio := STPO.Get_Priority (Self_Id); 988 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 989 Entry_Call.Called_PO := To_Address (Object); 990 Entry_Call.Called_Task := null; 991 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 992 Entry_Call.With_Abort := True; 993 994 PO_Do_Or_Queue (Self_Id, Object, Entry_Call); 995 PO_Service_Entries (Self_Id, Object); 996 997 if Single_Lock then 998 STPO.Lock_RTS; 999 else 1000 STPO.Write_Lock (Self_Id); 1001 end if; 1002 1003 -- Try to avoid waiting for completed or cancelled calls 1004 1005 if Entry_Call.State >= Done then 1006 Utilities.Exit_One_ATC_Level (Self_Id); 1007 1008 if Single_Lock then 1009 STPO.Unlock_RTS; 1010 else 1011 STPO.Unlock (Self_Id); 1012 end if; 1013 1014 Entry_Call_Successful := Entry_Call.State = Done; 1015 Initialization.Undefer_Abort_Nestable (Self_Id); 1016 Entry_Calls.Check_Exception (Self_Id, Entry_Call); 1017 return; 1018 end if; 1019 1020 Entry_Calls.Wait_For_Completion_With_Timeout 1021 (Entry_Call, Timeout, Mode, Yielded); 1022 1023 if Single_Lock then 1024 STPO.Unlock_RTS; 1025 else 1026 STPO.Unlock (Self_Id); 1027 end if; 1028 1029 -- ??? Do we need to yield in case Yielded is False 1030 1031 Initialization.Undefer_Abort_Nestable (Self_Id); 1032 Entry_Call_Successful := Entry_Call.State = Done; 1033 Entry_Calls.Check_Exception (Self_Id, Entry_Call); 1034 end Timed_Protected_Entry_Call; 1035 1036 ---------------------------- 1037 -- Update_For_Queue_To_PO -- 1038 ---------------------------- 1039 1040 -- Update the state of an existing entry call, based on 1041 -- whether the current queuing action is with or without abort. 1042 -- Call this only while holding the server's lock. 1043 -- It returns with the server's lock released. 1044 1045 New_State : constant array (Boolean, Entry_Call_State) 1046 of Entry_Call_State := 1047 (True => 1048 (Never_Abortable => Never_Abortable, 1049 Not_Yet_Abortable => Now_Abortable, 1050 Was_Abortable => Now_Abortable, 1051 Now_Abortable => Now_Abortable, 1052 Done => Done, 1053 Cancelled => Cancelled), 1054 False => 1055 (Never_Abortable => Never_Abortable, 1056 Not_Yet_Abortable => Not_Yet_Abortable, 1057 Was_Abortable => Was_Abortable, 1058 Now_Abortable => Now_Abortable, 1059 Done => Done, 1060 Cancelled => Cancelled) 1061 ); 1062 1063 procedure Update_For_Queue_To_PO 1064 (Entry_Call : Entry_Call_Link; 1065 With_Abort : Boolean) 1066 is 1067 Old : constant Entry_Call_State := Entry_Call.State; 1068 1069 begin 1070 pragma Assert (Old < Done); 1071 1072 Entry_Call.State := New_State (With_Abort, Entry_Call.State); 1073 1074 if Entry_Call.Mode = Asynchronous_Call then 1075 if Old < Was_Abortable and then 1076 Entry_Call.State = Now_Abortable 1077 then 1078 if Single_Lock then 1079 STPO.Lock_RTS; 1080 end if; 1081 1082 STPO.Write_Lock (Entry_Call.Self); 1083 1084 if Entry_Call.Self.Common.State = Async_Select_Sleep then 1085 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); 1086 end if; 1087 1088 STPO.Unlock (Entry_Call.Self); 1089 1090 if Single_Lock then 1091 STPO.Unlock_RTS; 1092 end if; 1093 1094 end if; 1095 1096 elsif Entry_Call.Mode = Conditional_Call then 1097 pragma Assert (Entry_Call.State < Was_Abortable); 1098 null; 1099 end if; 1100 end Update_For_Queue_To_PO; 1101 1102end System.Tasking.Protected_Objects.Operations; 1103