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