gcc/ada/5vinterr.adb

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