gcc/ada/s-interr-sigaction.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) 1998-2004 Free Software Fundation             --
  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 --  This is the IRIX & NT version of this package.
  35
  36 with Ada.Task_Identification;
  37 --  used for Task_Id
  38
  39 with Ada.Exceptions;
  40 --  used for Raise_Exception
  41
  42 with System.OS_Interface;
  43 --  used for intr_attach
  44
  45 with System.Storage_Elements;
  46 --  used for To_Address
  47 --           To_Integer
  48
  49 with System.Task_Primitives.Operations;
  50 --  used for Self
  51 --           Sleep
  52 --           Wakeup
  53 --           Write_Lock
  54 --           Unlock
  55
  56 with System.Tasking.Utilities;
  57 --  used for Make_Independent
  58
  59 with System.Tasking.Rendezvous;
  60 --  used for Call_Simple
  61
  62 with System.Tasking.Initialization;
  63 --  used for Defer_Abort
  64 --           Undefer_Abort
  65
  66 with System.Interrupt_Management;
  67
  68 with System.Parameters;
  69 --  used for Single_Lock
  70
  71 with Interfaces.C;
  72 --  used for int
  73
  74 with Unchecked_Conversion;
  75
  76 package body System.Interrupts is
  77
  78    use Parameters;
  79    use Tasking;
  80    use Ada.Exceptions;
  81    use System.OS_Interface;
  82    use Interfaces.C;
  83
  84    package STPO renames System.Task_Primitives.Operations;
  85    package IMNG renames System.Interrupt_Management;
  86
  87    subtype int is Interfaces.C.int;
  88
  89    function To_System is new Unchecked_Conversion
  90      (Ada.Task_Identification.Task_Id, Task_Id);
  91
  92    type Handler_Kind is (Unknown, Task_Entry, Protected_Procedure);
  93
  94    type Handler_Desc is record
  95       Kind   : Handler_Kind := Unknown;
  96       T      : Task_Id;
  97       E      : Task_Entry_Index;
  98       H      : Parameterless_Handler;
  99       Static : Boolean := False;
 100    end record;
 101
 102    task type Server_Task (Interrupt : Interrupt_ID) is
 103       pragma Interrupt_Priority (System.Interrupt_Priority'Last);
 104    end Server_Task;
 105
 106    type Server_Task_Access is access Server_Task;
 107
 108    Handlers        : array (Interrupt_ID) of Task_Id;
 109    Descriptors     : array (Interrupt_ID) of Handler_Desc;
 110    Interrupt_Count : array (Interrupt_ID) of Integer := (others => 0);
 111
 112    pragma Volatile_Components (Interrupt_Count);
 113
 114    procedure Attach_Handler
 115      (New_Handler : Parameterless_Handler;
 116       Interrupt   : Interrupt_ID;
 117       Static      : Boolean;
 118       Restoration : Boolean);
 119    --  This internal procedure is needed to finalize protected objects
 120    --  that contain interrupt handlers.
 121
 122    procedure Signal_Handler (Sig : Interrupt_ID);
 123    --  This procedure is used to handle all the signals.
 124
 125    --  Type and Head, Tail of the list containing Registered Interrupt
 126    --  Handlers. These definitions are used to register the handlers
 127    --  specified by the pragma Interrupt_Handler.
 128
 129    --
 130    --  Handler Registration:
 131    --
 132
 133    type Registered_Handler;
 134    type R_Link is access all Registered_Handler;
 135
 136    type Registered_Handler is record
 137       H    : System.Address := System.Null_Address;
 138       Next : R_Link := null;
 139    end record;
 140
 141    Registered_Handlers : R_Link := null;
 142
 143    function Is_Registered (Handler : Parameterless_Handler) return Boolean;
 144    --  See if the Handler has been "pragma"ed using Interrupt_Handler.
 145    --  Always consider a null handler as registered.
 146
 147    type Handler_Ptr is access procedure (Sig : Interrupt_ID);
 148
 149    function TISR is new Unchecked_Conversion (Handler_Ptr, isr_address);
 150
 151    --------------------
 152    -- Signal_Handler --
 153    --------------------
 154
 155    procedure Signal_Handler (Sig : Interrupt_ID) is
 156       Handler : Task_Id renames Handlers (Sig);
 157
 158    begin
 159       if Intr_Attach_Reset and then
 160         intr_attach (int (Sig), TISR (Signal_Handler'Access)) = FUNC_ERR
 161       then
 162          raise Program_Error;
 163       end if;
 164
 165       if Handler /= null then
 166          Interrupt_Count (Sig) := Interrupt_Count (Sig) + 1;
 167          STPO.Wakeup (Handler, Interrupt_Server_Idle_Sleep);
 168       end if;
 169    end Signal_Handler;
 170
 171    -----------------
 172    -- Is_Reserved --
 173    -----------------
 174
 175    function Is_Reserved (Interrupt : Interrupt_ID) return Boolean is
 176    begin
 177       return IMNG.Reserve (IMNG.Interrupt_ID (Interrupt));
 178    end Is_Reserved;
 179
 180    -----------------------
 181    -- Is_Entry_Attached --
 182    -----------------------
 183
 184    function Is_Entry_Attached (Interrupt : Interrupt_ID) return Boolean is
 185    begin
 186       if Is_Reserved (Interrupt) then
 187          Raise_Exception (Program_Error'Identity, "Interrupt" &
 188            Interrupt_ID'Image (Interrupt) & " is reserved");
 189       end if;
 190
 191       return Descriptors (Interrupt).T /= Null_Task;
 192    end Is_Entry_Attached;
 193
 194    -------------------------
 195    -- Is_Handler_Attached --
 196    -------------------------
 197
 198    function Is_Handler_Attached (Interrupt : Interrupt_ID) return Boolean is
 199    begin
 200       if Is_Reserved (Interrupt) then
 201          Raise_Exception (Program_Error'Identity, "Interrupt" &
 202            Interrupt_ID'Image (Interrupt) & " is reserved");
 203       end if;
 204
 205       return Descriptors (Interrupt).Kind /= Unknown;
 206    end Is_Handler_Attached;
 207
 208    ----------------
 209    -- Is_Ignored --
 210    ----------------
 211
 212    function Is_Ignored (Interrupt : Interrupt_ID) return Boolean is
 213    begin
 214       raise Program_Error;
 215       return False;
 216    end Is_Ignored;
 217
 218    ------------------
 219    -- Unblocked_By --
 220    ------------------
 221
 222    function Unblocked_By (Interrupt : Interrupt_ID) return Task_Id is
 223    begin
 224       raise Program_Error;
 225       return Null_Task;
 226    end Unblocked_By;
 227
 228    ----------------------
 229    -- Ignore_Interrupt --
 230    ----------------------
 231
 232    procedure Ignore_Interrupt (Interrupt : Interrupt_ID) is
 233    begin
 234       raise Program_Error;
 235    end Ignore_Interrupt;
 236
 237    ------------------------
 238    -- Unignore_Interrupt --
 239    ------------------------
 240
 241    procedure Unignore_Interrupt (Interrupt : Interrupt_ID) is
 242    begin
 243       raise Program_Error;
 244    end Unignore_Interrupt;
 245
 246    -------------------------------------
 247    -- Has_Interrupt_Or_Attach_Handler --
 248    -------------------------------------
 249
 250    function Has_Interrupt_Or_Attach_Handler
 251      (Object : access Dynamic_Interrupt_Protection) return Boolean
 252    is
 253       pragma Unreferenced (Object);
 254    begin
 255       return True;
 256    end Has_Interrupt_Or_Attach_Handler;
 257
 258    --------------
 259    -- Finalize --
 260    --------------
 261
 262    procedure Finalize (Object : in out Static_Interrupt_Protection) is
 263    begin
 264       --  ??? loop to be executed only when we're not doing library level
 265       --  finalization, since in this case all interrupt tasks are gone.
 266
 267       for N in reverse Object.Previous_Handlers'Range loop
 268          Attach_Handler
 269            (New_Handler => Object.Previous_Handlers (N).Handler,
 270             Interrupt   => Object.Previous_Handlers (N).Interrupt,
 271             Static      => Object.Previous_Handlers (N).Static,
 272             Restoration => True);
 273       end loop;
 274
 275       Tasking.Protected_Objects.Entries.Finalize
 276         (Tasking.Protected_Objects.Entries.Protection_Entries (Object));
 277    end Finalize;
 278
 279    -------------------------------------
 280    -- Has_Interrupt_Or_Attach_Handler --
 281    -------------------------------------
 282
 283    function Has_Interrupt_Or_Attach_Handler
 284      (Object : access Static_Interrupt_Protection) return Boolean
 285    is
 286       pragma Unreferenced (Object);
 287    begin
 288       return True;
 289    end Has_Interrupt_Or_Attach_Handler;
 290
 291    ----------------------
 292    -- Install_Handlers --
 293    ----------------------
 294
 295    procedure Install_Handlers
 296      (Object       : access Static_Interrupt_Protection;
 297       New_Handlers : New_Handler_Array)
 298    is
 299    begin
 300       for N in New_Handlers'Range loop
 301
 302          --  We need a lock around this ???
 303
 304          Object.Previous_Handlers (N).Interrupt := New_Handlers (N).Interrupt;
 305          Object.Previous_Handlers (N).Static    := Descriptors
 306            (New_Handlers (N).Interrupt).Static;
 307
 308          --  We call Exchange_Handler and not directly Interrupt_Manager.
 309          --  Exchange_Handler so we get the Is_Reserved check.
 310
 311          Exchange_Handler
 312            (Old_Handler => Object.Previous_Handlers (N).Handler,
 313             New_Handler => New_Handlers (N).Handler,
 314             Interrupt   => New_Handlers (N).Interrupt,
 315             Static      => True);
 316       end loop;
 317    end Install_Handlers;
 318
 319    ---------------------
 320    -- Current_Handler --
 321    ---------------------
 322
 323    function Current_Handler
 324      (Interrupt : Interrupt_ID) return Parameterless_Handler
 325    is
 326    begin
 327       if Is_Reserved (Interrupt) then
 328          raise Program_Error;
 329       end if;
 330
 331       if Descriptors (Interrupt).Kind = Protected_Procedure then
 332          return Descriptors (Interrupt).H;
 333       else
 334          return null;
 335       end if;
 336    end Current_Handler;
 337
 338    --------------------
 339    -- Attach_Handler --
 340    --------------------
 341
 342    procedure Attach_Handler
 343      (New_Handler : Parameterless_Handler;
 344       Interrupt   : Interrupt_ID;
 345       Static      : Boolean := False) is
 346    begin
 347       Attach_Handler (New_Handler, Interrupt, Static, False);
 348    end Attach_Handler;
 349
 350    procedure Attach_Handler
 351      (New_Handler : Parameterless_Handler;
 352       Interrupt   : Interrupt_ID;
 353       Static      : Boolean;
 354       Restoration : Boolean)
 355    is
 356       New_Task : Server_Task_Access;
 357
 358    begin
 359       if Is_Reserved (Interrupt) then
 360          raise Program_Error;
 361       end if;
 362
 363       if not Restoration and then not Static
 364
 365          --  Tries to overwrite a static Interrupt Handler with a
 366          --  dynamic Handler
 367
 368         and then (Descriptors (Interrupt).Static
 369
 370                      --  The new handler is not specified as an
 371                      --  Interrupt Handler by a pragma.
 372
 373                      or else not Is_Registered (New_Handler))
 374       then
 375          Raise_Exception (Program_Error'Identity,
 376            "Trying to overwrite a static Interrupt Handler with a " &
 377            "dynamic Handler");
 378       end if;
 379
 380       if Handlers (Interrupt) = null then
 381          New_Task := new Server_Task (Interrupt);
 382          Handlers (Interrupt) := To_System (New_Task.all'Identity);
 383       end if;
 384
 385       if intr_attach (int (Interrupt),
 386         TISR (Signal_Handler'Access)) = FUNC_ERR
 387       then
 388          raise Program_Error;
 389       end if;
 390
 391       if New_Handler = null then
 392
 393          --  The null handler means we are detaching the handler
 394
 395          Descriptors (Interrupt) :=
 396            (Kind => Unknown, T => null, E => 0, H => null, Static => False);
 397
 398       else
 399          Descriptors (Interrupt).Kind := Protected_Procedure;
 400          Descriptors (Interrupt).H := New_Handler;
 401          Descriptors (Interrupt).Static := Static;
 402       end if;
 403    end Attach_Handler;
 404
 405    ----------------------
 406    -- Exchange_Handler --
 407    ----------------------
 408
 409    procedure Exchange_Handler
 410      (Old_Handler : out Parameterless_Handler;
 411       New_Handler : Parameterless_Handler;
 412       Interrupt   : Interrupt_ID;
 413       Static      : Boolean := False)
 414    is
 415    begin
 416       if Is_Reserved (Interrupt) then
 417          raise Program_Error;
 418       end if;
 419
 420       if Descriptors (Interrupt).Kind = Task_Entry then
 421
 422          --  In case we have an Interrupt Entry already installed.
 423          --  raise a program error. (propagate it to the caller).
 424
 425          Raise_Exception (Program_Error'Identity,
 426            "An interrupt is already installed");
 427       end if;
 428
 429       Old_Handler := Current_Handler (Interrupt);
 430       Attach_Handler (New_Handler, Interrupt, Static);
 431    end Exchange_Handler;
 432
 433    --------------------
 434    -- Detach_Handler --
 435    --------------------
 436
 437    procedure Detach_Handler
 438      (Interrupt : Interrupt_ID;
 439       Static    : Boolean := False)
 440    is
 441    begin
 442       if Is_Reserved (Interrupt) then
 443          raise Program_Error;
 444       end if;
 445
 446       if Descriptors (Interrupt).Kind = Task_Entry then
 447          Raise_Exception (Program_Error'Identity,
 448            "Trying to detach an Interrupt Entry");
 449       end if;
 450
 451       if not Static and then Descriptors (Interrupt).Static then
 452          Raise_Exception (Program_Error'Identity,
 453            "Trying to detach a static Interrupt Handler");
 454       end if;
 455
 456       Descriptors (Interrupt) :=
 457         (Kind => Unknown, T => null, E => 0, H => null, Static => False);
 458
 459       if intr_attach (int (Interrupt), null) = FUNC_ERR then
 460          raise Program_Error;
 461       end if;
 462    end Detach_Handler;
 463
 464    ---------------
 465    -- Reference --
 466    ---------------
 467
 468    function Reference (Interrupt : Interrupt_ID) return System.Address is
 469       Signal : constant System.Address :=
 470                  System.Storage_Elements.To_Address
 471                    (System.Storage_Elements.Integer_Address (Interrupt));
 472
 473    begin
 474       if Is_Reserved (Interrupt) then
 475
 476          --  Only usable Interrupts can be used for binding it to an Entry
 477
 478          raise Program_Error;
 479       end if;
 480
 481       return Signal;
 482    end Reference;
 483
 484    --------------------------------
 485    -- Register_Interrupt_Handler --
 486    --------------------------------
 487
 488    procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
 489    begin
 490       Registered_Handlers :=
 491        new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers);
 492    end Register_Interrupt_Handler;
 493
 494    -------------------
 495    -- Is_Registered --
 496    -------------------
 497
 498    --  See if the Handler has been "pragma"ed using Interrupt_Handler.
 499    --  Always consider a null handler as registered.
 500
 501    function Is_Registered (Handler : Parameterless_Handler) return Boolean is
 502       Ptr : R_Link := Registered_Handlers;
 503
 504       type Fat_Ptr is record
 505          Object_Addr  : System.Address;
 506          Handler_Addr : System.Address;
 507       end record;
 508
 509       function To_Fat_Ptr is new Unchecked_Conversion
 510         (Parameterless_Handler, Fat_Ptr);
 511
 512       Fat : Fat_Ptr;
 513
 514    begin
 515       if Handler = null then
 516          return True;
 517       end if;
 518
 519       Fat := To_Fat_Ptr (Handler);
 520
 521       while Ptr /= null loop
 522
 523          if Ptr.H = Fat.Handler_Addr then
 524             return True;
 525          end if;
 526
 527          Ptr := Ptr.Next;
 528       end loop;
 529
 530       return False;
 531    end Is_Registered;
 532
 533    -----------------------------
 534    -- Bind_Interrupt_To_Entry --
 535    -----------------------------
 536
 537    procedure Bind_Interrupt_To_Entry
 538      (T       : Task_Id;
 539       E       : Task_Entry_Index;
 540       Int_Ref : System.Address)
 541    is
 542       Interrupt   : constant Interrupt_ID :=
 543                       Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
 544
 545       New_Task : Server_Task_Access;
 546
 547    begin
 548       if Is_Reserved (Interrupt) then
 549          raise Program_Error;
 550       end if;
 551
 552       if Descriptors (Interrupt).Kind /= Unknown then
 553          Raise_Exception (Program_Error'Identity,
 554            "A binding for this interrupt is already present");
 555       end if;
 556
 557       if Handlers (Interrupt) = null then
 558          New_Task := new Server_Task (Interrupt);
 559          Handlers (Interrupt) := To_System (New_Task.all'Identity);
 560       end if;
 561
 562       if intr_attach (int (Interrupt),
 563         TISR (Signal_Handler'Access)) = FUNC_ERR
 564       then
 565          raise Program_Error;
 566       end if;
 567
 568       Descriptors (Interrupt).Kind := Task_Entry;
 569       Descriptors (Interrupt).T := T;
 570       Descriptors (Interrupt).E := E;
 571
 572       --  Indicate the attachment of Interrupt Entry in ATCB.
 573       --  This is need so that when an Interrupt Entry task terminates
 574       --  the binding can be cleaned. The call to unbinding must be
 575       --  make by the task before it terminates.
 576
 577       T.Interrupt_Entry := True;
 578    end Bind_Interrupt_To_Entry;
 579
 580    ------------------------------
 581    -- Detach_Interrupt_Entries --
 582    ------------------------------
 583
 584    procedure Detach_Interrupt_Entries (T : Task_Id) is
 585    begin
 586       for J in Interrupt_ID loop
 587          if not Is_Reserved (J) then
 588             if Descriptors (J).Kind = Task_Entry
 589               and then Descriptors (J).T = T
 590             then
 591                Descriptors (J).Kind := Unknown;
 592
 593                if intr_attach (int (J), null) = FUNC_ERR then
 594                   raise Program_Error;
 595                end if;
 596             end if;
 597          end if;
 598       end loop;
 599
 600       --  Indicate in ATCB that no Interrupt Entries are attached.
 601
 602       T.Interrupt_Entry := True;
 603    end Detach_Interrupt_Entries;
 604
 605    ---------------------
 606    -- Block_Interrupt --
 607    ---------------------
 608
 609    procedure Block_Interrupt (Interrupt : Interrupt_ID) is
 610    begin
 611       raise Program_Error;
 612    end Block_Interrupt;
 613
 614    -----------------------
 615    -- Unblock_Interrupt --
 616    -----------------------
 617
 618    procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
 619    begin
 620       raise Program_Error;
 621    end Unblock_Interrupt;
 622
 623    ----------------
 624    -- Is_Blocked --
 625    ----------------
 626
 627    function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
 628    begin
 629       raise Program_Error;
 630       return False;
 631    end Is_Blocked;
 632
 633    task body Server_Task is
 634       Desc    : Handler_Desc renames Descriptors (Interrupt);
 635       Self_Id : constant Task_Id := STPO.Self;
 636       Temp    : Parameterless_Handler;
 637
 638    begin
 639       Utilities.Make_Independent;
 640
 641       loop
 642          while Interrupt_Count (Interrupt) > 0 loop
 643             Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
 644             begin
 645                case Desc.Kind is
 646                   when Unknown =>
 647                      null;
 648                   when Task_Entry =>
 649                      Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
 650                   when Protected_Procedure =>
 651                      Temp := Desc.H;
 652                      Temp.all;
 653                end case;
 654             exception
 655                when others => null;
 656             end;
 657          end loop;
 658
 659          Initialization.Defer_Abort (Self_Id);
 660
 661          if Single_Lock then
 662             STPO.Lock_RTS;
 663          end if;
 664
 665          STPO.Write_Lock (Self_Id);
 666          Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
 667          STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
 668          Self_Id.Common.State := Runnable;
 669          STPO.Unlock (Self_Id);
 670
 671          if Single_Lock then
 672             STPO.Unlock_RTS;
 673          end if;
 674
 675          Initialization.Undefer_Abort (Self_Id);
 676
 677          --  Undefer abort here to allow a window for this task
 678          --  to be aborted  at the time of system shutdown.
 679
 680       end loop;
 681    end Server_Task;
 682
 683 end System.Interrupts;