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