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