gcc/ada/init.c

   1 /****************************************************************************
   2  *                                                                          *
   3  *                         GNAT COMPILER COMPONENTS                         *
   4  *                                                                          *
   5  *                                 I N I T                                  *
   6  *                                                                          *
   7  *                          C Implementation File                           *
   8  *                                                                          *
   9  *          Copyright (C) 1992-2006, Free Software Foundation, Inc.         *
  10  *                                                                          *
  11  * GNAT 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.  GNAT 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 GNAT;  see file COPYING.  If not, write *
  19  * to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, *
  20  * Boston, MA 02110-1301, USA.                                              *
  21  *                                                                          *
  22  * As a  special  exception,  if you  link  this file  with other  files to *
  23  * produce an executable,  this file does not by itself cause the resulting *
  24  * executable to be covered by the GNU General Public License. This except- *
  25  * ion does not  however invalidate  any other reasons  why the  executable *
  26  * file might be covered by the  GNU Public License.                        *
  27  *                                                                          *
  28  * GNAT was originally developed  by the GNAT team at  New York University. *
  29  * Extensive contributions were provided by Ada Core Technologies Inc.      *
  30  *                                                                          *
  31  ****************************************************************************/
  32
  33 /*  This unit contains initialization circuits that are system dependent. A
  34     major part of the functionality involved involves stack overflow checking.
  35     The GCC backend generates probe instructions to test for stack overflow.
  36     For details on the exact approach used to generate these probes, see the
  37     "Using and Porting GCC" manual, in particular the "Stack Checking" section
  38     and the subsection "Specifying How Stack Checking is Done". The handlers
  39     installed by this file are used to handle resulting signals that come
  40     from these probes failing (i.e. touching protected pages) */
  41
  42 /* This file should be kept synchronized with 2sinit.ads, 2sinit.adb,
  43    s-init-ae653-cert.adb and s-init-xi-sparc.adb. All these files implement
  44    the required functionality for different targets. */
  45
  46 /* The following include is here to meet the published VxWorks requirement
  47    that the __vxworks header appear before any other include. */
  48 #ifdef __vxworks
  49 #include "vxWorks.h"
  50 #endif
  51
  52 #ifdef IN_RTS
  53 #include "tconfig.h"
  54 #include "tsystem.h"
  55 #include <sys/stat.h>
  56
  57 /* We don't have libiberty, so us malloc.  */
  58 #define xmalloc(S) malloc (S)
  59 #else
  60 #include "config.h"
  61 #include "system.h"
  62 #endif
  63
  64 #include "adaint.h"
  65 #include "raise.h"
  66
  67 extern void __gnat_raise_program_error (const char *, int);
  68
  69 /* Addresses of exception data blocks for predefined exceptions. Tasking_Error
  70    is not used in this unit, and the abort signal is only used on IRIX. */
  71 extern struct Exception_Data constraint_error;
  72 extern struct Exception_Data numeric_error;
  73 extern struct Exception_Data program_error;
  74 extern struct Exception_Data storage_error;
  75
  76 /* For the Cert run time we use the regular raise exception routine because
  77    Raise_From_Signal_Handler is not available. */
  78 #ifdef CERT
  79 #define Raise_From_Signal_Handler \
  80                       __gnat_raise_exception
  81 extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
  82 #else
  83 #define Raise_From_Signal_Handler \
  84                       ada__exceptions__raise_from_signal_handler
  85 extern void Raise_From_Signal_Handler (struct Exception_Data *, const char *);
  86 #endif
  87
  88 /* Global values computed by the binder */
  89 int   __gl_main_priority                 = -1;
  90 int   __gl_time_slice_val                = -1;
  91 char  __gl_wc_encoding                   = 'n';
  92 char  __gl_locking_policy                = ' ';
  93 char  __gl_queuing_policy                = ' ';
  94 char  __gl_task_dispatching_policy       = ' ';
  95 char *__gl_priority_specific_dispatching = 0;
  96 int   __gl_num_specific_dispatching      = 0;
  97 char *__gl_interrupt_states              = 0;
  98 int   __gl_num_interrupt_states          = 0;
  99 int   __gl_unreserve_all_interrupts      = 0;
 100 int   __gl_exception_tracebacks          = 0;
 101 int   __gl_zero_cost_exceptions          = 0;
 102 int   __gl_detect_blocking               = 0;
 103 int   __gl_default_stack_size            = -1;
 104
 105 /* Indication of whether synchronous signal handler has already been
 106    installed by a previous call to adainit */
 107 int  __gnat_handler_installed      = 0;
 108
 109 #ifndef IN_RTS
 110 int __gnat_inside_elab_final_code = 0;
 111 /* ??? This variable is obsolete since 2001-08-29 but is kept to allow
 112    bootstrap from old GNAT versions (< 3.15). */
 113 #endif
 114
 115 /* HAVE_GNAT_INIT_FLOAT must be set on every targets where a __gnat_init_float
 116    is defined. If this is not set them a void implementation will be defined
 117    at the end of this unit. */
 118 #undef HAVE_GNAT_INIT_FLOAT
 119
 120 /******************************/
 121 /* __gnat_get_interrupt_state */
 122 /******************************/
 123
 124 char __gnat_get_interrupt_state (int);
 125
 126 /* This routine is called from the runtime as needed to determine the state
 127    of an interrupt, as set by an Interrupt_State pragma appearing anywhere
 128    in the current partition. The input argument is the interrupt number,
 129    and the result is one of the following:
 130
 131        'n'   this interrupt not set by any Interrupt_State pragma
 132        'u'   Interrupt_State pragma set state to User
 133        'r'   Interrupt_State pragma set state to Runtime
 134        's'   Interrupt_State pragma set state to System */
 135
 136 char
 137 __gnat_get_interrupt_state (int intrup)
 138 {
 139   if (intrup >= __gl_num_interrupt_states)
 140     return 'n';
 141   else
 142     return __gl_interrupt_states [intrup];
 143 }
 144
 145 /***********************************/
 146 /* __gnat_get_specific_dispatching */
 147 /***********************************/
 148
 149 char __gnat_get_specific_dispatching (int);
 150
 151 /* This routine is called from the run time as needed to determine the
 152    priority specific dispatching policy, as set by a
 153    Priority_Specific_Dispatching pragma appearing anywhere in the current
 154    partition. The input argument is the priority number, and the result is
 155    the upper case first character of the policy name, e.g. 'F' for
 156    FIFO_Within_Priorities. A space ' ' is returned if no
 157    Priority_Specific_Dispatching pragma is used in the partition. */
 158
 159 char
 160 __gnat_get_specific_dispatching (int priority)
 161 {
 162   if (__gl_num_specific_dispatching == 0)
 163     return ' ';
 164   else if (priority >= __gl_num_specific_dispatching)
 165     return 'F';
 166   else
 167     return __gl_priority_specific_dispatching [priority];
 168 }
 169
 170 #ifndef IN_RTS
 171
 172 /**********************/
 173 /* __gnat_set_globals */
 174 /**********************/
 175
 176 /* This routine is kept for boostrapping purposes, since the binder generated
 177    file now sets the __gl_* variables directly. */
 178
 179 void
 180 __gnat_set_globals ()
 181 {
 182 }
 183
 184 #endif
 185
 186 /* Notes on the Zero Cost Exceptions scheme and its impact on the signal
 187    handlers implemented below :
 188
 189    What we call Zero Cost Exceptions is implemented using the GCC eh
 190    circuitry, even if the underlying implementation is setjmp/longjmp
 191    based. In any case ...
 192
 193    The GCC unwinder expects to be dealing with call return addresses, since
 194    this is the "nominal" case of what we retrieve while unwinding a regular
 195    call chain. To evaluate if a handler applies at some point in this chain,
 196    the propagation engine needs to determine what region the corresponding
 197    call instruction pertains to. The return address may not be attached to the
 198    same region as the call, so the unwinder unconditionally subtracts "some"
 199    amount to the return addresses it gets to search the region tables. The
 200    exact amount is computed to ensure that the resulting address is inside the
 201    call instruction, and is thus target dependent (think about delay slots for
 202    instance).
 203
 204    When we raise an exception from a signal handler, e.g. to transform a
 205    SIGSEGV into Storage_Error, things need to appear as if the signal handler
 206    had been "called" by the instruction which triggered the signal, so that
 207    exception handlers that apply there are considered. What the unwinder will
 208    retrieve as the return address from the signal handler is what it will find
 209    as the faulting instruction address in the corresponding signal context
 210    pushed by the kernel. Leaving this address untouched may loose, because if
 211    the triggering instruction happens to be the very first of a region, the
 212    later adjustments performed by the unwinder would yield an address outside
 213    that region. We need to compensate for those adjustments at some point,
 214    which we used to do in the GCC unwinding fallback macro.
 215
 216    The thread at http://gcc.gnu.org/ml/gcc-patches/2004-05/msg00343.html
 217    describes a couple of issues with the fallback based compensation approach.
 218    First, on some targets the adjustment to apply depends on the triggering
 219    signal, which is not easily accessible from the macro.  Besides, other
 220    languages, e.g. Java, deal with this by performing the adjustment in the
 221    signal handler before the raise, so fallback adjustments just break those
 222    front-ends.
 223
 224    We now follow the Java way for most targets, via adjust_context_for_raise
 225    below.  */
 226
 227 /***************/
 228 /* AIX Section */
 229 /***************/
 230
 231 #if defined (_AIX)
 232
 233 #include <signal.h>
 234 #include <sys/time.h>
 235
 236 /* Some versions of AIX don't define SA_NODEFER. */
 237
 238 #ifndef SA_NODEFER
 239 #define SA_NODEFER 0
 240 #endif /* SA_NODEFER */
 241
 242 /* Versions of AIX before 4.3 don't have nanosleep but provide
 243    nsleep instead. */
 244
 245 #ifndef _AIXVERSION_430
 246
 247 extern int nanosleep (struct timestruc_t *, struct timestruc_t *);
 248
 249 int
 250 nanosleep (struct timestruc_t *Rqtp, struct timestruc_t *Rmtp)
 251 {
 252   return nsleep (Rqtp, Rmtp);
 253 }
 254
 255 #endif /* _AIXVERSION_430 */
 256
 257 static void __gnat_error_handler (int);
 258
 259 static void
 260 __gnat_error_handler (int sig)
 261 {
 262   struct Exception_Data *exception;
 263   const char *msg;
 264
 265   switch (sig)
 266     {
 267     case SIGSEGV:
 268       /* FIXME: we need to detect the case of a *real* SIGSEGV */
 269       exception = &storage_error;
 270       msg = "stack overflow or erroneous memory access";
 271       break;
 272
 273     case SIGBUS:
 274       exception = &constraint_error;
 275       msg = "SIGBUS";
 276       break;
 277
 278     case SIGFPE:
 279       exception = &constraint_error;
 280       msg = "SIGFPE";
 281       break;
 282
 283     default:
 284       exception = &program_error;
 285       msg = "unhandled signal";
 286     }
 287
 288   Raise_From_Signal_Handler (exception, msg);
 289 }
 290
 291 void
 292 __gnat_install_handler (void)
 293 {
 294   struct sigaction act;
 295
 296   /* Set up signal handler to map synchronous signals to appropriate
 297      exceptions.  Make sure that the handler isn't interrupted by another
 298      signal that might cause a scheduling event! */
 299
 300   act.sa_handler = __gnat_error_handler;
 301   act.sa_flags = SA_NODEFER | SA_RESTART;
 302   sigemptyset (&act.sa_mask);
 303
 304   /* Do not install handlers if interrupt state is "System" */
 305   if (__gnat_get_interrupt_state (SIGABRT) != 's')
 306     sigaction (SIGABRT, &act, NULL);
 307   if (__gnat_get_interrupt_state (SIGFPE) != 's')
 308     sigaction (SIGFPE,  &act, NULL);
 309   if (__gnat_get_interrupt_state (SIGILL) != 's')
 310     sigaction (SIGILL,  &act, NULL);
 311   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 312     sigaction (SIGSEGV, &act, NULL);
 313   if (__gnat_get_interrupt_state (SIGBUS) != 's')
 314     sigaction (SIGBUS,  &act, NULL);
 315
 316   __gnat_handler_installed = 1;
 317 }
 318
 319 /*****************/
 320 /* Tru64 section */
 321 /*****************/
 322
 323 #elif defined(__alpha__) && defined(__osf__)
 324
 325 #include <signal.h>
 326 #include <sys/siginfo.h>
 327
 328 static void __gnat_error_handler (int, siginfo_t *, struct sigcontext *);
 329 extern char *__gnat_get_code_loc (struct sigcontext *);
 330 extern void __gnat_set_code_loc (struct sigcontext *, char *);
 331 extern size_t __gnat_machine_state_length (void);
 332
 333 static void
 334 __gnat_error_handler
 335   (int sig, siginfo_t *sip, struct sigcontext *context ATTRIBUTE_UNUSED)
 336 {
 337   struct Exception_Data *exception;
 338   static int recurse = 0;
 339   const char *msg;
 340
 341   /* If this was an explicit signal from a "kill", just resignal it.  */
 342   if (SI_FROMUSER (sip))
 343     {
 344       signal (sig, SIG_DFL);
 345       kill (getpid(), sig);
 346     }
 347
 348   /* Otherwise, treat it as something we handle.  */
 349   switch (sig)
 350     {
 351     case SIGSEGV:
 352       /* If the problem was permissions, this is a constraint error.
 353          Likewise if the failing address isn't maximally aligned or if
 354          we've recursed.
 355
 356          ??? Using a static variable here isn't task-safe, but it's
 357          much too hard to do anything else and we're just determining
 358          which exception to raise.  */
 359       if (sip->si_code == SEGV_ACCERR
 360           || (((long) sip->si_addr) & 3) != 0
 361           || recurse)
 362         {
 363           exception = &constraint_error;
 364           msg = "SIGSEGV";
 365         }
 366       else
 367         {
 368           /* See if the page before the faulting page is accessible.  Do that
 369              by trying to access it.  We'd like to simply try to access
 370              4096 + the faulting address, but it's not guaranteed to be
 371              the actual address, just to be on the same page.  */
 372           recurse++;
 373           ((volatile char *)
 374            ((long) sip->si_addr & - getpagesize ()))[getpagesize ()];
 375           msg = "stack overflow (or erroneous memory access)";
 376           exception = &storage_error;
 377         }
 378       break;
 379
 380     case SIGBUS:
 381       exception = &program_error;
 382       msg = "SIGBUS";
 383       break;
 384
 385     case SIGFPE:
 386       exception = &constraint_error;
 387       msg = "SIGFPE";
 388       break;
 389
 390     default:
 391       exception = &program_error;
 392       msg = "unhandled signal";
 393     }
 394
 395   recurse = 0;
 396   Raise_From_Signal_Handler (exception, (char *) msg);
 397 }
 398
 399 void
 400 __gnat_install_handler (void)
 401 {
 402   struct sigaction act;
 403
 404   /* Setup signal handler to map synchronous signals to appropriate
 405      exceptions. Make sure that the handler isn't interrupted by another
 406      signal that might cause a scheduling event! */
 407
 408   act.sa_handler = (void (*) (int)) __gnat_error_handler;
 409   act.sa_flags = SA_RESTART | SA_NODEFER | SA_SIGINFO;
 410   sigemptyset (&act.sa_mask);
 411
 412   /* Do not install handlers if interrupt state is "System" */
 413   if (__gnat_get_interrupt_state (SIGABRT) != 's')
 414     sigaction (SIGABRT, &act, NULL);
 415   if (__gnat_get_interrupt_state (SIGFPE) != 's')
 416     sigaction (SIGFPE,  &act, NULL);
 417   if (__gnat_get_interrupt_state (SIGILL) != 's')
 418     sigaction (SIGILL,  &act, NULL);
 419   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 420     sigaction (SIGSEGV, &act, NULL);
 421   if (__gnat_get_interrupt_state (SIGBUS) != 's')
 422     sigaction (SIGBUS,  &act, NULL);
 423
 424   __gnat_handler_installed = 1;
 425 }
 426
 427 /* Routines called by s-mastop-tru64.adb.  */
 428
 429 #define SC_GP 29
 430
 431 char *
 432 __gnat_get_code_loc (struct sigcontext *context)
 433 {
 434   return (char *) context->sc_pc;
 435 }
 436
 437 void
 438 __gnat_set_code_loc (struct sigcontext *context, char *pc)
 439 {
 440   context->sc_pc = (long) pc;
 441 }
 442
 443
 444 size_t
 445 __gnat_machine_state_length (void)
 446 {
 447   return sizeof (struct sigcontext);
 448 }
 449
 450 /********************/
 451 /* PA HP-UX section */
 452 /********************/
 453
 454 #elif defined (__hppa__) && defined (__hpux__)
 455
 456 #include <signal.h>
 457 #include <sys/ucontext.h>
 458
 459 static void
 460 __gnat_error_handler (int sig, siginfo_t *siginfo, void *ucontext);
 461
 462 /* __gnat_adjust_context_for_raise - see comments along with the default
 463    version later in this file.  */
 464
 465 #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
 466
 467 void
 468 __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
 469 {
 470   mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext;
 471
 472   if (UseWideRegs (mcontext))
 473     mcontext->ss_wide.ss_32.ss_pcoq_head_lo ++;
 474   else
 475     mcontext->ss_narrow.ss_pcoq_head ++;
 476 }
 477
 478 static void
 479 __gnat_error_handler
 480   (int sig, siginfo_t *siginfo ATTRIBUTE_UNUSED, void *ucontext)
 481 {
 482   struct Exception_Data *exception;
 483   const char *msg;
 484
 485   switch (sig)
 486     {
 487     case SIGSEGV:
 488       /* FIXME: we need to detect the case of a *real* SIGSEGV */
 489       exception = &storage_error;
 490       msg = "stack overflow or erroneous memory access";
 491       break;
 492
 493     case SIGBUS:
 494       exception = &constraint_error;
 495       msg = "SIGBUS";
 496       break;
 497
 498     case SIGFPE:
 499       exception = &constraint_error;
 500       msg = "SIGFPE";
 501       break;
 502
 503     default:
 504       exception = &program_error;
 505       msg = "unhandled signal";
 506     }
 507
 508   __gnat_adjust_context_for_raise (sig, ucontext);
 509
 510   Raise_From_Signal_Handler (exception, msg);
 511 }
 512
 513 void
 514 __gnat_install_handler (void)
 515 {
 516   struct sigaction act;
 517
 518   /* Set up signal handler to map synchronous signals to appropriate
 519      exceptions.  Make sure that the handler isn't interrupted by another
 520      signal that might cause a scheduling event! Also setup an alternate
 521      stack region for the handler execution so that stack overflows can be
 522      handled properly, avoiding a SEGV generation from stack usage by the
 523      handler itself. */
 524
 525   static char handler_stack[SIGSTKSZ*2];
 526   /* SIGSTKSZ appeared to be "short" for the needs in some contexts
 527      (e.g. experiments with GCC ZCX exceptions).  */
 528
 529   stack_t stack;
 530
 531   stack.ss_sp    = handler_stack;
 532   stack.ss_size  = sizeof (handler_stack);
 533   stack.ss_flags = 0;
 534
 535   sigaltstack (&stack, NULL);
 536
 537   act.sa_sigaction = __gnat_error_handler;
 538   act.sa_flags = SA_NODEFER | SA_RESTART | SA_ONSTACK | SA_SIGINFO;
 539   sigemptyset (&act.sa_mask);
 540
 541   /* Do not install handlers if interrupt state is "System" */
 542   if (__gnat_get_interrupt_state (SIGABRT) != 's')
 543     sigaction (SIGABRT, &act, NULL);
 544   if (__gnat_get_interrupt_state (SIGFPE) != 's')
 545     sigaction (SIGFPE,  &act, NULL);
 546   if (__gnat_get_interrupt_state (SIGILL) != 's')
 547     sigaction (SIGILL,  &act, NULL);
 548   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 549     sigaction (SIGSEGV, &act, NULL);
 550   if (__gnat_get_interrupt_state (SIGBUS) != 's')
 551     sigaction (SIGBUS,  &act, NULL);
 552
 553   __gnat_handler_installed = 1;
 554 }
 555
 556 /*********************/
 557 /* GNU/Linux Section */
 558 /*********************/
 559
 560 #elif defined (linux) && (defined (i386) || defined (__x86_64__) \
 561                           || defined (__ia64__))
 562
 563 #include <signal.h>
 564
 565 #define __USE_GNU 1 /* required to get REG_EIP/RIP from glibc's ucontext.h */
 566 #include <sys/ucontext.h>
 567
 568 /* GNU/Linux, which uses glibc, does not define NULL in included
 569    header files */
 570
 571 #if !defined (NULL)
 572 #define NULL ((void *) 0)
 573 #endif
 574
 575 #if defined (MaRTE)
 576
 577 /* MaRTE OS provides its own version of sigaction, sigfillset, and
 578    sigemptyset (overriding these symbol names). We want to make sure that
 579    the versions provided by the underlying C library are used here (these
 580    versions are renamed by MaRTE to linux_sigaction, fake_linux_sigfillset,
 581    and fake_linux_sigemptyset, respectively). The MaRTE library will not
 582    always be present (it will not be linked if no tasking constructs are
 583    used), so we use the weak symbol mechanism to point always to the symbols
 584    defined within the C library. */
 585
 586 #pragma weak linux_sigaction
 587 int linux_sigaction (int signum, const struct sigaction *act,
 588                      struct sigaction *oldact) {
 589   return sigaction (signum, act, oldact);
 590 }
 591 #define sigaction(signum, act, oldact) linux_sigaction (signum, act, oldact)
 592
 593 #pragma weak fake_linux_sigfillset
 594 void fake_linux_sigfillset (sigset_t *set) {
 595   sigfillset (set);
 596 }
 597 #define sigfillset(set) fake_linux_sigfillset (set)
 598
 599 #pragma weak fake_linux_sigemptyset
 600 void fake_linux_sigemptyset (sigset_t *set) {
 601   sigemptyset (set);
 602 }
 603 #define sigemptyset(set) fake_linux_sigemptyset (set)
 604
 605 #endif
 606
 607 static void __gnat_error_handler (int, siginfo_t *siginfo, void *ucontext);
 608
 609 /* __gnat_adjust_context_for_raise - see comments along with the default
 610    version later in this file.  */
 611
 612 #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
 613
 614 void
 615 __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
 616 {
 617   mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext;
 618
 619 #if defined (i386)
 620   mcontext->gregs[REG_EIP]++;
 621 #elif defined (__x86_64__)
 622   mcontext->gregs[REG_RIP]++;
 623 #elif defined (__ia64__)
 624   mcontext->sc_ip++;
 625 #endif
 626 }
 627
 628 static void
 629 __gnat_error_handler (int sig,
 630                       siginfo_t *siginfo ATTRIBUTE_UNUSED,
 631                       void *ucontext)
 632 {
 633   struct Exception_Data *exception;
 634   const char *msg;
 635   static int recurse = 0;
 636
 637   switch (sig)
 638     {
 639     case SIGSEGV:
 640       /* If the problem was permissions, this is a constraint error.
 641        Likewise if the failing address isn't maximally aligned or if
 642        we've recursed.
 643
 644        ??? Using a static variable here isn't task-safe, but it's
 645        much too hard to do anything else and we're just determining
 646        which exception to raise.  */
 647       if (recurse)
 648       {
 649         exception = &constraint_error;
 650         msg = "SIGSEGV";
 651       }
 652       else
 653       {
 654         /* Here we would like a discrimination test to see whether the
 655            page before the faulting address is accessible. Unfortunately
 656            Linux seems to have no way of giving us the faulting address.
 657
 658            In versions of a-init.c before 1.95, we had a test of the page
 659            before the stack pointer using:
 660
 661             recurse++;
 662              ((volatile char *)
 663               ((long) info->esp_at_signal & - getpagesize ()))[getpagesize ()];
 664
 665            but that's wrong, since it tests the stack pointer location, and
 666            the current stack probe code does not move the stack pointer
 667            until all probes succeed.
 668
 669            For now we simply do not attempt any discrimination at all. Note
 670            that this is quite acceptable, since a "real" SIGSEGV can only
 671            occur as the result of an erroneous program */
 672
 673         msg = "stack overflow (or erroneous memory access)";
 674         exception = &storage_error;
 675       }
 676       break;
 677
 678     case SIGBUS:
 679       exception = &constraint_error;
 680       msg = "SIGBUS";
 681       break;
 682
 683     case SIGFPE:
 684       exception = &constraint_error;
 685       msg = "SIGFPE";
 686       break;
 687
 688     default:
 689       exception = &program_error;
 690       msg = "unhandled signal";
 691     }
 692   recurse = 0;
 693
 694   /* We adjust the interrupted context here (and not in the
 695      MD_FALLBACK_FRAME_STATE_FOR macro) because recent versions of the Native
 696      POSIX Thread Library (NPTL) are compiled with DWARF 2 unwind information,
 697      and hence the later macro is never executed for signal frames. */
 698
 699   __gnat_adjust_context_for_raise (sig, ucontext);
 700
 701   Raise_From_Signal_Handler (exception, msg);
 702 }
 703
 704 void
 705 __gnat_install_handler (void)
 706 {
 707   struct sigaction act;
 708
 709   /* Set up signal handler to map synchronous signals to appropriate
 710      exceptions.  Make sure that the handler isn't interrupted by another
 711      signal that might cause a scheduling event! */
 712
 713   act.sa_sigaction = __gnat_error_handler;
 714   act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO;
 715   sigemptyset (&act.sa_mask);
 716
 717   /* Do not install handlers if interrupt state is "System" */
 718   if (__gnat_get_interrupt_state (SIGABRT) != 's')
 719     sigaction (SIGABRT, &act, NULL);
 720   if (__gnat_get_interrupt_state (SIGFPE) != 's')
 721     sigaction (SIGFPE,  &act, NULL);
 722   if (__gnat_get_interrupt_state (SIGILL) != 's')
 723     sigaction (SIGILL,  &act, NULL);
 724   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 725     sigaction (SIGSEGV, &act, NULL);
 726   if (__gnat_get_interrupt_state (SIGBUS) != 's')
 727     sigaction (SIGBUS,  &act, NULL);
 728
 729   __gnat_handler_installed = 1;
 730 }
 731
 732 /*******************/
 733 /* Interix Section */
 734 /*******************/
 735
 736 #elif defined (__INTERIX)
 737
 738 #include <signal.h>
 739
 740 static void __gnat_error_handler (int);
 741
 742 static void
 743 __gnat_error_handler (int sig)
 744 {
 745   struct Exception_Data *exception;
 746   const char *msg;
 747
 748   switch (sig)
 749     {
 750     case SIGSEGV:
 751       exception = &storage_error;
 752       msg = "stack overflow or erroneous memory access";
 753       break;
 754
 755     case SIGBUS:
 756       exception = &constraint_error;
 757       msg = "SIGBUS";
 758       break;
 759
 760     case SIGFPE:
 761       exception = &constraint_error;
 762       msg = "SIGFPE";
 763       break;
 764
 765     default:
 766       exception = &program_error;
 767       msg = "unhandled signal";
 768     }
 769
 770   Raise_From_Signal_Handler (exception, msg);
 771 }
 772
 773 void
 774 __gnat_install_handler (void)
 775 {
 776   struct sigaction act;
 777
 778   /* Set up signal handler to map synchronous signals to appropriate
 779      exceptions.  Make sure that the handler isn't interrupted by another
 780      signal that might cause a scheduling event! */
 781
 782   act.sa_handler = __gnat_error_handler;
 783   act.sa_flags = 0;
 784   sigemptyset (&act.sa_mask);
 785
 786   /* Handlers for signals besides SIGSEGV cause c974013 to hang */
 787 /*  sigaction (SIGILL,  &act, NULL); */
 788 /*  sigaction (SIGABRT, &act, NULL); */
 789 /*  sigaction (SIGFPE,  &act, NULL); */
 790 /*  sigaction (SIGBUS,  &act, NULL); */
 791
 792   /* Do not install handlers if interrupt state is "System" */
 793   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 794     sigaction (SIGSEGV, &act, NULL);
 795
 796   __gnat_handler_installed = 1;
 797 }
 798
 799 /****************/
 800 /* IRIX Section */
 801 /****************/
 802
 803 #elif defined (sgi)
 804
 805 #include <signal.h>
 806 #include <siginfo.h>
 807
 808 #ifndef NULL
 809 #define NULL 0
 810 #endif
 811
 812 #define SIGADAABORT 48
 813 #define SIGNAL_STACK_SIZE 4096
 814 #define SIGNAL_STACK_ALIGNMENT 64
 815
 816 #define Check_Abort_Status     \
 817                       system__soft_links__check_abort_status
 818 extern int (*Check_Abort_Status) (void);
 819
 820 extern struct Exception_Data _abort_signal;
 821
 822 static void __gnat_error_handler (int, int, sigcontext_t *);
 823
 824 /* We are not setting the SA_SIGINFO bit in the sigaction flags when
 825    connecting that handler, with the effects described in the sigaction
 826    man page:
 827
 828           SA_SIGINFO [...]
 829           If cleared and the signal is caught, the first argument is
 830           also the signal number but the second argument is the signal
 831           code identifying the cause of the signal. The third argument
 832           points to a sigcontext_t structure containing the receiving
 833           process's context when the signal was delivered.
 834 */
 835
 836 static void
 837 __gnat_error_handler (int sig, int code, sigcontext_t *sc ATTRIBUTE_UNUSED)
 838 {
 839   struct Exception_Data *exception;
 840   const char *msg;
 841
 842   switch (sig)
 843     {
 844     case SIGSEGV:
 845       if (code == EFAULT)
 846         {
 847           exception = &program_error;
 848           msg = "SIGSEGV: (Invalid virtual address)";
 849         }
 850       else if (code == ENXIO)
 851         {
 852           exception = &program_error;
 853           msg = "SIGSEGV: (Read beyond mapped object)";
 854         }
 855       else if (code == ENOSPC)
 856         {
 857           exception = &program_error; /* ??? storage_error ??? */
 858           msg = "SIGSEGV: (Autogrow for file failed)";
 859         }
 860       else if (code == EACCES || code == EEXIST)
 861         {
 862           /* ??? We handle stack overflows here, some of which do trigger
 863                  SIGSEGV + EEXIST on Irix 6.5 although EEXIST is not part of
 864                  the documented valid codes for SEGV in the signal(5) man
 865                  page.  */
 866
 867           /* ??? Re-add smarts to further verify that we launched
 868                  the stack into a guard page, not an attempt to
 869                  write to .text or something */
 870           exception = &storage_error;
 871           msg = "SIGSEGV: (stack overflow or erroneous memory access)";
 872         }
 873       else
 874         {
 875           /* Just in case the OS guys did it to us again.  Sometimes
 876              they fail to document all of the valid codes that are
 877              passed to signal handlers, just in case someone depends
 878              on knowing all the codes */
 879           exception = &program_error;
 880           msg = "SIGSEGV: (Undocumented reason)";
 881         }
 882       break;
 883
 884     case SIGBUS:
 885       /* Map all bus errors to Program_Error.  */
 886       exception = &program_error;
 887       msg = "SIGBUS";
 888       break;
 889
 890     case SIGFPE:
 891       /* Map all fpe errors to Constraint_Error.  */
 892       exception = &constraint_error;
 893       msg = "SIGFPE";
 894       break;
 895
 896     case SIGADAABORT:
 897       if ((*Check_Abort_Status) ())
 898         {
 899           exception = &_abort_signal;
 900           msg = "";
 901         }
 902       else
 903         return;
 904
 905       break;
 906
 907     default:
 908       /* Everything else is a Program_Error. */
 909       exception = &program_error;
 910       msg = "unhandled signal";
 911     }
 912
 913   Raise_From_Signal_Handler (exception, msg);
 914 }
 915
 916 void
 917 __gnat_install_handler (void)
 918 {
 919   struct sigaction act;
 920
 921   /* Setup signal handler to map synchronous signals to appropriate
 922      exceptions.  Make sure that the handler isn't interrupted by another
 923      signal that might cause a scheduling event! */
 924
 925   act.sa_handler = __gnat_error_handler;
 926   act.sa_flags = SA_NODEFER + SA_RESTART;
 927   sigfillset (&act.sa_mask);
 928   sigemptyset (&act.sa_mask);
 929
 930   /* Do not install handlers if interrupt state is "System" */
 931   if (__gnat_get_interrupt_state (SIGABRT) != 's')
 932     sigaction (SIGABRT, &act, NULL);
 933   if (__gnat_get_interrupt_state (SIGFPE) != 's')
 934     sigaction (SIGFPE,  &act, NULL);
 935   if (__gnat_get_interrupt_state (SIGILL) != 's')
 936     sigaction (SIGILL,  &act, NULL);
 937   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
 938     sigaction (SIGSEGV, &act, NULL);
 939   if (__gnat_get_interrupt_state (SIGBUS) != 's')
 940     sigaction (SIGBUS,  &act, NULL);
 941   if (__gnat_get_interrupt_state (SIGADAABORT) != 's')
 942     sigaction (SIGADAABORT,  &act, NULL);
 943
 944   __gnat_handler_installed = 1;
 945 }
 946
 947 /*******************/
 948 /* Solaris Section */
 949 /*******************/
 950
 951 #elif defined (sun) && defined (__SVR4) && !defined (__vxworks)
 952
 953 #include <signal.h>
 954 #include <siginfo.h>
 955
 956 static void __gnat_error_handler (int, siginfo_t *);
 957
 958 static void
 959 __gnat_error_handler (int sig, siginfo_t *sip)
 960 {
 961   struct Exception_Data *exception;
 962   static int recurse = 0;
 963   const char *msg;
 964
 965   /* If this was an explicit signal from a "kill", just resignal it.  */
 966   if (SI_FROMUSER (sip))
 967     {
 968       signal (sig, SIG_DFL);
 969       kill (getpid(), sig);
 970     }
 971
 972   /* Otherwise, treat it as something we handle.  */
 973   switch (sig)
 974     {
 975     case SIGSEGV:
 976       /* If the problem was permissions, this is a constraint error.
 977          Likewise if the failing address isn't maximally aligned or if
 978          we've recursed.
 979
 980          ??? Using a static variable here isn't task-safe, but it's
 981          much too hard to do anything else and we're just determining
 982          which exception to raise.  */
 983       if (sip->si_code == SEGV_ACCERR
 984           || (((long) sip->si_addr) & 3) != 0
 985           || recurse)
 986         {
 987           exception = &constraint_error;
 988           msg = "SIGSEGV";
 989         }
 990       else
 991         {
 992           /* See if the page before the faulting page is accessible.  Do that
 993              by trying to access it.  We'd like to simply try to access
 994              4096 + the faulting address, but it's not guaranteed to be
 995              the actual address, just to be on the same page.  */
 996           recurse++;
 997           ((volatile char *)
 998            ((long) sip->si_addr & - getpagesize ()))[getpagesize ()];
 999           exception = &storage_error;
1000           msg = "stack overflow (or erroneous memory access)";
1001         }
1002       break;
1003
1004     case SIGBUS:
1005       exception = &program_error;
1006       msg = "SIGBUS";
1007       break;
1008
1009     case SIGFPE:
1010       exception = &constraint_error;
1011       msg = "SIGFPE";
1012       break;
1013
1014     default:
1015       exception = &program_error;
1016       msg = "unhandled signal";
1017     }
1018
1019   recurse = 0;
1020
1021   Raise_From_Signal_Handler (exception, msg);
1022 }
1023
1024 void
1025 __gnat_install_handler (void)
1026 {
1027   struct sigaction act;
1028
1029   /* Set up signal handler to map synchronous signals to appropriate
1030      exceptions.  Make sure that the handler isn't interrupted by another
1031      signal that might cause a scheduling event! */
1032
1033   act.sa_handler = __gnat_error_handler;
1034   act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO;
1035   sigemptyset (&act.sa_mask);
1036
1037   /* Do not install handlers if interrupt state is "System" */
1038   if (__gnat_get_interrupt_state (SIGABRT) != 's')
1039     sigaction (SIGABRT, &act, NULL);
1040   if (__gnat_get_interrupt_state (SIGFPE) != 's')
1041     sigaction (SIGFPE,  &act, NULL);
1042   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
1043     sigaction (SIGSEGV, &act, NULL);
1044   if (__gnat_get_interrupt_state (SIGBUS) != 's')
1045     sigaction (SIGBUS,  &act, NULL);
1046
1047   __gnat_handler_installed = 1;
1048 }
1049
1050 /***************/
1051 /* VMS Section */
1052 /***************/
1053
1054 #elif defined (VMS)
1055
1056 long __gnat_error_handler (int *, void *);
1057
1058 #ifdef __IA64
1059 #define lib_get_curr_invo_context LIB$I64_GET_CURR_INVO_CONTEXT
1060 #define lib_get_prev_invo_context LIB$I64_GET_PREV_INVO_CONTEXT
1061 #define lib_get_invo_handle LIB$I64_GET_INVO_HANDLE
1062 #else
1063 #define lib_get_curr_invo_context LIB$GET_CURR_INVO_CONTEXT
1064 #define lib_get_prev_invo_context LIB$GET_PREV_INVO_CONTEXT
1065 #define lib_get_invo_handle LIB$GET_INVO_HANDLE
1066 #endif
1067
1068 #if defined (IN_RTS) && !defined (__IA64)
1069
1070 /* The prehandler actually gets control first on a condition. It swaps the
1071    stack pointer and calls the handler (__gnat_error_handler). */
1072 extern long __gnat_error_prehandler (void);
1073
1074 extern char *__gnat_error_prehandler_stack;   /* Alternate signal stack */
1075 #endif
1076
1077 /* Define macro symbols for the VMS conditions that become Ada exceptions.
1078    Most of these are also defined in the header file ssdef.h which has not
1079    yet been converted to be recognized by Gnu C. */
1080
1081 /* Defining these as macros, as opposed to external addresses, allows
1082    them to be used in a case statement (below */
1083 #define SS$_ACCVIO            12
1084 #define SS$_HPARITH         1284
1085 #define SS$_STKOVF          1364
1086 #define SS$_RESIGNAL        2328
1087
1088 /* These codes are in standard message libraries */
1089 extern int CMA$_EXIT_THREAD;
1090 extern int SS$_DEBUG;
1091 extern int SS$_INTDIV;
1092 extern int LIB$_KEYNOTFOU;
1093 extern int LIB$_ACTIMAGE;
1094 extern int MTH$_FLOOVEMAT;       /* Some ACVC_21 CXA tests */
1095
1096 /* These codes are non standard, which is to say the author is
1097    not sure if they are defined in the standard message libraries
1098    so keep them as macros for now. */
1099 #define RDB$_STREAM_EOF 20480426
1100 #define FDL$_UNPRIKW 11829410
1101
1102 struct cond_except {
1103   const int *cond;
1104   const struct Exception_Data *except;
1105 };
1106
1107 struct descriptor_s {unsigned short len, mbz; __char_ptr32 adr; };
1108
1109 /* Conditions that don't have an Ada exception counterpart must raise
1110    Non_Ada_Error.  Since this is defined in s-auxdec, it should only be
1111    referenced by user programs, not the compiler or tools. Hence the
1112    #ifdef IN_RTS. */
1113
1114 #ifdef IN_RTS
1115
1116 #define Status_Error ada__io_exceptions__status_error
1117 extern struct Exception_Data Status_Error;
1118
1119 #define Mode_Error ada__io_exceptions__mode_error
1120 extern struct Exception_Data Mode_Error;
1121
1122 #define Name_Error ada__io_exceptions__name_error
1123 extern struct Exception_Data Name_Error;
1124
1125 #define Use_Error ada__io_exceptions__use_error
1126 extern struct Exception_Data Use_Error;
1127
1128 #define Device_Error ada__io_exceptions__device_error
1129 extern struct Exception_Data Device_Error;
1130
1131 #define End_Error ada__io_exceptions__end_error
1132 extern struct Exception_Data End_Error;
1133
1134 #define Data_Error ada__io_exceptions__data_error
1135 extern struct Exception_Data Data_Error;
1136
1137 #define Layout_Error ada__io_exceptions__layout_error
1138 extern struct Exception_Data Layout_Error;
1139
1140 #define Non_Ada_Error system__aux_dec__non_ada_error
1141 extern struct Exception_Data Non_Ada_Error;
1142
1143 #define Coded_Exception system__vms_exception_table__coded_exception
1144 extern struct Exception_Data *Coded_Exception (Exception_Code);
1145
1146 #define Base_Code_In system__vms_exception_table__base_code_in
1147 extern Exception_Code Base_Code_In (Exception_Code);
1148
1149 /* DEC Ada exceptions are not defined in a header file, so they
1150    must be declared as external addresses */
1151
1152 extern int ADA$_PROGRAM_ERROR;
1153 extern int ADA$_LOCK_ERROR;
1154 extern int ADA$_EXISTENCE_ERROR;
1155 extern int ADA$_KEY_ERROR;
1156 extern int ADA$_KEYSIZERR;
1157 extern int ADA$_STAOVF;
1158 extern int ADA$_CONSTRAINT_ERRO;
1159 extern int ADA$_IOSYSFAILED;
1160 extern int ADA$_LAYOUT_ERROR;
1161 extern int ADA$_STORAGE_ERROR;
1162 extern int ADA$_DATA_ERROR;
1163 extern int ADA$_DEVICE_ERROR;
1164 extern int ADA$_END_ERROR;
1165 extern int ADA$_MODE_ERROR;
1166 extern int ADA$_NAME_ERROR;
1167 extern int ADA$_STATUS_ERROR;
1168 extern int ADA$_NOT_OPEN;
1169 extern int ADA$_ALREADY_OPEN;
1170 extern int ADA$_USE_ERROR;
1171 extern int ADA$_UNSUPPORTED;
1172 extern int ADA$_FAC_MODE_MISMAT;
1173 extern int ADA$_ORG_MISMATCH;
1174 extern int ADA$_RFM_MISMATCH;
1175 extern int ADA$_RAT_MISMATCH;
1176 extern int ADA$_MRS_MISMATCH;
1177 extern int ADA$_MRN_MISMATCH;
1178 extern int ADA$_KEY_MISMATCH;
1179 extern int ADA$_MAXLINEXC;
1180 extern int ADA$_LINEXCMRS;
1181
1182 /* DEC Ada specific conditions */
1183 static const struct cond_except dec_ada_cond_except_table [] = {
1184   {&ADA$_PROGRAM_ERROR,   &program_error},
1185   {&ADA$_USE_ERROR,       &Use_Error},
1186   {&ADA$_KEYSIZERR,       &program_error},
1187   {&ADA$_STAOVF,          &storage_error},
1188   {&ADA$_CONSTRAINT_ERRO, &constraint_error},
1189   {&ADA$_IOSYSFAILED,     &Device_Error},
1190   {&ADA$_LAYOUT_ERROR,    &Layout_Error},
1191   {&ADA$_STORAGE_ERROR,   &storage_error},
1192   {&ADA$_DATA_ERROR,      &Data_Error},
1193   {&ADA$_DEVICE_ERROR,    &Device_Error},
1194   {&ADA$_END_ERROR,       &End_Error},
1195   {&ADA$_MODE_ERROR,      &Mode_Error},
1196   {&ADA$_NAME_ERROR,      &Name_Error},
1197   {&ADA$_STATUS_ERROR,    &Status_Error},
1198   {&ADA$_NOT_OPEN,        &Use_Error},
1199   {&ADA$_ALREADY_OPEN,    &Use_Error},
1200   {&ADA$_USE_ERROR,       &Use_Error},
1201   {&ADA$_UNSUPPORTED,     &Use_Error},
1202   {&ADA$_FAC_MODE_MISMAT, &Use_Error},
1203   {&ADA$_ORG_MISMATCH,    &Use_Error},
1204   {&ADA$_RFM_MISMATCH,    &Use_Error},
1205   {&ADA$_RAT_MISMATCH,    &Use_Error},
1206   {&ADA$_MRS_MISMATCH,    &Use_Error},
1207   {&ADA$_MRN_MISMATCH,    &Use_Error},
1208   {&ADA$_KEY_MISMATCH,    &Use_Error},
1209   {&ADA$_MAXLINEXC,       &constraint_error},
1210   {&ADA$_LINEXCMRS,       &constraint_error},
1211   {0,                     0}
1212 };
1213
1214 #if 0
1215    /* Already handled by a pragma Import_Exception
1216       in Aux_IO_Exceptions */
1217   {&ADA$_LOCK_ERROR,      &Lock_Error},
1218   {&ADA$_EXISTENCE_ERROR, &Existence_Error},
1219   {&ADA$_KEY_ERROR,       &Key_Error},
1220 #endif
1221
1222 #endif /* IN_RTS */
1223
1224 /* Non DEC Ada specific conditions. We could probably also put
1225    SS$_HPARITH here and possibly SS$_ACCVIO, SS$_STKOVF. */
1226 static const struct cond_except cond_except_table [] = {
1227   {&MTH$_FLOOVEMAT, &constraint_error},
1228   {&SS$_INTDIV,     &constraint_error},
1229   {0,               0}
1230 };
1231
1232 /* To deal with VMS conditions and their mapping to Ada exceptions,
1233    the __gnat_error_handler routine below is installed as an exception
1234    vector having precedence over DEC frame handlers.  Some conditions
1235    still need to be handled by such handlers, however, in which case
1236    __gnat_error_handler needs to return SS$_RESIGNAL.  Consider for
1237    instance the use of a third party library compiled with DECAda and
1238    performing it's own exception handling internally.
1239
1240    To allow some user-level flexibility, which conditions should be
1241    resignaled is controlled by a predicate function, provided with the
1242    condition value and returning a boolean indication stating whether
1243    this condition should be resignaled or not.
1244
1245    That predicate function is called indirectly, via a function pointer,
1246    by __gnat_error_handler, and changing that pointer is allowed to the
1247    the user code by way of the __gnat_set_resignal_predicate interface.
1248
1249    The user level function may then implement what it likes, including
1250    for instance the maintenance of a dynamic data structure if the set
1251    of to be resignalled conditions has to change over the program's
1252    lifetime.
1253
1254    ??? This is not a perfect solution to deal with the possible
1255    interactions between the GNAT and the DECAda exception handling
1256    models and better (more general) schemes are studied.  This is so
1257    just provided as a convenient workaround in the meantime, and
1258    should be use with caution since the implementation has been kept
1259    very simple.  */
1260
1261 typedef int
1262 resignal_predicate (int code);
1263
1264 const int *cond_resignal_table [] = {
1265   &CMA$_EXIT_THREAD,
1266   &SS$_DEBUG,
1267   &LIB$_KEYNOTFOU,
1268   &LIB$_ACTIMAGE,
1269   (int *) RDB$_STREAM_EOF,
1270   (int *) FDL$_UNPRIKW,
1271   0
1272 };
1273
1274 const int facility_resignal_table [] = {
1275   0x1380000, /* RDB */
1276   0x2220000, /* SQL */
1277   0
1278 };
1279
1280 /* Default GNAT predicate for resignaling conditions.  */
1281
1282 static int
1283 __gnat_default_resignal_p (int code)
1284 {
1285   int i, iexcept;
1286
1287   for (i = 0; facility_resignal_table [i]; i++)
1288     if ((code & 0xfff0000) == facility_resignal_table [i])
1289       return 1;
1290
1291   for (i = 0, iexcept = 0;
1292        cond_resignal_table [i] &&
1293        !(iexcept = LIB$MATCH_COND (&code, &cond_resignal_table [i]));
1294        i++);
1295
1296   return iexcept;
1297 }
1298
1299 /* Static pointer to predicate that the __gnat_error_handler exception
1300    vector invokes to determine if it should resignal a condition.  */
1301
1302 static resignal_predicate * __gnat_resignal_p = __gnat_default_resignal_p;
1303
1304 /* User interface to change the predicate pointer to PREDICATE. Reset to
1305    the default if PREDICATE is null.  */
1306
1307 void
1308 __gnat_set_resignal_predicate (resignal_predicate * predicate)
1309 {
1310   if (predicate == 0)
1311     __gnat_resignal_p = __gnat_default_resignal_p;
1312   else
1313     __gnat_resignal_p = predicate;
1314 }
1315
1316 /* Should match System.Parameters.Default_Exception_Msg_Max_Length */
1317 #define Default_Exception_Msg_Max_Length 512
1318
1319 /* Action routine for SYS$PUTMSG. There may be
1320    multiple conditions, each with text to be appended to
1321    MESSAGE and separated by line termination. */
1322
1323 static int
1324 copy_msg (msgdesc, message)
1325      struct descriptor_s *msgdesc;
1326      char *message;
1327 {
1328   int len = strlen (message);
1329   int copy_len;
1330
1331   /* Check for buffer overflow and skip */
1332   if (len > 0 && len <= Default_Exception_Msg_Max_Length - 3)
1333     {
1334       strcat (message, "\r\n");
1335       len += 2;
1336     }
1337
1338   /* Check for buffer overflow and truncate if necessary */
1339   copy_len = (len + msgdesc->len <= Default_Exception_Msg_Max_Length - 1 ?
1340               msgdesc->len :
1341               Default_Exception_Msg_Max_Length - 1 - len);
1342   strncpy (&message [len], msgdesc->adr, copy_len);
1343   message [len + copy_len] = 0;
1344
1345   return 0;
1346 }
1347
1348 long
1349 __gnat_handle_vms_condition (int *sigargs, void *mechargs)
1350 {
1351   struct Exception_Data *exception = 0;
1352   Exception_Code base_code;
1353   struct descriptor_s gnat_facility = {4,0,"GNAT"};
1354   char message [Default_Exception_Msg_Max_Length];
1355
1356   const char *msg = "";
1357
1358   /* Check for conditions to resignal which aren't effected by pragma
1359      Import_Exception.  */
1360   if (__gnat_resignal_p (sigargs [1]))
1361     return SS$_RESIGNAL;
1362
1363 #ifdef IN_RTS
1364   /* See if it's an imported exception. Beware that registered exceptions
1365      are bound to their base code, with the severity bits masked off.  */
1366   base_code = Base_Code_In ((Exception_Code) sigargs [1]);
1367   exception = Coded_Exception (base_code);
1368
1369   if (exception)
1370     {
1371       message [0] = 0;
1372
1373       /* Subtract PC & PSL fields which messes with PUTMSG */
1374       sigargs [0] -= 2;
1375       SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
1376       sigargs [0] += 2;
1377       msg = message;
1378
1379       exception->Name_Length = 19;
1380       /* The full name really should be get sys$getmsg returns. ??? */
1381       exception->Full_Name = "IMPORTED_EXCEPTION";
1382       exception->Import_Code = base_code;
1383     }
1384 #endif
1385
1386   if (exception == 0)
1387     switch (sigargs[1])
1388       {
1389       case SS$_ACCVIO:
1390         if (sigargs[3] == 0)
1391           {
1392             exception = &constraint_error;
1393             msg = "access zero";
1394           }
1395         else
1396           {
1397             exception = &storage_error;
1398             msg = "stack overflow (or erroneous memory access)";
1399           }
1400         break;
1401
1402       case SS$_STKOVF:
1403         exception = &storage_error;
1404         msg = "stack overflow";
1405         break;
1406
1407       case SS$_HPARITH:
1408 #ifndef IN_RTS
1409         return SS$_RESIGNAL; /* toplev.c handles for compiler */
1410 #else
1411         {
1412           exception = &constraint_error;
1413           msg = "arithmetic error";
1414         }
1415 #endif
1416         break;
1417
1418       default:
1419 #ifdef IN_RTS
1420         {
1421           int i;
1422
1423           /* Scan the DEC Ada exception condition table for a match and fetch
1424              the associated GNAT exception pointer */
1425           for (i = 0;
1426                dec_ada_cond_except_table [i].cond &&
1427                !LIB$MATCH_COND (&sigargs [1],
1428                                 &dec_ada_cond_except_table [i].cond);
1429                i++);
1430           exception = (struct Exception_Data *)
1431             dec_ada_cond_except_table [i].except;
1432
1433           if (!exception)
1434             {
1435               /* Scan the VMS standard condition table for a match and fetch
1436                  the associated GNAT exception pointer */
1437               for (i = 0;
1438                    cond_except_table [i].cond &&
1439                    !LIB$MATCH_COND (&sigargs [1], &cond_except_table [i].cond);
1440                    i++);
1441               exception =(struct Exception_Data *) cond_except_table [i].except;
1442
1443               if (!exception)
1444                 /* User programs expect Non_Ada_Error to be raised, reference
1445                    DEC Ada test CXCONDHAN. */
1446                 exception = &Non_Ada_Error;
1447             }
1448         }
1449 #else
1450         exception = &program_error;
1451 #endif
1452         message [0] = 0;
1453         /* Subtract PC & PSL fields which messes with PUTMSG */
1454         sigargs [0] -= 2;
1455         SYS$PUTMSG (sigargs, copy_msg, &gnat_facility, message);
1456         sigargs [0] += 2;
1457         msg = message;
1458         break;
1459       }
1460
1461  __gnat_adjust_context_for_raise (0, (void *)mechargs);
1462  Raise_From_Signal_Handler (exception, msg);
1463 }
1464
1465 long
1466 __gnat_error_handler (int *sigargs, void *mechargs)
1467 {
1468   return __gnat_handle_vms_condition (sigargs, mechargs);
1469 }
1470
1471 void
1472 __gnat_install_handler (void)
1473 {
1474   long prvhnd ATTRIBUTE_UNUSED;
1475
1476 #if !defined (IN_RTS)
1477   SYS$SETEXV (1, __gnat_error_handler, 3, &prvhnd);
1478 #endif
1479
1480   /* On alpha-vms, we avoid the global vector annoyance thanks to frame based
1481      handlers to turn conditions into exceptions since GCC 3.4.  The global
1482      vector is still required for earlier GCC versions.  We're resorting to
1483      the __gnat_error_prehandler assembly function in this case.  */
1484
1485 #if defined (IN_RTS) && defined (__alpha__)
1486   if ((__GNUC__ * 10 + __GNUC_MINOR__) < 34)
1487     {
1488       char * c = (char *) xmalloc (2049);
1489
1490       __gnat_error_prehandler_stack = &c[2048];
1491       SYS$SETEXV (1, __gnat_error_prehandler, 3, &prvhnd);
1492     }
1493 #endif
1494
1495   __gnat_handler_installed = 1;
1496 }
1497
1498 /* __gnat_adjust_context_for_raise for alpha - see comments along with the
1499    default version later in this file.  */
1500
1501 #if defined (IN_RTS) && defined (__alpha__)
1502
1503 #include <vms/chfctxdef.h>
1504 #include <vms/chfdef.h>
1505
1506 #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
1507
1508 void
1509 __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
1510 {
1511   /* Add one to the address of the instruction signaling the condition,
1512      located in the sigargs array.  */
1513
1514   CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext;
1515   CHF$SIGNAL_ARRAY * sigargs
1516     = (CHF$SIGNAL_ARRAY *) mechargs->chf$q_mch_sig_addr;
1517
1518   int vcount = sigargs->chf$is_sig_args;
1519   int * pc_slot = & (&sigargs->chf$l_sig_name)[vcount-2];
1520
1521   (*pc_slot) ++;
1522 }
1523
1524 #endif
1525
1526 /* __gnat_adjust_context_for_raise for ia64.  */
1527
1528 #if defined (IN_RTS) && defined (__IA64)
1529
1530 #include <vms/chfctxdef.h>
1531 #include <vms/chfdef.h>
1532
1533 #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
1534
1535 typedef unsigned long long u64;
1536
1537 void
1538 __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
1539 {
1540   /* Add one to the address of the instruction signaling the condition,
1541      located in the 64bits sigargs array.  */
1542
1543   CHF$MECH_ARRAY * mechargs = (CHF$MECH_ARRAY *) ucontext;
1544
1545   CHF64$SIGNAL_ARRAY *chfsig64
1546     = (CHF64$SIGNAL_ARRAY *) mechargs->chf$ph_mch_sig64_addr;
1547
1548   u64 * post_sigarray
1549     = (u64 *)chfsig64 + 1 + chfsig64->chf64$l_sig_args;
1550
1551   u64 * ih_pc_loc = post_sigarray - 2;
1552
1553   (*ih_pc_loc) ++;
1554 }
1555
1556 #endif
1557
1558 /*******************/
1559 /* FreeBSD Section */
1560 /*******************/
1561
1562 #elif defined (__FreeBSD__)
1563
1564 #include <signal.h>
1565 #include <sys/ucontext.h>
1566 #include <unistd.h>
1567
1568 static void __gnat_error_handler (int, siginfo_t *, ucontext_t *);
1569 void __gnat_adjust_context_for_raise (int, void*);
1570
1571 /* __gnat_adjust_context_for_raise - see comments along with the default
1572    version later in this file.  */
1573
1574 #define HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
1575
1576 void
1577 __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED, void *ucontext)
1578 {
1579   mcontext_t *mcontext = &((ucontext_t *) ucontext)->uc_mcontext;
1580   mcontext->mc_eip++;
1581 }
1582
1583 static void
1584 __gnat_error_handler (int sig, siginfo_t *info __attribute__ ((unused)),
1585                       ucontext_t *ucontext)
1586 {
1587   struct Exception_Data *exception;
1588   const char *msg;
1589
1590   switch (sig)
1591     {
1592     case SIGFPE:
1593       exception = &constraint_error;
1594       msg = "SIGFPE";
1595       break;
1596
1597     case SIGILL:
1598       exception = &constraint_error;
1599       msg = "SIGILL";
1600       break;
1601
1602     case SIGSEGV:
1603       exception = &storage_error;
1604       msg = "stack overflow or erroneous memory access";
1605       break;
1606
1607     case SIGBUS:
1608       exception = &constraint_error;
1609       msg = "SIGBUS";
1610       break;
1611
1612     default:
1613       exception = &program_error;
1614       msg = "unhandled signal";
1615     }
1616
1617   __gnat_adjust_context_for_raise (sig, ucontext);
1618   Raise_From_Signal_Handler (exception, msg);
1619 }
1620
1621 void
1622 __gnat_install_handler ()
1623 {
1624   struct sigaction act;
1625
1626   /* Set up signal handler to map synchronous signals to appropriate
1627      exceptions.  Make sure that the handler isn't interrupted by another
1628      signal that might cause a scheduling event! */
1629
1630   act.sa_handler = __gnat_error_handler;
1631   act.sa_flags = SA_NODEFER | SA_RESTART | SA_SIGINFO;
1632   (void) sigemptyset (&act.sa_mask);
1633
1634   (void) sigaction (SIGILL,  &act, NULL);
1635   (void) sigaction (SIGFPE,  &act, NULL);
1636   (void) sigaction (SIGSEGV, &act, NULL);
1637   (void) sigaction (SIGBUS,  &act, NULL);
1638
1639   __gnat_handler_installed = 1;
1640 }
1641
1642 /*******************/
1643 /* VxWorks Section */
1644 /*******************/
1645
1646 #elif defined(__vxworks)
1647
1648 #include <signal.h>
1649 #include <taskLib.h>
1650
1651 #ifndef __RTP__
1652 #include <intLib.h>
1653 #include <iv.h>
1654 #endif
1655
1656 #ifdef VTHREADS
1657 #include "private/vThreadsP.h"
1658 #endif
1659
1660 static void __gnat_error_handler (int, int, struct sigcontext *);
1661 void __gnat_map_signal (int);
1662
1663 #ifndef __RTP__
1664
1665 /* Directly vectored Interrupt routines are not supported when using RTPs */
1666
1667 extern int __gnat_inum_to_ivec (int);
1668
1669 /* This is needed by the GNAT run time to handle Vxworks interrupts */
1670 int
1671 __gnat_inum_to_ivec (int num)
1672 {
1673   return INUM_TO_IVEC (num);
1674 }
1675 #endif
1676
1677 #if !defined(__alpha_vxworks) && (_WRS_VXWORKS_MAJOR != 6) && !defined(__RTP__)
1678
1679 /* getpid is used by s-parint.adb, but is not defined by VxWorks, except
1680    on Alpha VxWorks and VxWorks 6.x (including RTPs). */
1681
1682 extern long getpid (void);
1683
1684 long
1685 getpid (void)
1686 {
1687   return taskIdSelf ();
1688 }
1689 #endif
1690
1691 /* VxWorks expects the field excCnt to be zeroed when a signal is handled.
1692    The VxWorks version of longjmp does this; gcc's builtin_longjmp does not */
1693 void
1694 __gnat_clear_exception_count (void)
1695 {
1696 #ifdef VTHREADS
1697   WIND_TCB *currentTask = (WIND_TCB *) taskIdSelf();
1698
1699   currentTask->vThreads.excCnt = 0;
1700 #endif
1701 }
1702
1703 /* Exported to s-intman-vxworks.adb in order to handle different signal
1704    to exception mappings in different VxWorks versions */
1705 void
1706 __gnat_map_signal (int sig)
1707 {
1708   struct Exception_Data *exception;
1709   const char *msg;
1710
1711   switch (sig)
1712     {
1713     case SIGFPE:
1714       exception = &constraint_error;
1715       msg = "SIGFPE";
1716       break;
1717 #ifdef VTHREADS
1718     case SIGILL:
1719       exception = &constraint_error;
1720       msg = "Floating point exception or SIGILL";
1721       break;
1722     case SIGSEGV:
1723       exception = &storage_error;
1724       msg = "SIGSEGV: possible stack overflow";
1725       break;
1726     case SIGBUS:
1727       exception = &storage_error;
1728       msg = "SIGBUS: possible stack overflow";
1729       break;
1730 #else
1731     case SIGILL:
1732       exception = &constraint_error;
1733       msg = "SIGILL";
1734       break;
1735     case SIGSEGV:
1736       exception = &program_error;
1737       msg = "SIGSEGV";
1738       break;
1739     case SIGBUS:
1740       exception = &program_error;
1741       msg = "SIGBUS";
1742       break;
1743 #endif
1744     default:
1745       exception = &program_error;
1746       msg = "unhandled signal";
1747     }
1748
1749   __gnat_clear_exception_count ();
1750   Raise_From_Signal_Handler (exception, msg);
1751 }
1752
1753 static void
1754 __gnat_error_handler (int sig, int code, struct sigcontext *sc)
1755 {
1756   sigset_t mask;
1757   int result;
1758
1759   /* VxWorks will always mask out the signal during the signal handler and
1760      will reenable it on a longjmp.  GNAT does not generate a longjmp to
1761      return from a signal handler so the signal will still be masked unless
1762      we unmask it. */
1763   sigprocmask (SIG_SETMASK, NULL, &mask);
1764   sigdelset (&mask, sig);
1765   sigprocmask (SIG_SETMASK, &mask, NULL);
1766
1767   __gnat_map_signal (sig);
1768
1769 }
1770
1771 void
1772 __gnat_install_handler (void)
1773 {
1774   struct sigaction act;
1775
1776   /* Setup signal handler to map synchronous signals to appropriate
1777      exceptions.  Make sure that the handler isn't interrupted by another
1778      signal that might cause a scheduling event! */
1779
1780   act.sa_handler = __gnat_error_handler;
1781   act.sa_flags = SA_SIGINFO | SA_ONSTACK;
1782   sigemptyset (&act.sa_mask);
1783
1784   /* For VxWorks, install all signal handlers, since pragma Interrupt_State
1785      applies to vectored hardware interrupts, not signals */
1786   sigaction (SIGFPE,  &act, NULL);
1787   sigaction (SIGILL,  &act, NULL);
1788   sigaction (SIGSEGV, &act, NULL);
1789   sigaction (SIGBUS,  &act, NULL);
1790
1791   __gnat_handler_installed = 1;
1792 }
1793
1794 #define HAVE_GNAT_INIT_FLOAT
1795
1796 void
1797 __gnat_init_float (void)
1798 {
1799   /* Disable overflow/underflow exceptions on the PPC processor, this is needed
1800      to get correct Ada semantics.  Note that for AE653 vThreads, the HW
1801      overflow settings are an OS configuration issue.  The instructions
1802      below have no effect */
1803 #if defined (_ARCH_PPC) && !defined (_SOFT_FLOAT) && !defined (VTHREADS)
1804   asm ("mtfsb0 25");
1805   asm ("mtfsb0 26");
1806 #endif
1807
1808   /* Similarly for sparc64. Achieved by masking bits in the Trap Enable Mask
1809      field of the Floating-point Status Register (see the SPARC Architecture
1810      Manual Version 9, p 48).  */
1811 #if defined (sparc64)
1812
1813 #define FSR_TEM_NVM (1 << 27)  /* Invalid operand  */
1814 #define FSR_TEM_OFM (1 << 26)  /* Overflow  */
1815 #define FSR_TEM_UFM (1 << 25)  /* Underflow  */
1816 #define FSR_TEM_DZM (1 << 24)  /* Division by Zero  */
1817 #define FSR_TEM_NXM (1 << 23)  /* Inexact result  */
1818   {
1819     unsigned int fsr;
1820
1821     __asm__("st %%fsr, %0" : "=m" (fsr));
1822     fsr &= ~(FSR_TEM_OFM | FSR_TEM_UFM);
1823     __asm__("ld %0, %%fsr" : : "m" (fsr));
1824   }
1825 #endif
1826 }
1827
1828 /******************/
1829 /* NetBSD Section */
1830 /******************/
1831
1832 #elif defined(__NetBSD__)
1833
1834 #include <signal.h>
1835 #include <unistd.h>
1836
1837 static void
1838 __gnat_error_handler (int sig)
1839 {
1840   struct Exception_Data *exception;
1841   const char *msg;
1842
1843   switch(sig)
1844   {
1845     case SIGFPE:
1846       exception = &constraint_error;
1847       msg = "SIGFPE";
1848       break;
1849     case SIGILL:
1850       exception = &constraint_error;
1851       msg = "SIGILL";
1852       break;
1853     case SIGSEGV:
1854       exception = &storage_error;
1855       msg = "stack overflow or erroneous memory access";
1856       break;
1857     case SIGBUS:
1858       exception = &constraint_error;
1859       msg = "SIGBUS";
1860       break;
1861     default:
1862       exception = &program_error;
1863       msg = "unhandled signal";
1864     }
1865
1866     Raise_From_Signal_Handler(exception, msg);
1867 }
1868
1869 void
1870 __gnat_install_handler(void)
1871 {
1872   struct sigaction act;
1873
1874   act.sa_handler = __gnat_error_handler;
1875   act.sa_flags = SA_NODEFER | SA_RESTART;
1876   sigemptyset (&act.sa_mask);
1877
1878   /* Do not install handlers if interrupt state is "System" */
1879   if (__gnat_get_interrupt_state (SIGFPE) != 's')
1880     sigaction (SIGFPE,  &act, NULL);
1881   if (__gnat_get_interrupt_state (SIGILL) != 's')
1882     sigaction (SIGILL,  &act, NULL);
1883   if (__gnat_get_interrupt_state (SIGSEGV) != 's')
1884     sigaction (SIGSEGV, &act, NULL);
1885   if (__gnat_get_interrupt_state (SIGBUS) != 's')
1886     sigaction (SIGBUS,  &act, NULL);
1887
1888   __gnat_handler_installed = 1;
1889 }
1890
1891 #else
1892
1893 /* For all other versions of GNAT, the handler does nothing */
1894
1895 /*******************/
1896 /* Default Section */
1897 /*******************/
1898
1899 void
1900 __gnat_install_handler (void)
1901 {
1902   __gnat_handler_installed = 1;
1903 }
1904
1905 #endif
1906
1907 /*********************/
1908 /* __gnat_init_float */
1909 /*********************/
1910
1911 /* This routine is called as each process thread is created, for possible
1912    initialization of the FP processor. This version is used under INTERIX,
1913    WIN32 and could be used under OS/2 */
1914
1915 #if defined (_WIN32) || defined (__INTERIX) || defined (__EMX__) \
1916   || defined (__Lynx__) || defined(__NetBSD__) || defined(__FreeBSD__)
1917
1918 #define HAVE_GNAT_INIT_FLOAT
1919
1920 void
1921 __gnat_init_float (void)
1922 {
1923 #if defined (__i386__) || defined (i386)
1924
1925   /* This is used to properly initialize the FPU on an x86 for each
1926      process thread. */
1927
1928   asm ("finit");
1929
1930 #endif  /* Defined __i386__ */
1931 }
1932 #endif
1933
1934 #ifndef HAVE_GNAT_INIT_FLOAT
1935
1936 /* All targets without a specific __gnat_init_float will use an empty one */
1937 void
1938 __gnat_init_float (void)
1939 {
1940 }
1941 #endif
1942
1943 /***********************************/
1944 /* __gnat_adjust_context_for_raise */
1945 /***********************************/
1946
1947 #ifndef HAVE_GNAT_ADJUST_CONTEXT_FOR_RAISE
1948
1949 /* All targets without a specific version will use an empty one */
1950
1951 /* UCONTEXT is a pointer to a context structure received by a signal handler
1952    about to propagate an exception. Adjust it to compensate the fact that the
1953    generic unwinder thinks the corresponding PC is a call return address.  */
1954
1955 void
1956 __gnat_adjust_context_for_raise (int signo ATTRIBUTE_UNUSED,
1957                                  void *ucontext ATTRIBUTE_UNUSED)
1958 {
1959   /* The point is that the interrupted context PC typically is the address
1960      that we should search an EH region for, which is different from the call
1961      return address case. The target independent part of the GCC unwinder
1962      don't differentiate the two situations, so we compensate here for the
1963      adjustments it will blindly make.
1964
1965      signo is passed because on some targets for some signals the PC in
1966      context points to the instruction after the faulting one, in which case
1967      the unwinder adjustment is still desired.  */
1968
1969   /* On a number of targets, we have arranged for the adjustment to be
1970      performed by the MD_FALLBACK_FRAME_STATE circuitry, so we don't provide a
1971      specific instance of this routine.  The MD_FALLBACK doesn't have access
1972      to the signal number, though, so the compensation is systematic there and
1973      might be wrong in some cases.  */
1974
1975   /* Having the compensation wrong leads to potential failures.  A very
1976      typical case is what happens when there is no compensation and a signal
1977      triggers for the first instruction in a region : the unwinder adjustment
1978      has it search in the wrong EH region.  */
1979 }
1980
1981 #endif