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