1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . T A S K I N G . E N T R Y _ C A L L S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2021, Free Software Foundation, Inc. -- 10-- -- 11-- GNARL is free software; you can redistribute it and/or modify it under -- 12-- terms of the GNU General Public License as published by the Free Soft- -- 13-- ware Foundation; either version 3, or (at your option) any later ver- -- 14-- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- 15-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- 16-- or FITNESS FOR A PARTICULAR PURPOSE. -- 17-- -- 18-- As a special exception under Section 7 of GPL version 3, you are granted -- 19-- additional permissions described in the GCC Runtime Library Exception, -- 20-- version 3.1, as published by the Free Software Foundation. -- 21-- -- 22-- You should have received a copy of the GNU General Public License and -- 23-- a copy of the GCC Runtime Library Exception along with this program; -- 24-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- 25-- <http://www.gnu.org/licenses/>. -- 26-- -- 27-- GNARL was developed by the GNARL team at Florida State University. -- 28-- Extensive contributions were provided by Ada Core Technologies, Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with System.Task_Primitives.Operations; 33with System.Tasking.Initialization; 34with System.Tasking.Protected_Objects.Entries; 35with System.Tasking.Protected_Objects.Operations; 36with System.Tasking.Queuing; 37with System.Tasking.Utilities; 38 39package body System.Tasking.Entry_Calls is 40 41 package STPO renames System.Task_Primitives.Operations; 42 43 use Protected_Objects.Entries; 44 use Protected_Objects.Operations; 45 46 -- DO NOT use Protected_Objects.Lock or Protected_Objects.Unlock 47 -- internally. Those operations will raise Program_Error, which 48 -- we are not prepared to handle inside the RTS. Instead, use 49 -- System.Task_Primitives lock operations directly on Protection.L. 50 51 ----------------------- 52 -- Local Subprograms -- 53 ----------------------- 54 55 procedure Lock_Server (Entry_Call : Entry_Call_Link); 56 57 -- This locks the server targeted by Entry_Call 58 -- 59 -- This may be a task or a protected object, depending on the target of the 60 -- original call or any subsequent requeues. 61 -- 62 -- This routine is needed because the field specifying the server for this 63 -- call must be protected by the server's mutex. If it were protected by 64 -- the caller's mutex, accessing the server's queues would require locking 65 -- the caller to get the server, locking the server, and then accessing the 66 -- queues. This involves holding two ATCB locks at once, something which we 67 -- can guarantee that it will always be done in the same order, or locking 68 -- a protected object while we hold an ATCB lock, something which is not 69 -- permitted. Since the server cannot be obtained reliably, it must be 70 -- obtained unreliably and then checked again once it has been locked. 71 -- 72 -- This should only be called by the Entry_Call.Self. 73 -- It should be holding no other ATCB locks at the time. 74 75 procedure Unlock_Server (Entry_Call : Entry_Call_Link); 76 -- STPO.Unlock the server targeted by Entry_Call. The server must 77 -- be locked before calling this. 78 79 procedure Unlock_And_Update_Server 80 (Self_ID : Task_Id; 81 Entry_Call : Entry_Call_Link); 82 -- Similar to Unlock_Server, but services entry calls if the 83 -- server is a protected object. 84 85 procedure Check_Pending_Actions_For_Entry_Call 86 (Self_ID : Task_Id; 87 Entry_Call : Entry_Call_Link); 88 -- This procedure performs priority change of a queued call and dequeuing 89 -- of an entry call when the call is cancelled. If the call is dequeued the 90 -- state should be set to Cancelled. Call only with abort deferred and 91 -- holding lock of Self_ID. This is a bit of common code for all entry 92 -- calls. The effect is to do any deferred base priority change operation, 93 -- in case some other task called STPO.Set_Priority while the current task 94 -- had abort deferred, and to dequeue the call if the call has been 95 -- aborted. 96 97 procedure Poll_Base_Priority_Change_At_Entry_Call 98 (Self_ID : Task_Id; 99 Entry_Call : Entry_Call_Link); 100 pragma Inline (Poll_Base_Priority_Change_At_Entry_Call); 101 -- A specialized version of Poll_Base_Priority_Change, that does the 102 -- optional entry queue reordering. Has to be called with the Self_ID's 103 -- ATCB write-locked. May temporarily release the lock. 104 105 --------------------- 106 -- Check_Exception -- 107 --------------------- 108 109 procedure Check_Exception 110 (Self_ID : Task_Id; 111 Entry_Call : Entry_Call_Link) 112 is 113 pragma Warnings (Off, Self_ID); 114 115 use type Ada.Exceptions.Exception_Id; 116 117 procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); 118 pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); 119 120 E : constant Ada.Exceptions.Exception_Id := 121 Entry_Call.Exception_To_Raise; 122 begin 123 -- pragma Assert (Self_ID.Deferral_Level = 0); 124 125 -- The above may be useful for debugging, but the Florist packages 126 -- contain critical sections that defer abort and then do entry calls, 127 -- which causes the above Assert to trip. 128 129 if E /= Ada.Exceptions.Null_Id then 130 Internal_Raise (E); 131 end if; 132 end Check_Exception; 133 134 ------------------------------------------ 135 -- Check_Pending_Actions_For_Entry_Call -- 136 ------------------------------------------ 137 138 procedure Check_Pending_Actions_For_Entry_Call 139 (Self_ID : Task_Id; 140 Entry_Call : Entry_Call_Link) 141 is 142 begin 143 pragma Assert (Self_ID = Entry_Call.Self); 144 145 Poll_Base_Priority_Change_At_Entry_Call (Self_ID, Entry_Call); 146 147 if Self_ID.Pending_ATC_Level < Self_ID.ATC_Nesting_Level 148 and then Entry_Call.State = Now_Abortable 149 then 150 STPO.Unlock (Self_ID); 151 Lock_Server (Entry_Call); 152 153 if Queuing.Onqueue (Entry_Call) 154 and then Entry_Call.State = Now_Abortable 155 then 156 Queuing.Dequeue_Call (Entry_Call); 157 Entry_Call.State := 158 (if Entry_Call.Cancellation_Attempted then Cancelled else Done); 159 Unlock_And_Update_Server (Self_ID, Entry_Call); 160 161 else 162 Unlock_Server (Entry_Call); 163 end if; 164 165 STPO.Write_Lock (Self_ID); 166 end if; 167 end Check_Pending_Actions_For_Entry_Call; 168 169 ----------------- 170 -- Lock_Server -- 171 ----------------- 172 173 procedure Lock_Server (Entry_Call : Entry_Call_Link) is 174 Test_Task : Task_Id; 175 Test_PO : Protection_Entries_Access; 176 Ceiling_Violation : Boolean; 177 Failures : Integer := 0; 178 179 begin 180 Test_Task := Entry_Call.Called_Task; 181 182 loop 183 if Test_Task = null then 184 185 -- Entry_Call was queued on a protected object, or in transition, 186 -- when we last fetched Test_Task. 187 188 Test_PO := To_Protection (Entry_Call.Called_PO); 189 190 if Test_PO = null then 191 192 -- We had very bad luck, interleaving with TWO different 193 -- requeue operations. Go around the loop and try again. 194 195 STPO.Yield; 196 197 else 198 Lock_Entries_With_Status (Test_PO, Ceiling_Violation); 199 200 -- ??? 201 202 -- The following code allows Lock_Server to be called when 203 -- cancelling a call, to allow for the possibility that the 204 -- priority of the caller has been raised beyond that of the 205 -- protected entry call by Ada.Dynamic_Priorities.Set_Priority. 206 207 -- If the current task has a higher priority than the ceiling 208 -- of the protected object, temporarily lower it. It will 209 -- be reset in Unlock. 210 211 if Ceiling_Violation then 212 declare 213 Current_Task : constant Task_Id := STPO.Self; 214 Old_Base_Priority : System.Any_Priority; 215 216 begin 217 STPO.Write_Lock (Current_Task); 218 Old_Base_Priority := Current_Task.Common.Base_Priority; 219 Current_Task.New_Base_Priority := Test_PO.Ceiling; 220 System.Tasking.Initialization.Change_Base_Priority 221 (Current_Task); 222 STPO.Unlock (Current_Task); 223 224 -- Following lock should not fail 225 226 Lock_Entries (Test_PO); 227 228 Test_PO.Old_Base_Priority := Old_Base_Priority; 229 Test_PO.Pending_Action := True; 230 end; 231 end if; 232 233 exit when To_Address (Test_PO) = Entry_Call.Called_PO; 234 Unlock_Entries (Test_PO); 235 end if; 236 237 else 238 STPO.Write_Lock (Test_Task); 239 exit when Test_Task = Entry_Call.Called_Task; 240 STPO.Unlock (Test_Task); 241 end if; 242 243 Test_Task := Entry_Call.Called_Task; 244 Failures := Failures + 1; 245 pragma Assert (Failures <= 5); 246 end loop; 247 end Lock_Server; 248 249 --------------------------------------------- 250 -- Poll_Base_Priority_Change_At_Entry_Call -- 251 --------------------------------------------- 252 253 procedure Poll_Base_Priority_Change_At_Entry_Call 254 (Self_ID : Task_Id; 255 Entry_Call : Entry_Call_Link) 256 is 257 begin 258 if Self_ID.Pending_Priority_Change then 259 260 -- Check for ceiling violations ??? 261 262 Self_ID.Pending_Priority_Change := False; 263 264 -- Requeue the entry call at the new priority. We need to requeue 265 -- even if the new priority is the same than the previous (see ACATS 266 -- test cxd4006). 267 268 STPO.Unlock (Self_ID); 269 Lock_Server (Entry_Call); 270 Queuing.Requeue_Call_With_New_Prio 271 (Entry_Call, STPO.Get_Priority (Self_ID)); 272 Unlock_And_Update_Server (Self_ID, Entry_Call); 273 STPO.Write_Lock (Self_ID); 274 end if; 275 end Poll_Base_Priority_Change_At_Entry_Call; 276 277 -------------------- 278 -- Reset_Priority -- 279 -------------------- 280 281 procedure Reset_Priority 282 (Acceptor : Task_Id; 283 Acceptor_Prev_Priority : Rendezvous_Priority) 284 is 285 begin 286 pragma Assert (Acceptor = STPO.Self); 287 288 -- Since we limit this kind of "active" priority change to be done 289 -- by the task for itself, we don't need to lock Acceptor. 290 291 if Acceptor_Prev_Priority /= Priority_Not_Boosted then 292 STPO.Set_Priority (Acceptor, Acceptor_Prev_Priority, 293 Loss_Of_Inheritance => True); 294 end if; 295 end Reset_Priority; 296 297 ------------------------------ 298 -- Try_To_Cancel_Entry_Call -- 299 ------------------------------ 300 301 procedure Try_To_Cancel_Entry_Call (Succeeded : out Boolean) is 302 Entry_Call : Entry_Call_Link; 303 Self_ID : constant Task_Id := STPO.Self; 304 305 use type Ada.Exceptions.Exception_Id; 306 307 begin 308 Entry_Call := Self_ID.Entry_Calls (Self_ID.ATC_Nesting_Level)'Access; 309 310 -- Experimentation has shown that abort is sometimes (but not 311 -- always) already deferred when Cancel_xxx_Entry_Call is called. 312 -- That may indicate an error. Find out what is going on. ??? 313 314 pragma Assert (Entry_Call.Mode = Asynchronous_Call); 315 Initialization.Defer_Abort_Nestable (Self_ID); 316 STPO.Write_Lock (Self_ID); 317 Entry_Call.Cancellation_Attempted := True; 318 319 if Self_ID.Pending_ATC_Level >= Entry_Call.Level then 320 Self_ID.Pending_ATC_Level := Entry_Call.Level - 1; 321 end if; 322 323 Entry_Calls.Wait_For_Completion (Entry_Call); 324 STPO.Unlock (Self_ID); 325 Succeeded := Entry_Call.State = Cancelled; 326 Initialization.Undefer_Abort_Nestable (Self_ID); 327 328 -- Ideally, abort should no longer be deferred at this point, so we 329 -- should be able to call Check_Exception. The loop below should be 330 -- considered temporary, to work around the possibility that abort 331 -- may be deferred more than one level deep ??? 332 333 if Entry_Call.Exception_To_Raise /= Ada.Exceptions.Null_Id then 334 while Self_ID.Deferral_Level > 0 loop 335 System.Tasking.Initialization.Undefer_Abort_Nestable (Self_ID); 336 end loop; 337 338 Entry_Calls.Check_Exception (Self_ID, Entry_Call); 339 end if; 340 end Try_To_Cancel_Entry_Call; 341 342 ------------------------------ 343 -- Unlock_And_Update_Server -- 344 ------------------------------ 345 346 procedure Unlock_And_Update_Server 347 (Self_ID : Task_Id; 348 Entry_Call : Entry_Call_Link) 349 is 350 Called_PO : Protection_Entries_Access; 351 Caller : Task_Id; 352 353 begin 354 if Entry_Call.Called_Task /= null then 355 STPO.Unlock (Entry_Call.Called_Task); 356 else 357 Called_PO := To_Protection (Entry_Call.Called_PO); 358 PO_Service_Entries (Self_ID, Called_PO, False); 359 360 if Called_PO.Pending_Action then 361 Called_PO.Pending_Action := False; 362 Caller := STPO.Self; 363 STPO.Write_Lock (Caller); 364 Caller.New_Base_Priority := Called_PO.Old_Base_Priority; 365 Initialization.Change_Base_Priority (Caller); 366 STPO.Unlock (Caller); 367 end if; 368 369 Unlock_Entries (Called_PO); 370 end if; 371 end Unlock_And_Update_Server; 372 373 ------------------- 374 -- Unlock_Server -- 375 ------------------- 376 377 procedure Unlock_Server (Entry_Call : Entry_Call_Link) is 378 Caller : Task_Id; 379 Called_PO : Protection_Entries_Access; 380 381 begin 382 if Entry_Call.Called_Task /= null then 383 STPO.Unlock (Entry_Call.Called_Task); 384 else 385 Called_PO := To_Protection (Entry_Call.Called_PO); 386 387 if Called_PO.Pending_Action then 388 Called_PO.Pending_Action := False; 389 Caller := STPO.Self; 390 STPO.Write_Lock (Caller); 391 Caller.New_Base_Priority := Called_PO.Old_Base_Priority; 392 Initialization.Change_Base_Priority (Caller); 393 STPO.Unlock (Caller); 394 end if; 395 396 Unlock_Entries (Called_PO); 397 end if; 398 end Unlock_Server; 399 400 ------------------------- 401 -- Wait_For_Completion -- 402 ------------------------- 403 404 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is 405 Self_Id : constant Task_Id := Entry_Call.Self; 406 407 begin 408 -- If this is a conditional call, it should be cancelled when it 409 -- becomes abortable. This is checked in the loop below. 410 411 Self_Id.Common.State := Entry_Caller_Sleep; 412 413 -- Try to remove calls to Sleep in the loop below by letting the caller 414 -- a chance of getting ready immediately, using Unlock & Yield. 415 -- See similar action in Wait_For_Call & Timed_Selective_Wait. 416 417 STPO.Unlock (Self_Id); 418 419 if Entry_Call.State < Done then 420 STPO.Yield; 421 end if; 422 423 STPO.Write_Lock (Self_Id); 424 425 loop 426 Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); 427 428 exit when Entry_Call.State >= Done; 429 430 STPO.Sleep (Self_Id, Entry_Caller_Sleep); 431 end loop; 432 433 Self_Id.Common.State := Runnable; 434 Utilities.Exit_One_ATC_Level (Self_Id); 435 end Wait_For_Completion; 436 437 -------------------------------------- 438 -- Wait_For_Completion_With_Timeout -- 439 -------------------------------------- 440 441 procedure Wait_For_Completion_With_Timeout 442 (Entry_Call : Entry_Call_Link; 443 Wakeup_Time : Duration; 444 Mode : Delay_Modes; 445 Yielded : out Boolean) 446 is 447 Self_Id : constant Task_Id := Entry_Call.Self; 448 Timedout : Boolean := False; 449 450 begin 451 -- This procedure waits for the entry call to be served, with a timeout. 452 -- It tries to cancel the call if the timeout expires before the call is 453 -- served. 454 455 -- If we wake up from the timed sleep operation here, it may be for 456 -- several possible reasons: 457 458 -- 1) The entry call is done being served. 459 -- 2) There is an abort or priority change to be served. 460 -- 3) The timeout has expired (Timedout = True) 461 -- 4) There has been a spurious wakeup. 462 463 -- Once the timeout has expired we may need to continue to wait if the 464 -- call is already being serviced. In that case, we want to go back to 465 -- sleep, but without any timeout. The variable Timedout is used to 466 -- control this. If the Timedout flag is set, we do not need to 467 -- STPO.Sleep with a timeout. We just sleep until we get a wakeup for 468 -- some status change. 469 470 -- The original call may have become abortable after waking up. We want 471 -- to check Check_Pending_Actions_For_Entry_Call again in any case. 472 473 pragma Assert (Entry_Call.Mode = Timed_Call); 474 475 Yielded := False; 476 Self_Id.Common.State := Entry_Caller_Sleep; 477 478 -- Looping is necessary in case the task wakes up early from the timed 479 -- sleep, due to a "spurious wakeup". Spurious wakeups are a weakness of 480 -- POSIX condition variables. A thread waiting for a condition variable 481 -- is allowed to wake up at any time, not just when the condition is 482 -- signaled. See same loop in the ordinary Wait_For_Completion, above. 483 484 loop 485 Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); 486 exit when Entry_Call.State >= Done; 487 488 STPO.Timed_Sleep (Self_Id, Wakeup_Time, Mode, 489 Entry_Caller_Sleep, Timedout, Yielded); 490 491 if Timedout then 492 -- Try to cancel the call (see Try_To_Cancel_Entry_Call for 493 -- corresponding code in the ATC case). 494 495 Entry_Call.Cancellation_Attempted := True; 496 497 -- Reset Entry_Call.State so that the call is marked as cancelled 498 -- by Check_Pending_Actions_For_Entry_Call below. 499 500 if Entry_Call.State < Was_Abortable then 501 Entry_Call.State := Now_Abortable; 502 end if; 503 504 if Self_Id.Pending_ATC_Level >= Entry_Call.Level then 505 Self_Id.Pending_ATC_Level := Entry_Call.Level - 1; 506 end if; 507 508 -- The following loop is the same as the loop and exit code 509 -- from the ordinary Wait_For_Completion. If we get here, we 510 -- have timed out but we need to keep waiting until the call 511 -- has actually completed or been cancelled successfully. 512 513 loop 514 Check_Pending_Actions_For_Entry_Call (Self_Id, Entry_Call); 515 exit when Entry_Call.State >= Done; 516 STPO.Sleep (Self_Id, Entry_Caller_Sleep); 517 end loop; 518 519 Self_Id.Common.State := Runnable; 520 Utilities.Exit_One_ATC_Level (Self_Id); 521 522 return; 523 end if; 524 end loop; 525 526 -- This last part is the same as ordinary Wait_For_Completion, 527 -- and is only executed if the call completed without timing out. 528 529 Self_Id.Common.State := Runnable; 530 Utilities.Exit_One_ATC_Level (Self_Id); 531 end Wait_For_Completion_With_Timeout; 532 533 -------------------------- 534 -- Wait_Until_Abortable -- 535 -------------------------- 536 537 procedure Wait_Until_Abortable 538 (Self_ID : Task_Id; 539 Call : Entry_Call_Link) 540 is 541 begin 542 pragma Assert (Self_ID.ATC_Nesting_Level > Level_No_ATC_Occurring); 543 pragma Assert (Call.Mode = Asynchronous_Call); 544 545 STPO.Write_Lock (Self_ID); 546 Self_ID.Common.State := Entry_Caller_Sleep; 547 548 loop 549 Check_Pending_Actions_For_Entry_Call (Self_ID, Call); 550 exit when Call.State >= Was_Abortable; 551 STPO.Sleep (Self_ID, Async_Select_Sleep); 552 end loop; 553 554 Self_ID.Common.State := Runnable; 555 STPO.Unlock (Self_ID); 556 557 end Wait_Until_Abortable; 558 559end System.Tasking.Entry_Calls; 560