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