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