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