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