home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / os2xcpt.c < prev    next >
C/C++ Source or Header  |  2000-12-05  |  33KB  |  1,003 lines
  1. /* -*-C-*-
  2.  
  3. $Id: os2xcpt.c,v 1.8 2000/12/05 21:23:46 cph Exp $
  4.  
  5. Copyright (c) 1994-2000 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. #include <stdarg.h>
  23. #include "scheme.h"
  24. #include "gccode.h"
  25. #include "os2.h"
  26.  
  27. extern int pc_to_utility_index (unsigned long);
  28. extern int pc_to_builtin_index (unsigned long);
  29. extern SCHEME_OBJECT * find_constant_space_block (SCHEME_OBJECT *);
  30. extern int OS2_disable_stack_guard (void *);
  31. extern int OS2_essential_thread_p (TID);
  32. extern void OS2_message_box (const char *, const char *, int);
  33.  
  34. extern ULONG C_Stack_Pointer;
  35. extern ULONG C_Frame_Pointer;
  36.  
  37. typedef enum
  38. {
  39.   trap_state_trapped,
  40.   trap_state_exit,
  41.   trap_state_suspend,
  42.   trap_state_recover,
  43.   trap_state_exitting_soft,
  44.   trap_state_exitting_hard
  45. } trap_state_t;
  46.  
  47. #define STATE_UNKNOWN        (LONG_TO_UNSIGNED_FIXNUM (0))
  48. #define STATE_PRIMITIVE        (LONG_TO_UNSIGNED_FIXNUM (1))
  49. #define STATE_COMPILED_CODE    (LONG_TO_UNSIGNED_FIXNUM (2))
  50. #define STATE_PROBABLY_COMPILED    (LONG_TO_UNSIGNED_FIXNUM (3))
  51.  
  52. typedef struct
  53. {
  54.   SCHEME_OBJECT state;
  55.   SCHEME_OBJECT pc_info_1;
  56.   SCHEME_OBJECT pc_info_2;
  57.   SCHEME_OBJECT extra_trap_info;
  58. } trap_recovery_info_t;
  59.  
  60. typedef struct
  61. {
  62.   ULONG number;
  63.   const char * name;
  64.   const char * description;
  65. } exception_entry_t;
  66.  
  67. #define PC_ALIGNMENT_MASK ((1 << PC_ZERO_BITS) - 1)
  68. #define SCHEME_ALIGNMENT_MASK ((sizeof (long)) - 1)
  69. #define FREE_PARANOIA_MARGIN 0x100
  70.  
  71. #ifdef HAS_COMPILER_SUPPORT
  72. #define ALLOW_ONLY_C 0
  73. #else
  74. #define ALLOW_ONLY_C 1
  75. #define PLAUSIBLE_CC_BLOCK_P(block) 0
  76. #endif
  77.  
  78. static ULONG find_program_end_address (void);
  79. extern ULONG APIENTRY OS2_exception_handler
  80.   (PEXCEPTIONREPORTRECORD, PEXCEPTIONREGISTRATIONRECORD, PCONTEXTRECORD,
  81.    PVOID);
  82. static void trap_immediate_termination (void);
  83. static void trap_normal_termination (void);
  84. static void trap_recover (PEXCEPTIONREPORTRECORD, PCONTEXTRECORD);
  85. static void continue_from_trap (PEXCEPTIONREPORTRECORD, PCONTEXTRECORD);
  86. static void do_abort_to_interpreter (void);
  87. static SCHEME_OBJECT * compiled_code_free (PCONTEXTRECORD);
  88. static SCHEME_OBJECT * interpreter_free (int force_gc);
  89. static SCHEME_OBJECT * find_block_address (char *, SCHEME_OBJECT *);
  90. static SCHEME_OBJECT * find_block_address_in_area (char *, SCHEME_OBJECT *);
  91. static void setup_trap_frame
  92.   (PEXCEPTIONREPORTRECORD, PCONTEXTRECORD, trap_recovery_info_t *,
  93.    SCHEME_OBJECT *);
  94. static exception_entry_t * find_exception_entry (ULONG);
  95. static const char * find_exception_name (ULONG);
  96. static void describe_exception (ULONG, int);
  97. static int isvowel (char);
  98. static void noise_start (void);
  99. static void noise (const char *, ...);
  100. static USHORT noise_end (const char *, ULONG);
  101.  
  102. static trap_state_t trap_state;
  103. static trap_state_t user_trap_state;
  104. static trap_state_t saved_trap_state;
  105. static ULONG saved_exception_number;
  106. static ULONG program_end_address;
  107.  
  108. void
  109. OS2_initialize_exception_handling (void)
  110. {
  111.   trap_state = trap_state_recover;
  112.   user_trap_state = trap_state_recover;
  113.   program_end_address = (find_program_end_address ());
  114. }
  115.  
  116. static ULONG
  117. find_program_end_address (void)
  118. {
  119.   /* The normal configuration for a C program is for the program text
  120.      to start at 0x10000 and go up contiguously from there.  */
  121.   ULONG start = 0x10000;    /* First 16 pages reserved for OS.  */
  122.   ULONG step = 0x1000;        /* 4k page size.  */
  123.   ULONG end = 0x20000000;    /* 512M maximum process address space.  */
  124.   ULONG flag_mask
  125.     = (PAG_FREE | PAG_READ | PAG_WRITE | PAG_EXECUTE | PAG_GUARD
  126.        | PAG_DEFAULT | PAG_SHARED | PAG_COMMIT);
  127.   ULONG program_flags        /* Permissions for program text pages.  */
  128.     = (PAG_READ | PAG_EXECUTE | PAG_COMMIT);
  129.   ULONG length = (end - start);
  130.   ULONG flags;
  131.   APIRET rc;
  132.  
  133.   rc = (DosQueryMem (((PVOID) start), (& length), (& flags)));
  134.   if (! ((rc == NO_ERROR) && ((flags & flag_mask) == program_flags)))
  135.     OS2_logic_error ("Error reading program text start address.");
  136.   while (1)
  137.     {
  138.       start += length;
  139.       length = (end - start);
  140.       rc = (DosQueryMem (((PVOID) start), (& length), (& flags)));
  141.       if (rc == NO_ERROR)
  142.     {
  143.       if ((flags & flag_mask) != program_flags)
  144.         return (start);
  145.     }
  146.       else if (rc == ERROR_INVALID_ADDRESS)
  147.     return (start);
  148.       else
  149.     OS2_logic_error ("Error from DosQueryMem.");
  150.     }
  151. }
  152.  
  153. void
  154. OS2_enter_interpreter (void (* enter_interpreter) (void))
  155. {
  156.   /* This registration record is required to be allocated on the C
  157.      stack, so we have to use this unusual mechanism to install the
  158.      trap-handling code.  */
  159.   EXCEPTIONREGISTRATIONRECORD registration;
  160.   (registration . ExceptionHandler) = OS2_exception_handler;
  161.   DosSetExceptionHandler (& registration);
  162.   (* enter_interpreter) ();
  163.   outf_fatal ("Exception!\n");
  164.   termination_trap ();
  165. }
  166.  
  167. trap_state_t
  168. OS_set_trap_state (trap_state_t state)
  169. {
  170.   trap_state_t old_trap_state = user_trap_state;
  171.   user_trap_state = state;
  172.   trap_state = state;
  173.   return (old_trap_state);
  174. }
  175.  
  176. ULONG APIENTRY
  177. OS2_exception_handler (PEXCEPTIONREPORTRECORD report,
  178.                PEXCEPTIONREGISTRATIONRECORD registration,
  179.                PCONTEXTRECORD context,
  180.                PVOID dispatcher_context)
  181. {
  182.   trap_state_t old_trap_state;
  183.   int stack_overflowed_p;
  184.   ULONG exception_number;
  185.   int recovery_unlikely_p = 0;
  186.  
  187.   /* We must ignore EH_NONCONTINUABLE exceptions because in order to
  188.      do the throw, the registers must be correctly configured for C,
  189.      and we accomplish this by bashing the context and returning with
  190.      XCPT_CONTINUE_EXECUTION from here.  */
  191.   if ((((report -> fHandlerFlags)
  192.     & (EH_UNWINDING | EH_EXIT_UNWIND | EH_STACK_INVALID | EH_NESTED_CALL
  193.        | EH_NONCONTINUABLE))
  194.        != 0)
  195.       || (! (((report -> ExceptionNum) == XCPT_ACCESS_VIOLATION)
  196.          || ((report -> ExceptionNum) == XCPT_ARRAY_BOUNDS_EXCEEDED)
  197.          || ((report -> ExceptionNum) == XCPT_DATATYPE_MISALIGNMENT)
  198.          || ((report -> ExceptionNum) == XCPT_FLOAT_DENORMAL_OPERAND)
  199.          || ((report -> ExceptionNum) == XCPT_FLOAT_DIVIDE_BY_ZERO)
  200.          || ((report -> ExceptionNum) == XCPT_FLOAT_INEXACT_RESULT)
  201.          || ((report -> ExceptionNum) == XCPT_FLOAT_INVALID_OPERATION)
  202.          || ((report -> ExceptionNum) == XCPT_FLOAT_OVERFLOW)
  203.          || ((report -> ExceptionNum) == XCPT_FLOAT_STACK_CHECK)
  204.          || ((report -> ExceptionNum) == XCPT_FLOAT_UNDERFLOW)
  205.          || ((report -> ExceptionNum) == XCPT_GUARD_PAGE_VIOLATION)
  206.          || ((report -> ExceptionNum) == XCPT_ILLEGAL_INSTRUCTION)
  207.          || ((report -> ExceptionNum) == XCPT_INTEGER_DIVIDE_BY_ZERO)
  208.          || ((report -> ExceptionNum) == XCPT_INTEGER_OVERFLOW)
  209.          || ((report -> ExceptionNum) == XCPT_INVALID_LOCK_SEQUENCE)
  210.          || ((report -> ExceptionNum) == XCPT_PRIVILEGED_INSTRUCTION))))
  211.     return (XCPT_CONTINUE_SEARCH);
  212.   exception_number = (report -> ExceptionNum);
  213.   stack_overflowed_p = (STACK_OVERFLOWED_P ());
  214.  
  215.   /* If this is a guard page violation, we're only interested if it
  216.      occurred in one of the Scheme stack guard pages.  Test this by
  217.      examining the second parameter, which is the address of the
  218.      access within the guard page.  `OS2_disable_stack_guard' will
  219.      perform this test, additionally disabling the guard page if it is
  220.      one of ours.  */
  221.   if (exception_number == XCPT_GUARD_PAGE_VIOLATION)
  222.     {
  223.       if (!OS2_disable_stack_guard ((void *) ((report -> ExceptionInfo) [1])))
  224.     return (XCPT_CONTINUE_SEARCH);
  225.       /* OK, we've determined that this is one of our guard pages, and
  226.      it has been disabled.  If `stack_overflowed_p' is true, we
  227.      can't recover cleanly and must terminate Scheme.  Otherwise,
  228.      we still have some maneuvering room -- so signal a Scheme
  229.      stack-overflow interrupt and continue.  When Scheme takes the
  230.      interrupt, it will do a throw, and the throw will re-enable
  231.      the stack guard.  */
  232.       if (!stack_overflowed_p)
  233.     {
  234.       REQUEST_INTERRUPT (INT_Stack_Overflow);
  235.       return (XCPT_CONTINUE_EXECUTION);
  236.     }
  237.     }
  238.  
  239.   old_trap_state = trap_state;
  240.   if (old_trap_state == trap_state_exitting_hard)
  241.     _exit (1);
  242.   if (old_trap_state == trap_state_exitting_soft)
  243.     trap_immediate_termination ();
  244.   trap_state = trap_state_trapped;
  245.  
  246.   noise_start ();
  247.   if (WITHIN_CRITICAL_SECTION_P ())
  248.     {
  249.       noise ("Scheme has detected ");
  250.       describe_exception (exception_number, 0);
  251.       noise (" within critical section \"%s\".  ", (CRITICAL_SECTION_NAME ()));
  252.     }
  253.   else if (stack_overflowed_p || (old_trap_state != trap_state_recover))
  254.     {
  255.       noise ("Scheme has detected ");
  256.       describe_exception (exception_number, 0);
  257.       noise (".  ");
  258.     }
  259.   if (stack_overflowed_p)
  260.     {
  261.       noise ("The stack has overflowed overwriting adjacent memory.  ");
  262.       noise ("This was probably caused by a runaway recursion.  ");
  263.     }
  264.  
  265.   switch (old_trap_state)
  266.     {
  267.     case trap_state_recover:
  268.       if ((WITHIN_CRITICAL_SECTION_P ()) || stack_overflowed_p)
  269.     {
  270.       noise ("Successful recovery is unlikely.  ");
  271.       recovery_unlikely_p = 1;
  272.       break;
  273.     }
  274.       saved_trap_state = old_trap_state;
  275.       saved_exception_number = exception_number;
  276.       (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
  277.       trap_recover (report, context);
  278.       return (XCPT_CONTINUE_EXECUTION);
  279.  
  280.     case trap_state_trapped:
  281.       if (saved_trap_state == trap_state_recover)
  282.     {
  283.       noise ("This occurred while attempting to recover from ");
  284.       describe_exception (saved_exception_number, 1);
  285.       noise (".  Successful recovery is ");
  286.       if (WITHIN_CRITICAL_SECTION_P ())
  287.         noise ("extremely ");
  288.       noise ("unlikely.  ");
  289.       recovery_unlikely_p = 1;
  290.       break;
  291.     }
  292.       (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
  293.       trap_immediate_termination ();
  294.       break;
  295.  
  296.     case trap_state_exit:
  297.       (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
  298.       termination_trap ();
  299.       break;
  300.     }
  301.  
  302.   noise ("\n\n");
  303.   saved_trap_state = old_trap_state;
  304.   saved_exception_number = exception_number;
  305.   {
  306.     int first_query = 1;
  307.     while (1)
  308.       {
  309.     noise ("Attempt recovery?");
  310.     if ((noise_end
  311.          ("Recovery Choice",
  312.           (MB_YESNO
  313.            | (first_query ? MB_ERROR : 0)
  314.            | (recovery_unlikely_p ? MB_DEFBUTTON2 : MB_DEFBUTTON1))))
  315.         == MBID_YES)
  316.       {
  317.         trap_recover (report, context);
  318.         return (XCPT_CONTINUE_EXECUTION);
  319.       }
  320.     else
  321.       {
  322.         first_query = 0;
  323.         noise ("Terminate Scheme normally?  ");
  324.         noise ("Selecting \"No\" terminates Scheme immediately ");
  325.         noise ("(without cleanup).  Selecting \"Cancel\" returns to ");
  326.         noise ("Recovery Choice dialog.");
  327.         switch (noise_end ("Termination Choices", (MB_YESNOCANCEL)))
  328.           {
  329.           case MBID_YES:
  330.         trap_normal_termination ();
  331.         break;
  332.           case MBID_NO:
  333.         trap_immediate_termination ();
  334.         _exit (1);
  335.         break;
  336.           }
  337.       }
  338.       }
  339.   }
  340.   return (XCPT_CONTINUE_SEARCH);
  341. }
  342.  
  343. static void
  344. trap_immediate_termination (void)
  345. {
  346.   extern void EXFUN (OS_restore_external_state, (void));
  347.   trap_state = trap_state_exitting_hard;
  348.   OS_restore_external_state ();
  349.   exit (1);
  350. }
  351.  
  352. static void
  353. trap_normal_termination (void)
  354. {
  355.   trap_state = trap_state_exitting_soft;
  356.   termination_trap ();
  357. }
  358.  
  359. static void
  360. trap_recover (PEXCEPTIONREPORTRECORD report, PCONTEXTRECORD context)
  361. {
  362.   if (WITHIN_CRITICAL_SECTION_P ())
  363.     {
  364.       CLEAR_CRITICAL_SECTION_HOOK ();
  365.       EXIT_CRITICAL_SECTION ({});
  366.     }
  367.   continue_from_trap (report, context);
  368. }
  369.  
  370. /* Heuristic recovery from processor traps/exceptions.
  371.  
  372.    continue_from_trap attempts to:
  373.  
  374.    1) validate the trap information (pc and sp);
  375.    2) determine whether compiled code was executing, a primitive was
  376.       executing, or execution was in the interpreter;
  377.    3) guess what C global state is still valid; and
  378.    4) set up a recovery frame for the interpreter so that debuggers
  379.       can display more information.  */
  380.  
  381. static void
  382. continue_from_trap (PEXCEPTIONREPORTRECORD report, PCONTEXTRECORD context)
  383. {
  384.   ULONG pc;
  385.   enum
  386.     {
  387.       pc_in_hyperspace,
  388.       pc_in_c,
  389.       pc_in_primitive,
  390.       pc_in_utility,
  391.       pc_in_builtin,
  392.       pc_in_heap
  393.     } pc_location;
  394.  
  395.   SCHEME_OBJECT * block_address;
  396.   trap_recovery_info_t trinfo;
  397.   SCHEME_OBJECT * new_sp;
  398.  
  399.   /* Punt if the context doesn't contain the registers we need to see.  */
  400.   if (((context -> ContextFlags) & CONTEXT_CONTROL) == 0)
  401.     {
  402.       (trinfo . state) = STATE_UNKNOWN;
  403.       (trinfo . pc_info_1) = SHARP_F;
  404.       (trinfo . pc_info_2) = SHARP_F;
  405.       (trinfo . extra_trap_info) = SHARP_F;
  406.       Free = (interpreter_free (1));
  407.       new_sp = 0;
  408.       goto done;
  409.     }
  410.  
  411.   /* Classify the PC location.  */
  412.   pc = (context -> ctx_RegEip);
  413.   if ((pc & PC_ALIGNMENT_MASK) != 0)
  414.     pc_location = pc_in_hyperspace;
  415.   else if (pc <= program_end_address)
  416.     {
  417.       if ((pc_to_builtin_index (pc)) != (-1))
  418.     pc_location = pc_in_builtin;
  419.       else if ((pc_to_utility_index (pc)) != (-1))
  420.     pc_location = pc_in_utility;
  421.       else if (PRIMITIVE_P (Regs [REGBLOCK_PRIMITIVE]))
  422.     pc_location = pc_in_primitive;
  423.       else
  424.     pc_location = pc_in_c;
  425.     }
  426.   else if (ALLOW_ONLY_C)
  427.     pc_location = pc_in_hyperspace;
  428.   else if ((((ULONG) Heap_Bottom) <= pc) && (pc < ((ULONG) Heap_Top)))
  429.     {
  430.       pc_location = pc_in_heap;
  431.       block_address = (find_block_address (((void *) pc), Heap_Bottom));
  432.     }
  433.   else if ((((ULONG) Constant_Space) <= pc) && (pc < ((ULONG) Constant_Top)))
  434.     {
  435.       pc_location = pc_in_heap;
  436.       block_address = (find_block_address (((void *) pc), Constant_Space));
  437.     }
  438.   else
  439.     pc_location = pc_in_hyperspace;
  440.  
  441.   /* Find Scheme's stack pointer.  */
  442.   switch (pc_location)
  443.     {
  444.     case pc_in_builtin:
  445.     case pc_in_heap:
  446.       new_sp = ((SCHEME_OBJECT *) (context -> ctx_RegEsp));
  447.       break;
  448.     case pc_in_utility:
  449.     case pc_in_primitive:
  450.     case pc_in_c:
  451.       new_sp = Stack_Pointer;
  452.       break;
  453.     default:
  454.       new_sp = 0;
  455.       break;
  456.     }
  457.   if (! ((Stack_Bottom <= new_sp)
  458.      && (new_sp < Stack_Top)
  459.      && ((((ULONG) new_sp) & SCHEME_ALIGNMENT_MASK) == 0)))
  460.     new_sp = 0;
  461.  
  462.   /* Build the trinfo structure.  */
  463.   switch (pc_location)
  464.     {
  465.     case pc_in_heap:
  466.       if (block_address != 0)
  467.     {
  468.       (trinfo . state) = STATE_COMPILED_CODE;
  469.       (trinfo . pc_info_1)
  470.         = (MAKE_POINTER_OBJECT (TC_COMPILED_CODE_BLOCK, block_address));
  471.       (trinfo . pc_info_2)
  472.         = (LONG_TO_UNSIGNED_FIXNUM (pc - ((ULONG) block_address)));
  473.     }
  474.       else
  475.     {
  476.       (trinfo . state) = STATE_PROBABLY_COMPILED;
  477.       (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (pc));
  478.       (trinfo . pc_info_2) = SHARP_F;
  479.     }
  480.       Free = (compiled_code_free (context));
  481.       break;
  482.     case pc_in_builtin:
  483.       (trinfo . state) = STATE_PROBABLY_COMPILED;
  484.       (trinfo . pc_info_1)
  485.     = (LONG_TO_UNSIGNED_FIXNUM (pc_to_builtin_index (pc)));
  486.       (trinfo . pc_info_2) = SHARP_T;
  487.       Free = (compiled_code_free (context));
  488.       break;
  489.     case pc_in_utility:
  490.       (trinfo . state) = STATE_PROBABLY_COMPILED;
  491.       (trinfo . pc_info_1)
  492.     = (LONG_TO_UNSIGNED_FIXNUM (pc_to_utility_index (pc)));
  493.       (trinfo . pc_info_2) = UNSPECIFIC;
  494.       Free = ((new_sp == 0) ? MemTop : (interpreter_free (0)));
  495.       break;
  496.     case pc_in_primitive:
  497.       (trinfo . state) = STATE_PRIMITIVE;
  498.       (trinfo . pc_info_1) = (Regs [REGBLOCK_PRIMITIVE]);
  499.       (trinfo . pc_info_2)
  500.     = (LONG_TO_UNSIGNED_FIXNUM (Regs [REGBLOCK_LEXPR_ACTUALS]));
  501.       Free = ((new_sp == 0) ? MemTop : (interpreter_free (0)));
  502.       break;
  503.     default:
  504.       (trinfo . state) = STATE_UNKNOWN;
  505.       (trinfo . pc_info_1) = SHARP_F;
  506.       (trinfo . pc_info_2) = SHARP_F;
  507.       Free = (interpreter_free (1));
  508.       break;
  509.     }
  510.   {
  511.     SCHEME_OBJECT v
  512.       = (allocate_non_marked_vector
  513.      (TC_NON_MARKED_VECTOR,
  514.       ((((context -> ContextFlags) & CONTEXT_INTEGER) == 0) ? 4 : 10),
  515.       0));
  516.     /* First two elements of vector must be PC and SP, in that order.  */
  517.     VECTOR_SET (v, 0, ((SCHEME_OBJECT) (context -> ctx_RegEip)));
  518.     VECTOR_SET (v, 1, ((SCHEME_OBJECT) (context -> ctx_RegEsp)));
  519.     VECTOR_SET (v, 2, ((SCHEME_OBJECT) (context -> ctx_RegEbp)));
  520.     VECTOR_SET (v, 3, ((SCHEME_OBJECT) (context -> ctx_EFlags)));
  521.     if (((context -> ContextFlags) & CONTEXT_INTEGER) != 0)
  522.       {
  523.     VECTOR_SET (v, 4, ((SCHEME_OBJECT) (context -> ctx_RegEdi)));
  524.     VECTOR_SET (v, 5, ((SCHEME_OBJECT) (context -> ctx_RegEsi)));
  525.     VECTOR_SET (v, 6, ((SCHEME_OBJECT) (context -> ctx_RegEax)));
  526.     VECTOR_SET (v, 7, ((SCHEME_OBJECT) (context -> ctx_RegEbx)));
  527.     VECTOR_SET (v, 8, ((SCHEME_OBJECT) (context -> ctx_RegEcx)));
  528.     VECTOR_SET (v, 9, ((SCHEME_OBJECT) (context -> ctx_RegEdx)));
  529.       }
  530.     (trinfo . extra_trap_info) = v;
  531.   }
  532.  done:
  533.   setup_trap_frame (report, context, (& trinfo), new_sp);
  534.  
  535.   /* If this was a hardware-generated floating-point exception, clear
  536.      the corresponding bit in the processor status word.  Otherwise
  537.      the exception will be resignalled when we restart.  */
  538.   if (((context -> ContextFlags) & CONTEXT_FLOATING_POINT) != 0)
  539.     switch (report -> ExceptionNum)
  540.       {
  541.       case XCPT_FLOAT_DENORMAL_OPERAND:
  542.     ((context -> ctx_env) [1]) &=~ 0x02;
  543.     break;
  544.       case XCPT_FLOAT_DIVIDE_BY_ZERO:
  545.     ((context -> ctx_env) [1]) &=~ 0x04;
  546.     break;
  547.       case XCPT_FLOAT_INEXACT_RESULT:
  548.     ((context -> ctx_env) [1]) &=~ 0x20;
  549.     break;
  550.       case XCPT_FLOAT_INVALID_OPERATION:
  551.     ((context -> ctx_env) [1]) &=~ 0x01;
  552.     break;
  553.       case XCPT_FLOAT_OVERFLOW:
  554.     ((context -> ctx_env) [1]) &=~ 0x08;
  555.     break;
  556.       case XCPT_FLOAT_UNDERFLOW:
  557.     ((context -> ctx_env) [1]) &=~ 0x10;
  558.     break;
  559.       }
  560.   /* Now attempt to continue.  This requires some trickery if the
  561.      registers are configured for Scheme compiled code, because
  562.      longjmp will fail unless the stack and frame pointers are set up
  563.      for C.  This is because of error checking that is built in to the
  564.      OS/2 exception handling mechanism: it checks the stack pointer to
  565.      make sure that the exception-handler registration records are on
  566.      the stack.  */
  567.   if (! ((pc_location == pc_in_builtin) || (pc_location == pc_in_heap)))
  568.     abort_to_interpreter (PRIM_APPLY);
  569.   (context -> ctx_RegEsp) = C_Stack_Pointer;
  570.   (context -> ctx_RegEbp) = C_Frame_Pointer;
  571.   (context -> ctx_RegEip) = ((ULONG) do_abort_to_interpreter);
  572. }
  573.  
  574. static void
  575. do_abort_to_interpreter (void)
  576. {
  577.   abort_to_interpreter (PRIM_APPLY);
  578. }
  579.  
  580. static SCHEME_OBJECT *
  581. compiled_code_free (PCONTEXTRECORD context)
  582. {
  583.   if (((context -> ContextFlags) & CONTEXT_INTEGER) != 0)
  584.     {
  585.       ULONG edi = (context -> ctx_RegEdi);
  586.       if (((edi & SCHEME_ALIGNMENT_MASK) == 0)
  587.       && (((ULONG) Heap_Bottom) <= edi)
  588.       && (edi < ((ULONG) Heap_Top)))
  589.     return (((SCHEME_OBJECT *) edi) + FREE_PARANOIA_MARGIN);
  590.     }
  591.   return (interpreter_free (1));
  592. }
  593.  
  594. static SCHEME_OBJECT *
  595. interpreter_free (int force_gc)
  596. {
  597.   return
  598.     ((((force_gc ? MemTop : Heap_Bottom) <= Free)
  599.       && (Free < Heap_Top)
  600.       && ((((ULONG) Free) & SCHEME_ALIGNMENT_MASK) == 0))
  601.      ? (((Free + FREE_PARANOIA_MARGIN) < MemTop)
  602.     ? (Free + FREE_PARANOIA_MARGIN)
  603.     : (Free < MemTop)
  604.     ? MemTop
  605.     : Free)
  606.      : MemTop);
  607. }
  608.  
  609. /* Find the compiled code block in area which contains `pc_value'.
  610.    This attempts to be more efficient than `find_block_address_in_area'.
  611.    If the pointer is in the heap, it can actually do twice as
  612.    much work, but it is expected to pay off on the average. */
  613.  
  614. #define MINIMUM_SCAN_RANGE        2048
  615.  
  616. static SCHEME_OBJECT *
  617. find_block_address (char * pc_value, SCHEME_OBJECT * area_start)
  618. {
  619.   if (area_start == Constant_Space)
  620.     {
  621.       SCHEME_OBJECT * constant_block =
  622.     (find_constant_space_block
  623.      ((SCHEME_OBJECT *)
  624.       (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK)));
  625.       return
  626.     ((constant_block == 0)
  627.      ? 0
  628.      : (find_block_address_in_area (pc_value, constant_block)));
  629.     }
  630.   {
  631.     SCHEME_OBJECT * nearest_word =
  632.       ((SCHEME_OBJECT *)
  633.        (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
  634.     long maximum_distance = (nearest_word - area_start);
  635.     long distance = maximum_distance;
  636.     while ((distance / 2) > MINIMUM_SCAN_RANGE)
  637.       distance = (distance / 2);
  638.     while ((distance * 2) < maximum_distance)
  639.       {
  640.     SCHEME_OBJECT * block =
  641.       (find_block_address_in_area (pc_value, (nearest_word - distance)));
  642.     if (block != 0)
  643.       return (block);
  644.     distance *= 2;
  645.       }
  646.   }
  647.   return (find_block_address_in_area (pc_value, area_start));
  648. }
  649.  
  650. /* Find the compiled code block in area which contains `pc_value', by
  651.    scanning sequentially the complete area.  For the time being, skip
  652.    over manifest closures and linkage sections. */
  653.  
  654. static SCHEME_OBJECT *
  655. find_block_address_in_area (char * pc_value, SCHEME_OBJECT * area_start)
  656. {
  657.   SCHEME_OBJECT * first_valid = area_start;
  658.   SCHEME_OBJECT * area = area_start;
  659.   while (((char *) area) < pc_value)
  660.     {
  661.       SCHEME_OBJECT object = (*area);
  662.       switch (OBJECT_TYPE (object))
  663.     {
  664.     case TC_LINKAGE_SECTION:
  665.       switch (READ_LINKAGE_KIND (object))
  666.         {
  667.         case GLOBAL_OPERATOR_LINKAGE_KIND:
  668.         case OPERATOR_LINKAGE_KIND:
  669.           {
  670.         long count = (READ_OPERATOR_LINKAGE_COUNT (object));
  671.         area = ((END_OPERATOR_LINKAGE_AREA (area, count)) + 1);
  672.           }
  673.           break;
  674.         case ASSIGNMENT_LINKAGE_KIND:
  675.         case CLOSURE_PATTERN_LINKAGE_KIND:
  676.         case REFERENCE_LINKAGE_KIND:
  677.         default:
  678.           area += ((READ_CACHE_LINKAGE_COUNT (object)) + 1);
  679.           break;
  680.         }
  681.       break;
  682.     case TC_MANIFEST_CLOSURE:
  683.       area += 1;
  684.       {
  685.         long count = (MANIFEST_CLOSURE_COUNT (area));
  686.         area = ((MANIFEST_CLOSURE_END (area, count)) + 1);
  687.       }
  688.       break;
  689.     case TC_MANIFEST_NM_VECTOR:
  690.       {
  691.         long count = (OBJECT_DATUM (object));
  692.         if (((char *) (area + (count + 1))) < pc_value)
  693.           {
  694.         area += (count + 1);
  695.         first_valid = area;
  696.         break;
  697.           }
  698.         {
  699.           SCHEME_OBJECT * block = (area - 1);
  700.           return
  701.         (((area == first_valid)
  702.           || ((OBJECT_TYPE (* block)) != TC_MANIFEST_VECTOR)
  703.           || ((OBJECT_DATUM (* block)) < ((unsigned long) (count + 1)))
  704.           || (! (PLAUSIBLE_CC_BLOCK_P (block))))
  705.          ? 0
  706.          : block);
  707.         }
  708.       }
  709.     default:
  710.       area += 1;
  711.       break;
  712.     }
  713.     }
  714.   return (0);
  715. }
  716.  
  717. static void
  718. setup_trap_frame (PEXCEPTIONREPORTRECORD report,
  719.           PCONTEXTRECORD context,
  720.           trap_recovery_info_t * trinfo,
  721.           SCHEME_OBJECT * new_sp)
  722. {
  723.   long saved_mask;
  724.   SCHEME_OBJECT handler;
  725.   SCHEME_OBJECT trap_name;
  726.  
  727.   /* Disable interrupts while building stack frame.  */
  728.   saved_mask = (FETCH_INTERRUPT_MASK ());
  729.   SET_INTERRUPT_MASK (0);
  730.  
  731.   /* Get the trap handler -- lose if there isn't one.  */
  732.   handler
  733.     = ((Valid_Fixed_Obj_Vector ())
  734.        ? (Get_Fixed_Obj_Slot (Trap_Handler))
  735.        : SHARP_F);
  736.   if (handler == SHARP_F)
  737.     {
  738.       noise_start ();
  739.       noise ("There is no trap handler for recovery!\n");
  740.       noise ("This occurred during ");
  741.       describe_exception ((report -> ExceptionNum), 0);
  742.       noise (".\n");
  743.       noise ("pc = 0x%08x; sp = 0x%08x.\n",
  744.          (context -> ctx_RegEip), (context -> ctx_RegEsp));
  745.       (void) noise_end ("Exception Info", (MB_OK | MB_ERROR));
  746.       termination_trap ();
  747.     }
  748.  
  749.   /* Set the GC interrupt bit if necessary.  */
  750.   if (Free >= MemTop)
  751.     Request_GC (0);
  752.  
  753.   /* Make sure the stack is correctly initialized.  */
  754.   if (new_sp != 0)
  755.     Stack_Pointer = new_sp;
  756.   else
  757.     {
  758.       INITIALIZE_STACK ();
  759.      Will_Push (CONTINUATION_SIZE);
  760.       Store_Return (RC_END_OF_COMPUTATION);
  761.       Store_Expression (SHARP_F);
  762.       Save_Cont ();
  763.      Pushed ();
  764.     }
  765.   {
  766.     const char * name = (find_exception_name (report -> ExceptionNum));
  767.     trap_name
  768.       = ((name == 0) ? SHARP_F : (char_pointer_to_string ((char *) name)));
  769.   }
  770.   /* Push the hardware-trap stack frame.  The continuation parser will
  771.      find this and use it to present meaningful debugging information
  772.      to the user.  */
  773.  Will_Push (7 + CONTINUATION_SIZE);
  774.   STACK_PUSH (trinfo -> extra_trap_info);
  775.   STACK_PUSH (trinfo -> pc_info_2);
  776.   STACK_PUSH (trinfo -> pc_info_1);
  777.   STACK_PUSH (trinfo -> state);
  778.   STACK_PUSH (BOOLEAN_TO_OBJECT (new_sp != 0));
  779.   STACK_PUSH (long_to_integer (report -> ExceptionNum));
  780.   STACK_PUSH (trap_name);
  781.   Store_Return (RC_HARDWARE_TRAP);
  782.   Store_Expression (UNSPECIFIC);
  783.   Save_Cont ();
  784.  Pushed ();
  785.  
  786.   /* Make sure the history register is properly initialized.  */
  787.   if ((new_sp != 0) && ((trinfo -> state) == STATE_COMPILED_CODE))
  788.     Stop_History ();
  789.   History = (Make_Dummy_History ());
  790.  
  791.   /* Push the call frame for the trap handler.  */
  792.  Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
  793.   STACK_PUSH (trap_name);
  794.   STACK_PUSH (handler);
  795.   STACK_PUSH (STACK_FRAME_HEADER + 1);
  796.  Pushed ();
  797.  
  798.   /* Restore the interrupt mask and call the handler.  */
  799.   SET_INTERRUPT_MASK (saved_mask);
  800. }
  801.  
  802. #define EXCEPTION_ENTRY(name, description) { name, #name, description }
  803. static exception_entry_t exception_names [] =
  804. {
  805.   EXCEPTION_ENTRY (XCPT_ACCESS_VIOLATION, "access violation"),
  806.   EXCEPTION_ENTRY (XCPT_ARRAY_BOUNDS_EXCEEDED, "array bounds exceeded"),
  807.   EXCEPTION_ENTRY (XCPT_ASYNC_PROCESS_TERMINATE, "async process terminate"),
  808. #ifdef XCPT_B1NPX_ERRATA_02
  809.   EXCEPTION_ENTRY (XCPT_B1NPX_ERRATA_02, "B1NPX errata"),
  810. #endif
  811.   EXCEPTION_ENTRY (XCPT_BAD_STACK, "bad stack"),
  812.   EXCEPTION_ENTRY (XCPT_BREAKPOINT, "breakpoint"),
  813.   EXCEPTION_ENTRY (XCPT_DATATYPE_MISALIGNMENT, "data type misalignment"),
  814.   EXCEPTION_ENTRY (XCPT_FLOAT_DENORMAL_OPERAND,
  815.            "floating point denormal operand"),
  816.   EXCEPTION_ENTRY (XCPT_FLOAT_DIVIDE_BY_ZERO, "floating point divide by zero"),
  817.   EXCEPTION_ENTRY (XCPT_FLOAT_INEXACT_RESULT, "floating point inexact result"),
  818.   EXCEPTION_ENTRY (XCPT_FLOAT_INVALID_OPERATION,
  819.            "floating point invalid operation"),
  820.   EXCEPTION_ENTRY (XCPT_FLOAT_OVERFLOW, "floating point overflow"),
  821.   EXCEPTION_ENTRY (XCPT_FLOAT_STACK_CHECK, "floating point stack check"),
  822.   EXCEPTION_ENTRY (XCPT_FLOAT_UNDERFLOW, "floating point underflow"),
  823.   EXCEPTION_ENTRY (XCPT_GUARD_PAGE_VIOLATION, "guard page violation"),
  824.   EXCEPTION_ENTRY (XCPT_ILLEGAL_INSTRUCTION, "illegal instruction"),
  825.   EXCEPTION_ENTRY (XCPT_INTEGER_DIVIDE_BY_ZERO, "integer divide by zero"),
  826.   EXCEPTION_ENTRY (XCPT_INTEGER_OVERFLOW, "integer overflow"),
  827.   EXCEPTION_ENTRY (XCPT_INVALID_DISPOSITION, "invalid disposition"),
  828.   EXCEPTION_ENTRY (XCPT_INVALID_LOCK_SEQUENCE, "invalid lock sequence"),
  829.   EXCEPTION_ENTRY (XCPT_INVALID_UNWIND_TARGET, "invalid unwind target"),
  830.   EXCEPTION_ENTRY (XCPT_IN_PAGE_ERROR, "in-page error"),
  831.   EXCEPTION_ENTRY (XCPT_NONCONTINUABLE_EXCEPTION, "noncontinuable exception"),
  832.   EXCEPTION_ENTRY (XCPT_PRIVILEGED_INSTRUCTION, "privileged instruction"),
  833.   EXCEPTION_ENTRY (XCPT_PROCESS_TERMINATE, "process terminate"),
  834.   EXCEPTION_ENTRY (XCPT_SIGNAL, "signal"),
  835.   EXCEPTION_ENTRY (XCPT_SINGLE_STEP, "single step"),
  836.   EXCEPTION_ENTRY (XCPT_UNABLE_TO_GROW_STACK, "unable to grow stack"),
  837.   EXCEPTION_ENTRY (XCPT_UNWIND, "unwind")
  838. };
  839.  
  840. static exception_entry_t *
  841. find_exception_entry (ULONG exception_number)
  842. {
  843.   unsigned int i = 0;
  844.   unsigned int end
  845.     = ((sizeof (exception_names)) / (sizeof (exception_entry_t)));
  846.   while (i < end)
  847.     {
  848.       if (exception_number == ((exception_names [i]) . number))
  849.     return (& (exception_names [i]));
  850.       i += 1;
  851.     }
  852.   return (0);
  853. }
  854.  
  855. static const char *
  856. find_exception_name (ULONG exception_number)
  857. {
  858.   exception_entry_t * entry = (find_exception_entry (exception_number));
  859.   return ((entry == 0) ? 0 : (entry -> name));
  860. }
  861.  
  862. static void
  863. describe_exception (ULONG exception_number, int earlierp)
  864. {
  865.   exception_entry_t * entry = (find_exception_entry (exception_number));
  866.   const char * prefix = (earlierp ? "earlier " : "");
  867.   if (entry == 0)
  868.     noise ("an %sunknown exception [code = %d]", prefix, exception_number);
  869.   else
  870.     noise ("a%s %s%s exception",
  871.        ((earlierp || (isvowel ((entry -> description) [0]))) ? "n" : ""),
  872.        prefix,
  873.        (entry -> description));
  874. }
  875.  
  876. static int
  877. isvowel (char c)
  878. {
  879.   return
  880.     ((c == 'a') || (c == 'e') || (c == 'i') || (c == 'o') || (c == 'u')
  881.      || (c == 'A') || (c == 'E') || (c == 'I') || (c == 'O') || (c == 'U'));
  882. }
  883.  
  884. static char * noise_accumulator;
  885. static char * noise_accumulator_position;
  886.  
  887. static void
  888. noise_start (void)
  889. {
  890.   noise_accumulator = 0;
  891.   noise_accumulator_position = 0;
  892. }
  893.  
  894. static void
  895. noise (const char * format, ...)
  896. {
  897.   unsigned int index = (noise_accumulator_position - noise_accumulator);
  898.   noise_accumulator
  899.     = ((noise_accumulator == 0)
  900.        ? (OS_malloc (256))
  901.        : (OS_realloc (noise_accumulator, (index + 256))));
  902.   noise_accumulator_position = (noise_accumulator + index);
  903.   {
  904.     va_list arg_pointer;
  905.     va_start (arg_pointer, format);
  906.     noise_accumulator_position
  907.       += (vsprintf (noise_accumulator_position, format, arg_pointer));
  908.     va_end (arg_pointer);
  909.   }
  910. }
  911.  
  912. static USHORT
  913. noise_end (const char * title, ULONG style)
  914. {
  915.   if (noise_accumulator == 0)
  916.     return (MBID_YES);
  917.   {
  918.     USHORT rc
  919.       = (WinMessageBox (HWND_DESKTOP,
  920.             NULLHANDLE, /* client window handle */
  921.             noise_accumulator,
  922.             ((char *) title),
  923.             0,
  924.             style));
  925.     OS_free (noise_accumulator);
  926.     noise_accumulator = 0;
  927.     noise_accumulator_position = 0;
  928.     return (rc);
  929.   }
  930. }
  931.  
  932. ULONG APIENTRY
  933. OS2_subthread_exception_handler (PEXCEPTIONREPORTRECORD report,
  934.                  PEXCEPTIONREGISTRATIONRECORD registration,
  935.                  PCONTEXTRECORD context,
  936.                  PVOID dispatcher_context)
  937. {
  938.   ULONG exception_number;
  939.   PTIB ptib;
  940.   PPIB ppib;
  941.   TID tid;
  942.   char * format
  943.     = "Scheme has detected exception number 0x%08x within thread %d.%s%s\
  944.   This indicates a bug in the Scheme implementation.\
  945.   Please report this information to a Scheme wizard.\n\n";
  946.   char backtrace [1024];
  947.  
  948.   if (((report -> fHandlerFlags)
  949.        & (EH_UNWINDING | EH_EXIT_UNWIND | EH_STACK_INVALID | EH_NESTED_CALL))
  950.       != 0)
  951.     return (XCPT_CONTINUE_SEARCH);
  952.   exception_number = (report -> ExceptionNum);
  953.   if (! ((exception_number == XCPT_ACCESS_VIOLATION)
  954.      || (exception_number == XCPT_ARRAY_BOUNDS_EXCEEDED)
  955.      || (exception_number == XCPT_DATATYPE_MISALIGNMENT)
  956.      || (exception_number == XCPT_FLOAT_DENORMAL_OPERAND)
  957.      || (exception_number == XCPT_FLOAT_DIVIDE_BY_ZERO)
  958.      || (exception_number == XCPT_FLOAT_INEXACT_RESULT)
  959.      || (exception_number == XCPT_FLOAT_INVALID_OPERATION)
  960.      || (exception_number == XCPT_FLOAT_OVERFLOW)
  961.      || (exception_number == XCPT_FLOAT_STACK_CHECK)
  962.      || (exception_number == XCPT_FLOAT_UNDERFLOW)
  963.      || (exception_number == XCPT_ILLEGAL_INSTRUCTION)
  964.      || (exception_number == XCPT_INTEGER_DIVIDE_BY_ZERO)
  965.      || (exception_number == XCPT_INTEGER_OVERFLOW)
  966.      || (exception_number == XCPT_INVALID_LOCK_SEQUENCE)
  967.      || (exception_number == XCPT_PRIVILEGED_INSTRUCTION)))
  968.     return (XCPT_CONTINUE_SEARCH);
  969.   (void) dos_get_info_blocks ((&ptib), (&ppib));
  970.   if (((context -> ContextFlags) & CONTEXT_CONTROL) == 0)
  971.     (backtrace[0]) = '\0';
  972.   else
  973.     {
  974.       ULONG * ebp = ((ULONG *) (context -> ctx_RegEbp));
  975.       unsigned int count = 0;
  976.       sprintf (backtrace, "  (Backtrace:");
  977.       sprintf ((backtrace + (strlen (backtrace))), " 0x%08x",
  978.            (context -> ctx_RegEip));
  979.       while ((((char *) ebp) > ((char *) (ptib -> tib_pstack)))
  980.          && (((char *) ebp) < ((char *) (ptib -> tib_pstacklimit)))
  981.          && (count < 10))
  982.     {
  983.       sprintf ((backtrace + (strlen (backtrace))), " 0x%08x", (ebp[1]));
  984.       ebp = ((ULONG *) (ebp[0]));
  985.     }
  986.       sprintf ((backtrace + (strlen (backtrace))), ")");
  987.     }
  988.   tid = (ptib -> tib_ptib2 -> tib2_ultid);
  989.   if (OS2_essential_thread_p (tid))
  990.     {
  991.       outf_fatal (format, exception_number, tid, backtrace, "");
  992.       termination_init_error ();
  993.     }
  994.   else
  995.     {
  996.       char buffer [1024];
  997.       sprintf (buffer, format, exception_number, tid, backtrace,
  998.            "  The thread will be killed.");
  999.       OS2_message_box ("Scheme Error", buffer, 0);
  1000.       OS2_endthread ();
  1001.     }
  1002. }
  1003.