1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- SYSTEM.TASKING.PROTECTED_OBJECTS.SINGLE_ENTRY -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1998-2009, 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 32pragma Style_Checks (All_Checks); 33-- Turn off subprogram ordering check, since restricted GNARLI subprograms are 34-- gathered together at end. 35 36-- This package provides an optimized version of Protected_Objects.Operations 37-- and Protected_Objects.Entries making the following assumptions: 38 39-- PO has only one entry 40-- There is only one caller at a time (No_Entry_Queue) 41-- There is no dynamic priority support (No_Dynamic_Priorities) 42-- No Abort Statements 43-- (No_Abort_Statements, Max_Asynchronous_Select_Nesting => 0) 44-- PO are at library level 45-- No Requeue 46-- None of the tasks will terminate (no need for finalization) 47 48-- This interface is intended to be used in the ravenscar and restricted 49-- profiles, the compiler is responsible for ensuring that the conditions 50-- mentioned above are respected, except for the No_Entry_Queue restriction 51-- that is checked dynamically in this package, since the check cannot be 52-- performed at compile time, and is relatively cheap (see PO_Do_Or_Queue, 53-- Service_Entry). 54 55pragma Polling (Off); 56-- Turn off polling, we do not want polling to take place during tasking 57-- operations. It can cause infinite loops and other problems. 58 59pragma Suppress (All_Checks); 60-- Why is this required ??? 61 62with Ada.Exceptions; 63 64with System.Task_Primitives.Operations; 65with System.Parameters; 66 67package body System.Tasking.Protected_Objects.Single_Entry is 68 69 package STPO renames System.Task_Primitives.Operations; 70 71 use Parameters; 72 73 ----------------------- 74 -- Local Subprograms -- 75 ----------------------- 76 77 procedure Send_Program_Error 78 (Self_Id : Task_Id; 79 Entry_Call : Entry_Call_Link); 80 pragma Inline (Send_Program_Error); 81 -- Raise Program_Error in the caller of the specified entry call 82 83 -------------------------- 84 -- Entry Calls Handling -- 85 -------------------------- 86 87 procedure Wakeup_Entry_Caller 88 (Self_ID : Task_Id; 89 Entry_Call : Entry_Call_Link; 90 New_State : Entry_Call_State); 91 pragma Inline (Wakeup_Entry_Caller); 92 -- This is called at the end of service of an entry call, 93 -- to abort the caller if he is in an abortable part, and 94 -- to wake up the caller if he is on Entry_Caller_Sleep. 95 -- Call it holding the lock of Entry_Call.Self. 96 -- 97 -- Timed_Call or Simple_Call: 98 -- The caller is waiting on Entry_Caller_Sleep, in 99 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. 100 101 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link); 102 pragma Inline (Wait_For_Completion); 103 -- This procedure suspends the calling task until the specified entry call 104 -- has either been completed or cancelled. On exit, the call will not be 105 -- queued. This waits for calls on protected entries. 106 -- Call this only when holding Self_ID locked. 107 108 procedure Wait_For_Completion_With_Timeout 109 (Entry_Call : Entry_Call_Link; 110 Wakeup_Time : Duration; 111 Mode : Delay_Modes); 112 -- Same as Wait_For_Completion but it waits for a timeout with the value 113 -- specified in Wakeup_Time as well. 114 115 procedure Check_Exception 116 (Self_ID : Task_Id; 117 Entry_Call : Entry_Call_Link); 118 pragma Inline (Check_Exception); 119 -- Raise any pending exception from the Entry_Call. 120 -- This should be called at the end of every compiler interface procedure 121 -- that implements an entry call. 122 -- The caller should not be holding any locks, or there will be deadlock. 123 124 procedure PO_Do_Or_Queue 125 (Self_Id : Task_Id; 126 Object : Protection_Entry_Access; 127 Entry_Call : Entry_Call_Link); 128 -- This procedure executes or queues an entry call, depending 129 -- on the status of the corresponding barrier. It assumes that the 130 -- specified object is locked. 131 132 --------------------- 133 -- Check_Exception -- 134 --------------------- 135 136 procedure Check_Exception 137 (Self_ID : Task_Id; 138 Entry_Call : Entry_Call_Link) 139 is 140 pragma Warnings (Off, Self_ID); 141 142 procedure Internal_Raise (X : Ada.Exceptions.Exception_Id); 143 pragma Import (C, Internal_Raise, "__gnat_raise_with_msg"); 144 145 use type Ada.Exceptions.Exception_Id; 146 147 E : constant Ada.Exceptions.Exception_Id := 148 Entry_Call.Exception_To_Raise; 149 150 begin 151 if E /= Ada.Exceptions.Null_Id then 152 Internal_Raise (E); 153 end if; 154 end Check_Exception; 155 156 ------------------------ 157 -- Send_Program_Error -- 158 ------------------------ 159 160 procedure Send_Program_Error 161 (Self_Id : Task_Id; 162 Entry_Call : Entry_Call_Link) 163 is 164 Caller : constant Task_Id := Entry_Call.Self; 165 begin 166 Entry_Call.Exception_To_Raise := Program_Error'Identity; 167 168 if Single_Lock then 169 STPO.Lock_RTS; 170 end if; 171 172 STPO.Write_Lock (Caller); 173 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); 174 STPO.Unlock (Caller); 175 176 if Single_Lock then 177 STPO.Unlock_RTS; 178 end if; 179 end Send_Program_Error; 180 181 ------------------------- 182 -- Wait_For_Completion -- 183 ------------------------- 184 185 procedure Wait_For_Completion (Entry_Call : Entry_Call_Link) is 186 Self_Id : constant Task_Id := Entry_Call.Self; 187 begin 188 Self_Id.Common.State := Entry_Caller_Sleep; 189 STPO.Sleep (Self_Id, Entry_Caller_Sleep); 190 Self_Id.Common.State := Runnable; 191 end Wait_For_Completion; 192 193 -------------------------------------- 194 -- Wait_For_Completion_With_Timeout -- 195 -------------------------------------- 196 197 procedure Wait_For_Completion_With_Timeout 198 (Entry_Call : Entry_Call_Link; 199 Wakeup_Time : Duration; 200 Mode : Delay_Modes) 201 is 202 Self_Id : constant Task_Id := Entry_Call.Self; 203 Timedout : Boolean; 204 205 Yielded : Boolean; 206 pragma Unreferenced (Yielded); 207 208 use type Ada.Exceptions.Exception_Id; 209 210 begin 211 -- This procedure waits for the entry call to be served, with a timeout. 212 -- It tries to cancel the call if the timeout expires before the call is 213 -- served. 214 215 -- If we wake up from the timed sleep operation here, it may be for the 216 -- following possible reasons: 217 218 -- 1) The entry call is done being served. 219 -- 2) The timeout has expired (Timedout = True) 220 221 -- Once the timeout has expired we may need to continue to wait if the 222 -- call is already being serviced. In that case, we want to go back to 223 -- sleep, but without any timeout. The variable Timedout is used to 224 -- control this. If the Timedout flag is set, we do not need to Sleep 225 -- with a timeout. We just sleep until we get a wakeup for some status 226 -- change. 227 228 pragma Assert (Entry_Call.Mode = Timed_Call); 229 Self_Id.Common.State := Entry_Caller_Sleep; 230 231 STPO.Timed_Sleep 232 (Self_Id, Wakeup_Time, Mode, Entry_Caller_Sleep, Timedout, Yielded); 233 234 Entry_Call.State := (if Timedout then Cancelled else Done); 235 Self_Id.Common.State := Runnable; 236 end Wait_For_Completion_With_Timeout; 237 238 ------------------------- 239 -- Wakeup_Entry_Caller -- 240 ------------------------- 241 242 -- This is called at the end of service of an entry call, to abort the 243 -- caller if he is in an abortable part, and to wake up the caller if it 244 -- is on Entry_Caller_Sleep. It assumes that the call is already off-queue. 245 246 -- (This enforces the rule that a task must be off-queue if its state is 247 -- Done or Cancelled.) Call it holding the lock of Entry_Call.Self. 248 249 -- Timed_Call or Simple_Call: 250 -- The caller is waiting on Entry_Caller_Sleep, in 251 -- Wait_For_Completion, or Wait_For_Completion_With_Timeout. 252 253 -- Conditional_Call: 254 -- The caller might be in Wait_For_Completion, 255 -- waiting for a rendezvous (possibly requeued without abort) 256 -- to complete. 257 258 procedure Wakeup_Entry_Caller 259 (Self_ID : Task_Id; 260 Entry_Call : Entry_Call_Link; 261 New_State : Entry_Call_State) 262 is 263 pragma Warnings (Off, Self_ID); 264 265 Caller : constant Task_Id := Entry_Call.Self; 266 267 begin 268 pragma Assert (New_State = Done or else New_State = Cancelled); 269 pragma Assert 270 (Caller.Common.State /= Terminated and then 271 Caller.Common.State /= Unactivated); 272 273 Entry_Call.State := New_State; 274 STPO.Wakeup (Caller, Entry_Caller_Sleep); 275 end Wakeup_Entry_Caller; 276 277 ----------------------- 278 -- Restricted GNARLI -- 279 ----------------------- 280 281 -------------------------------- 282 -- Complete_Single_Entry_Body -- 283 -------------------------------- 284 285 procedure Complete_Single_Entry_Body (Object : Protection_Entry_Access) is 286 pragma Warnings (Off, Object); 287 288 begin 289 -- Nothing needs to do (Object.Call_In_Progress.Exception_To_Raise 290 -- has already been set to Null_Id). 291 292 null; 293 end Complete_Single_Entry_Body; 294 295 -------------------------------------------- 296 -- Exceptional_Complete_Single_Entry_Body -- 297 -------------------------------------------- 298 299 procedure Exceptional_Complete_Single_Entry_Body 300 (Object : Protection_Entry_Access; 301 Ex : Ada.Exceptions.Exception_Id) is 302 begin 303 Object.Call_In_Progress.Exception_To_Raise := Ex; 304 end Exceptional_Complete_Single_Entry_Body; 305 306 --------------------------------- 307 -- Initialize_Protection_Entry -- 308 --------------------------------- 309 310 procedure Initialize_Protection_Entry 311 (Object : Protection_Entry_Access; 312 Ceiling_Priority : Integer; 313 Compiler_Info : System.Address; 314 Entry_Body : Entry_Body_Access) 315 is 316 begin 317 Initialize_Protection (Object.Common'Access, Ceiling_Priority); 318 319 Object.Compiler_Info := Compiler_Info; 320 Object.Call_In_Progress := null; 321 Object.Entry_Body := Entry_Body; 322 Object.Entry_Queue := null; 323 end Initialize_Protection_Entry; 324 325 ---------------- 326 -- Lock_Entry -- 327 ---------------- 328 329 -- Compiler interface only. 330 -- Do not call this procedure from within the run-time system. 331 332 procedure Lock_Entry (Object : Protection_Entry_Access) is 333 begin 334 Lock (Object.Common'Access); 335 end Lock_Entry; 336 337 -------------------------- 338 -- Lock_Read_Only_Entry -- 339 -------------------------- 340 341 -- Compiler interface only 342 343 -- Do not call this procedure from within the runtime system 344 345 procedure Lock_Read_Only_Entry (Object : Protection_Entry_Access) is 346 begin 347 Lock_Read_Only (Object.Common'Access); 348 end Lock_Read_Only_Entry; 349 350 -------------------- 351 -- PO_Do_Or_Queue -- 352 -------------------- 353 354 procedure PO_Do_Or_Queue 355 (Self_Id : Task_Id; 356 Object : Protection_Entry_Access; 357 Entry_Call : Entry_Call_Link) 358 is 359 Barrier_Value : Boolean; 360 361 begin 362 -- When the Action procedure for an entry body returns, it must be 363 -- completed (having called [Exceptional_]Complete_Entry_Body). 364 365 Barrier_Value := Object.Entry_Body.Barrier (Object.Compiler_Info, 1); 366 367 if Barrier_Value then 368 if Object.Call_In_Progress /= null then 369 370 -- This violates the No_Entry_Queue restriction, send 371 -- Program_Error to the caller. 372 373 Send_Program_Error (Self_Id, Entry_Call); 374 return; 375 end if; 376 377 Object.Call_In_Progress := Entry_Call; 378 Object.Entry_Body.Action 379 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); 380 Object.Call_In_Progress := null; 381 382 if Single_Lock then 383 STPO.Lock_RTS; 384 end if; 385 386 STPO.Write_Lock (Entry_Call.Self); 387 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); 388 STPO.Unlock (Entry_Call.Self); 389 390 if Single_Lock then 391 STPO.Unlock_RTS; 392 end if; 393 394 elsif Entry_Call.Mode /= Conditional_Call then 395 if Object.Entry_Queue /= null then 396 397 -- This violates the No_Entry_Queue restriction, send 398 -- Program_Error to the caller. 399 400 Send_Program_Error (Self_Id, Entry_Call); 401 return; 402 else 403 Object.Entry_Queue := Entry_Call; 404 end if; 405 406 else 407 -- Conditional_Call 408 409 if Single_Lock then 410 STPO.Lock_RTS; 411 end if; 412 413 STPO.Write_Lock (Entry_Call.Self); 414 Wakeup_Entry_Caller (Self_Id, Entry_Call, Cancelled); 415 STPO.Unlock (Entry_Call.Self); 416 417 if Single_Lock then 418 STPO.Unlock_RTS; 419 end if; 420 end if; 421 422 exception 423 when others => 424 Send_Program_Error 425 (Self_Id, Entry_Call); 426 end PO_Do_Or_Queue; 427 428 ---------------------------- 429 -- Protected_Single_Count -- 430 ---------------------------- 431 432 function Protected_Count_Entry (Object : Protection_Entry) return Natural is 433 begin 434 if Object.Entry_Queue /= null then 435 return 1; 436 else 437 return 0; 438 end if; 439 end Protected_Count_Entry; 440 441 --------------------------------- 442 -- Protected_Single_Entry_Call -- 443 --------------------------------- 444 445 procedure Protected_Single_Entry_Call 446 (Object : Protection_Entry_Access; 447 Uninterpreted_Data : System.Address; 448 Mode : Call_Modes) 449 is 450 Self_Id : constant Task_Id := STPO.Self; 451 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); 452 begin 453 -- If pragma Detect_Blocking is active then Program_Error must be 454 -- raised if this potentially blocking operation is called from a 455 -- protected action. 456 457 if Detect_Blocking 458 and then Self_Id.Common.Protected_Action_Nesting > 0 459 then 460 raise Program_Error with "potentially blocking operation"; 461 end if; 462 463 Lock_Entry (Object); 464 465 Entry_Call.Mode := Mode; 466 Entry_Call.State := Now_Abortable; 467 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 468 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 469 470 PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access); 471 Unlock_Entry (Object); 472 473 -- The call is either `Done' or not. It cannot be cancelled since there 474 -- is no ATC construct. 475 476 pragma Assert (Entry_Call.State /= Cancelled); 477 478 if Entry_Call.State /= Done then 479 if Single_Lock then 480 STPO.Lock_RTS; 481 end if; 482 483 STPO.Write_Lock (Self_Id); 484 Wait_For_Completion (Entry_Call'Access); 485 STPO.Unlock (Self_Id); 486 487 if Single_Lock then 488 STPO.Unlock_RTS; 489 end if; 490 end if; 491 492 Check_Exception (Self_Id, Entry_Call'Access); 493 end Protected_Single_Entry_Call; 494 495 ----------------------------------- 496 -- Protected_Single_Entry_Caller -- 497 ----------------------------------- 498 499 function Protected_Single_Entry_Caller 500 (Object : Protection_Entry) return Task_Id is 501 begin 502 return Object.Call_In_Progress.Self; 503 end Protected_Single_Entry_Caller; 504 505 ------------------- 506 -- Service_Entry -- 507 ------------------- 508 509 procedure Service_Entry (Object : Protection_Entry_Access) is 510 Self_Id : constant Task_Id := STPO.Self; 511 Entry_Call : constant Entry_Call_Link := Object.Entry_Queue; 512 Caller : Task_Id; 513 514 begin 515 if Entry_Call /= null 516 and then Object.Entry_Body.Barrier (Object.Compiler_Info, 1) 517 then 518 Object.Entry_Queue := null; 519 520 if Object.Call_In_Progress /= null then 521 522 -- Violation of No_Entry_Queue restriction, raise exception 523 524 Send_Program_Error (Self_Id, Entry_Call); 525 Unlock_Entry (Object); 526 return; 527 end if; 528 529 Object.Call_In_Progress := Entry_Call; 530 Object.Entry_Body.Action 531 (Object.Compiler_Info, Entry_Call.Uninterpreted_Data, 1); 532 Object.Call_In_Progress := null; 533 Caller := Entry_Call.Self; 534 Unlock_Entry (Object); 535 536 if Single_Lock then 537 STPO.Lock_RTS; 538 end if; 539 540 STPO.Write_Lock (Caller); 541 Wakeup_Entry_Caller (Self_Id, Entry_Call, Done); 542 STPO.Unlock (Caller); 543 544 if Single_Lock then 545 STPO.Unlock_RTS; 546 end if; 547 548 else 549 -- Just unlock the entry 550 551 Unlock_Entry (Object); 552 end if; 553 554 exception 555 when others => 556 Send_Program_Error (Self_Id, Entry_Call); 557 Unlock_Entry (Object); 558 end Service_Entry; 559 560 --------------------------------------- 561 -- Timed_Protected_Single_Entry_Call -- 562 --------------------------------------- 563 564 -- Compiler interface only (do not call from within the RTS) 565 566 procedure Timed_Protected_Single_Entry_Call 567 (Object : Protection_Entry_Access; 568 Uninterpreted_Data : System.Address; 569 Timeout : Duration; 570 Mode : Delay_Modes; 571 Entry_Call_Successful : out Boolean) 572 is 573 Self_Id : constant Task_Id := STPO.Self; 574 Entry_Call : Entry_Call_Record renames Self_Id.Entry_Calls (1); 575 576 begin 577 -- If pragma Detect_Blocking is active then Program_Error must be 578 -- raised if this potentially blocking operation is called from a 579 -- protected action. 580 581 if Detect_Blocking 582 and then Self_Id.Common.Protected_Action_Nesting > 0 583 then 584 raise Program_Error with "potentially blocking operation"; 585 end if; 586 587 Lock (Object.Common'Access); 588 589 Entry_Call.Mode := Timed_Call; 590 Entry_Call.State := Now_Abortable; 591 Entry_Call.Uninterpreted_Data := Uninterpreted_Data; 592 Entry_Call.Exception_To_Raise := Ada.Exceptions.Null_Id; 593 594 PO_Do_Or_Queue (Self_Id, Object, Entry_Call'Access); 595 Unlock_Entry (Object); 596 597 -- Try to avoid waiting for completed calls. 598 -- The call is either `Done' or not. It cannot be cancelled since there 599 -- is no ATC construct and the timed wait has not started yet. 600 601 pragma Assert (Entry_Call.State /= Cancelled); 602 603 if Entry_Call.State = Done then 604 Check_Exception (Self_Id, Entry_Call'Access); 605 Entry_Call_Successful := True; 606 return; 607 end if; 608 609 if Single_Lock then 610 STPO.Lock_RTS; 611 else 612 STPO.Write_Lock (Self_Id); 613 end if; 614 615 Wait_For_Completion_With_Timeout (Entry_Call'Access, Timeout, Mode); 616 617 if Single_Lock then 618 STPO.Unlock_RTS; 619 else 620 STPO.Unlock (Self_Id); 621 end if; 622 623 pragma Assert (Entry_Call.State >= Done); 624 625 Check_Exception (Self_Id, Entry_Call'Access); 626 Entry_Call_Successful := Entry_Call.State = Done; 627 end Timed_Protected_Single_Entry_Call; 628 629 ------------------ 630 -- Unlock_Entry -- 631 ------------------ 632 633 procedure Unlock_Entry (Object : Protection_Entry_Access) is 634 begin 635 Unlock (Object.Common'Access); 636 end Unlock_Entry; 637 638end System.Tasking.Protected_Objects.Single_Entry; 639