gcc/ada/5lintman.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 _ M A N A G E M E N T          --
   6 --                                                                          --
   7 --                                  B o d y                                 --
   8 --                                                                          --
   9 --             Copyright (C) 1991-1994, Florida State University            --
  10 --             Copyright (C) 1995-2003, Ada Core Technologies               --
  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.       --
  31 -- Extensive contributions were provided by Ada Core Technologies, Inc.     --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 --  This is the GNU/Linux version of this package
  36
  37 --  This file performs the system-dependent translation between machine
  38 --  exceptions and the Ada exceptions, if any, that should be raised when they
  39 --  occur. This version works for the x86 running linux.
  40
  41 --  This is a Sun OS (FSU THREADS) version of this package
  42
  43 --  PLEASE DO NOT add any dependences on other packages. ??? why not ???
  44 --  This package is designed to work with or without tasking support.
  45
  46 --  Make a careful study of all signals available under the OS, to see which
  47 --  need to be reserved, kept always unmasked, or kept always unmasked. Be on
  48 --  the lookout for special signals that may be used by the thread library.
  49
  50 --  The definitions of "reserved" differ slightly between the ARM and POSIX.
  51 --  Here is the ARM definition of reserved interrupt:
  52
  53 --  The set of reserved interrupts is implementation defined. A reserved
  54 --  interrupt is either an interrupt for which user-defined handlers are not
  55 --  supported, or one which already has an attached handler by some other
  56 --  implementation-defined means. Program units can be connected to
  57 --  non-reserved interrupts.
  58
  59 --  POSIX.5b/.5c specifies further:
  60
  61 --  Signals which the application cannot accept, and for which the application
  62 --  cannot modify the signal action or masking, because the signals are
  63 --  reserved for use by the Ada language implementation. The reserved signals
  64 --  defined by this standard are Signal_Abort, Signal_Alarm,
  65 --  Signal_Floating_Point_Error, Signal_Illegal_Instruction,
  66 --  Signal_Segmentation_Violation, Signal_Bus_Error. If the implementation
  67 --  supports any signals besides those defined by this standard, the
  68 --  implementation may also reserve some of those.
  69
  70 --  The signals defined by POSIX.5b/.5c that are not specified as being
  71 --  reserved are SIGHUP, SIGINT, SIGPIPE, SIGQUIT, SIGTERM, SIGUSR1, SIGUSR2,
  72 --  SIGCHLD, SIGCONT, SIGSTOP, SIGTSTP, SIGTTIN, SIGTTOU, SIGIO SIGURG, and all
  73 --  the real-time signals.
  74
  75 --  Beware of reserving signals that POSIX.5b/.5c require to be available for
  76 --  users. POSIX.5b/.5c say:
  77
  78 --  An implementation shall not impose restrictions on the ability of an
  79 --  application to send, accept, block, or ignore the signals defined by this
  80 --  standard, except as specified in this standard.
  81
  82 --  Here are some other relevant requirements from POSIX.5b/.5c:
  83
  84 --  For the environment task, the initial signal mask is that specified for
  85 --  the process...
  86
  87 --  It is anticipated that the paragraph above may be modified by a future
  88 --  revision of this standard, to require that the realtime signals always be
  89 --  initially masked for a process that is an Ada active partition.
  90
  91 --  For all other tasks, the initial signal mask shall include all the signals
  92 --  that are not reserved signals and are not bound to entries of the task.
  93
  94 with Interfaces.C;
  95 --  used for int and other types
  96
  97 with System.Error_Reporting;
  98 --  used for Shutdown
  99
 100 with System.OS_Interface;
 101 --  used for various Constants, Signal and types
 102
 103 with Ada.Exceptions;
 104 --  used for Exception_Id
 105 --           Raise_From_Signal_Handler
 106
 107 with System.Soft_Links;
 108 --  used for Get_Machine_State_Addr
 109
 110 with Unchecked_Conversion;
 111
 112 package body System.Interrupt_Management is
 113
 114    use Interfaces.C;
 115    use System.Error_Reporting;
 116    use System.OS_Interface;
 117
 118    package TSL renames System.Soft_Links;
 119
 120    type Interrupt_List is array (Interrupt_ID range <>) of Interrupt_ID;
 121    Exception_Interrupts : constant Interrupt_List :=
 122      (SIGFPE, SIGILL, SIGSEGV);
 123
 124    Unreserve_All_Interrupts : Interfaces.C.int;
 125    pragma Import
 126      (C, Unreserve_All_Interrupts, "__gl_unreserve_all_interrupts");
 127
 128    subtype int is Interfaces.C.int;
 129    subtype unsigned_short is Interfaces.C.unsigned_short;
 130    subtype unsigned_long is Interfaces.C.unsigned_long;
 131
 132    ----------------------
 133    -- Notify_Exception --
 134    ----------------------
 135
 136    pragma Warnings (Off);
 137    --  Because many unaccessed arguments
 138
 139    Signal_Mask : aliased sigset_t;
 140    --  The set of signals handled by Notify_Exception
 141
 142    --  This function identifies the Ada exception to be raised using
 143    --  the information when the system received a synchronous signal.
 144    --  Since this function is machine and OS dependent, different code
 145    --  has to be provided for different target.
 146
 147    procedure Notify_Exception
 148      (signo         : Signal;
 149       gs            : unsigned_short;
 150       fs            : unsigned_short;
 151       es            : unsigned_short;
 152       ds            : unsigned_short;
 153       edi           : unsigned_long;
 154       esi           : unsigned_long;
 155       ebp           : unsigned_long;
 156       esp           : unsigned_long;
 157       ebx           : unsigned_long;
 158       edx           : unsigned_long;
 159       ecx           : unsigned_long;
 160       eax           : unsigned_long;
 161       trapno        : unsigned_long;
 162       err           : unsigned_long;
 163       eip           : unsigned_long;
 164       cs            : unsigned_short;
 165       eflags        : unsigned_long;
 166       esp_at_signal : unsigned_long;
 167       ss            : unsigned_short;
 168       fpstate       : System.Address;
 169       oldmask       : unsigned_long;
 170       cr2           : unsigned_long);
 171
 172    procedure Notify_Exception
 173      (signo         : Signal;
 174       gs            : unsigned_short;
 175       fs            : unsigned_short;
 176       es            : unsigned_short;
 177       ds            : unsigned_short;
 178       edi           : unsigned_long;
 179       esi           : unsigned_long;
 180       ebp           : unsigned_long;
 181       esp           : unsigned_long;
 182       ebx           : unsigned_long;
 183       edx           : unsigned_long;
 184       ecx           : unsigned_long;
 185       eax           : unsigned_long;
 186       trapno        : unsigned_long;
 187       err           : unsigned_long;
 188       eip           : unsigned_long;
 189       cs            : unsigned_short;
 190       eflags        : unsigned_long;
 191       esp_at_signal : unsigned_long;
 192       ss            : unsigned_short;
 193       fpstate       : System.Address;
 194       oldmask       : unsigned_long;
 195       cr2           : unsigned_long)
 196    is
 197       pragma Warnings (On);
 198
 199       function To_Machine_State_Ptr is new
 200         Unchecked_Conversion (Address, Machine_State_Ptr);
 201
 202       --  These are not directly visible
 203
 204       procedure Raise_From_Signal_Handler
 205         (E : Ada.Exceptions.Exception_Id;
 206          M : System.Address);
 207       pragma Import
 208         (Ada, Raise_From_Signal_Handler,
 209          "ada__exceptions__raise_from_signal_handler");
 210       pragma No_Return (Raise_From_Signal_Handler);
 211
 212       mstate  : Machine_State_Ptr;
 213       message : aliased constant String := "" & ASCII.Nul;
 214       --  A null terminated String.
 215
 216       Result  : int;
 217
 218    begin
 219
 220       --  Raise_From_Signal_Handler makes sure that the exception is raised
 221       --  safely from this signal handler.
 222
 223       --  ??? The original signal mask (the one we had before coming into this
 224       --  signal catching function) should be restored by
 225       --  Raise_From_Signal_Handler. For now, restore it explicitely
 226
 227       Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
 228       pragma Assert (Result = 0);
 229
 230       --  Check that treatment of exception propagation here
 231       --  is consistent with treatment of the abort signal in
 232       --  System.Task_Primitives.Operations.
 233
 234       mstate := To_Machine_State_Ptr (TSL.Get_Machine_State_Addr.all);
 235       mstate.eip := eip;
 236       mstate.ebx := ebx;
 237       mstate.esp := esp_at_signal;
 238       mstate.ebp := ebp;
 239       mstate.esi := esi;
 240       mstate.edi := edi;
 241
 242       case signo is
 243          when SIGFPE =>
 244             Raise_From_Signal_Handler
 245               (Constraint_Error'Identity, message'Address);
 246          when SIGILL =>
 247             Raise_From_Signal_Handler
 248               (Constraint_Error'Identity, message'Address);
 249          when SIGSEGV =>
 250             Raise_From_Signal_Handler
 251               (Storage_Error'Identity, message'Address);
 252          when others =>
 253             if Shutdown ("Unexpected signal") then
 254                null;
 255             end if;
 256       end case;
 257    end Notify_Exception;
 258
 259    ---------------------------
 260    -- Initialize_Interrupts --
 261    ---------------------------
 262
 263    --  Nothing needs to be done on this platform.
 264
 265    procedure Initialize_Interrupts is
 266    begin
 267       null;
 268    end Initialize_Interrupts;
 269
 270 begin
 271    declare
 272       act     : aliased struct_sigaction;
 273       old_act : aliased struct_sigaction;
 274       Result  : int;
 275
 276       function State (Int : Interrupt_ID) return Character;
 277       pragma Import (C, State, "__gnat_get_interrupt_state");
 278       --  Get interrupt state.  Defined in a-init.c
 279       --  The input argument is the interrupt number,
 280       --  and the result is one of the following:
 281
 282       User    : constant Character := 'u';
 283       Runtime : constant Character := 'r';
 284       Default : constant Character := 's';
 285       --    'n'   this interrupt not set by any Interrupt_State pragma
 286       --    'u'   Interrupt_State pragma set state to User
 287       --    'r'   Interrupt_State pragma set state to Runtime
 288       --    's'   Interrupt_State pragma set state to System (use "default"
 289       --           system handler)
 290
 291    begin
 292       --  Need to call pthread_init very early because it is doing signal
 293       --  initializations.
 294
 295       pthread_init;
 296
 297       Abort_Task_Interrupt := SIGADAABORT;
 298
 299       act.sa_handler := Notify_Exception'Address;
 300
 301       act.sa_flags := 0;
 302
 303       --  On some targets, we set sa_flags to SA_NODEFER so that during the
 304       --  handler execution we do not change the Signal_Mask to be masked for
 305       --  the Signal.
 306
 307       --  This is a temporary fix to the problem that the Signal_Mask is
 308       --  not restored after the exception (longjmp) from the handler.
 309       --  The right fix should be made in sigsetjmp so that we save
 310       --  the Signal_Set and restore it after a longjmp.
 311
 312       --  Since SA_NODEFER is obsolete, instead we reset explicitely
 313       --  the mask in the exception handler.
 314
 315       Result := sigemptyset (Signal_Mask'Access);
 316       pragma Assert (Result = 0);
 317
 318       --  Add signals that map to Ada exceptions to the mask.
 319
 320       for J in Exception_Interrupts'Range loop
 321          if State (Exception_Interrupts (J)) /= Default  then
 322             Result :=
 323             sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
 324             pragma Assert (Result = 0);
 325          end if;
 326       end loop;
 327
 328       act.sa_mask := Signal_Mask;
 329
 330       pragma Assert (Keep_Unmasked = (Interrupt_ID'Range => False));
 331       pragma Assert (Reserve = (Interrupt_ID'Range => False));
 332
 333       --  Process state of exception signals
 334
 335       for J in Exception_Interrupts'Range loop
 336          if State (Exception_Interrupts (J)) /= User then
 337             Keep_Unmasked (Exception_Interrupts (J)) := True;
 338             Reserve (Exception_Interrupts (J)) := True;
 339
 340             if State (Exception_Interrupts (J)) /= Default then
 341                Result :=
 342                  sigaction
 343                  (Signal (Exception_Interrupts (J)), act'Unchecked_Access,
 344                   old_act'Unchecked_Access);
 345                pragma Assert (Result = 0);
 346             end if;
 347          end if;
 348       end loop;
 349
 350       if State (Abort_Task_Interrupt) /= User then
 351          Keep_Unmasked (Abort_Task_Interrupt) := True;
 352          Reserve (Abort_Task_Interrupt) := True;
 353       end if;
 354
 355       --  Set SIGINT to unmasked state as long as it's
 356       --  not in "User" state.  Check for Unreserve_All_Interrupts last
 357
 358       if State (SIGINT) /= User then
 359          Keep_Unmasked (SIGINT) := True;
 360          Reserve (SIGINT) := True;
 361       end if;
 362
 363       --  Check all signals for state that requires keeping them
 364       --  unmasked and reserved
 365
 366       for J in Interrupt_ID'Range loop
 367          if State (J) = Default or else State (J) = Runtime then
 368             Keep_Unmasked (J) := True;
 369             Reserve (J) := True;
 370          end if;
 371       end loop;
 372
 373       --  Add the set of signals that must always be unmasked for this target
 374
 375       for J in Unmasked'Range loop
 376          Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
 377          Reserve (Interrupt_ID (Unmasked (J))) := True;
 378       end loop;
 379
 380       --  Add target-specific reserved signals
 381
 382       for J in Reserved'Range loop
 383          Reserve (Interrupt_ID (Reserved (J))) := True;
 384       end loop;
 385
 386       --  Process pragma Unreserve_All_Interrupts. This overrides any
 387       --  settings due to pragma Interrupt_State:
 388
 389       if Unreserve_All_Interrupts /= 0 then
 390          Keep_Unmasked (SIGINT) := False;
 391          Reserve (SIGINT) := False;
 392       end if;
 393
 394       --  We do not have Signal 0 in reality. We just use this value
 395       --  to identify non-existent signals (see s-intnam.ads). Therefore,
 396       --  Signal 0 should not be used in all signal related operations hence
 397       --  mark it as reserved.
 398
 399       Reserve (0) := True;
 400    end;
 401 end System.Interrupt_Management;