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