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