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    -- Install_Restricted_Handlers --
 295    ---------------------------------
 296
 297    procedure Install_Restricted_Handlers (Handlers : New_Handler_Array) is
 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) is
 331    begin
 332       Attach_Handler (New_Handler, Interrupt, Static, False);
 333    end Attach_Handler;
 334
 335    procedure Attach_Handler
 336      (New_Handler : Parameterless_Handler;
 337       Interrupt   : Interrupt_ID;
 338       Static      : Boolean;
 339       Restoration : Boolean)
 340    is
 341       New_Task : Server_Task_Access;
 342
 343    begin
 344       if Is_Reserved (Interrupt) then
 345          raise Program_Error;
 346       end if;
 347
 348       if not Restoration and then not Static
 349
 350          --  Tries to overwrite a static Interrupt Handler with dynamic handle
 351
 352         and then
 353           (Descriptors (Interrupt).Static
 354
 355             --  New handler not specified as an Interrupt Handler by a pragma
 356
 357              or else not Is_Registered (New_Handler))
 358       then
 359          raise Program_Error with
 360            "Trying to overwrite a static Interrupt Handler with a " &
 361            "dynamic Handler";
 362       end if;
 363
 364       if Handlers (Interrupt) = null then
 365          New_Task := new Server_Task (Interrupt);
 366          Handlers (Interrupt) := To_System (New_Task.all'Identity);
 367       end if;
 368
 369       if intr_attach (int (Interrupt),
 370         TISR (Signal_Handler'Access)) = FUNC_ERR
 371       then
 372          raise Program_Error;
 373       end if;
 374
 375       if New_Handler = null then
 376
 377          --  The null handler means we are detaching the handler
 378
 379          Descriptors (Interrupt) :=
 380            (Kind => Unknown, T => null, E => 0, H => null, Static => False);
 381
 382       else
 383          Descriptors (Interrupt).Kind := Protected_Procedure;
 384          Descriptors (Interrupt).H := New_Handler;
 385          Descriptors (Interrupt).Static := Static;
 386       end if;
 387    end Attach_Handler;
 388
 389    ----------------------
 390    -- Exchange_Handler --
 391    ----------------------
 392
 393    procedure Exchange_Handler
 394      (Old_Handler : out Parameterless_Handler;
 395       New_Handler : Parameterless_Handler;
 396       Interrupt   : Interrupt_ID;
 397       Static      : Boolean := False)
 398    is
 399    begin
 400       if Is_Reserved (Interrupt) then
 401          raise Program_Error;
 402       end if;
 403
 404       if Descriptors (Interrupt).Kind = Task_Entry then
 405
 406          --  In case we have an Interrupt Entry already installed.
 407          --  raise a program error. (propagate it to the caller).
 408
 409          raise Program_Error with "An interrupt is already installed";
 410
 411       else
 412          Old_Handler := Current_Handler (Interrupt);
 413          Attach_Handler (New_Handler, Interrupt, Static);
 414       end if;
 415    end Exchange_Handler;
 416
 417    --------------------
 418    -- Detach_Handler --
 419    --------------------
 420
 421    procedure Detach_Handler
 422      (Interrupt : Interrupt_ID;
 423       Static    : Boolean := False)
 424    is
 425    begin
 426       if Is_Reserved (Interrupt) then
 427          raise Program_Error;
 428       end if;
 429
 430       if Descriptors (Interrupt).Kind = Task_Entry then
 431          raise Program_Error with "Trying to detach an Interrupt Entry";
 432       end if;
 433
 434       if not Static and then Descriptors (Interrupt).Static then
 435          raise Program_Error with
 436            "Trying to detach a static Interrupt Handler";
 437       end if;
 438
 439       Descriptors (Interrupt) :=
 440         (Kind => Unknown, T => null, E => 0, H => null, Static => False);
 441
 442       if intr_attach (int (Interrupt), null) = FUNC_ERR then
 443          raise Program_Error;
 444       end if;
 445    end Detach_Handler;
 446
 447    ---------------
 448    -- Reference --
 449    ---------------
 450
 451    function Reference (Interrupt : Interrupt_ID) return System.Address is
 452       Signal : constant System.Address :=
 453                  System.Storage_Elements.To_Address
 454                    (System.Storage_Elements.Integer_Address (Interrupt));
 455
 456    begin
 457       if Is_Reserved (Interrupt) then
 458
 459          --  Only usable Interrupts can be used for binding it to an Entry
 460
 461          raise Program_Error;
 462       end if;
 463
 464       return Signal;
 465    end Reference;
 466
 467    --------------------------------
 468    -- Register_Interrupt_Handler --
 469    --------------------------------
 470
 471    procedure Register_Interrupt_Handler (Handler_Addr : System.Address) is
 472    begin
 473       Registered_Handlers :=
 474        new Registered_Handler'(H => Handler_Addr, Next => Registered_Handlers);
 475    end Register_Interrupt_Handler;
 476
 477    -------------------
 478    -- Is_Registered --
 479    -------------------
 480
 481    --  See if the Handler has been "pragma"ed using Interrupt_Handler.
 482    --  Always consider a null handler as registered.
 483
 484    function Is_Registered (Handler : Parameterless_Handler) return Boolean is
 485       Ptr : R_Link := Registered_Handlers;
 486
 487       type Fat_Ptr is record
 488          Object_Addr  : System.Address;
 489          Handler_Addr : System.Address;
 490       end record;
 491
 492       function To_Fat_Ptr is new Ada.Unchecked_Conversion
 493         (Parameterless_Handler, Fat_Ptr);
 494
 495       Fat : Fat_Ptr;
 496
 497    begin
 498       if Handler = null then
 499          return True;
 500       end if;
 501
 502       Fat := To_Fat_Ptr (Handler);
 503
 504       while Ptr /= null loop
 505
 506          if Ptr.H = Fat.Handler_Addr then
 507             return True;
 508          end if;
 509
 510          Ptr := Ptr.Next;
 511       end loop;
 512
 513       return False;
 514    end Is_Registered;
 515
 516    -----------------------------
 517    -- Bind_Interrupt_To_Entry --
 518    -----------------------------
 519
 520    procedure Bind_Interrupt_To_Entry
 521      (T       : Task_Id;
 522       E       : Task_Entry_Index;
 523       Int_Ref : System.Address)
 524    is
 525       Interrupt   : constant Interrupt_ID :=
 526                       Interrupt_ID (Storage_Elements.To_Integer (Int_Ref));
 527
 528       New_Task : Server_Task_Access;
 529
 530    begin
 531       if Is_Reserved (Interrupt) then
 532          raise Program_Error;
 533       end if;
 534
 535       if Descriptors (Interrupt).Kind /= Unknown then
 536          raise Program_Error with
 537            "A binding for this interrupt is already present";
 538       end if;
 539
 540       if Handlers (Interrupt) = null then
 541          New_Task := new Server_Task (Interrupt);
 542          Handlers (Interrupt) := To_System (New_Task.all'Identity);
 543       end if;
 544
 545       if intr_attach (int (Interrupt),
 546         TISR (Signal_Handler'Access)) = FUNC_ERR
 547       then
 548          raise Program_Error;
 549       end if;
 550
 551       Descriptors (Interrupt).Kind := Task_Entry;
 552       Descriptors (Interrupt).T := T;
 553       Descriptors (Interrupt).E := E;
 554
 555       --  Indicate the attachment of Interrupt Entry in ATCB. This is needed so
 556       --  that when an Interrupt Entry task terminates the binding can be
 557       --  cleaned up. The call to unbinding must be make by the task before it
 558       --  terminates.
 559
 560       T.Interrupt_Entry := True;
 561    end Bind_Interrupt_To_Entry;
 562
 563    ------------------------------
 564    -- Detach_Interrupt_Entries --
 565    ------------------------------
 566
 567    procedure Detach_Interrupt_Entries (T : Task_Id) is
 568    begin
 569       for J in Interrupt_ID loop
 570          if not Is_Reserved (J) then
 571             if Descriptors (J).Kind = Task_Entry
 572               and then Descriptors (J).T = T
 573             then
 574                Descriptors (J).Kind := Unknown;
 575
 576                if intr_attach (int (J), null) = FUNC_ERR then
 577                   raise Program_Error;
 578                end if;
 579             end if;
 580          end if;
 581       end loop;
 582
 583       --  Indicate in ATCB that no Interrupt Entries are attached
 584
 585       T.Interrupt_Entry := True;
 586    end Detach_Interrupt_Entries;
 587
 588    ---------------------
 589    -- Block_Interrupt --
 590    ---------------------
 591
 592    procedure Block_Interrupt (Interrupt : Interrupt_ID) is
 593    begin
 594       raise Program_Error;
 595    end Block_Interrupt;
 596
 597    -----------------------
 598    -- Unblock_Interrupt --
 599    -----------------------
 600
 601    procedure Unblock_Interrupt (Interrupt : Interrupt_ID) is
 602    begin
 603       raise Program_Error;
 604    end Unblock_Interrupt;
 605
 606    ----------------
 607    -- Is_Blocked --
 608    ----------------
 609
 610    function Is_Blocked (Interrupt : Interrupt_ID) return Boolean is
 611    begin
 612       raise Program_Error;
 613       return False;
 614    end Is_Blocked;
 615
 616    task body Server_Task is
 617       Desc    : Handler_Desc renames Descriptors (Interrupt);
 618       Self_Id : constant Task_Id := STPO.Self;
 619       Temp    : Parameterless_Handler;
 620
 621    begin
 622       Utilities.Make_Independent;
 623
 624       loop
 625          while Interrupt_Count (Interrupt) > 0 loop
 626             Interrupt_Count (Interrupt) := Interrupt_Count (Interrupt) - 1;
 627             begin
 628                case Desc.Kind is
 629                   when Unknown =>
 630                      null;
 631                   when Task_Entry =>
 632                      Rendezvous.Call_Simple (Desc.T, Desc.E, Null_Address);
 633                   when Protected_Procedure =>
 634                      Temp := Desc.H;
 635                      Temp.all;
 636                end case;
 637             exception
 638                when others => null;
 639             end;
 640          end loop;
 641
 642          Initialization.Defer_Abort (Self_Id);
 643
 644          if Single_Lock then
 645             STPO.Lock_RTS;
 646          end if;
 647
 648          STPO.Write_Lock (Self_Id);
 649          Self_Id.Common.State := Interrupt_Server_Idle_Sleep;
 650          STPO.Sleep (Self_Id, Interrupt_Server_Idle_Sleep);
 651          Self_Id.Common.State := Runnable;
 652          STPO.Unlock (Self_Id);
 653
 654          if Single_Lock then
 655             STPO.Unlock_RTS;
 656          end if;
 657
 658          Initialization.Undefer_Abort (Self_Id);
 659
 660          --  Undefer abort here to allow a window for this task to be aborted
 661          --  at the time of system shutdown.
 662
 663       end loop;
 664    end Server_Task;
 665
 666 end System.Interrupts;