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-2002 Florida State University             --
  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. It is --
  30 -- now maintained by Ada Core Technologies Inc. in cooperation with Florida --
  31 -- State University (http://www.gnat.com).                                  --
  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    Signal_Mask : aliased sigset_t;
 137    --  The set of signals handled by Notify_Exception
 138
 139    --  This function identifies the Ada exception to be raised using
 140    --  the information when the system received a synchronous signal.
 141    --  Since this function is machine and OS dependent, different code
 142    --  has to be provided for different target.
 143
 144    procedure Notify_Exception
 145      (signo         : Signal;
 146       gs            : unsigned_short;
 147       fs            : unsigned_short;
 148       es            : unsigned_short;
 149       ds            : unsigned_short;
 150       edi           : unsigned_long;
 151       esi           : unsigned_long;
 152       ebp           : unsigned_long;
 153       esp           : unsigned_long;
 154       ebx           : unsigned_long;
 155       edx           : unsigned_long;
 156       ecx           : unsigned_long;
 157       eax           : unsigned_long;
 158       trapno        : unsigned_long;
 159       err           : unsigned_long;
 160       eip           : unsigned_long;
 161       cs            : unsigned_short;
 162       eflags        : unsigned_long;
 163       esp_at_signal : unsigned_long;
 164       ss            : unsigned_short;
 165       fpstate       : System.Address;
 166       oldmask       : unsigned_long;
 167       cr2           : unsigned_long);
 168
 169    procedure Notify_Exception
 170      (signo         : Signal;
 171       gs            : unsigned_short;
 172       fs            : unsigned_short;
 173       es            : unsigned_short;
 174       ds            : unsigned_short;
 175       edi           : unsigned_long;
 176       esi           : unsigned_long;
 177       ebp           : unsigned_long;
 178       esp           : unsigned_long;
 179       ebx           : unsigned_long;
 180       edx           : unsigned_long;
 181       ecx           : unsigned_long;
 182       eax           : unsigned_long;
 183       trapno        : unsigned_long;
 184       err           : unsigned_long;
 185       eip           : unsigned_long;
 186       cs            : unsigned_short;
 187       eflags        : unsigned_long;
 188       esp_at_signal : unsigned_long;
 189       ss            : unsigned_short;
 190       fpstate       : System.Address;
 191       oldmask       : unsigned_long;
 192       cr2           : unsigned_long)
 193    is
 194
 195       function To_Machine_State_Ptr is new
 196         Unchecked_Conversion (Address, Machine_State_Ptr);
 197
 198       --  These are not directly visible
 199
 200       procedure Raise_From_Signal_Handler
 201         (E : Ada.Exceptions.Exception_Id;
 202          M : System.Address);
 203       pragma Import
 204         (Ada, Raise_From_Signal_Handler,
 205          "ada__exceptions__raise_from_signal_handler");
 206       pragma No_Return (Raise_From_Signal_Handler);
 207
 208       mstate  : Machine_State_Ptr;
 209       message : aliased constant String := "" & ASCII.Nul;
 210       --  a null terminated String.
 211
 212       Result  : int;
 213
 214    begin
 215
 216       --  Raise_From_Signal_Handler makes sure that the exception is raised
 217       --  safely from this signal handler.
 218
 219       --  ??? The original signal mask (the one we had before coming into this
 220       --  signal catching function) should be restored by
 221       --  Raise_From_Signal_Handler. For now, restore it explicitly
 222
 223       Result := pthread_sigmask (SIG_UNBLOCK, Signal_Mask'Access, null);
 224       pragma Assert (Result = 0);
 225
 226       --  Check that treatment of exception propagation here
 227       --  is consistent with treatment of the abort signal in
 228       --  System.Task_Primitives.Operations.
 229
 230       mstate := To_Machine_State_Ptr (TSL.Get_Machine_State_Addr.all);
 231       mstate.eip := eip;
 232       mstate.ebx := ebx;
 233       mstate.esp := esp_at_signal;
 234       mstate.ebp := ebp;
 235       mstate.esi := esi;
 236       mstate.edi := edi;
 237
 238       case signo is
 239          when SIGFPE =>
 240             Raise_From_Signal_Handler
 241               (Constraint_Error'Identity, message'Address);
 242          when SIGILL =>
 243             Raise_From_Signal_Handler
 244               (Constraint_Error'Identity, message'Address);
 245          when SIGSEGV =>
 246             Raise_From_Signal_Handler
 247               (Storage_Error'Identity, message'Address);
 248          when others =>
 249             if Shutdown ("Unexpected signal") then
 250                null;
 251             end if;
 252       end case;
 253    end Notify_Exception;
 254
 255    ---------------------------
 256    -- Initialize_Interrupts --
 257    ---------------------------
 258
 259    --  Nothing needs to be done on this platform.
 260
 261    procedure Initialize_Interrupts is
 262    begin
 263       null;
 264    end Initialize_Interrupts;
 265
 266 begin
 267    declare
 268       act     : aliased struct_sigaction;
 269       old_act : aliased struct_sigaction;
 270       Result  : int;
 271
 272    begin
 273
 274       --  Need to call pthread_init very early because it is doing signal
 275       --  initializations.
 276
 277       pthread_init;
 278
 279       Abort_Task_Interrupt := SIGADAABORT;
 280
 281       act.sa_handler := Notify_Exception'Address;
 282
 283       act.sa_flags := 0;
 284       --  On some targets, we set sa_flags to SA_NODEFER so that during the
 285       --  handler execution we do not change the Signal_Mask to be masked for
 286       --  the Signal.
 287       --  This is a temporary fix to the problem that the Signal_Mask is
 288       --  not restored after the exception (longjmp) from the handler.
 289       --  The right fix should be made in sigsetjmp so that we save
 290       --  the Signal_Set and restore it after a longjmp.
 291       --  Since SA_NODEFER is obsolete, instead we reset explicitly
 292       --  the mask in the exception handler.
 293
 294       Result := sigemptyset (Signal_Mask'Access);
 295       pragma Assert (Result = 0);
 296
 297       for J in Exception_Interrupts'Range loop
 298          Result :=
 299            sigaddset (Signal_Mask'Access, Signal (Exception_Interrupts (J)));
 300          pragma Assert (Result = 0);
 301       end loop;
 302
 303       act.sa_mask := Signal_Mask;
 304
 305       for J in Exception_Interrupts'Range loop
 306          Keep_Unmasked (Exception_Interrupts (J)) := True;
 307          Result :=
 308            sigaction
 309            (Signal (Exception_Interrupts (J)),
 310             act'Unchecked_Access,
 311             old_act'Unchecked_Access);
 312          pragma Assert (Result = 0);
 313       end loop;
 314
 315       Keep_Unmasked (Abort_Task_Interrupt) := True;
 316
 317       --  By keeping SIGINT unmasked, allow the user to do a Ctrl-C, but in the
 318       --  same time, disable the ability of handling this signal
 319       --  via Ada.Interrupts.
 320       --  The pragma Unreserve_All_Interrupts allows the user to
 321       --  change this behavior.
 322
 323       if Unreserve_All_Interrupts = 0 then
 324          Keep_Unmasked (SIGINT) := True;
 325       end if;
 326
 327       for J in Unmasked'Range loop
 328          Keep_Unmasked (Interrupt_ID (Unmasked (J))) := True;
 329       end loop;
 330
 331       Reserve := Keep_Unmasked or Keep_Masked;
 332
 333       for J in Reserved'Range loop
 334          Reserve (Interrupt_ID (Reserved (J))) := True;
 335       end loop;
 336
 337       Reserve (0) := True;
 338       --  We do not have Signal 0 in reality. We just use this value
 339       --  to identify non-existent signals (see s-intnam.ads). Therefore,
 340       --  Signal 0 should not be used in all signal related operations hence
 341       --  mark it as reserved.
 342
 343    end;
 344 end System.Interrupt_Management;