gcc/ada/s-interr-sigaction.adb

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