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