1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME LIBRARY (GNARL) COMPONENTS -- 4-- -- 5-- S Y S T E M . I N T E R R U P T S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 1992-2013, 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 is an OpenVMS/Alpha version of this package 33 34-- Invariants: 35 36-- Once we associate a Server_Task with an interrupt, the task never 37-- goes away, and we never remove the association. 38 39-- There is no more than one interrupt per Server_Task and no more than 40-- one Server_Task per interrupt. 41 42-- Within this package, the lock L is used to protect the various status 43-- tables. If there is a Server_Task associated with an interrupt, we use 44-- the per-task lock of the Server_Task instead so that we protect the 45-- status between Interrupt_Manager and Server_Task. Protection among 46-- service requests are done using User Request to Interrupt_Manager 47-- rendezvous. 48 49with Ada.Task_Identification; 50with Ada.Unchecked_Conversion; 51 52with System.Task_Primitives; 53with System.Interrupt_Management; 54 55with System.Interrupt_Management.Operations; 56pragma Elaborate_All (System.Interrupt_Management.Operations); 57 58with System.Task_Primitives.Operations; 59with System.Task_Primitives.Interrupt_Operations; 60with System.Storage_Elements; 61with System.Tasking.Utilities; 62 63with System.Tasking.Rendezvous; 64pragma Elaborate_All (System.Tasking.Rendezvous); 65 66with System.Tasking.Initialization; 67with System.Parameters; 68 69package body System.Interrupts is 70 71 use Tasking; 72 use System.Parameters; 73 74 package POP renames System.Task_Primitives.Operations; 75 package PIO renames System.Task_Primitives.Interrupt_Operations; 76 package IMNG renames System.Interrupt_Management; 77 package IMOP renames System.Interrupt_Management.Operations; 78 79 function To_System is new Ada.Unchecked_Conversion 80 (Ada.Task_Identification.Task_Id, Task_Id); 81 82 ----------------- 83 -- Local Tasks -- 84 ----------------- 85 86 -- WARNING: System.Tasking.Stages performs calls to this task with 87 -- low-level constructs. Do not change this spec without synchronizing it. 88 89 task Interrupt_Manager is 90 entry Detach_Interrupt_Entries (T : Task_Id); 91 92 entry Initialize (Mask : IMNG.Interrupt_Mask); 93 94 entry Attach_Handler 95 (New_Handler : Parameterless_Handler; 96 Interrupt : Interrupt_ID; 97 Static : Boolean; 98 Restoration : Boolean := False); 99 100 entry Exchange_Handler 101 (Old_Handler : out Parameterless_Handler; 102 New_Handler : Parameterless_Handler; 103 Interrupt : Interrupt_ID; 104 Static : Boolean); 105 106 entry Detach_Handler 107 (Interrupt : Interrupt_ID; 108 Static : Boolean); 109 110 entry Bind_Interrupt_To_Entry 111 (T : Task_Id; 112 E : Task_Entry_Index; 113 Interrupt : Interrupt_ID); 114 115 entry Block_Interrupt (Interrupt : Interrupt_ID); 116 117 entry Unblock_Interrupt (Interrupt : Interrupt_ID); 118 119 entry Ignore_Interrupt (Interrupt : Interrupt_ID); 120 121 entry Unignore_Interrupt (Interrupt : Interrupt_ID); 122 123 pragma Interrupt_Priority (System.Interrupt_Priority'Last); 124 end Interrupt_Manager; 125 126 task type Server_Task (Interrupt : Interrupt_ID) is 127 pragma Priority (System.Interrupt_Priority'Last); 128 -- Note: the above pragma Priority is strictly speaking improper since 129 -- it is outside the range of allowed priorities, but the compiler 130 -- treats system units specially and does not apply this range checking 131 -- rule to system units. 132 133 end Server_Task; 134 135 type Server_Task_Access is access Server_Task; 136 137 ------------------------------- 138 -- Local Types and Variables -- 139 ------------------------------- 140 141 type Entry_Assoc is record 142 T : Task_Id; 143 E : Task_Entry_Index; 144 end record; 145 146 type Handler_Assoc is record 147 H : Parameterless_Handler; 148 Static : Boolean; -- Indicates static binding; 149 end record; 150 151 User_Handler : array (Interrupt_ID'Range) of Handler_Assoc := 152 (others => (null, Static => False)); 153 pragma Volatile_Components (User_Handler); 154 -- Holds the protected procedure handler (if any) and its Static 155 -- information for each interrupt. A handler is a Static one if it is 156 -- specified through the pragma Attach_Handler. Attach_Handler. Otherwise, 157 -- not static) 158 159 User_Entry : array (Interrupt_ID'Range) of Entry_Assoc := 160 (others => (T => Null_Task, E => Null_Task_Entry)); 161 pragma Volatile_Components (User_Entry); 162 -- Holds the task and entry index (if any) for each interrupt 163 164 Blocked : constant array (Interrupt_ID'Range) of Boolean := 165 (others => False); 166 -- ??? pragma Volatile_Components (Blocked); 167 -- True iff the corresponding interrupt is blocked in the process level 168 169 Ignored : array (Interrupt_ID'Range) of Boolean := (others => False); 170 pragma Volatile_Components (Ignored); 171 -- True iff the corresponding interrupt is blocked in the process level 172 173 Last_Unblocker : constant array (Interrupt_ID'Range) of Task_Id := 174 (others => Null_Task); 175-- ??? pragma Volatile_Components (Last_Unblocker); 176 -- Holds the ID of the last Task which Unblocked this Interrupt. 177 -- It contains Null_Task if no tasks have ever requested the 178 -- Unblocking operation or the Interrupt is currently Blocked. 179 180 Server_ID : array (Interrupt_ID'Range) of Task_Id := 181 (others => Null_Task); 182 pragma Atomic_Components (Server_ID); 183 -- Holds the Task_Id of the Server_Task for each interrupt. Task_Id is 184 -- needed to accomplish locking per Interrupt base. Also is needed to 185 -- decide whether to create a new Server_Task. 186 187 -- Type and Head, Tail of the list containing Registered Interrupt 188 -- Handlers. These definitions are used to register the handlers specified 189 -- by the pragma Interrupt_Handler. 190 191 type Registered_Handler; 192 type R_Link is access all Registered_Handler; 193 194 type Registered_Handler is record 195 H : System.Address := System.Null_Address; 196 Next : R_Link := null; 197 end record; 198 199 Registered_Handler_Head : R_Link := null; 200 Registered_Handler_Tail : R_Link := null; 201 202 Access_Hold : Server_Task_Access; 203 -- variable used to allocate Server_Task using "new" 204 205 ----------------------- 206 -- Local Subprograms -- 207 ----------------------- 208 209 function Is_Registered (Handler : Parameterless_Handler) return Boolean; 210 -- See if the Handler has been "pragma"ed using Interrupt_Handler. 211 -- Always consider a null handler as registered. 212 213 -------------------------------- 214 -- Register_Interrupt_Handler -- 215 -------------------------------- 216 217 procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is 218 New_Node_Ptr : R_Link; 219 220 begin 221 -- This routine registers the Handler as usable for Dynamic 222 -- Interrupt Handler. Routines attaching and detaching Handler 223 -- dynamically should first consult if the Handler is registered. 224 -- A Program Error should be raised if it is not registered. 225 226 -- The pragma Interrupt_Handler can only appear in the library 227 -- level PO definition and instantiation. Therefore, we do not need 228 -- to implement Unregistering operation. Neither we need to 229 -- protect the queue structure using a Lock. 230 231 pragma Assert (Handler_Addr /= System.Null_Address); 232 233 New_Node_Ptr := new Registered_Handler; 234 New_Node_Ptr.H := Handler_Addr; 235 236 if Registered_Handler_Head = null then 237 Registered_Handler_Head := New_Node_Ptr; 238 Registered_Handler_Tail := New_Node_Ptr; 239 240 else 241 Registered_Handler_Tail.Next := New_Node_Ptr; 242 Registered_Handler_Tail := New_Node_Ptr; 243 end if; 244 end Register_Interrupt_Handler; 245 246 ------------------- 247 -- Is_Registered -- 248 ------------------- 249 250 function Is_Registered (Handler : Parameterless_Handler) return Boolean is 251 type Fat_Ptr is record 252 Object_Addr : System.Address; 253 Handler_Addr : System.Address; 254 end record; 255 256 function To_Fat_Ptr is new Ada.Unchecked_Conversion 257 (Parameterless_Handler, Fat_Ptr); 258 259 Ptr : R_Link; 260 Fat : Fat_Ptr; 261 262 begin 263 if Handler = null then 264 return True; 265 end if; 266 267 Fat := To_Fat_Ptr (Handler); 268 269 Ptr := Registered_Handler_Head; 270 271 while Ptr /= null loop 272 if Ptr.H = Fat.Handler_Addr then 273 return True; 274 end if; 275 276 Ptr := Ptr.Next; 277 end loop; 278 279 return False; 280 end Is_Registered; 281 282 ----------------- 283 -- Is_Reserved -- 284 ----------------- 285 286 function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is 287 begin 288 return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt)); 289 end Is_Reserved; 290 291 ----------------------- 292 -- Is_Entry_Attached -- 293 ----------------------- 294 295 function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is 296 begin 297 if Is_Reserved (Interrupt) then 298 raise Program_Error with 299 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 300 end if; 301 302 return User_Entry (Interrupt).T /= Null_Task; 303 end Is_Entry_Attached; 304 305 ------------------------- 306 -- Is_Handler_Attached -- 307 ------------------------- 308 309 function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is 310 begin 311 if Is_Reserved (Interrupt) then 312 raise Program_Error with 313 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 314 end if; 315 316 return User_Handler (Interrupt).H /= null; 317 end Is_Handler_Attached; 318 319 ---------------- 320 -- Is_Blocked -- 321 ---------------- 322 323 function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is 324 begin 325 if Is_Reserved (Interrupt) then 326 raise Program_Error with 327 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 328 end if; 329 330 return Blocked (Interrupt); 331 end Is_Blocked; 332 333 ---------------- 334 -- Is_Ignored -- 335 ---------------- 336 337 function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is 338 begin 339 if Is_Reserved (Interrupt) then 340 raise Program_Error with 341 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 342 end if; 343 344 return Ignored (Interrupt); 345 end Is_Ignored; 346 347 --------------------- 348 -- Current_Handler -- 349 --------------------- 350 351 function Current_Handler 352 (Interrupt : Interrupt_ID) return Parameterless_Handler 353 is 354 begin 355 if Is_Reserved (Interrupt) then 356 raise Program_Error with 357 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 358 end if; 359 360 -- ??? Since Parameterless_Handler is not Atomic, the current 361 -- implementation is wrong. We need a new service in Interrupt_Manager 362 -- to ensure atomicity. 363 364 return User_Handler (Interrupt).H; 365 end Current_Handler; 366 367 -------------------- 368 -- Attach_Handler -- 369 -------------------- 370 371 -- Calling this procedure with New_Handler = null and Static = True 372 -- means we want to detach the current handler regardless of the 373 -- previous handler's binding status (i.e. do not care if it is a 374 -- dynamic or static handler). 375 376 -- This option is needed so that during the finalization of a PO, we 377 -- can detach handlers attached through pragma Attach_Handler. 378 379 procedure Attach_Handler 380 (New_Handler : Parameterless_Handler; 381 Interrupt : Interrupt_ID; 382 Static : Boolean := False) is 383 begin 384 if Is_Reserved (Interrupt) then 385 raise Program_Error with 386 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 387 end if; 388 389 Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static); 390 391 end Attach_Handler; 392 393 ---------------------- 394 -- Exchange_Handler -- 395 ---------------------- 396 397 -- Calling this procedure with New_Handler = null and Static = True means 398 -- we want to detach the current handler regardless of the previous 399 -- handler's binding status (i.e. do not care if it is dynamic or static 400 -- handler). 401 402 -- This option is needed so that during the finalization of a PO, we can 403 -- detach handlers attached through pragma Attach_Handler. 404 405 procedure Exchange_Handler 406 (Old_Handler : out Parameterless_Handler; 407 New_Handler : Parameterless_Handler; 408 Interrupt : Interrupt_ID; 409 Static : Boolean := False) 410 is 411 begin 412 if Is_Reserved (Interrupt) then 413 raise Program_Error with 414 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 415 end if; 416 417 Interrupt_Manager.Exchange_Handler 418 (Old_Handler, New_Handler, Interrupt, Static); 419 420 end Exchange_Handler; 421 422 -------------------- 423 -- Detach_Handler -- 424 -------------------- 425 426 -- Calling this procedure with Static = True means we want to Detach the 427 -- current handler regardless of the previous handler's binding status 428 -- (i.e. do not care if it is a dynamic or static handler). 429 430 -- This option is needed so that during the finalization of a PO, we can 431 -- detach handlers attached through pragma Attach_Handler. 432 433 procedure Detach_Handler 434 (Interrupt : Interrupt_ID; 435 Static : Boolean := False) 436 is 437 begin 438 if Is_Reserved (Interrupt) then 439 raise Program_Error with 440 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 441 end if; 442 443 Interrupt_Manager.Detach_Handler (Interrupt, Static); 444 end Detach_Handler; 445 446 --------------- 447 -- Reference -- 448 --------------- 449 450 function Reference (Interrupt : Interrupt_ID) return System.Address is 451 begin 452 if Is_Reserved (Interrupt) then 453 raise Program_Error with 454 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 455 end if; 456 457 return Storage_Elements.To_Address 458 (Storage_Elements.Integer_Address (Interrupt)); 459 end Reference; 460 461 ----------------------------- 462 -- Bind_Interrupt_To_Entry -- 463 ----------------------------- 464 465 -- This procedure raises a Program_Error if it tries to 466 -- bind an interrupt to which an Entry or a Procedure is 467 -- already bound. 468 469 procedure Bind_Interrupt_To_Entry 470 (T : Task_Id; 471 E : Task_Entry_Index; 472 Int_Ref : System.Address) 473 is 474 Interrupt : constant Interrupt_ID := 475 Interrupt_ID (Storage_Elements.To_Integer (Int_Ref)); 476 477 begin 478 if Is_Reserved (Interrupt) then 479 raise Program_Error with 480 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 481 end if; 482 483 Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt); 484 485 end Bind_Interrupt_To_Entry; 486 487 ------------------------------ 488 -- Detach_Interrupt_Entries -- 489 ------------------------------ 490 491 procedure Detach_Interrupt_Entries (T : Task_Id) is 492 begin 493 Interrupt_Manager.Detach_Interrupt_Entries (T); 494 end Detach_Interrupt_Entries; 495 496 --------------------- 497 -- Block_Interrupt -- 498 --------------------- 499 500 procedure Block_Interrupt (Interrupt : Interrupt_ID) is 501 begin 502 if Is_Reserved (Interrupt) then 503 raise Program_Error with 504 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 505 end if; 506 507 Interrupt_Manager.Block_Interrupt (Interrupt); 508 end Block_Interrupt; 509 510 ----------------------- 511 -- Unblock_Interrupt -- 512 ----------------------- 513 514 procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is 515 begin 516 if Is_Reserved (Interrupt) then 517 raise Program_Error with 518 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 519 end if; 520 521 Interrupt_Manager.Unblock_Interrupt (Interrupt); 522 end Unblock_Interrupt; 523 524 ------------------ 525 -- Unblocked_By -- 526 ------------------ 527 528 function Unblocked_By 529 (Interrupt : Interrupt_ID) return System.Tasking.Task_Id is 530 begin 531 if Is_Reserved (Interrupt) then 532 raise Program_Error with 533 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 534 end if; 535 536 return Last_Unblocker (Interrupt); 537 end Unblocked_By; 538 539 ---------------------- 540 -- Ignore_Interrupt -- 541 ---------------------- 542 543 procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is 544 begin 545 if Is_Reserved (Interrupt) then 546 raise Program_Error with 547 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 548 end if; 549 550 Interrupt_Manager.Ignore_Interrupt (Interrupt); 551 end Ignore_Interrupt; 552 553 ------------------------ 554 -- Unignore_Interrupt -- 555 ------------------------ 556 557 procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is 558 begin 559 if Is_Reserved (Interrupt) then 560 raise Program_Error with 561 "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved"; 562 end if; 563 564 Interrupt_Manager.Unignore_Interrupt (Interrupt); 565 end Unignore_Interrupt; 566 567 ----------------------- 568 -- Interrupt_Manager -- 569 ----------------------- 570 571 task body Interrupt_Manager is 572 573 -------------------- 574 -- Local Routines -- 575 -------------------- 576 577 procedure Unprotected_Exchange_Handler 578 (Old_Handler : out Parameterless_Handler; 579 New_Handler : Parameterless_Handler; 580 Interrupt : Interrupt_ID; 581 Static : Boolean; 582 Restoration : Boolean := False); 583 584 procedure Unprotected_Detach_Handler 585 (Interrupt : Interrupt_ID; 586 Static : Boolean); 587 588 ---------------------------------- 589 -- Unprotected_Exchange_Handler -- 590 ---------------------------------- 591 592 procedure Unprotected_Exchange_Handler 593 (Old_Handler : out Parameterless_Handler; 594 New_Handler : Parameterless_Handler; 595 Interrupt : Interrupt_ID; 596 Static : Boolean; 597 Restoration : Boolean := False) 598 is 599 begin 600 if User_Entry (Interrupt).T /= Null_Task then 601 602 -- In case we have an Interrupt Entry already installed. 603 -- raise a program error. (propagate it to the caller). 604 605 raise Program_Error with "An interrupt is already installed"; 606 end if; 607 608 -- Note: A null handler with Static=True will pass the following 609 -- check. That is the case when we want to Detach a handler 610 -- regardless of the Static status of the current_Handler. We don't 611 -- check anything if Restoration is True, since we may be detaching 612 -- a static handler to restore a dynamic one. 613 614 if not Restoration and then not Static 615 616 -- Tries to overwrite a static Interrupt Handler with a 617 -- dynamic Handler 618 619 and then (User_Handler (Interrupt).Static 620 621 -- The new handler is not specified as an 622 -- Interrupt Handler by a pragma. 623 624 or else not Is_Registered (New_Handler)) 625 then 626 raise Program_Error with 627 "Trying to overwrite a static Interrupt Handler with a " & 628 "dynamic Handler"; 629 end if; 630 631 -- The interrupt should no longer be ignored if it was ever ignored 632 633 Ignored (Interrupt) := False; 634 635 -- Save the old handler 636 637 Old_Handler := User_Handler (Interrupt).H; 638 639 -- The new handler 640 641 User_Handler (Interrupt).H := New_Handler; 642 643 if New_Handler = null then 644 645 -- The null handler means we are detaching the handler 646 647 User_Handler (Interrupt).Static := False; 648 649 else 650 User_Handler (Interrupt).Static := Static; 651 end if; 652 653 -- Invoke a corresponding Server_Task if not yet created. 654 -- Place Task_Id info in Server_ID array. 655 656 if Server_ID (Interrupt) = Null_Task then 657 Access_Hold := new Server_Task (Interrupt); 658 Server_ID (Interrupt) := To_System (Access_Hold.all'Identity); 659 else 660 POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep); 661 end if; 662 663 end Unprotected_Exchange_Handler; 664 665 -------------------------------- 666 -- Unprotected_Detach_Handler -- 667 -------------------------------- 668 669 procedure Unprotected_Detach_Handler 670 (Interrupt : Interrupt_ID; 671 Static : Boolean) 672 is 673 begin 674 if User_Entry (Interrupt).T /= Null_Task then 675 676 -- In case we have an Interrupt Entry installed. 677 -- raise a program error. (propagate it to the caller). 678 679 raise Program_Error with 680 "An interrupt entry is already installed"; 681 end if; 682 683 -- Note : Static = True will pass the following check. That is the 684 -- case when we want to detach a handler regardless of the static 685 -- status of the current_Handler. 686 687 if not Static and then User_Handler (Interrupt).Static then 688 -- Tries to detach a static Interrupt Handler. 689 -- raise a program error. 690 691 raise Program_Error with 692 "Trying to detach a static Interrupt Handler"; 693 end if; 694 695 -- The interrupt should no longer be ignored if 696 -- it was ever ignored. 697 698 Ignored (Interrupt) := False; 699 700 -- The new handler 701 702 User_Handler (Interrupt).H := null; 703 User_Handler (Interrupt).Static := False; 704 IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt)); 705 706 end Unprotected_Detach_Handler; 707 708 -- Start of processing for Interrupt_Manager 709 710 begin 711 -- By making this task independent of master, when the process 712 -- goes away, the Interrupt_Manager will terminate gracefully. 713 714 System.Tasking.Utilities.Make_Independent; 715 716 -- Environment task gets its own interrupt mask, saves it, 717 -- and then masks all interrupts except the Keep_Unmasked set. 718 719 -- During rendezvous, the Interrupt_Manager receives the old 720 -- interrupt mask of the environment task, and sets its own 721 -- interrupt mask to that value. 722 723 -- The environment task will call the entry of Interrupt_Manager some 724 -- during elaboration of the body of this package. 725 726 accept Initialize (Mask : IMNG.Interrupt_Mask) do 727 pragma Warnings (Off, Mask); 728 null; 729 end Initialize; 730 731 -- Note: All tasks in RTS will have all the Reserve Interrupts 732 -- being masked (except the Interrupt_Manager) and Keep_Unmasked 733 -- unmasked when created. 734 735 -- Abort_Task_Interrupt is one of the Interrupt unmasked 736 -- in all tasks. We mask the Interrupt in this particular task 737 -- so that "sigwait" is possible to catch an explicitly sent 738 -- Abort_Task_Interrupt from the Server_Tasks. 739 740 -- This sigwaiting is needed so that we make sure a Server_Task is 741 -- out of its own sigwait state. This extra synchronization is 742 -- necessary to prevent following scenarios. 743 744 -- 1) Interrupt_Manager sends an Abort_Task_Interrupt to the 745 -- Server_Task then changes its own interrupt mask (OS level). 746 -- If an interrupt (corresponding to the Server_Task) arrives 747 -- in the mean time we have the Interrupt_Manager unmasked and 748 -- the Server_Task waiting on sigwait. 749 750 -- 2) For unbinding handler, we install a default action in the 751 -- Interrupt_Manager. POSIX.1c states that the result of using 752 -- "sigwait" and "sigaction" simultaneously on the same interrupt 753 -- is undefined. Therefore, we need to be informed from the 754 -- Server_Task of the fact that the Server_Task is out of its 755 -- sigwait stage. 756 757 loop 758 -- A block is needed to absorb Program_Error exception 759 760 declare 761 Old_Handler : Parameterless_Handler; 762 begin 763 select 764 765 accept Attach_Handler 766 (New_Handler : Parameterless_Handler; 767 Interrupt : Interrupt_ID; 768 Static : Boolean; 769 Restoration : Boolean := False) 770 do 771 Unprotected_Exchange_Handler 772 (Old_Handler, New_Handler, Interrupt, Static, Restoration); 773 end Attach_Handler; 774 775 or accept Exchange_Handler 776 (Old_Handler : out Parameterless_Handler; 777 New_Handler : Parameterless_Handler; 778 Interrupt : Interrupt_ID; 779 Static : Boolean) 780 do 781 Unprotected_Exchange_Handler 782 (Old_Handler, New_Handler, Interrupt, Static); 783 end Exchange_Handler; 784 785 or accept Detach_Handler 786 (Interrupt : Interrupt_ID; 787 Static : Boolean) 788 do 789 Unprotected_Detach_Handler (Interrupt, Static); 790 end Detach_Handler; 791 792 or accept Bind_Interrupt_To_Entry 793 (T : Task_Id; 794 E : Task_Entry_Index; 795 Interrupt : Interrupt_ID) 796 do 797 -- if there is a binding already (either a procedure or an 798 -- entry), raise Program_Error (propagate it to the caller). 799 800 if User_Handler (Interrupt).H /= null 801 or else User_Entry (Interrupt).T /= Null_Task 802 then 803 raise Program_Error with 804 "A binding for this interrupt is already present"; 805 end if; 806 807 -- The interrupt should no longer be ignored if 808 -- it was ever ignored. 809 810 Ignored (Interrupt) := False; 811 User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E); 812 813 -- Indicate the attachment of Interrupt Entry in ATCB. 814 -- This is need so that when an Interrupt Entry task 815 -- terminates the binding can be cleaned. 816 -- The call to unbinding must be 817 -- make by the task before it terminates. 818 819 T.Interrupt_Entry := True; 820 821 -- Invoke a corresponding Server_Task if not yet created. 822 -- Place Task_Id info in Server_ID array. 823 824 if Server_ID (Interrupt) = Null_Task then 825 826 Access_Hold := new Server_Task (Interrupt); 827 Server_ID (Interrupt) := 828 To_System (Access_Hold.all'Identity); 829 else 830 POP.Wakeup (Server_ID (Interrupt), 831 Interrupt_Server_Idle_Sleep); 832 end if; 833 end Bind_Interrupt_To_Entry; 834 835 or accept Detach_Interrupt_Entries (T : Task_Id) 836 do 837 for J in Interrupt_ID'Range loop 838 if not Is_Reserved (J) then 839 if User_Entry (J).T = T then 840 841 -- The interrupt should no longer be ignored if 842 -- it was ever ignored. 843 844 Ignored (J) := False; 845 User_Entry (J) := 846 Entry_Assoc'(T => Null_Task, E => Null_Task_Entry); 847 IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (J)); 848 end if; 849 end if; 850 end loop; 851 852 -- Indicate in ATCB that no Interrupt Entries are attached 853 854 T.Interrupt_Entry := False; 855 end Detach_Interrupt_Entries; 856 857 or accept Block_Interrupt (Interrupt : Interrupt_ID) do 858 pragma Warnings (Off, Interrupt); 859 raise Program_Error; 860 end Block_Interrupt; 861 862 or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do 863 pragma Warnings (Off, Interrupt); 864 raise Program_Error; 865 end Unblock_Interrupt; 866 867 or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do 868 pragma Warnings (Off, Interrupt); 869 raise Program_Error; 870 end Ignore_Interrupt; 871 872 or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do 873 pragma Warnings (Off, Interrupt); 874 raise Program_Error; 875 end Unignore_Interrupt; 876 877 end select; 878 879 exception 880 -- If there is a program error we just want to propagate it 881 -- to the caller and do not want to stop this task. 882 883 when Program_Error => 884 null; 885 886 when others => 887 pragma Assert (False); 888 null; 889 end; 890 end loop; 891 end Interrupt_Manager; 892 893 ----------------- 894 -- Server_Task -- 895 ----------------- 896 897 task body Server_Task is 898 Self_ID : constant Task_Id := Self; 899 Tmp_Handler : Parameterless_Handler; 900 Tmp_ID : Task_Id; 901 Tmp_Entry_Index : Task_Entry_Index; 902 Intwait_Mask : aliased IMNG.Interrupt_Mask; 903 904 begin 905 -- By making this task independent of master, when the process 906 -- goes away, the Server_Task will terminate gracefully. 907 908 System.Tasking.Utilities.Make_Independent; 909 910 -- Install default action in system level 911 912 IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt)); 913 914 -- Set up the mask (also clears the event flag) 915 916 IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access); 917 IMOP.Add_To_Interrupt_Mask 918 (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt)); 919 920 -- Remember the Interrupt_ID for Abort_Task 921 922 PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID); 923 924 -- Note: All tasks in RTS will have all the Reserve Interrupts 925 -- being masked (except the Interrupt_Manager) and Keep_Unmasked 926 -- unmasked when created. 927 928 loop 929 System.Tasking.Initialization.Defer_Abort (Self_ID); 930 931 -- A Handler or an Entry is installed. At this point all tasks 932 -- mask for the Interrupt is masked. Catch the Interrupt using 933 -- sigwait. 934 935 -- This task may wake up from sigwait by receiving an interrupt 936 -- (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding 937 -- a Procedure Handler or an Entry. Or it could be a wake up 938 -- from status change (Unblocked -> Blocked). If that is not 939 -- the case, we should execute the attached Procedure or Entry. 940 941 if Single_Lock then 942 POP.Lock_RTS; 943 end if; 944 945 POP.Write_Lock (Self_ID); 946 947 if User_Handler (Interrupt).H = null 948 and then User_Entry (Interrupt).T = Null_Task 949 then 950 -- No Interrupt binding. If there is an interrupt, 951 -- Interrupt_Manager will take default action. 952 953 Self_ID.Common.State := Interrupt_Server_Idle_Sleep; 954 POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep); 955 Self_ID.Common.State := Runnable; 956 957 else 958 Self_ID.Common.State := Interrupt_Server_Blocked_On_Event_Flag; 959 Self_ID.Common.State := Runnable; 960 961 if not (Self_ID.Deferral_Level = 0 962 and then Self_ID.Pending_ATC_Level 963 < Self_ID.ATC_Nesting_Level) 964 then 965 if User_Handler (Interrupt).H /= null then 966 Tmp_Handler := User_Handler (Interrupt).H; 967 968 -- RTS calls should not be made with self being locked 969 970 POP.Unlock (Self_ID); 971 972 if Single_Lock then 973 POP.Unlock_RTS; 974 end if; 975 976 Tmp_Handler.all; 977 978 if Single_Lock then 979 POP.Lock_RTS; 980 end if; 981 982 POP.Write_Lock (Self_ID); 983 984 elsif User_Entry (Interrupt).T /= Null_Task then 985 Tmp_ID := User_Entry (Interrupt).T; 986 Tmp_Entry_Index := User_Entry (Interrupt).E; 987 988 -- RTS calls should not be made with self being locked 989 990 POP.Unlock (Self_ID); 991 992 if Single_Lock then 993 POP.Unlock_RTS; 994 end if; 995 996 System.Tasking.Rendezvous.Call_Simple 997 (Tmp_ID, Tmp_Entry_Index, System.Null_Address); 998 999 if Single_Lock then 1000 POP.Lock_RTS; 1001 end if; 1002 1003 POP.Write_Lock (Self_ID); 1004 end if; 1005 end if; 1006 end if; 1007 1008 POP.Unlock (Self_ID); 1009 1010 if Single_Lock then 1011 POP.Unlock_RTS; 1012 end if; 1013 1014 System.Tasking.Initialization.Undefer_Abort (Self_ID); 1015 1016 -- Undefer abort here to allow a window for this task 1017 -- to be aborted at the time of system shutdown. 1018 end loop; 1019 end Server_Task; 1020 1021 ------------------------------------- 1022 -- Has_Interrupt_Or_Attach_Handler -- 1023 ------------------------------------- 1024 1025 function Has_Interrupt_Or_Attach_Handler 1026 (Object : access Dynamic_Interrupt_Protection) return Boolean 1027 is 1028 pragma Warnings (Off, Object); 1029 1030 begin 1031 return True; 1032 end Has_Interrupt_Or_Attach_Handler; 1033 1034 -------------- 1035 -- Finalize -- 1036 -------------- 1037 1038 procedure Finalize (Object : in out Static_Interrupt_Protection) is 1039 begin 1040 -- ??? loop to be executed only when we're not doing library level 1041 -- finalization, since in this case all interrupt tasks are gone. 1042 1043 if not Interrupt_Manager'Terminated then 1044 for N in reverse Object.Previous_Handlers'Range loop 1045 Interrupt_Manager.Attach_Handler 1046 (New_Handler => Object.Previous_Handlers (N).Handler, 1047 Interrupt => Object.Previous_Handlers (N).Interrupt, 1048 Static => Object.Previous_Handlers (N).Static, 1049 Restoration => True); 1050 end loop; 1051 end if; 1052 1053 Tasking.Protected_Objects.Entries.Finalize 1054 (Tasking.Protected_Objects.Entries.Protection_Entries (Object)); 1055 end Finalize; 1056 1057 ------------------------------------- 1058 -- Has_Interrupt_Or_Attach_Handler -- 1059 ------------------------------------- 1060 1061 function Has_Interrupt_Or_Attach_Handler 1062 (Object : access Static_Interrupt_Protection) return Boolean 1063 is 1064 pragma Warnings (Off, Object); 1065 begin 1066 return True; 1067 end Has_Interrupt_Or_Attach_Handler; 1068 1069 ---------------------- 1070 -- Install_Handlers -- 1071 ---------------------- 1072 1073 procedure Install_Handlers 1074 (Object : access Static_Interrupt_Protection; 1075 New_Handlers : New_Handler_Array) 1076 is 1077 begin 1078 for N in New_Handlers'Range loop 1079 1080 -- We need a lock around this ??? 1081 1082 Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt; 1083 Object.Previous_Handlers (N).Static := User_Handler 1084 (New_Handlers (N).Interrupt).Static; 1085 1086 -- We call Exchange_Handler and not directly Interrupt_Manager. 1087 -- Exchange_Handler so we get the Is_Reserved check. 1088 1089 Exchange_Handler 1090 (Old_Handler => Object.Previous_Handlers (N).Handler, 1091 New_Handler => New_Handlers (N).Handler, 1092 Interrupt => New_Handlers (N).Interrupt, 1093 Static => True); 1094 end loop; 1095 end Install_Handlers; 1096 1097 --------------------------------- 1098 -- Install_Restricted_Handlers -- 1099 --------------------------------- 1100 1101 procedure Install_Restricted_Handlers 1102 (Prio : Any_Priority; 1103 Handlers : New_Handler_Array) 1104 is 1105 pragma Unreferenced (Prio); 1106 begin 1107 for N in Handlers'Range loop 1108 Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True); 1109 end loop; 1110 end Install_Restricted_Handlers; 1111 1112-- Elaboration code for package System.Interrupts 1113 1114begin 1115 -- Get Interrupt_Manager's ID so that Abort_Interrupt can be sent 1116 1117 Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity); 1118 1119 -- During the elaboration of this package body we want RTS to inherit the 1120 -- interrupt mask from the Environment Task. 1121 1122 -- The Environment Task should have gotten its mask from the enclosing 1123 -- process during the RTS start up. (See in s-inmaop.adb). Pass the 1124 -- Interrupt_Mask of the Environment task to the Interrupt_Manager. 1125 1126 -- Note : At this point we know that all tasks (including RTS internal 1127 -- servers) are masked for non-reserved signals (see s-taprop.adb). Only 1128 -- the Interrupt_Manager will have masks set up differently inheriting the 1129 -- original Environment Task's mask. 1130 1131 Interrupt_Manager.Initialize (IMOP.Environment_Mask); 1132end System.Interrupts; 1133