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