gcc/ada/s-interr-hwint.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                 GNAT 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-2009, 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 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT 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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- GNARL was developed by the GNARL team at Florida State University.       --
  28 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  29 --                                                                          --
  30 ------------------------------------------------------------------------------
  31
  32 --  Invariants:
  33
  34 --  All user-handleable signals are masked at all times in all tasks/threads
  35 --  except possibly for the Interrupt_Manager task.
  36
  37 --  When a user task wants to have the effect of masking/unmasking an signal,
  38 --  it must call Block_Interrupt/Unblock_Interrupt, which will have the effect
  39 --  of unmasking/masking the signal in the Interrupt_Manager task. These
  40 --  comments do not apply to vectored hardware interrupts, which may be masked
  41 --  or unmasked using routined interfaced to the relevant embedded RTOS system
  42 --  calls.
  43
  44 --  Once we associate a Signal_Server_Task with an signal, the task never goes
  45 --  away, and we never remove the association. On the other hand, it is more
  46 --  convenient to terminate an associated Interrupt_Server_Task for a vectored
  47 --  hardware interrupt (since we use a binary semaphore for synchronization
  48 --  with the umbrella handler).
  49
  50 --  There is no more than one signal per Signal_Server_Task and no more than
  51 --  one Signal_Server_Task per signal. The same relation holds for hardware
  52 --  interrupts and Interrupt_Server_Task's at any given time. That is, only
  53 --  one non-terminated Interrupt_Server_Task exists for a give interrupt at
  54 --  any time.
  55
  56 --  Within this package, the lock L is used to protect the various status
  57 --  tables. If there is a Server_Task associated with a signal or interrupt, we
  58 --  use the per-task lock of the Server_Task instead so that we protect the
  59 --  status between Interrupt_Manager and Server_Task. Protection among service
  60 --  requests are ensured via user calls to the Interrupt_Manager entries.
  61
  62 --  This is reasonably generic version of this package, supporting vectored
  63 --  hardware interrupts using non-RTOS specific adapter routines which
  64 --  should easily implemented on any RTOS capable of supporting GNAT.
  65
  66 with Ada.Unchecked_Conversion;
  67 with Ada.Task_Identification;
  68
  69 with Interfaces.C; use Interfaces.C;
  70 with System.OS_Interface; use System.OS_Interface;
  71 with System.Interrupt_Management;
  72 with System.Task_Primitives.Operations;
  73 with System.Storage_Elements;
  74 with System.Tasking.Utilities;
  75
  76 with System.Tasking.Rendezvous;
  77 pragma Elaborate_All (System.Tasking.Rendezvous);
  78
  79 package body System.Interrupts is
  80
  81    use Tasking;
  82
  83    package POP renames System.Task_Primitives.Operations;
  84
  85    function To_Ada is new Ada.Unchecked_Conversion
  86      (System.Tasking.Task_Id, Ada.Task_Identification.Task_Id);
  87
  88    function To_System is new Ada.Unchecked_Conversion
  89      (Ada.Task_Identification.Task_Id, Task_Id);
  90
  91    -----------------
  92    -- Local Tasks --
  93    -----------------
  94
  95    --  WARNING: System.Tasking.Stages performs calls to this task with
  96    --  low-level constructs. Do not change this spec without synchronizing it.
  97
  98    task Interrupt_Manager is
  99       entry Detach_Interrupt_Entries (T : Task_Id);
 100
 101       entry Attach_Handler
 102         (New_Handler : Parameterless_Handler;
 103          Interrupt   : Interrupt_ID;
 104          Static      : Boolean;
 105          Restoration : Boolean := False);
 106
 107       entry Exchange_Handler
 108         (Old_Handler : out Parameterless_Handler;
 109          New_Handler : Parameterless_Handler;
 110          Interrupt   : Interrupt_ID;
 111          Static      : Boolean);
 112
 113       entry Detach_Handler
 114         (Interrupt : Interrupt_ID;
 115          Static    : Boolean);
 116
 117       entry Bind_Interrupt_To_Entry
 118         (T         : Task_Id;
 119          E         : Task_Entry_Index;
 120          Interrupt : Interrupt_ID);
 121
 122       pragma Interrupt_Priority (System.Interrupt_Priority'First);
 123    end Interrupt_Manager;
 124
 125    task type Interrupt_Server_Task
 126      (Interrupt : Interrupt_ID; Int_Sema : Binary_Semaphore_Id) is
 127       --  Server task for vectored hardware interrupt handling
 128       pragma Interrupt_Priority (System.Interrupt_Priority'First + 2);
 129    end Interrupt_Server_Task;
 130
 131    type Interrupt_Task_Access is access Interrupt_Server_Task;
 132
 133    -------------------------------
 134    -- Local Types and Variables --
 135    -------------------------------
 136
 137    type Entry_Assoc is record
 138       T : Task_Id;
 139       E : Task_Entry_Index;
 140    end record;
 141
 142    type Handler_Assoc is record
 143       H      : Parameterless_Handler;
 144       Static : Boolean;   --  Indicates static binding;
 145    end record;
 146
 147    User_Handler : array (Interrupt_ID) of Handler_Assoc :=
 148      (others => (null, Static => False));
 149    pragma Volatile_Components (User_Handler);
 150    --  Holds the protected procedure handler (if any) and its Static
 151    --  information  for each interrupt or signal. A handler is static
 152    --  iff it is specified through the pragma Attach_Handler.
 153
 154    User_Entry : array (Interrupt_ID) of Entry_Assoc :=
 155      (others => (T => Null_Task, E => Null_Task_Entry));
 156    pragma Volatile_Components (User_Entry);
 157    --  Holds the task and entry index (if any) for each interrupt / signal
 158
 159    --  Type and Head, Tail of the list containing Registered Interrupt
 160    --  Handlers. These definitions are used to register the handlers
 161    --  specified by the pragma Interrupt_Handler.
 162
 163    type Registered_Handler;
 164    type R_Link is access all Registered_Handler;
 165
 166    type Registered_Handler is record
 167       H    : System.Address := System.Null_Address;
 168       Next : R_Link := null;
 169    end record;
 170
 171    Registered_Handler_Head : R_Link := null;
 172    Registered_Handler_Tail : R_Link := null;
 173
 174    Server_ID : array (Interrupt_ID) of System.Tasking.Task_Id :=
 175      (others => System.Tasking.Null_Task);
 176    pragma Atomic_Components (Server_ID);
 177    --  Holds the Task_Id of the Server_Task for each interrupt / signal.
 178    --  Task_Id is needed to accomplish locking per interrupt base. Also
 179    --  is needed to determine whether to create a new Server_Task.
 180
 181    Semaphore_ID_Map : array
 182      (Interrupt_ID range 0 .. System.OS_Interface.Max_HW_Interrupt)
 183       of Binary_Semaphore_Id := (others => 0);
 184    --  Array of binary semaphores associated with vectored interrupts
 185    --  Note that the last bound should be Max_HW_Interrupt, but this will raise
 186    --  Storage_Error if Num_HW_Interrupts is null, so use an extra 4 bytes
 187    --  instead.
 188
 189    Interrupt_Access_Hold : Interrupt_Task_Access;
 190    --  Variable for allocating an Interrupt_Server_Task
 191
 192    Handler_Installed : array (HW_Interrupt) of Boolean := (others => False);
 193    --  True if Notify_Interrupt was connected to the interrupt.  Handlers
 194    --  can be connected but disconnection is not possible on VxWorks.
 195    --  Therefore we ensure Notify_Installed is connected at most once.
 196
 197    -----------------------
 198    -- Local Subprograms --
 199    -----------------------
 200
 201    procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID);
 202    --  Check if Id is a reserved interrupt, and if so raise Program_Error
 203    --  with an appropriate message, otherwise return.
 204
 205    procedure Finalize_Interrupt_Servers;
 206    --  Unbind the handlers for hardware interrupt server tasks at program
 207    --  termination.
 208
 209    function Is_Registered (Handler : Parameterless_Handler) return Boolean;
 210    --  See if Handler has been "pragma"ed using Interrupt_Handler.
 211    --  Always consider a null handler as registered.
 212
 213    procedure Notify_Interrupt (Param : System.Address);
 214    pragma Convention (C, Notify_Interrupt);
 215    --  Umbrella handler for vectored interrupts (not signals)
 216
 217    procedure Install_Umbrella_Handler
 218      (Interrupt : HW_Interrupt;
 219       Handler   : System.OS_Interface.Interrupt_Handler);
 220    --  Install the runtime umbrella handler for a vectored hardware
 221    --  interrupt
 222
 223    procedure Unimplemented (Feature : String);
 224    pragma No_Return (Unimplemented);
 225    --  Used to mark a call to an unimplemented function. Raises Program_Error
 226    --  with an appropriate message noting that Feature is unimplemented.
 227
 228    --------------------
 229    -- Attach_Handler --
 230    --------------------
 231
 232    --  Calling this procedure with New_Handler = null and Static = True
 233    --  means we want to detach the current handler regardless of the
 234    --  previous handler's binding status (i.e. do not care if it is a
 235    --  dynamic or static handler).
 236
 237    --  This option is needed so that during the finalization of a PO, we
 238    --  can detach handlers attached through pragma Attach_Handler.
 239
 240    procedure Attach_Handler
 241      (New_Handler : Parameterless_Handler;
 242       Interrupt   : Interrupt_ID;
 243       Static      : Boolean := False) is
 244    begin
 245       Check_Reserved_Interrupt (Interrupt);
 246       Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
 247    end Attach_Handler;
 248
 249    -----------------------------
 250    -- Bind_Interrupt_To_Entry --
 251    -----------------------------
 252
 253    --  This procedure raises a Program_Error if it tries to
 254    --  bind an interrupt to which an Entry or a Procedure is
 255    --  already bound.
 256
 257    procedure Bind_Interrupt_To_Entry
 258      (T       : Task_Id;
 259       E       : Task_Entry_Index;
 260       Int_Ref : System.Address)
 261    is
 262       Interrupt : constant Interrupt_ID :=
 263         Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
 264
 265    begin
 266       Check_Reserved_Interrupt (Interrupt);
 267       Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
 268    end Bind_Interrupt_To_Entry;
 269
 270    ---------------------
 271    -- Block_Interrupt --
 272    ---------------------
 273
 274    procedure Block_Interrupt (Interrupt : Interrupt_ID) is
 275    begin
 276       Unimplemented ("Block_Interrupt");
 277    end Block_Interrupt;
 278
 279    ------------------------------
 280    -- Check_Reserved_Interrupt --
 281    ------------------------------
 282
 283    procedure Check_Reserved_Interrupt (Interrupt : Interrupt_ID) is
 284    begin
 285       if Is_Reserved (Interrupt) then
 286          raise Program_Error with
 287            "Interrupt" & Interrupt_ID'Image (Interrupt) & " is reserved";
 288       else
 289          return;
 290       end if;
 291    end Check_Reserved_Interrupt;
 292
 293    ---------------------
 294    -- Current_Handler --
 295    ---------------------
 296
 297    function Current_Handler
 298      (Interrupt : Interrupt_ID) return Parameterless_Handler
 299    is
 300    begin
 301       Check_Reserved_Interrupt (Interrupt);
 302
 303       --  ??? Since Parameterless_Handler is not Atomic, the
 304       --  current implementation is wrong. We need a new service in
 305       --  Interrupt_Manager to ensure atomicity.
 306
 307       return User_Handler (Interrupt).H;
 308    end Current_Handler;
 309
 310    --------------------
 311    -- Detach_Handler --
 312    --------------------
 313
 314    --  Calling this procedure with Static = True means we want to Detach the
 315    --  current handler regardless of the previous handler's binding status
 316    --  (i.e. do not care if it is a dynamic or static handler).
 317
 318    --  This option is needed so that during the finalization of a PO, we can
 319    --  detach handlers attached through pragma Attach_Handler.
 320
 321    procedure Detach_Handler
 322      (Interrupt : Interrupt_ID;
 323       Static    : Boolean := False) is
 324    begin
 325       Check_Reserved_Interrupt (Interrupt);
 326       Interrupt_Manager.Detach_Handler (Interrupt, Static);
 327    end Detach_Handler;
 328
 329    ------------------------------
 330    -- Detach_Interrupt_Entries --
 331    ------------------------------
 332
 333    procedure Detach_Interrupt_Entries (T : Task_Id) is
 334    begin
 335       Interrupt_Manager.Detach_Interrupt_Entries (T);
 336    end Detach_Interrupt_Entries;
 337
 338    ----------------------
 339    -- Exchange_Handler --
 340    ----------------------
 341
 342    --  Calling this procedure with New_Handler = null and Static = True
 343    --  means we want to detach the current handler regardless of the
 344    --  previous handler's binding status (i.e. do not care if it is a
 345    --  dynamic or static handler).
 346
 347    --  This option is needed so that during the finalization of a PO, we
 348    --  can detach handlers attached through pragma Attach_Handler.
 349
 350    procedure Exchange_Handler
 351      (Old_Handler : out Parameterless_Handler;
 352       New_Handler : Parameterless_Handler;
 353       Interrupt   : Interrupt_ID;
 354       Static      : Boolean := False)
 355    is
 356    begin
 357       Check_Reserved_Interrupt (Interrupt);
 358       Interrupt_Manager.Exchange_Handler
 359         (Old_Handler, New_Handler, Interrupt, Static);
 360    end Exchange_Handler;
 361
 362    --------------
 363    -- Finalize --
 364    --------------
 365
 366    procedure Finalize (Object : in out Static_Interrupt_Protection) is
 367    begin
 368       --  ??? loop to be executed only when we're not doing library level
 369       --  finalization, since in this case all interrupt / signal tasks are
 370       --  gone.
 371
 372       if not Interrupt_Manager'Terminated then
 373          for N in reverse Object.Previous_Handlers'Range loop
 374             Interrupt_Manager.Attach_Handler
 375               (New_Handler => Object.Previous_Handlers (N).Handler,
 376                Interrupt   => Object.Previous_Handlers (N).Interrupt,
 377                Static      => Object.Previous_Handlers (N).Static,
 378                Restoration => True);
 379          end loop;
 380       end if;
 381
 382       Tasking.Protected_Objects.Entries.Finalize
 383         (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
 384    end Finalize;
 385
 386    --------------------------------
 387    -- Finalize_Interrupt_Servers --
 388    --------------------------------
 389
 390    --  Restore default handlers for interrupt servers
 391
 392    --  This is called by the Interrupt_Manager task when it receives the abort
 393    --  signal during program finalization.
 394
 395    procedure Finalize_Interrupt_Servers is
 396       HW_Interrupts : constant Boolean := HW_Interrupt'Last >= 0;
 397
 398    begin
 399       if HW_Interrupts then
 400          for Int in HW_Interrupt loop
 401             if Server_ID (Interrupt_ID (Int)) /= null
 402               and then
 403                 not Ada.Task_Identification.Is_Terminated
 404                  (To_Ada (Server_ID (Interrupt_ID (Int))))
 405             then
 406                Interrupt_Manager.Attach_Handler
 407                  (New_Handler => null,
 408                   Interrupt => Interrupt_ID (Int),
 409                   Static => True,
 410                   Restoration => True);
 411             end if;
 412          end loop;
 413       end if;
 414    end Finalize_Interrupt_Servers;
 415
 416    -------------------------------------
 417    -- Has_Interrupt_Or_Attach_Handler --
 418    -------------------------------------
 419
 420    function Has_Interrupt_Or_Attach_Handler
 421      (Object : access Dynamic_Interrupt_Protection)
 422       return   Boolean
 423    is
 424       pragma Unreferenced (Object);
 425    begin
 426       return True;
 427    end Has_Interrupt_Or_Attach_Handler;
 428
 429    function Has_Interrupt_Or_Attach_Handler
 430      (Object : access Static_Interrupt_Protection)
 431       return   Boolean
 432    is
 433       pragma Unreferenced (Object);
 434    begin
 435       return True;
 436    end Has_Interrupt_Or_Attach_Handler;
 437
 438    ----------------------
 439    -- Ignore_Interrupt --
 440    ----------------------
 441
 442    procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
 443    begin
 444       Unimplemented ("Ignore_Interrupt");
 445    end Ignore_Interrupt;
 446
 447    ----------------------
 448    -- Install_Handlers --
 449    ----------------------
 450
 451    procedure Install_Handlers
 452      (Object       : access Static_Interrupt_Protection;
 453       New_Handlers : New_Handler_Array)
 454    is
 455    begin
 456       for N in New_Handlers'Range loop
 457
 458          --  We need a lock around this ???
 459
 460          Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
 461          Object.Previous_Handlers (N).Static    := User_Handler
 462            (New_Handlers (N).Interrupt).Static;
 463
 464          --  We call Exchange_Handler and not directly Interrupt_Manager.
 465          --  Exchange_Handler so we get the Is_Reserved check.
 466
 467          Exchange_Handler
 468            (Old_Handler => Object.Previous_Handlers (N).Handler,
 469             New_Handler => New_Handlers (N).Handler,
 470             Interrupt   => New_Handlers (N).Interrupt,
 471             Static      => True);
 472       end loop;
 473    end Install_Handlers;
 474
 475    ---------------------------------
 476    -- Install_Restricted_Handlers --
 477    ---------------------------------
 478
 479    procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is
 480    begin
 481       for N in Handlers'Range loop
 482          Attach_Handler (Handlers (N).Handler, Handlers (N).Interrupt, True);
 483       end loop;
 484    end Install_Restricted_Handlers;
 485
 486    ------------------------------
 487    -- Install_Umbrella_Handler --
 488    ------------------------------
 489
 490    procedure Install_Umbrella_Handler
 491      (Interrupt : HW_Interrupt;
 492       Handler   : System.OS_Interface.Interrupt_Handler)
 493    is
 494       Vec : constant Interrupt_Vector :=
 495               Interrupt_Number_To_Vector (int (Interrupt));
 496
 497       Status : int;
 498
 499    begin
 500       --  Only install umbrella handler when no Ada handler has already been
 501       --  installed. Note that the interrupt number is passed as a parameter
 502       --  when an interrupt occurs, so the umbrella handler has a different
 503       --  wrapper generated by intConnect for each interrupt number.
 504
 505       if not Handler_Installed (Interrupt) then
 506          Status :=
 507             Interrupt_Connect (Vec, Handler, System.Address (Interrupt));
 508          pragma Assert (Status = 0);
 509
 510          Handler_Installed (Interrupt) := True;
 511       end if;
 512    end Install_Umbrella_Handler;
 513
 514    ----------------
 515    -- Is_Blocked --
 516    ----------------
 517
 518    function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
 519    begin
 520       Unimplemented ("Is_Blocked");
 521       return False;
 522    end Is_Blocked;
 523
 524    -----------------------
 525    -- Is_Entry_Attached --
 526    -----------------------
 527
 528    function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
 529    begin
 530       Check_Reserved_Interrupt (Interrupt);
 531       return User_Entry (Interrupt).T /= Null_Task;
 532    end Is_Entry_Attached;
 533
 534    -------------------------
 535    -- Is_Handler_Attached --
 536    -------------------------
 537
 538    function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
 539    begin
 540       Check_Reserved_Interrupt (Interrupt);
 541       return User_Handler (Interrupt).H /= null;
 542    end Is_Handler_Attached;
 543
 544    ----------------
 545    -- Is_Ignored --
 546    ----------------
 547
 548    function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
 549    begin
 550       Unimplemented ("Is_Ignored");
 551       return False;
 552    end Is_Ignored;
 553
 554    -------------------
 555    -- Is_Registered --
 556    -------------------
 557
 558    function Is_Registered (Handler : Parameterless_Handler) return Boolean is
 559       type Fat_Ptr is record
 560          Object_Addr  : System.Address;
 561          Handler_Addr : System.Address;
 562       end record;
 563
 564       function To_Fat_Ptr is new Ada.Unchecked_Conversion
 565         (Parameterless_Handler, Fat_Ptr);
 566
 567       Ptr : R_Link;
 568       Fat : Fat_Ptr;
 569
 570    begin
 571       if Handler = null then
 572          return True;
 573       end if;
 574
 575       Fat := To_Fat_Ptr (Handler);
 576
 577       Ptr := Registered_Handler_Head;
 578
 579       while Ptr /= null loop
 580          if Ptr.H = Fat.Handler_Addr then
 581             return True;
 582          end if;
 583
 584          Ptr := Ptr.Next;
 585       end loop;
 586
 587       return False;
 588    end Is_Registered;
 589
 590    -----------------
 591    -- Is_Reserved --
 592    -----------------
 593
 594    function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
 595       use System.Interrupt_Management;
 596    begin
 597       return Reserve (System.Interrupt_Management.Interrupt_ID (Interrupt));
 598    end Is_Reserved;
 599
 600    ----------------------
 601    -- Notify_Interrupt --
 602    ----------------------
 603
 604    --  Umbrella handler for vectored hardware interrupts (as opposed to
 605    --  signals and exceptions).  As opposed to the signal implementation,
 606    --  this handler is installed in the vector table when the first Ada
 607    --  handler is attached to the interrupt.  However because VxWorks don't
 608    --  support disconnecting handlers, this subprogram always test whether
 609    --  or not an Ada handler is effectively attached.
 610
 611    --  Otherwise, the handler that existed prior to program startup is
 612    --  in the vector table.  This ensures that handlers installed by
 613    --  the BSP are active unless explicitly replaced in the program text.
 614
 615    --  Each Interrupt_Server_Task has an associated binary semaphore
 616    --  on which it pends once it's been started.  This routine determines
 617    --  The appropriate semaphore and issues a semGive call, waking
 618    --  the server task.  When a handler is unbound,
 619    --  System.Interrupts.Unbind_Handler issues a Binary_Semaphore_Flush,
 620    --  and the server task deletes its semaphore and terminates.
 621
 622    procedure Notify_Interrupt (Param : System.Address) is
 623       Interrupt : constant Interrupt_ID := Interrupt_ID (Param);
 624
 625       Id : constant Binary_Semaphore_Id := Semaphore_ID_Map (Interrupt);
 626
 627       Status : int;
 628
 629    begin
 630       if Id /= 0 then
 631          Status := Binary_Semaphore_Release (Id);
 632          pragma Assert (Status = 0);
 633       end if;
 634    end Notify_Interrupt;
 635
 636    ---------------
 637    -- Reference --
 638    ---------------
 639
 640    function Reference (Interrupt : Interrupt_ID) return System.Address is
 641    begin
 642       Check_Reserved_Interrupt (Interrupt);
 643       return Storage_Elements.To_Address
 644         (Storage_Elements.Integer_Address (Interrupt));
 645    end Reference;
 646
 647    --------------------------------
 648    -- Register_Interrupt_Handler --
 649    --------------------------------
 650
 651    procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
 652       New_Node_Ptr : R_Link;
 653
 654    begin
 655       --  This routine registers a handler as usable for dynamic
 656       --  interrupt handler association. Routines attaching and detaching
 657       --  handlers dynamically should determine whether the handler is
 658       --  registered. Program_Error should be raised if it is not registered.
 659
 660       --  Pragma Interrupt_Handler can only appear in a library
 661       --  level PO definition and instantiation. Therefore, we do not need
 662       --  to implement an unregister operation. Nor do we need to
 663       --  protect the queue structure with a lock.
 664
 665       pragma Assert (Handler_Addr /= System.Null_Address);
 666
 667       New_Node_Ptr := new Registered_Handler;
 668       New_Node_Ptr.H := Handler_Addr;
 669
 670       if Registered_Handler_Head = null then
 671          Registered_Handler_Head := New_Node_Ptr;
 672          Registered_Handler_Tail := New_Node_Ptr;
 673
 674       else
 675          Registered_Handler_Tail.Next := New_Node_Ptr;
 676          Registered_Handler_Tail := New_Node_Ptr;
 677       end if;
 678    end Register_Interrupt_Handler;
 679
 680    -----------------------
 681    -- Unblock_Interrupt --
 682    -----------------------
 683
 684    procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
 685    begin
 686       Unimplemented ("Unblock_Interrupt");
 687    end Unblock_Interrupt;
 688
 689    ------------------
 690    -- Unblocked_By --
 691    ------------------
 692
 693    function Unblocked_By
 694      (Interrupt : Interrupt_ID) return System.Tasking.Task_Id
 695    is
 696    begin
 697       Unimplemented ("Unblocked_By");
 698       return Null_Task;
 699    end Unblocked_By;
 700
 701    ------------------------
 702    -- Unignore_Interrupt --
 703    ------------------------
 704
 705    procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
 706    begin
 707       Unimplemented ("Unignore_Interrupt");
 708    end Unignore_Interrupt;
 709
 710    -------------------
 711    -- Unimplemented --
 712    -------------------
 713
 714    procedure Unimplemented (Feature : String) is
 715    begin
 716       raise Program_Error with Feature & " not implemented on VxWorks";
 717    end Unimplemented;
 718
 719    -----------------------
 720    -- Interrupt_Manager --
 721    -----------------------
 722
 723    task body Interrupt_Manager is
 724
 725       --------------------
 726       -- Local Routines --
 727       --------------------
 728
 729       procedure Bind_Handler (Interrupt : Interrupt_ID);
 730       --  This procedure does not do anything if a signal is blocked.
 731       --  Otherwise, we have to interrupt Server_Task for status change through
 732       --  a wakeup signal.
 733
 734       procedure Unbind_Handler (Interrupt : Interrupt_ID);
 735       --  This procedure does not do anything if a signal is blocked.
 736       --  Otherwise, we have to interrupt Server_Task for status change
 737       --  through an abort signal.
 738
 739       procedure Unprotected_Exchange_Handler
 740         (Old_Handler : out Parameterless_Handler;
 741          New_Handler : Parameterless_Handler;
 742          Interrupt   : Interrupt_ID;
 743          Static      : Boolean;
 744          Restoration : Boolean := False);
 745
 746       procedure Unprotected_Detach_Handler
 747         (Interrupt : Interrupt_ID;
 748          Static    : Boolean);
 749
 750       ------------------
 751       -- Bind_Handler --
 752       ------------------
 753
 754       procedure Bind_Handler (Interrupt : Interrupt_ID) is
 755       begin
 756          Install_Umbrella_Handler
 757            (HW_Interrupt (Interrupt), Notify_Interrupt'Access);
 758       end Bind_Handler;
 759
 760       --------------------
 761       -- Unbind_Handler --
 762       --------------------
 763
 764       procedure Unbind_Handler (Interrupt : Interrupt_ID) is
 765          Status : int;
 766       begin
 767
 768          --  Flush server task off semaphore, allowing it to terminate
 769
 770          Status := Binary_Semaphore_Flush (Semaphore_ID_Map (Interrupt));
 771          pragma Assert (Status = 0);
 772       end Unbind_Handler;
 773
 774       --------------------------------
 775       -- Unprotected_Detach_Handler --
 776       --------------------------------
 777
 778       procedure Unprotected_Detach_Handler
 779         (Interrupt : Interrupt_ID;
 780          Static    : Boolean)
 781       is
 782          Old_Handler : Parameterless_Handler;
 783       begin
 784          if User_Entry (Interrupt).T /= Null_Task then
 785             --  If an interrupt entry is installed raise
 786             --  Program_Error. (propagate it to the caller).
 787
 788             raise Program_Error with
 789               "An interrupt entry is already installed";
 790          end if;
 791
 792          --  Note : Static = True will pass the following check. This is the
 793          --  case when we want to detach a handler regardless of the static
 794          --  status of the Current_Handler.
 795
 796          if not Static and then User_Handler (Interrupt).Static then
 797
 798             --  Trying to detach a static Interrupt Handler. raise
 799             --  Program_Error.
 800
 801             raise Program_Error with
 802               "Trying to detach a static Interrupt Handler";
 803          end if;
 804
 805          Old_Handler := User_Handler (Interrupt).H;
 806
 807          --  The new handler
 808
 809          User_Handler (Interrupt).H := null;
 810          User_Handler (Interrupt).Static := False;
 811
 812          if Old_Handler /= null then
 813             Unbind_Handler (Interrupt);
 814          end if;
 815       end Unprotected_Detach_Handler;
 816
 817       ----------------------------------
 818       -- Unprotected_Exchange_Handler --
 819       ----------------------------------
 820
 821       procedure Unprotected_Exchange_Handler
 822         (Old_Handler : out Parameterless_Handler;
 823          New_Handler : Parameterless_Handler;
 824          Interrupt   : Interrupt_ID;
 825          Static      : Boolean;
 826          Restoration : Boolean := False)
 827       is
 828       begin
 829          if User_Entry (Interrupt).T /= Null_Task then
 830
 831             --  If an interrupt entry is already installed, raise
 832             --  Program_Error. (propagate it to the caller).
 833
 834             raise Program_Error with "An interrupt is already installed";
 835          end if;
 836
 837          --  Note : A null handler with Static = True will
 838          --  pass the following check. This is the case when we want to
 839          --  detach a handler regardless of the Static status
 840          --  of Current_Handler.
 841          --  We don't check anything if Restoration is True, since we
 842          --  may be detaching a static handler to restore a dynamic one.
 843
 844          if not Restoration and then not Static
 845            and then (User_Handler (Interrupt).Static
 846
 847             --  Trying to overwrite a static Interrupt Handler with a
 848             --  dynamic Handler
 849
 850             --  The new handler is not specified as an
 851             --  Interrupt Handler by a pragma.
 852
 853            or else not Is_Registered (New_Handler))
 854          then
 855             raise Program_Error with
 856                "Trying to overwrite a static Interrupt Handler with a " &
 857                "dynamic Handler";
 858          end if;
 859
 860          --  Save the old handler
 861
 862          Old_Handler := User_Handler (Interrupt).H;
 863
 864          --  The new handler
 865
 866          User_Handler (Interrupt).H := New_Handler;
 867
 868          if New_Handler = null then
 869
 870             --  The null handler means we are detaching the handler
 871
 872             User_Handler (Interrupt).Static := False;
 873
 874          else
 875             User_Handler (Interrupt).Static := Static;
 876          end if;
 877
 878          --  Invoke a corresponding Server_Task if not yet created.
 879          --  Place Task_Id info in Server_ID array.
 880
 881          if New_Handler /= null
 882            and then
 883             (Server_ID (Interrupt) = Null_Task
 884               or else
 885                 Ada.Task_Identification.Is_Terminated
 886                   (To_Ada (Server_ID (Interrupt))))
 887          then
 888             Interrupt_Access_Hold :=
 889               new Interrupt_Server_Task (Interrupt, Binary_Semaphore_Create);
 890             Server_ID (Interrupt) :=
 891               To_System (Interrupt_Access_Hold.all'Identity);
 892          end if;
 893
 894          if (New_Handler = null) and then Old_Handler /= null then
 895
 896             --  Restore default handler
 897
 898             Unbind_Handler (Interrupt);
 899
 900          elsif Old_Handler = null then
 901
 902             --  Save default handler
 903
 904             Bind_Handler (Interrupt);
 905          end if;
 906       end Unprotected_Exchange_Handler;
 907
 908       --  Start of processing for Interrupt_Manager
 909
 910    begin
 911       --  By making this task independent of any master, when the process
 912       --  goes away, the Interrupt_Manager will terminate gracefully.
 913
 914       System.Tasking.Utilities.Make_Independent;
 915
 916       loop
 917          --  A block is needed to absorb Program_Error exception
 918
 919          declare
 920             Old_Handler : Parameterless_Handler;
 921
 922          begin
 923             select
 924                accept Attach_Handler
 925                  (New_Handler : Parameterless_Handler;
 926                   Interrupt   : Interrupt_ID;
 927                   Static      : Boolean;
 928                   Restoration : Boolean := False)
 929                do
 930                   Unprotected_Exchange_Handler
 931                     (Old_Handler, New_Handler, Interrupt, Static, Restoration);
 932                end Attach_Handler;
 933
 934             or
 935                accept Exchange_Handler
 936                  (Old_Handler : out Parameterless_Handler;
 937                   New_Handler : Parameterless_Handler;
 938                   Interrupt   : Interrupt_ID;
 939                   Static      : Boolean)
 940                do
 941                   Unprotected_Exchange_Handler
 942                     (Old_Handler, New_Handler, Interrupt, Static);
 943                end Exchange_Handler;
 944
 945             or
 946                accept Detach_Handler
 947                   (Interrupt   : Interrupt_ID;
 948                    Static      : Boolean)
 949                do
 950                   Unprotected_Detach_Handler (Interrupt, Static);
 951                end Detach_Handler;
 952             or
 953                accept Bind_Interrupt_To_Entry
 954                  (T       : Task_Id;
 955                   E       : Task_Entry_Index;
 956                   Interrupt : Interrupt_ID)
 957                do
 958                   --  If there is a binding already (either a procedure or an
 959                   --  entry), raise Program_Error (propagate it to the caller).
 960
 961                   if User_Handler (Interrupt).H /= null
 962                     or else User_Entry (Interrupt).T /= Null_Task
 963                   then
 964                      raise Program_Error with
 965                        "A binding for this interrupt is already present";
 966                   end if;
 967
 968                   User_Entry (Interrupt) := Entry_Assoc'(T => T, E => E);
 969
 970                   --  Indicate the attachment of interrupt entry in the ATCB.
 971                   --  This is needed so when an interrupt entry task terminates
 972                   --  the binding can be cleaned. The call to unbinding must be
 973                   --  make by the task before it terminates.
 974
 975                   T.Interrupt_Entry := True;
 976
 977                   --  Invoke a corresponding Server_Task if not yet created.
 978                   --  Place Task_Id info in Server_ID array.
 979
 980                   if Server_ID (Interrupt) = Null_Task
 981                     or else
 982                       Ada.Task_Identification.Is_Terminated
 983                         (To_Ada (Server_ID (Interrupt)))
 984                   then
 985                      Interrupt_Access_Hold := new Interrupt_Server_Task
 986                        (Interrupt, Binary_Semaphore_Create);
 987                      Server_ID (Interrupt) :=
 988                        To_System (Interrupt_Access_Hold.all'Identity);
 989                   end if;
 990
 991                   Bind_Handler (Interrupt);
 992                end Bind_Interrupt_To_Entry;
 993
 994             or
 995                accept Detach_Interrupt_Entries (T : Task_Id) do
 996                   for Int in Interrupt_ID'Range loop
 997                      if not Is_Reserved (Int) then
 998                         if User_Entry (Int).T = T then
 999                            User_Entry (Int) :=
1000                              Entry_Assoc'
1001                                (T => Null_Task, E => Null_Task_Entry);
1002                            Unbind_Handler (Int);
1003                         end if;
1004                      end if;
1005                   end loop;
1006
1007                   --  Indicate in ATCB that no interrupt entries are attached
1008
1009                   T.Interrupt_Entry := False;
1010                end Detach_Interrupt_Entries;
1011             end select;
1012
1013          exception
1014             --  If there is a Program_Error we just want to propagate it to
1015             --  the caller and do not want to stop this task.
1016
1017             when Program_Error =>
1018                null;
1019
1020             when others =>
1021                pragma Assert (False);
1022                null;
1023          end;
1024       end loop;
1025
1026    exception
1027       when Standard'Abort_Signal =>
1028          --  Flush interrupt server semaphores, so they can terminate
1029          Finalize_Interrupt_Servers;
1030          raise;
1031    end Interrupt_Manager;
1032
1033    ---------------------------
1034    -- Interrupt_Server_Task --
1035    ---------------------------
1036
1037    --  Server task for vectored hardware interrupt handling
1038
1039    task body Interrupt_Server_Task is
1040       Self_Id         : constant Task_Id := Self;
1041       Tmp_Handler     : Parameterless_Handler;
1042       Tmp_ID          : Task_Id;
1043       Tmp_Entry_Index : Task_Entry_Index;
1044       Status          : int;
1045
1046    begin
1047       System.Tasking.Utilities.Make_Independent;
1048       Semaphore_ID_Map (Interrupt) := Int_Sema;
1049
1050       loop
1051          --  Pend on semaphore that will be triggered by the
1052          --  umbrella handler when the associated interrupt comes in
1053
1054          Status := Binary_Semaphore_Obtain (Int_Sema);
1055          pragma Assert (Status = 0);
1056
1057          if User_Handler (Interrupt).H /= null then
1058
1059             --  Protected procedure handler
1060
1061             Tmp_Handler := User_Handler (Interrupt).H;
1062             Tmp_Handler.all;
1063
1064          elsif User_Entry (Interrupt).T /= Null_Task then
1065
1066             --  Interrupt entry handler
1067
1068             Tmp_ID := User_Entry (Interrupt).T;
1069             Tmp_Entry_Index := User_Entry (Interrupt).E;
1070             System.Tasking.Rendezvous.Call_Simple
1071               (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
1072
1073          else
1074             --  Semaphore has been flushed by an unbind operation in
1075             --  the Interrupt_Manager. Terminate the server task.
1076
1077             --  Wait for the Interrupt_Manager to complete its work
1078
1079             POP.Write_Lock (Self_Id);
1080
1081             --  Unassociate the interrupt handler
1082
1083             Semaphore_ID_Map (Interrupt) := 0;
1084
1085             --  Delete the associated semaphore
1086
1087             Status := Binary_Semaphore_Delete (Int_Sema);
1088
1089             pragma Assert (Status = 0);
1090
1091             --  Set status for the Interrupt_Manager
1092
1093             Server_ID (Interrupt) := Null_Task;
1094             POP.Unlock (Self_Id);
1095
1096             exit;
1097          end if;
1098       end loop;
1099    end Interrupt_Server_Task;
1100
1101 begin
1102    --  Get Interrupt_Manager's ID so that Abort_Interrupt can be sent
1103
1104    Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
1105 end System.Interrupts;