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