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-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 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.Traces.Tasking; 53with System.Restrictions; 54 55with System.Tasking.Initialization; 56pragma Elaborate_All (System.Tasking.Initialization); 57-- Insures that tasking is initialized if any protected objects are created 58 59package body System.Tasking.Protected_Objects.Operations is 60 61 package STPO renames System.Task_Primitives.Operations; 62 63 use Parameters; 64 use Task_Primitives; 65 use Ada.Exceptions; 66 use Entries; 67 68 use System.Restrictions; 69 use System.Restrictions.Rident; 70 use System.Traces; 71 use System.Traces.Tasking; 72 73 ----------------------- 74 -- Local Subprograms -- 75 ----------------------- 76 77 procedure Update_For_Queue_To_PO 78 (Entry_Call : Entry_Call_Link; 79 With_Abort : Boolean); 80 pragma Inline (Update_For_Queue_To_PO); 81 -- Update the state of an existing entry call to reflect the fact that it 82 -- is being enqueued, based on whether the current queuing action is with 83 -- or without abort. Call this only while holding the PO's lock. It returns 84 -- with the PO's lock still held. 85 86 procedure Requeue_Call 87 (Self_Id : Task_Id; 88 Object : Protection_Entries_Access; 89 Entry_Call : Entry_Call_Link); 90 -- Handle requeue of Entry_Call. 91 -- In particular, queue the call if needed, or service it immediately 92 -- if possible. 93 94 --------------------------------- 95 -- Cancel_Protected_Entry_Call -- 96 --------------------------------- 97 98 -- Compiler interface only (do not call from within the RTS) 99 100 -- This should have analogous effect to Cancel_Task_Entry_Call, setting 101 -- the value of Block.Cancelled instead of returning the parameter value 102 -- Cancelled. 103 104 -- The effect should be idempotent, since the call may already have been 105 -- dequeued. 106 107 -- Source code: 108 109 -- select r.e; 110 -- ...A... 111 -- then abort 112 -- ...B... 113 -- end select; 114 115 -- Expanded code: 116 117 -- declare 118 -- X : protected_entry_index := 1; 119 -- B80b : communication_block; 120 -- communication_blockIP (B80b); 121 122 -- begin 123 -- begin 124 -- A79b : label 125 -- A79b : declare 126 -- procedure _clean is 127 -- begin 128 -- if enqueued (B80b) then 129 -- cancel_protected_entry_call (B80b); 130 -- end if; 131 -- return; 132 -- end _clean; 133 134 -- begin 135 -- protected_entry_call (rTV!(r)._object'unchecked_access, X, 136 -- null_address, asynchronous_call, B80b, objectF => 0); 137 -- if enqueued (B80b) then 138 -- ...B... 139 -- end if; 140 -- at end 141 -- _clean; 142 -- end A79b; 143 144 -- exception 145 -- when _abort_signal => 146 -- abort_undefer.all; 147 -- null; 148 -- end; 149 150 -- if not cancelled (B80b) then 151 -- x := ...A... 152 -- end if; 153 -- end; 154 155 -- If the entry call completes after we get into the abortable part, 156 -- Abort_Signal should be raised and ATC will take us to the at-end 157 -- handler, which will call _clean. 158 159 -- If the entry call returns with the call already completed, we can skip 160 -- this, and use the "if enqueued()" to go past the at-end handler, but we 161 -- will still call _clean. 162 163 -- If the abortable part completes before the entry call is Done, it will 164 -- call _clean. 165 166 -- If the entry call or the abortable part raises an exception, 167 -- we will still call _clean, but the value of Cancelled should not matter. 168 169 -- Whoever calls _clean first gets to decide whether the call 170 -- has been "cancelled". 171 172 -- Enqueued should be true if there is any chance that the call is still on 173 -- a queue. It seems to be safe to make it True if the call was Onqueue at 174 -- some point before return from Protected_Entry_Call. 175 176 -- Cancelled should be true iff the abortable part completed 177 -- and succeeded in cancelling the entry call before it completed. 178 179 -- ????? 180 -- The need for Enqueued is less obvious. The "if enqueued ()" tests are 181 -- not necessary, since Cancel_Protected_Entry_Call/Protected_Entry_Call 182 -- must do the same test internally, with locking. The one that makes 183 -- cancellation conditional may be a useful heuristic since at least 1/2 184 -- the time the call should be off-queue by that point. The other one seems 185 -- totally useless, since Protected_Entry_Call must do the same check and 186 -- then possibly wait for the call to be abortable, internally. 187 188 -- We can check Call.State here without locking the caller's mutex, 189 -- since the call must be over after returning from Wait_For_Completion. 190 -- No other task can access the call record at this point. 191 192 procedure Cancel_Protected_Entry_Call 193 (Block : in out Communication_Block) is 194 begin 195 Entry_Calls.Try_To_Cancel_Entry_Call (Block.Cancelled); 196 end Cancel_Protected_Entry_Call; 197 198 --------------- 199 -- Cancelled -- 200 --------------- 201 202 function Cancelled (Block : Communication_Block) return Boolean is 203 begin 204 return Block.Cancelled; 205 end Cancelled; 206 207 ------------------------- 208 -- Complete_Entry_Body -- 209 ------------------------- 210 211 procedure Complete_Entry_Body (Object : Protection_Entries_Access) is 212 begin 213 Exceptional_Complete_Entry_Body (Object, Ada.Exceptions.Null_Id); 214 end Complete_Entry_Body; 215 216 -------------- 217 -- Enqueued -- 218 -------------- 219 220 function Enqueued (Block : Communication_Block) return Boolean is 221 begin 222 return Block.Enqueued; 223 end Enqueued; 224 225 ------------------------------------- 226 -- Exceptional_Complete_Entry_Body -- 227 ------------------------------------- 228 229 procedure Exceptional_Complete_Entry_Body 230 (Object : Protection_Entries_Access; 231 Ex : Ada.Exceptions.Exception_Id) 232 is 233 procedure Transfer_Occurrence 234 (Target : Ada.Exceptions.Exception_Occurrence_Access; 235 Source : Ada.Exceptions.Exception_Occurrence); 236 pragma Import (C, Transfer_Occurrence, "__gnat_transfer_occurrence"); 237 238 Entry_Call : constant Entry_Call_Link := Object.Call_In_Progress; 239 Self_Id : Task_Id; 240 241 begin 242 pragma Debug 243 (Debug.Trace (STPO.Self, "Exceptional_Complete_Entry_Body", 'P')); 244 245 -- We must have abort deferred, since we are inside a protected 246 -- operation. 247 248 if Entry_Call /= null then 249 250 -- The call was not requeued 251 252 Entry_Call.Exception_To_Raise := Ex; 253 254 if Ex /= Ada.Exceptions.Null_Id then 255 256 -- An exception was raised and abort was deferred, so adjust 257 -- before propagating, otherwise the task will stay with deferral 258 -- enabled for its remaining life. 259 260 Self_Id := STPO.Self; 261 262 if not ZCX_By_Default then 263 Initialization.Undefer_Abort_Nestable (Self_Id); 264 end if; 265 266 Transfer_Occurrence 267 (Entry_Call.Self.Common.Compiler_Data.Current_Excep'Access, 268 Self_Id.Common.Compiler_Data.Current_Excep); 269 end if; 270 271 -- Wakeup_Entry_Caller will be called from PO_Do_Or_Queue or 272 -- PO_Service_Entries on return. 273 274 end if; 275 276 if Runtime_Traces then 277 278 -- ??? Entry_Call can be null 279 280 Send_Trace_Info (PO_Done, Entry_Call.Self); 281 end if; 282 end Exceptional_Complete_Entry_Body; 283 284 -------------------- 285 -- PO_Do_Or_Queue -- 286 -------------------- 287 288 procedure PO_Do_Or_Queue 289 (Self_ID : Task_Id; 290 Object : Protection_Entries_Access; 291 Entry_Call : Entry_Call_Link) 292 is 293 E : constant Protected_Entry_Index := 294 Protected_Entry_Index (Entry_Call.E); 295 Barrier_Value : Boolean; 296 297 begin 298 -- When the Action procedure for an entry body returns, it is either 299 -- completed (having called [Exceptional_]Complete_Entry_Body) or it 300 -- is queued, having executed a requeue statement. 301 302 Barrier_Value := 303 Object.Entry_Bodies ( 304 Object.Find_Body_Index (Object.Compiler_Info, E)). 305 Barrier (Object.Compiler_Info, E); 306 307 if Barrier_Value then 308 309 -- Not abortable while service is in progress 310 311 if Entry_Call.State = Now_Abortable then 312 Entry_Call.State := Was_Abortable; 313 end if; 314 315 Object.Call_In_Progress := Entry_Call; 316 317 pragma Debug 318 (Debug.Trace (Self_ID, "PODOQ: start entry body", 'P')); 319 Object.Entry_Bodies ( 320 Object.Find_Body_Index (Object.Compiler_Info, E)).Action ( 321 Object.Compiler_Info, Entry_Call.Uninterpreted_Data, E); 322 323 if Object.Call_In_Progress /= null then 324 325 -- Body of current entry served call to completion 326 327 Object.Call_In_Progress := null; 328 329 if Single_Lock then 330 STPO.Lock_RTS; 331 end if; 332 333 STPO.Write_Lock (Entry_Call.Self); 334 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); 335 STPO.Unlock (Entry_Call.Self); 336 337 if Single_Lock then 338 STPO.Unlock_RTS; 339 end if; 340 341 else 342 Requeue_Call (Self_ID, Object, Entry_Call); 343 end if; 344 345 elsif Entry_Call.Mode /= Conditional_Call 346 or else not Entry_Call.With_Abort 347 then 348 349 if Run_Time_Restrictions.Set (Max_Entry_Queue_Length) 350 and then 351 Run_Time_Restrictions.Value (Max_Entry_Queue_Length) <= 352 Queuing.Count_Waiting (Object.Entry_Queues (E)) 353 then 354 -- This violates the Max_Entry_Queue_Length restriction, 355 -- raise Program_Error. 356 357 Entry_Call.Exception_To_Raise := Program_Error'Identity; 358 359 if Single_Lock then 360 STPO.Lock_RTS; 361 end if; 362 363 STPO.Write_Lock (Entry_Call.Self); 364 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Done); 365 STPO.Unlock (Entry_Call.Self); 366 367 if Single_Lock then 368 STPO.Unlock_RTS; 369 end if; 370 else 371 Queuing.Enqueue (Object.Entry_Queues (E), Entry_Call); 372 Update_For_Queue_To_PO (Entry_Call, Entry_Call.With_Abort); 373 end if; 374 else 375 -- Conditional_Call and With_Abort 376 377 if Single_Lock then 378 STPO.Lock_RTS; 379 end if; 380 381 STPO.Write_Lock (Entry_Call.Self); 382 pragma Assert (Entry_Call.State /= Not_Yet_Abortable); 383 Initialization.Wakeup_Entry_Caller (Self_ID, Entry_Call, Cancelled); 384 STPO.Unlock (Entry_Call.Self); 385 386 if Single_Lock then 387 STPO.Unlock_RTS; 388 end if; 389 end if; 390 391 exception 392 when others => 393 Queuing.Broadcast_Program_Error (Self_ID, Object, Entry_Call); 394 end PO_Do_Or_Queue; 395 396 ------------------------ 397 -- PO_Service_Entries -- 398 ------------------------ 399 400 procedure PO_Service_Entries 401 (Self_ID : Task_Id; 402 Object : Entries.Protection_Entries_Access; 403 Unlock_Object : Boolean := True) 404 is 405 E : Protected_Entry_Index; 406 Caller : Task_Id; 407 Entry_Call : Entry_Call_Link; 408 409 begin 410 loop 411 Queuing.Select_Protected_Entry_Call (Self_ID, Object, Entry_Call); 412 413 exit when Entry_Call = null; 414 415 E := Protected_Entry_Index (Entry_Call.E); 416 417 -- Not abortable while service is in progress 418 419 if Entry_Call.State = Now_Abortable then 420 Entry_Call.State := Was_Abortable; 421 end if; 422 423 Object.Call_In_Progress := Entry_Call; 424 425 begin 426 if Runtime_Traces then 427 Send_Trace_Info (PO_Run, Self_ID, 428 Entry_Call.Self, Entry_Index (E)); 429 end if; 430 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 Runtime_Traces then 550 Send_Trace_Info (PO_Call, Entry_Index (E)); 551 end if; 552 553 if Self_ID.ATC_Nesting_Level = ATC_Level'Last then 554 raise Storage_Error with "not enough ATC nesting levels"; 555 end if; 556 557 -- If pragma Detect_Blocking is active then Program_Error must be 558 -- raised if this potentially blocking operation is called from a 559 -- protected action. 560 561 if Detect_Blocking 562 and then Self_ID.Common.Protected_Action_Nesting > 0 563 then 564 raise Program_Error with "potentially blocking operation"; 565 end if; 566 567 -- Self_ID.Deferral_Level should be 0, except when called from Finalize, 568 -- where abort is already deferred. 569 570 Initialization.Defer_Abort_Nestable (Self_ID); 571 Lock_Entries_With_Status (Object, Ceiling_Violation); 572 573 if Ceiling_Violation then 574 575 -- Failed ceiling check 576 577 Initialization.Undefer_Abort_Nestable (Self_ID); 578 raise Program_Error; 579 end if; 580 581 Block.Self := Self_ID; 582 Self_ID.ATC_Nesting_Level := Self_ID.ATC_Nesting_Level + 1; 583 pragma Debug 584 (Debug.Trace (Self_ID, "PEC: entered ATC level: " & 585 ATC_Level'Image (Self_ID.ATC_Nesting_Level), 'A')); 586 Entry_Call := 587 Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; 588 Entry_Call.Next := null; 589 Entry_Call.Mode := Mode; 590 Entry_Call.Cancellation_Attempted := False; 591 592 Entry_Call.State := 593 (if Self_ID.Deferral_Level > 1 594 then Never_Abortable else Now_Abortable); 595 596 Entry_Call.E := Entry_Index (E); 597 Entry_Call.Prio := STPO.Get_Priority (Self_ID); 598 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 599 Entry_Call.Called_PO := To_Address (Object); 600 Entry_Call.Called_Task := null; 601 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 602 Entry_Call.With_Abort := True; 603 604 PO_Do_Or_Queue (Self_ID, Object, Entry_Call); 605 Initially_Abortable := Entry_Call.State = Now_Abortable; 606 PO_Service_Entries (Self_ID, Object); 607 608 -- Try to prevent waiting later (in Try_To_Cancel_Protected_Entry_Call) 609 -- for completed or cancelled calls. (This is a heuristic, only.) 610 611 if Entry_Call.State >= Done then 612 613 -- Once State >= Done it will not change any more 614 615 if Single_Lock then 616 STPO.Lock_RTS; 617 end if; 618 619 STPO.Write_Lock (Self_ID); 620 Utilities.Exit_One_ATC_Level (Self_ID); 621 STPO.Unlock (Self_ID); 622 623 if Single_Lock then 624 STPO.Unlock_RTS; 625 end if; 626 627 Block.Enqueued := False; 628 Block.Cancelled := Entry_Call.State = Cancelled; 629 Initialization.Undefer_Abort_Nestable (Self_ID); 630 Entry_Calls.Check_Exception (Self_ID, Entry_Call); 631 return; 632 633 else 634 -- In this case we cannot conclude anything, since State can change 635 -- concurrently. 636 637 null; 638 end if; 639 640 -- Now for the general case 641 642 if Mode = Asynchronous_Call then 643 644 -- Try to avoid an expensive call 645 646 if not Initially_Abortable then 647 if Single_Lock then 648 STPO.Lock_RTS; 649 Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); 650 STPO.Unlock_RTS; 651 else 652 Entry_Calls.Wait_Until_Abortable (Self_ID, Entry_Call); 653 end if; 654 end if; 655 656 else 657 case Mode is 658 when Simple_Call | Conditional_Call => 659 if Single_Lock then 660 STPO.Lock_RTS; 661 Entry_Calls.Wait_For_Completion (Entry_Call); 662 STPO.Unlock_RTS; 663 664 else 665 STPO.Write_Lock (Self_ID); 666 Entry_Calls.Wait_For_Completion (Entry_Call); 667 STPO.Unlock (Self_ID); 668 end if; 669 670 Block.Cancelled := Entry_Call.State = Cancelled; 671 672 when Asynchronous_Call | Timed_Call => 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 if Runtime_Traces then 965 Send_Trace_Info (POT_Call, Entry_Index (E), Timeout); 966 end if; 967 968 Initialization.Defer_Abort_Nestable (Self_Id); 969 Lock_Entries_With_Status (Object, Ceiling_Violation); 970 971 if Ceiling_Violation then 972 Initialization.Undefer_Abort (Self_Id); 973 raise Program_Error; 974 end if; 975 976 Self_Id.ATC_Nesting_Level := Self_Id.ATC_Nesting_Level + 1; 977 pragma Debug 978 (Debug.Trace (Self_Id, "TPEC: exited to ATC level: " & 979 ATC_Level'Image (Self_Id.ATC_Nesting_Level), 'A')); 980 Entry_Call := Self_Id.Entry_Calls (Self_Id.ATC_Nesting_Level)'Access; 981 Entry_Call.Next := null; 982 Entry_Call.Mode := Timed_Call; 983 Entry_Call.Cancellation_Attempted := False; 984 985 Entry_Call.State := 986 (if Self_Id.Deferral_Level > 1 987 then Never_Abortable 988 else Now_Abortable); 989 990 Entry_Call.E := Entry_Index (E); 991 Entry_Call.Prio := STPO.Get_Priority (Self_Id); 992 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 993 Entry_Call.Called_PO := To_Address (Object); 994 Entry_Call.Called_Task := null; 995 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 996 Entry_Call.With_Abort := True; 997 998 PO_Do_Or_Queue (Self_Id, Object, Entry_Call); 999 PO_Service_Entries (Self_Id, Object); 1000 1001 if Single_Lock then 1002 STPO.Lock_RTS; 1003 else 1004 STPO.Write_Lock (Self_Id); 1005 end if; 1006 1007 -- Try to avoid waiting for completed or cancelled calls 1008 1009 if Entry_Call.State >= Done then 1010 Utilities.Exit_One_ATC_Level (Self_Id); 1011 1012 if Single_Lock then 1013 STPO.Unlock_RTS; 1014 else 1015 STPO.Unlock (Self_Id); 1016 end if; 1017 1018 Entry_Call_Successful := Entry_Call.State = Done; 1019 Initialization.Undefer_Abort_Nestable (Self_Id); 1020 Entry_Calls.Check_Exception (Self_Id, Entry_Call); 1021 return; 1022 end if; 1023 1024 Entry_Calls.Wait_For_Completion_With_Timeout 1025 (Entry_Call, Timeout, Mode, Yielded); 1026 1027 if Single_Lock then 1028 STPO.Unlock_RTS; 1029 else 1030 STPO.Unlock (Self_Id); 1031 end if; 1032 1033 -- ??? Do we need to yield in case Yielded is False 1034 1035 Initialization.Undefer_Abort_Nestable (Self_Id); 1036 Entry_Call_Successful := Entry_Call.State = Done; 1037 Entry_Calls.Check_Exception (Self_Id, Entry_Call); 1038 end Timed_Protected_Entry_Call; 1039 1040 ---------------------------- 1041 -- Update_For_Queue_To_PO -- 1042 ---------------------------- 1043 1044 -- Update the state of an existing entry call, based on 1045 -- whether the current queuing action is with or without abort. 1046 -- Call this only while holding the server's lock. 1047 -- It returns with the server's lock released. 1048 1049 New_State : constant array (Boolean, Entry_Call_State) 1050 of Entry_Call_State := 1051 (True => 1052 (Never_Abortable => Never_Abortable, 1053 Not_Yet_Abortable => Now_Abortable, 1054 Was_Abortable => Now_Abortable, 1055 Now_Abortable => Now_Abortable, 1056 Done => Done, 1057 Cancelled => Cancelled), 1058 False => 1059 (Never_Abortable => Never_Abortable, 1060 Not_Yet_Abortable => Not_Yet_Abortable, 1061 Was_Abortable => Was_Abortable, 1062 Now_Abortable => Now_Abortable, 1063 Done => Done, 1064 Cancelled => Cancelled) 1065 ); 1066 1067 procedure Update_For_Queue_To_PO 1068 (Entry_Call : Entry_Call_Link; 1069 With_Abort : Boolean) 1070 is 1071 Old : constant Entry_Call_State := Entry_Call.State; 1072 1073 begin 1074 pragma Assert (Old < Done); 1075 1076 Entry_Call.State := New_State (With_Abort, Entry_Call.State); 1077 1078 if Entry_Call.Mode = Asynchronous_Call then 1079 if Old < Was_Abortable and then 1080 Entry_Call.State = Now_Abortable 1081 then 1082 if Single_Lock then 1083 STPO.Lock_RTS; 1084 end if; 1085 1086 STPO.Write_Lock (Entry_Call.Self); 1087 1088 if Entry_Call.Self.Common.State = Async_Select_Sleep then 1089 STPO.Wakeup (Entry_Call.Self, Async_Select_Sleep); 1090 end if; 1091 1092 STPO.Unlock (Entry_Call.Self); 1093 1094 if Single_Lock then 1095 STPO.Unlock_RTS; 1096 end if; 1097 1098 end if; 1099 1100 elsif Entry_Call.Mode = Conditional_Call then 1101 pragma Assert (Entry_Call.State < Was_Abortable); 1102 null; 1103 end if; 1104 end Update_For_Queue_To_PO; 1105 1106end System.Tasking.Protected_Objects.Operations; 1107