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