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