gcc/ada/5ginterr.adb

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