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