gcc/ada/s-interr.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 --                             $Revision: 1.1 $
  10 --                                                                          --
  11 --          Copyright (C) 1991-2001 Free Software Foundation, Inc.          --
  12 --                                                                          --
  13 -- GNARL is free software; you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion. GNARL is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNARL; see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNARL was developed by the GNARL team at Florida State University. It is --
  32 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  33 -- State University (http://www.gnat.com).                                  --
  34 --                                                                          --
  35 ------------------------------------------------------------------------------
  36
  37 --  Invariants:
  38
  39 --  All user-handleable interrupts are masked at all times in all
  40 --  tasks/threads except possibly for the Interrupt_Manager task.
  41
  42 --  When a user task wants to have the effect of masking/unmasking an
  43 --  interrupt, it must call Block_Interrupt/Unblock_Interrupt, which
  44 --  will have the effect of unmasking/masking the interrupt in the
  45 --  Interrupt_Manager task.
  46
  47 --  Note : Direct calls to sigaction, sigprocmask, pthread_sigsetmask or any
  48 --  other low-level interface that changes the interrupt action or
  49 --  interrupt mask needs a careful thought.
  50 --  One may acheive the effect of system calls first masking RTS blocked
  51 --  (by calling Block_Interrupt) for the interrupt under consideration.
  52 --  This will make all the tasks in RTS blocked for the Interrupt.
  53
  54 --  Once we associate a Server_Task with an interrupt, the task never
  55 --  goes away, and we never remove the association.
  56
  57 --  There is no more than one interrupt per Server_Task and no more than
  58 --  one Server_Task per interrupt.
  59
  60 --  Within this package, the lock L is used to protect the various status
  61 --  tables. If there is a Server_Task associated with an interrupt, we use
  62 --  the per-task lock of the Server_Task instead so that we protect the
  63 --  status between Interrupt_Manager and Server_Task. Protection among
  64 --  service requests are done using User Request to Interrupt_Manager
  65 --  rendezvous.
  66
  67 with Ada.Task_Identification;
  68 --  used for Task_ID type
  69
  70 with Ada.Exceptions;
  71 --  used for Raise_Exception
  72
  73 with System.Task_Primitives;
  74 --  used for RTS_Lock
  75 --           Self
  76
  77 with System.Interrupt_Management;
  78 --  used for Reserve
  79 --           Interrupt_ID
  80 --           Interrupt_Mask
  81 --           Abort_Task_Interrupt
  82
  83 with System.Interrupt_Management.Operations;
  84 --  used for Thread_Block_Interrupt
  85 --           Thread_Unblock_Interrupt
  86 --           Install_Default_Action
  87 --           Install_Ignore_Action
  88 --           Copy_Interrupt_Mask
  89 --           Set_Interrupt_Mask
  90 --           Empty_Interrupt_Mask
  91 --           Fill_Interrupt_Mask
  92 --           Add_To_Interrupt_Mask
  93 --           Delete_From_Interrupt_Mask
  94 --           Interrupt_Wait
  95 --           Interrupt_Self_Process
  96 --           Get_Interrupt_Mask
  97 --           Set_Interrupt_Mask
  98 --           IS_Member
  99 --           Environment_Mask
 100 --           All_Tasks_Mask
 101 pragma Elaborate_All (System.Interrupt_Management.Operations);
 102
 103 with System.Error_Reporting;
 104 --  used for Shutdown
 105
 106 with System.Task_Primitives.Operations;
 107 --  used for Write_Lock
 108 --           Unlock
 109 --           Abort
 110 --           Wakeup_Task
 111 --           Sleep
 112 --           Initialize_Lock
 113
 114 with System.Task_Primitives.Interrupt_Operations;
 115 --  used for Set_Interrupt_ID
 116
 117 with System.Storage_Elements;
 118 --  used for To_Address
 119 --           To_Integer
 120 --           Integer_Address
 121
 122 with System.Tasking;
 123 --  used for Task_ID
 124 --           Task_Entry_Index
 125 --           Null_Task
 126 --           Self
 127 --           Interrupt_Manager_ID
 128
 129 with System.Tasking.Utilities;
 130 --  used for Make_Independent
 131
 132 with System.Tasking.Rendezvous;
 133 --  used for Call_Simple
 134 pragma Elaborate_All (System.Tasking.Rendezvous);
 135
 136 with System.Tasking.Initialization;
 137 --  used for Defer_Abort
 138 --           Undefer_Abort
 139
 140 with Unchecked_Conversion;
 141
 142 package body System.Interrupts is
 143
 144    use Tasking;
 145    use System.Error_Reporting;
 146    use Ada.Exceptions;
 147
 148    package PRI renames System.Task_Primitives;
 149    package POP renames System.Task_Primitives.Operations;
 150    package PIO renames System.Task_Primitives.Interrupt_Operations;
 151    package IMNG renames System.Interrupt_Management;
 152    package IMOP renames System.Interrupt_Management.Operations;
 153
 154    function To_System is new Unchecked_Conversion
 155      (Ada.Task_Identification.Task_Id, Task_ID);
 156
 157    -----------------
 158    -- Local Tasks --
 159    -----------------
 160
 161    --  WARNING: System.Tasking.Utilities performs calls to this task
 162    --  with low-level constructs. Do not change this spec without synchro-
 163    --  nizing it.
 164
 165    task Interrupt_Manager is
 166       entry Initialize (Mask : IMNG.Interrupt_Mask);
 167
 168       entry Attach_Handler
 169         (New_Handler : in Parameterless_Handler;
 170          Interrupt   : in Interrupt_ID;
 171          Static      : in Boolean;
 172          Restoration : in Boolean := False);
 173
 174       entry Exchange_Handler
 175         (Old_Handler : out Parameterless_Handler;
 176          New_Handler : in Parameterless_Handler;
 177          Interrupt   : in Interrupt_ID;
 178          Static      : in Boolean);
 179
 180       entry Detach_Handler
 181         (Interrupt   : in Interrupt_ID;
 182          Static      : in Boolean);
 183
 184       entry Bind_Interrupt_To_Entry
 185         (T         : Task_ID;
 186          E         : Task_Entry_Index;
 187          Interrupt : Interrupt_ID);
 188
 189       entry Detach_Interrupt_Entries (T : Task_ID);
 190
 191       entry Block_Interrupt (Interrupt : Interrupt_ID);
 192
 193       entry Unblock_Interrupt (Interrupt : Interrupt_ID);
 194
 195       entry Ignore_Interrupt (Interrupt : Interrupt_ID);
 196
 197       entry Unignore_Interrupt (Interrupt : Interrupt_ID);
 198
 199       pragma Interrupt_Priority (System.Interrupt_Priority'Last);
 200    end Interrupt_Manager;
 201
 202    task type Server_Task (Interrupt : Interrupt_ID) is
 203       pragma Priority (System.Interrupt_Priority'Last);
 204    end Server_Task;
 205
 206    type Server_Task_Access is access Server_Task;
 207
 208    --------------------------------
 209    --  Local Types and Variables --
 210    --------------------------------
 211
 212    type Entry_Assoc is record
 213       T : Task_ID;
 214       E : Task_Entry_Index;
 215    end record;
 216
 217    type Handler_Assoc is record
 218       H      : Parameterless_Handler;
 219       Static : Boolean;   --  Indicates static binding;
 220    end record;
 221
 222    User_Handler : array (Interrupt_ID'Range) of Handler_Assoc :=
 223                     (others => (null, Static => False));
 224    pragma Volatile_Components (User_Handler);
 225    --  Holds the protected procedure handler (if any) and its Static
 226    --  information  for each interrupt. A handler is a Static one if
 227    --  it is specified through the pragma Attach_Handler.
 228    --  Attach_Handler. Otherwise, not static)
 229
 230    User_Entry : array (Interrupt_ID'Range) of Entry_Assoc :=
 231                   (others => (T => Null_Task, E => Null_Task_Entry));
 232    pragma Volatile_Components (User_Entry);
 233    --  Holds the task and entry index (if any) for each interrupt
 234
 235    Blocked : array (Interrupt_ID'Range) of Boolean := (others => False);
 236    pragma Volatile_Components (Blocked);
 237    --  True iff the corresponding interrupt is blocked in the process level
 238
 239    Ignored : array (Interrupt_ID'Range) of Boolean := (others => False);
 240    pragma Volatile_Components (Ignored);
 241    --  True iff the corresponding interrupt is blocked in the process level
 242
 243    Last_Unblocker :
 244      array (Interrupt_ID'Range) of Task_ID := (others => Null_Task);
 245    pragma Volatile_Components (Last_Unblocker);
 246    --  Holds the ID of the last Task which Unblocked this Interrupt.
 247    --  It contains Null_Task if no tasks have ever requested the
 248    --  Unblocking operation or the Interrupt is currently Blocked.
 249
 250    Server_ID : array (Interrupt_ID'Range) of Task_ID :=
 251                  (others => Null_Task);
 252    pragma Atomic_Components (Server_ID);
 253    --  Holds the Task_ID of the Server_Task for each interrupt.
 254    --  Task_ID is needed to accomplish locking per Interrupt base. Also
 255    --  is needed to decide whether to create a new Server_Task.
 256
 257    --  Type and Head, Tail of the list containing Registered Interrupt
 258    --  Handlers. These definitions are used to register the handlers
 259    --  specified by the pragma Interrupt_Handler.
 260
 261    type Registered_Handler;
 262    type R_Link is access all Registered_Handler;
 263
 264    type Registered_Handler is record
 265       H :    System.Address := System.Null_Address;
 266       Next : R_Link := null;
 267    end record;
 268
 269    Registered_Handler_Head : R_Link := null;
 270    Registered_Handler_Tail : R_Link := null;
 271
 272    Access_Hold : Server_Task_Access;
 273    --  variable used to allocate Server_Task using "new".
 274
 275    L : aliased PRI.RTS_Lock;
 276    --  L protects contents in tables above corresponding to interrupts
 277    --  for which Server_ID (T) = null.
 278    --
 279    --  If Server_ID (T) /= null then protection is via
 280    --  per-task (TCB) lock of Server_ID (T).
 281    --
 282    --  For deadlock prevention, L should not be locked after
 283    --  any other lock is held, hence we use PO_Level which is the highest
 284    --  lock level for error checking.
 285
 286    Task_Lock : array (Interrupt_ID'Range) of Boolean := (others => False);
 287    --  Boolean flags to give matching Locking and Unlocking. See the comments
 288    --  in Lock_Interrupt.
 289
 290    -----------------------
 291    -- Local Subprograms --
 292    -----------------------
 293
 294    procedure Lock_Interrupt
 295      (Self_ID   : Task_ID;
 296       Interrupt : Interrupt_ID);
 297    --  protect the tables using L or per-task lock. Set the Boolean
 298    --  value Task_Lock if the lock is made using per-task lock.
 299    --  This information is needed so that Unlock_Interrupt
 300    --  performs unlocking on the same lock. The situation we are preventing
 301    --  is, for example, when Attach_Handler is called for the first time
 302    --  we lock L and create an Server_Task. For a matching unlocking, if we
 303    --  rely on the fact that there is a Server_Task, we will unlock the
 304    --  per-task lock.
 305
 306    procedure Unlock_Interrupt
 307      (Self_ID   : Task_ID;
 308       Interrupt : Interrupt_ID);
 309
 310    function Is_Registered (Handler : Parameterless_Handler) return Boolean;
 311    --  ??? spec needs comments
 312
 313    --------------------
 314    -- Attach_Handler --
 315    --------------------
 316
 317    --  Calling this procedure with New_Handler = null and Static = True
 318    --  means we want to detach the current handler regardless of the
 319    --  previous handler's binding status (ie. do not care if it is a
 320    --  dynamic or static handler).
 321
 322    --  This option is needed so that during the finalization of a PO, we
 323    --  can detach handlers attached through pragma Attach_Handler.
 324
 325    procedure Attach_Handler
 326      (New_Handler : in Parameterless_Handler;
 327       Interrupt   : in Interrupt_ID;
 328       Static      : in Boolean := False)
 329    is
 330    begin
 331       if Is_Reserved (Interrupt) then
 332          Raise_Exception (Program_Error'Identity, "Interrupt" &
 333            Interrupt_ID'Image (Interrupt) & " is reserved");
 334       end if;
 335
 336       Interrupt_Manager.Attach_Handler (New_Handler, Interrupt, Static);
 337
 338    end Attach_Handler;
 339
 340    -----------------------------
 341    -- Bind_Interrupt_To_Entry --
 342    -----------------------------
 343
 344    --  This procedure raises a Program_Error if it tries to
 345    --  bind an interrupt to which an Entry or a Procedure is
 346    --  already bound.
 347
 348    procedure Bind_Interrupt_To_Entry
 349      (T       : Task_ID;
 350       E       : Task_Entry_Index;
 351       Int_Ref : System.Address)
 352    is
 353       Interrupt   : constant Interrupt_ID :=
 354         Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
 355
 356    begin
 357       if Is_Reserved (Interrupt) then
 358          Raise_Exception (Program_Error'Identity, "Interrupt" &
 359            Interrupt_ID'Image (Interrupt) & " is reserved");
 360       end if;
 361
 362       Interrupt_Manager.Bind_Interrupt_To_Entry (T, E, Interrupt);
 363
 364    end Bind_Interrupt_To_Entry;
 365
 366    ---------------------
 367    -- Block_Interrupt --
 368    ---------------------
 369
 370    procedure Block_Interrupt (Interrupt : Interrupt_ID) is
 371    begin
 372       if Is_Reserved (Interrupt) then
 373          Raise_Exception (Program_Error'Identity, "Interrupt" &
 374            Interrupt_ID'Image (Interrupt) & " is reserved");
 375       end if;
 376
 377       Interrupt_Manager.Block_Interrupt (Interrupt);
 378    end Block_Interrupt;
 379
 380    ---------------------
 381    -- Current_Handler --
 382    ---------------------
 383
 384    function Current_Handler
 385      (Interrupt : Interrupt_ID)
 386       return      Parameterless_Handler
 387    is
 388    begin
 389       if Is_Reserved (Interrupt) then
 390          Raise_Exception (Program_Error'Identity, "Interrupt" &
 391            Interrupt_ID'Image (Interrupt) & " is reserved");
 392       end if;
 393
 394       --  ??? Since Parameterless_Handler is not Atomic, the
 395       --  current implementation is wrong. We need a new service in
 396       --  Interrupt_Manager to ensure atomicity.
 397
 398       return User_Handler (Interrupt).H;
 399    end Current_Handler;
 400
 401    --------------------
 402    -- Detach_Handler --
 403    --------------------
 404
 405    --  Calling this procedure with Static = True means we want to Detach the
 406    --  current handler regardless of the previous handler's binding status
 407    --  (i.e. do not care if it is a dynamic or static handler).
 408
 409    --  This option is needed so that during the finalization of a PO, we can
 410    --  detach handlers attached through pragma Attach_Handler.
 411
 412    procedure Detach_Handler
 413      (Interrupt : in Interrupt_ID;
 414       Static    : in Boolean := False)
 415    is
 416    begin
 417       if Is_Reserved (Interrupt) then
 418          Raise_Exception (Program_Error'Identity, "Interrupt" &
 419            Interrupt_ID'Image (Interrupt) & " is reserved");
 420       end if;
 421
 422       Interrupt_Manager.Detach_Handler (Interrupt, Static);
 423
 424    end Detach_Handler;
 425
 426    ------------------------------
 427    -- Detach_Interrupt_Entries --
 428    ------------------------------
 429
 430    procedure Detach_Interrupt_Entries (T : Task_ID) is
 431    begin
 432       Interrupt_Manager.Detach_Interrupt_Entries (T);
 433    end Detach_Interrupt_Entries;
 434
 435    ----------------------
 436    -- Exchange_Handler --
 437    ----------------------
 438
 439    --  Calling this procedure with New_Handler = null and Static = True
 440    --  means we want to detach the current handler regardless of the
 441    --  previous handler's binding status (ie. do not care if it is a
 442    --  dynamic or static handler).
 443
 444    --  This option is needed so that during the finalization of a PO, we
 445    --  can detach handlers attached through pragma Attach_Handler.
 446
 447    procedure Exchange_Handler
 448      (Old_Handler : out Parameterless_Handler;
 449       New_Handler : in Parameterless_Handler;
 450       Interrupt   : in Interrupt_ID;
 451       Static      : in Boolean := False)
 452    is
 453    begin
 454       if Is_Reserved (Interrupt) then
 455          Raise_Exception (Program_Error'Identity, "Interrupt" &
 456            Interrupt_ID'Image (Interrupt) & " is reserved");
 457       end if;
 458
 459       Interrupt_Manager.Exchange_Handler
 460         (Old_Handler, New_Handler, Interrupt, Static);
 461
 462    end Exchange_Handler;
 463
 464    ----------------
 465    --  Finalize  --
 466    ----------------
 467
 468    procedure Finalize (Object : in out Static_Interrupt_Protection) is
 469    begin
 470       --  ??? loop to be executed only when we're not doing library level
 471       --  finalization, since in this case all interrupt tasks are gone.
 472       if not Interrupt_Manager'Terminated then
 473          for N in reverse Object.Previous_Handlers'Range loop
 474             Interrupt_Manager.Attach_Handler
 475               (New_Handler => Object.Previous_Handlers (N).Handler,
 476                Interrupt   => Object.Previous_Handlers (N).Interrupt,
 477                Static      => Object.Previous_Handlers (N).Static,
 478                Restoration => True);
 479          end loop;
 480       end if;
 481
 482       Tasking.Protected_Objects.Entries.Finalize
 483         (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
 484    end Finalize;
 485
 486    -------------------------------------
 487    -- Has_Interrupt_Or_Attach_Handler --
 488    -------------------------------------
 489
 490    function Has_Interrupt_Or_Attach_Handler
 491      (Object : access Dynamic_Interrupt_Protection) return Boolean is
 492    begin
 493       return True;
 494    end Has_Interrupt_Or_Attach_Handler;
 495
 496    function Has_Interrupt_Or_Attach_Handler
 497      (Object : access Static_Interrupt_Protection)
 498       return   Boolean
 499    is
 500    begin
 501       return True;
 502    end Has_Interrupt_Or_Attach_Handler;
 503
 504    ----------------------
 505    -- Ignore_Interrupt --
 506    ----------------------
 507
 508    procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
 509    begin
 510       if Is_Reserved (Interrupt) then
 511          Raise_Exception (Program_Error'Identity, "Interrupt" &
 512            Interrupt_ID'Image (Interrupt) & " is reserved");
 513       end if;
 514
 515       Interrupt_Manager.Ignore_Interrupt (Interrupt);
 516    end Ignore_Interrupt;
 517
 518    ----------------------
 519    -- Install_Handlers --
 520    ----------------------
 521
 522    procedure Install_Handlers
 523      (Object       : access Static_Interrupt_Protection;
 524       New_Handlers : in New_Handler_Array)
 525    is
 526    begin
 527       for N in New_Handlers'Range loop
 528
 529          --  We need a lock around this ???
 530
 531          Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
 532          Object.Previous_Handlers (N).Static    := User_Handler
 533            (New_Handlers (N).Interrupt).Static;
 534
 535          --  We call Exchange_Handler and not directly Interrupt_Manager.
 536          --  Exchange_Handler so we get the Is_Reserved check.
 537
 538          Exchange_Handler
 539            (Old_Handler => Object.Previous_Handlers (N).Handler,
 540             New_Handler => New_Handlers (N).Handler,
 541             Interrupt   => New_Handlers (N).Interrupt,
 542             Static      => True);
 543       end loop;
 544    end Install_Handlers;
 545
 546    ----------------
 547    -- Is_Blocked --
 548    ----------------
 549
 550    function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
 551    begin
 552       if Is_Reserved (Interrupt) then
 553          Raise_Exception (Program_Error'Identity, "Interrupt" &
 554            Interrupt_ID'Image (Interrupt) & " is reserved");
 555       end if;
 556
 557       return Blocked (Interrupt);
 558    end Is_Blocked;
 559
 560    -----------------------
 561    -- Is_Entry_Attached --
 562    -----------------------
 563
 564    function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
 565    begin
 566       if Is_Reserved (Interrupt) then
 567          Raise_Exception (Program_Error'Identity, "Interrupt" &
 568            Interrupt_ID'Image (Interrupt) & " is reserved");
 569       end if;
 570
 571       return User_Entry (Interrupt).T /= Null_Task;
 572    end Is_Entry_Attached;
 573
 574    -------------------------
 575    -- Is_Handler_Attached --
 576    -------------------------
 577
 578    function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
 579    begin
 580       if Is_Reserved (Interrupt) then
 581          Raise_Exception (Program_Error'Identity, "Interrupt" &
 582            Interrupt_ID'Image (Interrupt) & " is reserved");
 583       end if;
 584
 585       return User_Handler (Interrupt).H /= null;
 586    end Is_Handler_Attached;
 587
 588    ----------------
 589    -- Is_Ignored --
 590    ----------------
 591
 592    function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
 593    begin
 594       if Is_Reserved (Interrupt) then
 595          Raise_Exception (Program_Error'Identity, "Interrupt" &
 596            Interrupt_ID'Image (Interrupt) & " is reserved");
 597       end if;
 598
 599       return Ignored (Interrupt);
 600    end Is_Ignored;
 601
 602    -------------------
 603    -- Is_Registered --
 604    -------------------
 605
 606    --  See if the Handler has been "pragma"ed using Interrupt_Handler.
 607    --  Always consider a null handler as registered.
 608
 609    function Is_Registered (Handler : Parameterless_Handler) return Boolean is
 610
 611       type Fat_Ptr is record
 612          Object_Addr  : System.Address;
 613          Handler_Addr : System.Address;
 614       end record;
 615
 616       function To_Fat_Ptr is new Unchecked_Conversion
 617         (Parameterless_Handler, Fat_Ptr);
 618
 619       Ptr : R_Link;
 620       Fat : Fat_Ptr;
 621
 622    begin
 623       if Handler = null then
 624          return True;
 625       end if;
 626
 627       Fat := To_Fat_Ptr (Handler);
 628
 629       Ptr := Registered_Handler_Head;
 630
 631       while (Ptr /= null) loop
 632          if Ptr.H = Fat.Handler_Addr then
 633             return True;
 634          end if;
 635
 636          Ptr := Ptr.Next;
 637       end loop;
 638
 639       return False;
 640
 641    end Is_Registered;
 642
 643    -----------------
 644    -- Is_Reserved --
 645    -----------------
 646
 647    function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
 648    begin
 649       return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
 650    end Is_Reserved;
 651
 652    --------------------
 653    -- Lock_Interrupt --
 654    --------------------
 655
 656    --  ?????
 657
 658    --  This package has been modified several times.
 659    --  Do we still need this fancy locking scheme, now that more operations
 660    --  are entries of the interrupt manager task?
 661
 662    --  ?????
 663
 664    --  More likely, we will need to convert one or more entry calls to
 665    --  protected operations, because presently we are violating locking order
 666    --  rules by calling a task entry from within the runtime system.
 667
 668    procedure Lock_Interrupt
 669      (Self_ID   : Task_ID;
 670       Interrupt : Interrupt_ID)
 671    is
 672    begin
 673       Initialization.Defer_Abort (Self_ID);
 674
 675       POP.Write_Lock (L'Access);
 676
 677       if Task_Lock (Interrupt) then
 678
 679          --  We need to use per-task lock.
 680
 681          POP.Unlock (L'Access);
 682          POP.Write_Lock (Server_ID (Interrupt));
 683
 684          --  Rely on the fact that once Server_ID is set to a non-null
 685          --  value it will never be set back to null.
 686
 687       elsif Server_ID (Interrupt) /= Null_Task then
 688
 689          --  We need to use per-task lock.
 690
 691          Task_Lock (Interrupt) := True;
 692          POP.Unlock (L'Access);
 693          POP.Write_Lock (Server_ID (Interrupt));
 694       end if;
 695    end Lock_Interrupt;
 696
 697    ---------------
 698    -- Reference --
 699    ---------------
 700
 701    function Reference (Interrupt : Interrupt_ID) return System.Address is
 702    begin
 703       if Is_Reserved (Interrupt) then
 704          Raise_Exception (Program_Error'Identity, "Interrupt" &
 705            Interrupt_ID'Image (Interrupt) & " is reserved");
 706       end if;
 707
 708       return Storage_Elements.To_Address
 709         (Storage_Elements.Integer_Address (Interrupt));
 710    end Reference;
 711
 712    ---------------------------------
 713    -- Register_Interrupt_Handler  --
 714    ---------------------------------
 715
 716    procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
 717       New_Node_Ptr : R_Link;
 718
 719    begin
 720       --  This routine registers the Handler as usable for Dynamic
 721       --  Interrupt Handler. Routines attaching and detaching Handler
 722       --  dynamically should first consult if the Handler is rgistered.
 723       --  A Program Error should be raised if it is not registered.
 724
 725       --  The pragma Interrupt_Handler can only appear in the library
 726       --  level PO definition and instantiation. Therefore, we do not need
 727       --  to implement Unregistering operation. Neither we need to
 728       --  protect the queue structure using a Lock.
 729
 730       pragma Assert (Handler_Addr /= System.Null_Address);
 731
 732       New_Node_Ptr := new Registered_Handler;
 733       New_Node_Ptr.H := Handler_Addr;
 734
 735       if Registered_Handler_Head = null then
 736          Registered_Handler_Head := New_Node_Ptr;
 737          Registered_Handler_Tail := New_Node_Ptr;
 738
 739       else
 740          Registered_Handler_Tail.Next := New_Node_Ptr;
 741          Registered_Handler_Tail := New_Node_Ptr;
 742       end if;
 743    end Register_Interrupt_Handler;
 744
 745    -----------------------
 746    -- Unblock_Interrupt --
 747    -----------------------
 748
 749    procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
 750    begin
 751       if Is_Reserved (Interrupt) then
 752          Raise_Exception (Program_Error'Identity, "Interrupt" &
 753            Interrupt_ID'Image (Interrupt) & " is reserved");
 754       end if;
 755
 756       Interrupt_Manager.Unblock_Interrupt (Interrupt);
 757    end Unblock_Interrupt;
 758
 759    ------------------
 760    -- Unblocked_By --
 761    ------------------
 762
 763    function Unblocked_By
 764      (Interrupt : Interrupt_ID)
 765       return      System.Tasking.Task_ID
 766    is
 767    begin
 768       if Is_Reserved (Interrupt) then
 769          Raise_Exception (Program_Error'Identity, "Interrupt" &
 770            Interrupt_ID'Image (Interrupt) & " is reserved");
 771       end if;
 772
 773       return Last_Unblocker (Interrupt);
 774    end Unblocked_By;
 775
 776    ------------------------
 777    -- Unignore_Interrupt --
 778    ------------------------
 779
 780    procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
 781    begin
 782       if Is_Reserved (Interrupt) then
 783          Raise_Exception (Program_Error'Identity, "Interrupt" &
 784            Interrupt_ID'Image (Interrupt) & " is reserved");
 785       end if;
 786
 787       Interrupt_Manager.Unignore_Interrupt (Interrupt);
 788    end Unignore_Interrupt;
 789
 790    ----------------------
 791    -- Unlock_Interrupt --
 792    ----------------------
 793
 794    procedure Unlock_Interrupt
 795      (Self_ID   : Task_ID;
 796       Interrupt : Interrupt_ID)
 797    is
 798    begin
 799       if Task_Lock (Interrupt) then
 800          POP.Unlock (Server_ID (Interrupt));
 801       else
 802          POP.Unlock (L'Access);
 803       end if;
 804
 805       Initialization.Undefer_Abort (Self_ID);
 806    end Unlock_Interrupt;
 807
 808    -----------------------
 809    -- Interrupt_Manager --
 810    -----------------------
 811
 812    task body Interrupt_Manager is
 813
 814       ----------------------
 815       --  Local Variables --
 816       ----------------------
 817
 818       Intwait_Mask  : aliased IMNG.Interrupt_Mask;
 819       Ret_Interrupt : Interrupt_ID;
 820       Old_Mask      : aliased IMNG.Interrupt_Mask;
 821       Self_ID       : Task_ID := POP.Self;
 822
 823       ---------------------
 824       --  Local Routines --
 825       ---------------------
 826
 827       procedure Bind_Handler (Interrupt : Interrupt_ID);
 828       --  This procedure does not do anything if the Interrupt is blocked.
 829       --  Otherwise, we have to interrupt Server_Task for status change through
 830       --  Wakeup interrupt.
 831
 832       procedure Unbind_Handler (Interrupt : Interrupt_ID);
 833       --  This procedure does not do anything if the Interrupt is blocked.
 834       --  Otherwise, we have to interrupt Server_Task for status change
 835       --  through abort interrupt.
 836
 837       --  Following two procedure are named Unprotected... in order to
 838       --  indicate that Lock/Unlock_Interrupt operations are needed around.
 839
 840       procedure Unprotected_Exchange_Handler
 841         (Old_Handler : out Parameterless_Handler;
 842          New_Handler : in  Parameterless_Handler;
 843          Interrupt   : in  Interrupt_ID;
 844          Static      : in  Boolean;
 845          Restoration : in  Boolean := False);
 846
 847       procedure Unprotected_Detach_Handler
 848         (Interrupt   : in Interrupt_ID;
 849          Static      : in Boolean);
 850
 851       ------------------
 852       -- Bind_Handler --
 853       ------------------
 854
 855       procedure Bind_Handler (Interrupt : Interrupt_ID) is
 856       begin
 857          if not Blocked (Interrupt) then
 858
 859             --  Mask this task for the given Interrupt so that all tasks
 860             --  are masked for the Interrupt and the actuall delivery of the
 861             --  Interrupt will be caught using "sigwait" by the
 862             --  corresponding Server_Task.
 863
 864             IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));
 865
 866             --  We have installed a Handler or an Entry before we called
 867             --  this procedure. If the Handler Task is waiting to be awakened,
 868             --  do it here. Otherwise, the interrupt will be discarded.
 869
 870             POP.Wakeup (Server_ID (Interrupt), Interrupt_Server_Idle_Sleep);
 871          end if;
 872       end Bind_Handler;
 873
 874       --------------------
 875       -- Unbind_Handler --
 876       --------------------
 877
 878       procedure Unbind_Handler (Interrupt : Interrupt_ID) is
 879       begin
 880          if not Blocked (Interrupt) then
 881
 882             --  Currently, there is a Handler or an Entry attached and
 883             --  corresponding Server_Task is waiting on "sigwait."
 884             --  We have to wake up the Server_Task and make it
 885             --  wait on condition variable by sending an
 886             --  Abort_Task_Interrupt
 887
 888             POP.Abort_Task (Server_ID (Interrupt));
 889
 890             --  Make sure corresponding Server_Task is out of its own
 891             --  sigwait state.
 892
 893             Ret_Interrupt :=
 894               Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
 895
 896             pragma Assert
 897               (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt));
 898
 899             IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
 900
 901             --  Unmake the Interrupt for this task in order to allow default
 902             --  action again.
 903
 904             IMOP.Thread_Unblock_Interrupt (IMNG.Interrupt_ID (Interrupt));
 905
 906          else
 907             IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
 908          end if;
 909
 910       end Unbind_Handler;
 911
 912       --------------------------------
 913       -- Unprotected_Detach_Handler --
 914       --------------------------------
 915
 916       procedure Unprotected_Detach_Handler
 917         (Interrupt   : in Interrupt_ID;
 918          Static      : in Boolean)
 919       is
 920          Old_Handler : Parameterless_Handler;
 921
 922       begin
 923          if User_Entry (Interrupt).T /= Null_Task then
 924
 925             --  In case we have an Interrupt Entry installed.
 926             --  raise a program error. (propagate it to the caller).
 927
 928             Unlock_Interrupt (Self_ID, Interrupt);
 929             Raise_Exception (Program_Error'Identity,
 930               "An interrupt entry is already installed");
 931          end if;
 932
 933          --  Note : Static = True will pass the following check. That is the
 934          --  case when we want to detach a handler regardless of the static
 935          --  status of the current_Handler.
 936
 937          if not Static and then User_Handler (Interrupt).Static then
 938
 939             --  Tries to detach a static Interrupt Handler.
 940             --  raise a program error.
 941
 942             Unlock_Interrupt (Self_ID, Interrupt);
 943             Raise_Exception (Program_Error'Identity,
 944               "Trying to detach a static Interrupt Handler");
 945          end if;
 946
 947          --  The interrupt should no longer be ignored if
 948          --  it was ever ignored.
 949
 950          Ignored (Interrupt) := False;
 951
 952          Old_Handler := User_Handler (Interrupt).H;
 953
 954          --  The new handler
 955
 956          User_Handler (Interrupt).H := null;
 957          User_Handler (Interrupt).Static := False;
 958
 959          if Old_Handler /= null then
 960             Unbind_Handler (Interrupt);
 961          end if;
 962
 963       end Unprotected_Detach_Handler;
 964
 965       ----------------------------------
 966       -- Unprotected_Exchange_Handler --
 967       ----------------------------------
 968
 969       procedure Unprotected_Exchange_Handler
 970         (Old_Handler : out Parameterless_Handler;
 971          New_Handler : in  Parameterless_Handler;
 972          Interrupt   : in  Interrupt_ID;
 973          Static      : in  Boolean;
 974          Restoration : in  Boolean := False)
 975       is
 976       begin
 977          if User_Entry (Interrupt).T /= Null_Task then
 978
 979             --  In case we have an Interrupt Entry already installed.
 980             --  raise a program error. (propagate it to the caller).
 981
 982             Unlock_Interrupt (Self_ID, Interrupt);
 983             Raise_Exception (Program_Error'Identity,
 984               "An interrupt is already installed");
 985          end if;
 986
 987          --  Note : A null handler with Static = True will
 988          --  pass the following check. That is the case when we want to
 989          --  Detach a handler regardless of the Static status
 990          --  of the current_Handler.
 991          --  We don't check anything if Restoration is True, since we
 992          --  may be detaching a static handler to restore a dynamic one.
 993
 994          if not Restoration and then not Static
 995
 996             --  Tries to overwrite a static Interrupt Handler with a
 997             --  dynamic Handler
 998
 999            and then (User_Handler (Interrupt).Static
1000
1001                         --  The new handler is not specified as an
1002                         --  Interrupt Handler by a pragma.
1003
1004                         or else not Is_Registered (New_Handler))
1005          then
1006             Unlock_Interrupt (Self_ID, Interrupt);
1007             Raise_Exception (Program_Error'Identity,
1008               "Trying to overwrite a static Interrupt Handler with a " &
1009               "dynamic Handler");
1010          end if;
1011
1012          --  The interrupt should no longer be ingnored if
1013          --  it was ever ignored.
1014
1015          Ignored (Interrupt) := False;
1016
1017          --  Save the old handler
1018
1019          Old_Handler := User_Handler (Interrupt).H;
1020
1021          --  The new handler
1022
1023          User_Handler (Interrupt).H := New_Handler;
1024
1025          if New_Handler = null then
1026
1027             --  The null handler means we are detaching the handler.
1028
1029             User_Handler (Interrupt).Static := False;
1030
1031          else
1032             User_Handler (Interrupt).Static := Static;
1033          end if;
1034
1035          --  Invoke a corresponding Server_Task if not yet created.
1036          --  Place Task_ID info in Server_ID array.
1037
1038          if Server_ID (Interrupt) = Null_Task then
1039
1040             --  When a new Server_Task is created, it should have its
1041             --  signal mask set to the All_Tasks_Mask.
1042
1043             IMOP.Set_Interrupt_Mask
1044               (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
1045             Access_Hold := new Server_Task (Interrupt);
1046             IMOP.Set_Interrupt_Mask (Old_Mask'Access);
1047
1048             Server_ID (Interrupt) := To_System (Access_Hold.all'Identity);
1049          end if;
1050
1051          if (New_Handler = null) then
1052             if Old_Handler /= null then
1053                Unbind_Handler (Interrupt);
1054             end if;
1055
1056             return;
1057          end if;
1058
1059          if Old_Handler = null then
1060             Bind_Handler (Interrupt);
1061          end if;
1062
1063       end Unprotected_Exchange_Handler;
1064
1065    --  Start of processing for Interrupt_Manager
1066
1067    begin
1068       --  By making this task independent of master, when the process
1069       --  goes away, the Interrupt_Manager will terminate gracefully.
1070
1071       System.Tasking.Utilities.Make_Independent;
1072
1073       --  Environmen task gets its own interrupt mask, saves it,
1074       --  and then masks all interrupts except the Keep_Unmasked set.
1075
1076       --  During rendezvous, the Interrupt_Manager receives the old
1077       --  interrupt mask of the environment task, and sets its own
1078       --  interrupt mask to that value.
1079
1080       --  The environment task will call the entry of Interrupt_Manager some
1081       --  during elaboration of the body of this package.
1082
1083       accept Initialize (Mask : IMNG.Interrupt_Mask) do
1084          declare
1085             The_Mask : aliased IMNG.Interrupt_Mask;
1086
1087          begin
1088             IMOP.Copy_Interrupt_Mask (The_Mask, Mask);
1089             IMOP.Set_Interrupt_Mask (The_Mask'Access);
1090          end;
1091       end Initialize;
1092
1093       --  Note: All tasks in RTS will have all the Reserve Interrupts
1094       --  being masked (except the Interrupt_Manager) and Keep_Unmasked
1095       --  unmasked when created.
1096
1097       --  Abort_Task_Interrupt is one of the Interrupt unmasked
1098       --  in all tasks. We mask the Interrupt in this particular task
1099       --  so that "sigwait" is possible to catch an explicitly sent
1100       --  Abort_Task_Interrupt from the Server_Tasks.
1101
1102       --  This sigwaiting is needed so that we make sure a Server_Task is
1103       --  out of its own sigwait state. This extra synchronization is
1104       --  necessary to prevent following senarios.
1105
1106       --   1) Interrupt_Manager sends an Abort_Task_Interrupt to the
1107       --      Server_Task then changes its own interrupt mask (OS level).
1108       --      If an interrupt (corresponding to the Server_Task) arrives
1109       --      in the nean time we have the Interrupt_Manager umnasked and
1110       --      the Server_Task waiting on sigwait.
1111
1112       --   2) For unbinding handler, we install a default action in the
1113       --      Interrupt_Manager. POSIX.1c states that the result of using
1114       --      "sigwait" and "sigaction" simaltaneously on the same interrupt
1115       --      is undefined. Therefore, we need to be informed from the
1116       --      Server_Task of the fact that the Server_Task is out of its
1117       --      sigwait stage.
1118
1119       IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
1120       IMOP.Add_To_Interrupt_Mask
1121         (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
1122       IMOP.Thread_Block_Interrupt
1123         (IMNG.Abort_Task_Interrupt);
1124
1125       loop
1126          --  A block is needed to absorb Program_Error exception
1127
1128          declare
1129             Old_Handler : Parameterless_Handler;
1130
1131          begin
1132             select
1133
1134             accept Attach_Handler
1135                (New_Handler : in Parameterless_Handler;
1136                 Interrupt   : in Interrupt_ID;
1137                 Static      : in Boolean;
1138                 Restoration : in Boolean := False)
1139             do
1140                Lock_Interrupt (Self_ID, Interrupt);
1141                Unprotected_Exchange_Handler
1142                  (Old_Handler, New_Handler, Interrupt, Static, Restoration);
1143                Unlock_Interrupt (Self_ID, Interrupt);
1144             end Attach_Handler;
1145
1146             or accept Exchange_Handler
1147                (Old_Handler : out Parameterless_Handler;
1148                 New_Handler : in Parameterless_Handler;
1149                 Interrupt   : in Interrupt_ID;
1150                 Static      : in Boolean)
1151             do
1152                Lock_Interrupt (Self_ID, Interrupt);
1153                Unprotected_Exchange_Handler
1154                  (Old_Handler, New_Handler, Interrupt, Static);
1155                Unlock_Interrupt (Self_ID, Interrupt);
1156             end Exchange_Handler;
1157
1158             or accept Detach_Handler
1159                (Interrupt   : in Interrupt_ID;
1160                 Static      : in Boolean)
1161             do
1162                Lock_Interrupt (Self_ID, Interrupt);
1163                Unprotected_Detach_Handler (Interrupt, Static);
1164                Unlock_Interrupt (Self_ID, Interrupt);
1165             end Detach_Handler;
1166
1167             or accept Bind_Interrupt_To_Entry
1168               (T       : Task_ID;
1169                E       : Task_Entry_Index;
1170                Interrupt : Interrupt_ID)
1171             do
1172                Lock_Interrupt (Self_ID, Interrupt);
1173
1174                --  if there is a binding already (either a procedure or an
1175                --  entry), raise Program_Error (propagate it to the caller).
1176
1177                if User_Handler (Interrupt).H /= null
1178                  or else User_Entry (Interrupt).T /= Null_Task
1179                then
1180                   Unlock_Interrupt (Self_ID, Interrupt);
1181                   Raise_Exception (Program_Error'Identity,
1182                     "A binding for this interrupt is already present");
1183                end if;
1184
1185                --  The interrupt should no longer be ingnored if
1186                --  it was ever ignored.
1187
1188                Ignored (Interrupt) := False;
1189                User_Entry (Interrupt) := Entry_Assoc' (T => T, E => E);
1190
1191                --  Indicate the attachment of Interrupt Entry in ATCB.
1192                --  This is need so that when an Interrupt Entry task terminates
1193                --  the binding can be cleaned. The call to unbinding must be
1194                --  make by the task before it terminates.
1195
1196                T.Interrupt_Entry := True;
1197
1198                --  Invoke a corresponding Server_Task if not yet created.
1199                --  Place Task_ID info in Server_ID array.
1200
1201                if Server_ID (Interrupt) = Null_Task then
1202
1203                   --  When a new Server_Task is created, it should have its
1204                   --  signal mask set to the All_Tasks_Mask.
1205
1206                   IMOP.Set_Interrupt_Mask
1207                     (IMOP.All_Tasks_Mask'Access, Old_Mask'Access);
1208                   Access_Hold := new Server_Task (Interrupt);
1209                   IMOP.Set_Interrupt_Mask (Old_Mask'Access);
1210                   Server_ID (Interrupt) :=
1211                     To_System (Access_Hold.all'Identity);
1212                end if;
1213
1214                Bind_Handler (Interrupt);
1215                Unlock_Interrupt (Self_ID, Interrupt);
1216             end Bind_Interrupt_To_Entry;
1217
1218             or accept Detach_Interrupt_Entries (T : Task_ID)
1219             do
1220                for I in Interrupt_ID'Range loop
1221                   if not Is_Reserved (I) then
1222                      Lock_Interrupt (Self_ID, I);
1223
1224                      if User_Entry (I).T = T then
1225
1226                         --  The interrupt should no longer be ingnored if
1227                         --  it was ever ignored.
1228
1229                         Ignored (I) := False;
1230                         User_Entry (I) := Entry_Assoc'
1231                           (T => Null_Task, E => Null_Task_Entry);
1232                         Unbind_Handler (I);
1233                      end if;
1234
1235                      Unlock_Interrupt (Self_ID, I);
1236                   end if;
1237                end loop;
1238
1239                --  Indicate in ATCB that no Interrupt Entries are attached.
1240
1241                T.Interrupt_Entry := False;
1242             end Detach_Interrupt_Entries;
1243
1244             or accept Block_Interrupt (Interrupt : Interrupt_ID) do
1245                Lock_Interrupt (Self_ID, Interrupt);
1246
1247                if Blocked (Interrupt) then
1248                   Unlock_Interrupt (Self_ID, Interrupt);
1249                   return;
1250                end if;
1251
1252                Blocked (Interrupt) := True;
1253                Last_Unblocker (Interrupt) := Null_Task;
1254
1255                --  Mask this task for the given Interrupt so that all tasks
1256                --  are masked for the Interrupt.
1257
1258                IMOP.Thread_Block_Interrupt (IMNG.Interrupt_ID (Interrupt));
1259
1260                if User_Handler (Interrupt).H /= null
1261                  or else  User_Entry (Interrupt).T /= Null_Task
1262                then
1263                   --  This is the case where the Server_Task is waiting on
1264                   --  "sigwait." Wake it up by sending an Abort_Task_Interrupt
1265                   --  so that the Server_Task waits on Cond.
1266
1267                   POP.Abort_Task (Server_ID (Interrupt));
1268
1269                   --  Make sure corresponding Server_Task is out of its own
1270                   --  sigwait state.
1271
1272                   Ret_Interrupt :=
1273                     Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
1274                   pragma Assert
1275                     (Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt));
1276                end if;
1277
1278                Unlock_Interrupt (Self_ID, Interrupt);
1279             end Block_Interrupt;
1280
1281             or accept Unblock_Interrupt (Interrupt : Interrupt_ID) do
1282                Lock_Interrupt (Self_ID, Interrupt);
1283
1284                if not Blocked (Interrupt) then
1285                   Unlock_Interrupt (Self_ID, Interrupt);
1286                   return;
1287                end if;
1288
1289                Blocked (Interrupt) := False;
1290                Last_Unblocker (Interrupt) :=
1291                  To_System (Unblock_Interrupt'Caller);
1292
1293                if User_Handler (Interrupt).H = null
1294                  and then User_Entry (Interrupt).T = Null_Task
1295                then
1296                   --  No handler is attached. Unmask the Interrupt so that
1297                   --  the default action can be carried out.
1298                   IMOP.Thread_Unblock_Interrupt
1299                     (IMNG.Interrupt_ID (Interrupt));
1300
1301                else
1302                   --  The Server_Task must be waiting on the Cond variable
1303                   --  since it was being blocked and an Interrupt Hander or
1304                   --  an Entry was there. Wake it up and let it change
1305                   --  it place of waiting according to its new state.
1306                   POP.Wakeup (Server_ID (Interrupt),
1307                     Interrupt_Server_Blocked_Interrupt_Sleep);
1308                end if;
1309
1310                Unlock_Interrupt (Self_ID, Interrupt);
1311             end Unblock_Interrupt;
1312
1313             or accept Ignore_Interrupt (Interrupt : Interrupt_ID) do
1314                Lock_Interrupt (Self_ID, Interrupt);
1315
1316                if Ignored (Interrupt) then
1317                   Unlock_Interrupt (Self_ID, Interrupt);
1318                   return;
1319                end if;
1320
1321                Ignored (Interrupt) := True;
1322
1323                --  If there is a handler associated with the Interrupt,
1324                --  detach it first. In this way we make sure that the
1325                --  Server_Task is not on sigwait. This is legal since
1326                --  Unignore_Interrupt is to install the default action.
1327
1328                if User_Handler (Interrupt).H /= null then
1329                   Unprotected_Detach_Handler
1330                     (Interrupt => Interrupt, Static => True);
1331
1332                elsif User_Entry (Interrupt).T /= Null_Task then
1333                   User_Entry (Interrupt) := Entry_Assoc'
1334                     (T => Null_Task, E => Null_Task_Entry);
1335                   Unbind_Handler (Interrupt);
1336                end if;
1337
1338                IMOP.Install_Ignore_Action (IMNG.Interrupt_ID (Interrupt));
1339                Unlock_Interrupt (Self_ID, Interrupt);
1340             end Ignore_Interrupt;
1341
1342             or accept Unignore_Interrupt (Interrupt : Interrupt_ID) do
1343                Lock_Interrupt (Self_ID, Interrupt);
1344                Ignored (Interrupt) := False;
1345
1346                --  If there is a handler associated with the Interrupt,
1347                --  detach it first. In this way we make sure that the
1348                --  Server_Task is not on sigwait. This is legal since
1349                --  Unignore_Interrupt is to install the default action.
1350
1351                if User_Handler (Interrupt).H /= null then
1352                   Unprotected_Detach_Handler
1353                     (Interrupt => Interrupt, Static => True);
1354
1355                elsif User_Entry (Interrupt).T /= Null_Task then
1356                   User_Entry (Interrupt) := Entry_Assoc'
1357                     (T => Null_Task, E => Null_Task_Entry);
1358                   Unbind_Handler (Interrupt);
1359                end if;
1360
1361                IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
1362                Unlock_Interrupt (Self_ID, Interrupt);
1363             end Unignore_Interrupt;
1364
1365             end select;
1366
1367          exception
1368
1369             --  If there is a program error we just want to propagate it to
1370             --  the caller and do not want to stop this task.
1371
1372             when Program_Error =>
1373                null;
1374
1375             when others =>
1376                pragma Assert
1377                  (Shutdown ("Interrupt_Manager---exception not expected"));
1378                null;
1379          end;
1380
1381       end loop;
1382
1383       pragma Assert (Shutdown ("Interrupt_Manager---should not get here"));
1384
1385    end Interrupt_Manager;
1386
1387    -----------------
1388    -- Server_Task --
1389    -----------------
1390
1391    task body Server_Task is
1392       Intwait_Mask    : aliased IMNG.Interrupt_Mask;
1393       Ret_Interrupt   : Interrupt_ID;
1394       Self_ID         : Task_ID := Self;
1395       Tmp_Handler     : Parameterless_Handler;
1396       Tmp_ID          : Task_ID;
1397       Tmp_Entry_Index : Task_Entry_Index;
1398
1399    begin
1400       --  By making this task independent of master, when the process
1401       --  goes away, the Server_Task will terminate gracefully.
1402
1403       System.Tasking.Utilities.Make_Independent;
1404
1405       --  Install default action in system level.
1406
1407       IMOP.Install_Default_Action (IMNG.Interrupt_ID (Interrupt));
1408
1409       --  Note: All tasks in RTS will have all the Reserve Interrupts
1410       --  being masked (except the Interrupt_Manager) and Keep_Unmasked
1411       --  unmasked when created.
1412
1413       --  Abort_Task_Interrupt is one of the Interrupt unmasked
1414       --  in all tasks. We mask the Interrupt in this particular task
1415       --  so that "sigwait" is possible to catch an explicitly sent
1416       --  Abort_Task_Interrupt from the Interrupt_Manager.
1417
1418       --  There are two Interrupt interrupts that this task catch through
1419       --  "sigwait." One is the Interrupt this task is designated to catch
1420       --  in order to execure user handler or entry. The other one is the
1421       --  Abort_Task_Interrupt. This interrupt is being sent from the
1422       --  Interrupt_Manager to inform status changes (e.g: become Blocked,
1423       --  Handler or Entry is to be detached).
1424
1425       --  Prepare a mask to used for sigwait.
1426
1427       IMOP.Empty_Interrupt_Mask (Intwait_Mask'Access);
1428
1429       IMOP.Add_To_Interrupt_Mask
1430         (Intwait_Mask'Access, IMNG.Interrupt_ID (Interrupt));
1431
1432       IMOP.Add_To_Interrupt_Mask
1433         (Intwait_Mask'Access, IMNG.Abort_Task_Interrupt);
1434
1435       IMOP.Thread_Block_Interrupt
1436         (IMNG.Abort_Task_Interrupt);
1437
1438       PIO.Set_Interrupt_ID (IMNG.Interrupt_ID (Interrupt), Self_ID);
1439
1440       loop
1441          System.Tasking.Initialization.Defer_Abort (Self_ID);
1442          POP.Write_Lock (Self_ID);
1443
1444          if User_Handler (Interrupt).H = null
1445            and then User_Entry (Interrupt).T = Null_Task
1446          then
1447             --  No Interrupt binding. If there is an interrupt,
1448             --  Interrupt_Manager will take default action.
1449
1450             Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
1451             POP.Sleep (Self_ID, Interrupt_Server_Idle_Sleep);
1452             Self_ID.Common.State := Runnable;
1453
1454          elsif Blocked (Interrupt) then
1455
1456             --  Interrupt is blocked. Stay here, so we won't catch
1457             --  the Interrupt.
1458
1459             Self_ID.Common.State := Interrupt_Server_Blocked_Interrupt_Sleep;
1460             POP.Sleep (Self_ID, Interrupt_Server_Blocked_Interrupt_Sleep);
1461             Self_ID.Common.State := Runnable;
1462
1463          else
1464             --  A Handler or an Entry is installed. At this point all tasks
1465             --  mask for the Interrupt is masked. Catch the Interrupt using
1466             --  sigwait.
1467
1468             --  This task may wake up from sigwait by receiving an interrupt
1469             --  (Abort_Task_Interrupt) from the Interrupt_Manager for unbinding
1470             --  a Procedure Handler or an Entry. Or it could be a wake up
1471             --  from status change (Unblocked -> Blocked). If that is not
1472             --  the case, we should exceute the attached Procedure or Entry.
1473
1474             POP.Unlock (Self_ID);
1475
1476             Ret_Interrupt :=
1477               Interrupt_ID (IMOP.Interrupt_Wait (Intwait_Mask'Access));
1478
1479             if Ret_Interrupt = Interrupt_ID (IMNG.Abort_Task_Interrupt) then
1480
1481                --  Inform the Interrupt_Manager of wakeup from above sigwait.
1482
1483                POP.Abort_Task (Interrupt_Manager_ID);
1484                POP.Write_Lock (Self_ID);
1485
1486             else
1487                pragma Assert (Ret_Interrupt = Interrupt);
1488
1489                POP.Write_Lock (Self_ID);
1490
1491                --  Even though we have received an Interrupt the status may
1492                --  have changed already before we got the Self_ID lock above.
1493                --  Therefore we make sure a Handler or an Entry is still
1494                --  there and make appropriate call.
1495                --  If there is no calls to make we need to regenerate the
1496                --  Interrupt in order not to lose it.
1497
1498                if User_Handler (Interrupt).H /= null then
1499                   Tmp_Handler := User_Handler (Interrupt).H;
1500
1501                   --  RTS calls should not be made with self being locked.
1502
1503                   POP.Unlock (Self_ID);
1504
1505                   Tmp_Handler.all;
1506                   POP.Write_Lock (Self_ID);
1507
1508                elsif User_Entry (Interrupt).T /= Null_Task then
1509                   Tmp_ID := User_Entry (Interrupt).T;
1510                   Tmp_Entry_Index := User_Entry (Interrupt).E;
1511
1512                   --  RTS calls should not be made with self being locked.
1513
1514                   POP.Unlock (Self_ID);
1515
1516                   System.Tasking.Rendezvous.Call_Simple
1517                     (Tmp_ID, Tmp_Entry_Index, System.Null_Address);
1518
1519                   POP.Write_Lock (Self_ID);
1520                else
1521                   --  This is a situation that this task wake up
1522                   --  receiving an Interrupt and before it get the lock
1523                   --  the Interrupt is blocked. We do not
1524                   --  want to lose the interrupt in this case so that
1525                   --  regenerate the Interrupt to process level;
1526
1527                   IMOP.Interrupt_Self_Process (IMNG.Interrupt_ID (Interrupt));
1528                end if;
1529             end if;
1530
1531          end if;
1532
1533          POP.Unlock (Self_ID);
1534          System.Tasking.Initialization.Undefer_Abort (Self_ID);
1535
1536          --  Undefer abort here to allow a window for this task
1537          --  to be aborted  at the time of system shutdown.
1538       end loop;
1539
1540       pragma Assert (Shutdown ("Server_Task---should not get here"));
1541    end Server_Task;
1542
1543 --  Elaboration code for package System.Interrupts
1544
1545 begin
1546
1547    --  Get Interrupt_Manager's ID so that Abort_Interrupt can be sent.
1548
1549    Interrupt_Manager_ID := To_System (Interrupt_Manager'Identity);
1550
1551    --  Initialize the lock L.
1552
1553    Initialization.Defer_Abort (Self);
1554    POP.Initialize_Lock (L'Access, POP.PO_Level);
1555    Initialization.Undefer_Abort (Self);
1556
1557    --  During the elaboration of this package body we want RTS to
1558    --  inherit the interrupt mask from the Environment Task.
1559
1560    --  The Environment Task should have gotten its mask from
1561    --  the enclosing process during the RTS start up. (See
1562    --  in s-inmaop.adb). Pass the Interrupt_Mask of the Environment
1563    --  task to the Interrupt_Manager.
1564
1565    --  Note : At this point we know that all tasks (including
1566    --  RTS internal servers) are masked for non-reserved signals
1567    --  (see s-taprop.adb). Only the Interrupt_Manager will have
1568    --  masks set up differently inheriting the original Environment
1569    --  Task's mask.
1570
1571    Interrupt_Manager.Initialize (IMOP.Environment_Mask);
1572 end System.Interrupts;