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