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