1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 #include "scheme.h"
28 #include "history.h"
29 #include "os.h"
30 #include "nt.h"
31 #include "nttrap.h"
32 #include "gccode.h"
33 #include "ntscmlib.h"
34 #include <windows.h>
35
36 #ifdef __OPEN_WATCOM_14__
37 # include <excpt.h>
38 #endif
39
40 #ifdef W32_TRAP_DEBUG
41 extern char * AskUser (char *, int);
42 extern int TellUser (char *, ...);
43 extern int TellUserEx (int, char *, ...);
44 #endif /* W32_TRAP_DEBUG */
45
46 extern void callWinntExceptionTransferHook (void);
47 extern void NT_initialize_traps (void);
48 extern void NT_restore_traps (void);
49
50 extern DWORD
51 C_Stack_Pointer,
52 C_Frame_Pointer;
53
54 #ifdef W32_TRAP_DEBUG
55
56 static BOOL trap_verbose_p = FALSE;
57
58 #define IFVERBOSE(command) do \
59 { \
60 if (trap_verbose_p) \
61 { \
62 int result = (command); \
63 if (result == IDCANCEL) \
64 trap_verbose_p = FALSE; \
65 } \
66 } while (0)
67
68 #else
69 # define IFVERBOSE(command) do { } while (0)
70 #endif
71
72 static char * trap_output = ((char *) NULL);
73 static char * trap_output_pointer = ((char *) NULL);
74
75 static void
trap_noise_start(void)76 trap_noise_start (void)
77 {
78 trap_output = ((char *) NULL);
79 trap_output_pointer = ((char *) NULL);
80 return;
81 }
82
83 static void
trap_noise(const char * format,...)84 trap_noise (const char * format, ...)
85 {
86 va_list arg_ptr;
87 unsigned long size;
88 char * temp;
89
90 size = (trap_output_pointer - trap_output);
91 temp = ((trap_output == ((char *) NULL))
92 ? ((char *) (malloc (256)))
93 : ((char *) (realloc (trap_output, (256 + size)))));
94 if (temp == ((char *) NULL))
95 return;
96
97 trap_output = temp;
98 trap_output_pointer = (temp + size);
99 va_start (arg_ptr, format);
100 size = (wvsprintf (trap_output_pointer, format, arg_ptr));
101 trap_output_pointer += size;
102 va_end (arg_ptr);
103 return;
104 }
105
106 static int
trap_noise_end(UINT style)107 trap_noise_end (UINT style)
108 {
109 int value;
110
111 if (trap_output == ((char *) NULL))
112 return (IDYES);
113
114 value = (MessageBox (NULL,
115 trap_output,
116 "MIT/GNU Scheme Exception Information",
117 style));
118 free (trap_output);
119 trap_output = ((char *) NULL);
120 trap_output_pointer = ((char *) NULL);
121 return (value);
122 }
123
124 static BOOL
isvowel(char c)125 isvowel (char c)
126 {
127 switch (c)
128 {
129 case 'a':
130 case 'e':
131 case 'i':
132 case 'o':
133 case 'u':
134 case 'A':
135 case 'E':
136 case 'I':
137 case 'O':
138 case 'U':
139 return (TRUE);
140
141 default:
142 return (FALSE);
143 }
144 }
145
146 struct exception_name_s
147 {
148 DWORD code;
149 char * name;
150 };
151
152 static struct exception_name_s exception_names[] =
153 {
154 {
155 EXCEPTION_ACCESS_VIOLATION,
156 "ACCESS_VIOLATION",
157 },
158 {
159 EXCEPTION_DATATYPE_MISALIGNMENT,
160 "DATATYPE_MISALIGNMENT",
161 },
162 {
163 EXCEPTION_BREAKPOINT,
164 "BREAKPOINT",
165 },
166 {
167 EXCEPTION_SINGLE_STEP,
168 "SINGLE_STEP",
169 },
170 {
171 EXCEPTION_ARRAY_BOUNDS_EXCEEDED,
172 "ARRAY_BOUNDS_EXCEEDED",
173 },
174 {
175 EXCEPTION_FLT_DENORMAL_OPERAND,
176 "FLT_DENORMAL_OPERAND",
177 },
178 {
179 EXCEPTION_FLT_DIVIDE_BY_ZERO,
180 "FLT_DIVIDE_BY_ZERO",
181 },
182 {
183 EXCEPTION_FLT_INEXACT_RESULT,
184 "FLT_INEXACT_RESULT",
185 },
186 {
187 EXCEPTION_FLT_INVALID_OPERATION,
188 "FLT_INVALID_OPERATION",
189 },
190 {
191 EXCEPTION_FLT_OVERFLOW,
192 "FLT_OVERFLOW",
193 },
194 {
195 EXCEPTION_FLT_STACK_CHECK,
196 "FLT_STACK_CHECK",
197 },
198 {
199 EXCEPTION_FLT_UNDERFLOW,
200 "FLT_UNDERFLOW",
201 },
202 {
203 EXCEPTION_INT_DIVIDE_BY_ZERO,
204 "INT_DIVIDE_BY_ZERO",
205 },
206 {
207 EXCEPTION_INT_OVERFLOW,
208 "INT_OVERFLOW",
209 },
210
211 {
212 EXCEPTION_PRIV_INSTRUCTION,
213 "PRIV_INSTRUCTION",
214 },
215 {
216 EXCEPTION_IN_PAGE_ERROR,
217 "IN_PAGE_ERROR",
218 },
219 {
220 EXCEPTION_ILLEGAL_INSTRUCTION,
221 "ILLEGAL_INSTRUCTION",
222 },
223 {
224 EXCEPTION_NONCONTINUABLE_EXCEPTION,
225 "NONCONTINUABLE_EXCEPTION",
226 },
227 {
228 EXCEPTION_STACK_OVERFLOW,
229 "STACK_OVERFLOW",
230 },
231 {
232 EXCEPTION_INVALID_DISPOSITION,
233 "INVALID_DISPOSITION",
234 },
235 };
236
237 const int excp_name_limit = ((sizeof (exception_names))
238 / (sizeof (struct exception_name_s)));
239
240 static char *
find_exception_name(DWORD code)241 find_exception_name (DWORD code)
242 {
243 int i;
244
245 for (i = 0; i < excp_name_limit; i++)
246 if (exception_names[i].code == code)
247 return (exception_names[i].name);
248 return ((char *) NULL);
249 }
250
251 static void
describe_trap(char * noise,DWORD code)252 describe_trap (char * noise, DWORD code)
253 {
254 char * name;
255
256 name = (find_exception_name (code));
257 if (name == ((char *) NULL))
258 trap_noise (">> The %s an unknown trap [code = %d].\n",
259 noise, code);
260 else
261 trap_noise (">> The %s a%s %s trap.\n",
262 noise,
263 ((isvowel (name[0])) ? "n" : ""),
264 name);
265 return;
266 }
267
268 #define STATE_UNKNOWN (LONG_TO_UNSIGNED_FIXNUM (0))
269 #define STATE_PRIMITIVE (LONG_TO_UNSIGNED_FIXNUM (1))
270 #define STATE_COMPILED_CODE (LONG_TO_UNSIGNED_FIXNUM (2))
271 #define STATE_PROBABLY_COMPILED (LONG_TO_UNSIGNED_FIXNUM (3))
272
273 struct trap_recovery_info
274 {
275 SCHEME_OBJECT state;
276 SCHEME_OBJECT pc_info_1;
277 SCHEME_OBJECT pc_info_2;
278 SCHEME_OBJECT extra_trap_info;
279 };
280
281 static struct trap_recovery_info dummy_recovery_info =
282 {
283 STATE_UNKNOWN,
284 SHARP_F,
285 SHARP_F,
286 SHARP_F
287 };
288
289 struct nt_trap_code_desc
290 {
291 int trapno;
292 unsigned long code_mask;
293 unsigned long code_value;
294 char *name;
295 };
296
297 static enum trap_state trap_state;
298 static enum trap_state user_trap_state;
299
300 static enum trap_state saved_trap_state;
301 static DWORD saved_trap_code;
302
303 enum trap_state
OS_set_trap_state(enum trap_state state)304 OS_set_trap_state (enum trap_state state)
305 {
306 enum trap_state old_trap_state = user_trap_state;
307
308 user_trap_state = state;
309 trap_state = state;
310 return (old_trap_state);
311 }
312
313 static void
trap_normal_termination(void)314 trap_normal_termination (void)
315 {
316 trap_state = trap_state_exitting_soft;
317 termination_trap ();
318 }
319
320 static void
trap_immediate_termination(void)321 trap_immediate_termination (void)
322 {
323 extern void OS_restore_external_state (void);
324
325 trap_state = trap_state_exitting_hard;
326 OS_restore_external_state ();
327 exit (1);
328 }
329
330 void
NT_initialize_traps(void)331 NT_initialize_traps (void)
332 {
333 trap_state = trap_state_recover;
334 user_trap_state = trap_state_recover;
335 (void) SetErrorMode (SEM_FAILCRITICALERRORS | SEM_NOGPFAULTERRORBOX);
336 }
337
338 void
NT_restore_traps(void)339 NT_restore_traps (void)
340 {
341 return;
342 }
343
344 static int
display_exception_information(PEXCEPTION_RECORD info,PCONTEXT context,int flags)345 display_exception_information (PEXCEPTION_RECORD info, PCONTEXT context, int flags)
346 {
347 int value;
348 char msgbuf[4096];
349 char * flag, * name, * bufptr;
350
351 bufptr = &msgbuf[0];
352 name = (find_exception_name (info->ExceptionCode));
353 flag = ((info->ExceptionFlags == 0) ? "Continuable" : "Non-continuable");
354 if (name == ((char *) NULL))
355 bufptr
356 += (sprintf (bufptr, "%s Unknown Exception %d Raised at address %#lx",
357 flag, info->ExceptionCode, info->ExceptionAddress));
358 else
359 bufptr += (sprintf (bufptr, "%s %s Exception Raised at address %#lx",
360 flag, name, info->ExceptionAddress));
361
362 #ifdef W32_TRAP_DEBUG
363 if (context == ((PCONTEXT) NULL))
364 bufptr += (sprintf (bufptr, "\nContext is NULL."));
365 else
366 {
367 if ((context->ContextFlags & CONTEXT_CONTROL) != 0)
368 bufptr += (sprintf (bufptr,
369 "\nContext contains CONTROL information."));
370 if ((context->ContextFlags & CONTEXT_INTEGER) != 0)
371 bufptr += (sprintf (bufptr,
372 "\nContext contains INTEGER registers."));
373 if ((context->ContextFlags & CONTEXT_SEGMENTS) != 0)
374 bufptr += (sprintf (bufptr,
375 "\nContext contains SEGMENT registers."));
376 if ((context->ContextFlags & CONTEXT_FLOATING_POINT) != 0)
377 bufptr += (sprintf (bufptr,
378 "\nContext contains floating-point registers."));
379 bufptr
380 += (sprintf (bufptr, "\ncontext->Eip = %#lx.", context->Eip));
381 bufptr
382 += (sprintf (bufptr, "\ncontext->Esp = %#lx.", context->Esp));
383 bufptr += (sprintf (bufptr, "\nstack_pointer = %#lx.",
384 stack_pointer));
385 bufptr += (sprintf (bufptr, "\nadj (stack_pointer) = %#lx.",
386 ((unsigned long) stack_pointer)));
387 }
388 #endif /* W32_TRAP_DEBUG */
389
390 info = info->ExceptionRecord;
391 if (info != ((PEXCEPTION_RECORD) NULL))
392 bufptr += (sprintf (bufptr,
393 "\nTrap occurred within an earlier trap."));
394
395 #ifdef W32_TRAP_DEBUG
396 if (flags == MB_YESNO)
397 bufptr += (sprintf (bufptr, "\n\nDisplay More Information?"));
398 #else /* not W32_TRAP_DEBUG */
399 flags = MB_OK;
400 bufptr +=
401 (sprintf (bufptr,
402 "\n\nScheme cannot find the state necessary to continue."));
403 #endif /* W32_TRAP_DEBUG */
404
405 value = (MessageBox (NULL, &msgbuf[0],
406 "MIT/GNU Scheme Exception Info",
407 (flags | MB_ICONSTOP)));
408 return (value);
409 }
410
411 #define TEMP_STACK_LEN 2048 /* objects */
412
413 static BOOL
414 return_by_aborting,
415 clear_real_stack;
416
417 static SCHEME_OBJECT
418 temp_stack_buffer[TEMP_STACK_LEN],
419 * temp_stack = &temp_stack_buffer[0],
420 * temp_stack_end = &temp_stack_buffer[TEMP_STACK_LEN],
421 * temp_stack_limit,
422 * real_stack_guard,
423 * real_stack_pointer;
424
425 int
WinntExceptionTransferHook(void)426 WinntExceptionTransferHook (void)
427 {
428 /* These must be static because the memcpy below may
429 be overwriting this procedure's locals!
430 */
431
432 static int size;
433 static SCHEME_OBJECT * temp_stack_ptr, * new_sp;
434
435 temp_stack_ptr = stack_pointer;
436 size = (temp_stack_limit - temp_stack_ptr);
437 IFVERBOSE (TellUserEx (MB_OKCANCEL, "WinntExceptionTransferHook."));
438
439 if (clear_real_stack)
440 INITIALIZE_STACK ();
441 else
442 {
443 stack_pointer = real_stack_pointer;
444 stack_guard = real_stack_guard;
445 }
446
447 new_sp = (real_stack_pointer - size);
448 if (new_sp != temp_stack_ptr)
449 memcpy (new_sp, temp_stack_ptr, (size * (sizeof (SCHEME_OBJECT))));
450 stack_pointer = new_sp;
451 SET_INTERRUPT_MASK (GET_INT_MASK);
452 if (return_by_aborting)
453 abort_to_interpreter (PRIM_APPLY);
454 return (PRIM_APPLY);
455 }
456
457 extern unsigned short __cdecl getCS (void);
458 extern unsigned short __cdecl getDS (void);
459
460 static void
setup_trap_frame(DWORD code,PCONTEXT context,struct trap_recovery_info * trinfo,SCHEME_OBJECT * new_stack_pointer)461 setup_trap_frame (DWORD code,
462 PCONTEXT context,
463 struct trap_recovery_info * trinfo,
464 SCHEME_OBJECT * new_stack_pointer)
465 {
466 SCHEME_OBJECT trap_name, trap_code;
467 SCHEME_OBJECT handler;
468 int stack_recovered_p = (new_stack_pointer != 0);
469 unsigned long saved_mask = GET_INT_MASK;
470 SET_INTERRUPT_MASK (0); /* To prevent GC for now. */
471
472 IFVERBOSE (TellUserEx (MB_OKCANCEL,
473 "setup_trap_frame (%s, %#lx, %s, %#lx, %#lx).",
474 (find_exception_name (code)),
475 context,
476 trinfo,
477 new_stack_pointer));
478 handler
479 = ((VECTOR_P (fixed_objects))
480 ? (VECTOR_REF (fixed_objects, TRAP_HANDLER))
481 : SHARP_F);
482 if (!INTERPRETER_APPLICABLE_P (handler))
483 {
484 trap_noise_start ();
485 trap_noise ("There is no trap handler for recovery!\n");
486 describe_trap ("trap is", code);
487 (void) trap_noise_end (MB_OK | MB_ICONSTOP);
488 termination_trap ();
489 }
490 if (!FREE_OK_P (Free))
491 REQUEST_GC (0);
492
493 trap_name = ((context == 0)
494 ? SHARP_F
495 : (char_pointer_to_string (find_exception_name (code))));
496 trap_code = (long_to_integer (0));
497
498 if (win32_under_win32s_p ())
499 {
500 if (! stack_recovered_p)
501 INITIALIZE_STACK ();
502 clear_real_stack = FALSE;
503 real_stack_pointer = stack_pointer;
504 real_stack_guard = stack_guard;
505 temp_stack_limit = stack_pointer;
506 }
507 else
508 {
509 clear_real_stack = (!stack_recovered_p);
510 real_stack_pointer = new_stack_pointer;
511 real_stack_guard = stack_guard;
512 temp_stack_limit = temp_stack_end;
513 stack_pointer = temp_stack_end;
514 stack_guard = temp_stack;
515 }
516
517 Will_Push (7 + CONTINUATION_SIZE);
518 STACK_PUSH (trinfo -> extra_trap_info);
519 STACK_PUSH (trinfo -> pc_info_2);
520 STACK_PUSH (trinfo -> pc_info_1);
521 STACK_PUSH (trinfo -> state);
522 STACK_PUSH (BOOLEAN_TO_OBJECT (stack_recovered_p));
523 STACK_PUSH (trap_code);
524 STACK_PUSH (trap_name);
525 SET_RC (RC_HARDWARE_TRAP);
526 SET_EXP (long_to_integer (code));
527 SAVE_CONT ();
528 Pushed ();
529 if (stack_recovered_p
530 /* This may want to be done in other cases, but this may be enough. */
531 && (trinfo->state == STATE_COMPILED_CODE))
532 stop_history ();
533
534 history_register = (make_dummy_history ());
535 Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
536 STACK_PUSH (trap_name);
537 STACK_PUSH (handler);
538 PUSH_APPLY_FRAME_HEADER (1);
539 Pushed ();
540 SET_INTERRUPT_MASK (saved_mask);
541
542 IFVERBOSE (TellUserEx (MB_OKCANCEL, "setup_trap_frame done."));
543 return;
544 }
545
546 /* Heuristic recovery from processor traps/exceptions.
547
548 continue_from_trap attempts to:
549
550 1) validate the trap information (pc and sp);
551 2) determine whether compiled code was executing,
552 a primitive was executing,
553 or execution was in the interpreter;
554 3) guess what C global state is still valid; and
555 4) set up a recovery frame for the interpreter so that debuggers can
556 display more information.
557 */
558
559 #define SCHEME_ALIGNMENT_MASK ((sizeof (SCHEME_OBJECT)) - 1)
560 #define STACK_ALIGNMENT_MASK SCHEME_ALIGNMENT_MASK
561 #define FREE_PARANOIA_MARGIN 0x100
562
563 #define ALIGNED_P(addr) \
564 ((((unsigned long) (addr)) & SCHEME_ALIGNMENT_MASK) == 0)
565
566 /* But they may have bits that can be masked by this. */
567
568 #ifndef PC_VALUE_MASK
569 # define PC_VALUE_MASK (~0)
570 #endif
571
572 #define C_STACK_SIZE 0x01000000
573
574 static SCHEME_OBJECT * find_block_address
575 (char * pc_value, SCHEME_OBJECT * area_start);
576
577 #define IA32_NREGS 12
578
579 /* For now */
580 #define GET_ETEXT() (heap_start)
581
582 static void
continue_from_trap(DWORD code,PCONTEXT context)583 continue_from_trap (DWORD code, PCONTEXT context)
584 {
585 int pc_in_builtin;
586 int builtin_index;
587 int pc_in_C;
588 int pc_in_heap;
589 int pc_in_constant_space;
590 int pc_in_scheme;
591 int pc_in_hyper_space;
592 int pc_in_utility;
593 int utility_index;
594 int scheme_sp_valid;
595 long scheme_sp;
596 long the_pc;
597 SCHEME_OBJECT * new_stack_pointer;
598 SCHEME_OBJECT * xtra_info;
599 struct trap_recovery_info trinfo;
600
601 IFVERBOSE (TellUserEx (MB_OKCANCEL,
602 "continue_from_trap (%s, %#lx).",
603 (find_exception_name (code)), context));
604
605 if (context == ((PCONTEXT) NULL))
606 {
607 if (Free < heap_alloc_limit)
608 Free = heap_alloc_limit;
609 setup_trap_frame (code, context, (&dummy_recovery_info), 0);
610 /*NOTREACHED*/
611 }
612
613 if (context->SegSs == (getDS ()))
614 {
615 IFVERBOSE
616 (TellUserEx
617 (MB_OKCANCEL,
618 "continue_from_trap: SS = C DS; stack_pointer = %#lx; Esp = %#lx.",
619 stack_pointer, context->Esp));
620 scheme_sp = (context->Esp);
621 }
622 else
623 {
624 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap: SS unknown!"));
625 scheme_sp = 0;
626 }
627
628 if (context->SegCs == (getCS ()))
629 {
630 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap: CS = C CS."));
631 the_pc = (context->Eip & PC_VALUE_MASK);
632 }
633 else
634 {
635 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap: CS unknown"));
636 goto pc_in_hyperspace;
637 }
638
639 if (!PC_ALIGNED_P (the_pc))
640 {
641 pc_in_hyperspace:
642 pc_in_builtin = 0;
643 pc_in_utility = 0;
644 pc_in_C = 0;
645 pc_in_heap = 0;
646 pc_in_constant_space = 0;
647 pc_in_scheme = 0;
648 pc_in_hyper_space = 1;
649 }
650 else
651 {
652 builtin_index = (pc_to_builtin_index (the_pc));
653 pc_in_builtin = (builtin_index != -1);
654 utility_index = (pc_to_utility_index (the_pc));
655 pc_in_utility = (utility_index != -1);
656 pc_in_C = ((the_pc <= ((long) (GET_ETEXT ()))) && (! pc_in_builtin));
657 pc_in_heap =
658 ((the_pc < ((long) heap_end)) && (the_pc >= ((long) heap_start)));
659 pc_in_constant_space =
660 ((the_pc < ((long) constant_end)) &&
661 (the_pc >= ((long) constant_start)));
662 pc_in_scheme = (pc_in_heap || pc_in_constant_space || pc_in_builtin);
663 pc_in_hyper_space = ((!pc_in_C) && (!pc_in_scheme));
664 }
665
666 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 1"));
667
668 scheme_sp_valid
669 = (pc_in_scheme
670 && (ADDRESS_IN_STACK_P ((SCHEME_OBJECT *) scheme_sp))
671 && (ALIGNED_P (scheme_sp)));
672
673 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 2"));
674
675 new_stack_pointer
676 = (scheme_sp_valid
677 ? ((SCHEME_OBJECT *) scheme_sp)
678 : ((pc_in_C
679 && (ADDRESS_IN_STACK_P (stack_pointer)))
680 ? stack_pointer
681 : 0));
682
683 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 3"));
684
685 if (pc_in_hyper_space || pc_in_scheme)
686 {
687 /* In hyper space. */
688 (trinfo . state) = STATE_UNKNOWN;
689 (trinfo . pc_info_1) = SHARP_F;
690 (trinfo . pc_info_2) = SHARP_F;
691 new_stack_pointer = 0;
692 if (! ((ADDRESS_IN_HEAP_P (Free)) && (ALIGNED_P (Free))))
693 Free = heap_alloc_limit;
694 }
695 else if (pc_in_scheme)
696 {
697 /* In compiled code. */
698 SCHEME_OBJECT * block_addr;
699 SCHEME_OBJECT * maybe_free;
700 block_addr =
701 (pc_in_builtin
702 ? ((SCHEME_OBJECT *) NULL)
703 : (find_block_address (((void *) the_pc),
704 (pc_in_heap
705 ? heap_start
706 : constant_start))));
707
708 if (block_addr != ((SCHEME_OBJECT *) NULL))
709 {
710 (trinfo . state) = STATE_COMPILED_CODE;
711 (trinfo . pc_info_1) = (MAKE_CC_BLOCK (block_addr));
712 (trinfo . pc_info_2) =
713 (LONG_TO_UNSIGNED_FIXNUM (the_pc - ((long) block_addr)));
714 }
715 else if (pc_in_builtin)
716 {
717 (trinfo . state) = STATE_PROBABLY_COMPILED;
718 (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (builtin_index));
719 (trinfo . pc_info_2) = SHARP_T;
720 }
721 else
722 {
723 (trinfo . state) = STATE_PROBABLY_COMPILED;
724 (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (the_pc));
725 (trinfo . pc_info_2) = SHARP_F;
726 }
727
728 if ((block_addr == 0) && (!pc_in_builtin))
729 {
730 if (! ((ADDRESS_IN_HEAP_P (Free))
731 && (ALIGNED_P (Free))
732 && (!FREE_OK_P (Free))))
733 Free = heap_alloc_limit;
734 }
735 else
736 {
737 maybe_free = ((SCHEME_OBJECT *) context->Edi);
738 if ((ADDRESS_IN_HEAP_P (maybe_free)) && (ALIGNED_P (maybe_free)))
739 Free = (maybe_free + FREE_PARANOIA_MARGIN);
740 else
741 if (! ((ADDRESS_IN_HEAP_P (Free))
742 && (ALIGNED_P (Free))
743 && (!FREE_OK_P (Free))))
744 Free = heap_alloc_limit;
745 }
746 }
747
748 else /* pc_in_C */
749 {
750 /* In the interpreter, a primitive, or a compiled code utility. */
751
752 SCHEME_OBJECT primitive = GET_PRIMITIVE;
753
754 if (pc_in_utility)
755 {
756 (trinfo . state) = STATE_PROBABLY_COMPILED;
757 (trinfo . pc_info_1) = (LONG_TO_UNSIGNED_FIXNUM (utility_index));
758 (trinfo . pc_info_2) = UNSPECIFIC;
759 }
760 else if ((OBJECT_TYPE (primitive)) != TC_PRIMITIVE)
761 {
762 (trinfo . state) = STATE_UNKNOWN;
763 (trinfo . pc_info_1) = SHARP_F;
764 (trinfo . pc_info_2) = SHARP_F;
765 new_stack_pointer = 0;
766 }
767 else
768 {
769 (trinfo . state) = STATE_PRIMITIVE;
770 (trinfo . pc_info_1) = primitive;
771 (trinfo . pc_info_2) = (ULONG_TO_FIXNUM (GET_LEXPR_ACTUALS));
772 }
773 if ((new_stack_pointer != 0)
774 && (ADDRESS_IN_HEAP_P (Free))
775 && (ALIGNED_P (Free)))
776 {
777 if (FREE_OK_P (Free))
778 {
779 Free += FREE_PARANOIA_MARGIN;
780 if (!FREE_OK_P (Free))
781 Free = heap_alloc_limit;
782 }
783 }
784 else
785 Free = heap_alloc_limit;
786 }
787
788 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 4"));
789
790 if (win32_under_win32s_p ())
791 (trinfo . extra_trap_info) = SHARP_F;
792 else
793 {
794 xtra_info = Free;
795 Free += (1 + (IA32_NREGS + 2));
796 (trinfo . extra_trap_info) =
797 (MAKE_POINTER_OBJECT (TC_NON_MARKED_VECTOR, xtra_info));
798 (*xtra_info++) = (MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, (IA32_NREGS + 2)));
799 (*xtra_info++) = ((SCHEME_OBJECT) the_pc);
800 (*xtra_info++) = ((SCHEME_OBJECT) scheme_sp);
801 {
802 int counter = IA32_NREGS;
803 int * regs = ((int *) context->Edi);
804 while ((counter--) > 0)
805 (*xtra_info++) = ((SCHEME_OBJECT) (*regs++));
806 }
807 }
808
809 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 5"));
810
811 /* Handshake with try+except. */
812
813 context->Eip = ((DWORD) callWinntExceptionTransferHook);
814 context->SegCs = (getCS ());
815 return_by_aborting = TRUE;
816
817 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 6"));
818
819 if (pc_in_scheme && (! (win32_under_win32s_p ())))
820 {
821 context->Esp = C_Stack_Pointer;
822 context->Ebp = C_Frame_Pointer;
823 if (pc_in_scheme)
824 return_by_aborting = FALSE;
825 }
826
827 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 7"));
828
829 setup_trap_frame (code, context, (&trinfo), new_stack_pointer);
830
831 IFVERBOSE (TellUserEx (MB_OKCANCEL, "continue_from_trap 8"));
832 }
833
834 /* Find the compiled code block in area which contains `pc_value'.
835 This attempts to be more efficient than `find_block_address_in_area'.
836 If the pointer is in the heap, it can actually do twice as
837 much work, but it is expected to pay off on the average. */
838
839 static SCHEME_OBJECT * find_block_address_in_area
840 (char * pc_value, SCHEME_OBJECT * area_start);
841
842 #define MINIMUM_SCAN_RANGE 2048
843
844 static SCHEME_OBJECT *
find_block_address(char * pc_value,SCHEME_OBJECT * area_start)845 find_block_address (char * pc_value, SCHEME_OBJECT * area_start)
846 {
847 SCHEME_OBJECT * nearest_word
848 = ((SCHEME_OBJECT *)
849 (((unsigned long) pc_value) &~ SCHEME_ALIGNMENT_MASK));
850 long maximum_distance = (nearest_word - area_start);
851 long distance = maximum_distance;
852 while ((distance / 2) > MINIMUM_SCAN_RANGE)
853 distance = (distance / 2);
854 while ((distance * 2) < maximum_distance)
855 {
856 SCHEME_OBJECT * block
857 = (find_block_address_in_area (pc_value, (nearest_word - distance)));
858 if (block != 0)
859 return (block);
860 distance *= 2;
861 }
862 return (find_block_address_in_area (pc_value, area_start));
863 }
864
865 /*
866 Find the compiled code block in area which contains `pc_value',
867 by scanning sequentially the complete area.
868 For the time being, skip over manifest closures and linkage sections. */
869
870 static SCHEME_OBJECT *
find_block_address_in_area(char * pc_value,SCHEME_OBJECT * area_start)871 find_block_address_in_area (char * pc_value,
872 SCHEME_OBJECT * area_start)
873 {
874 SCHEME_OBJECT * first_valid = area_start;
875 SCHEME_OBJECT * area = area_start;
876 while (((char *) area) < pc_value)
877 {
878 SCHEME_OBJECT object = (*area);
879 switch (OBJECT_TYPE (object))
880 {
881 case TC_LINKAGE_SECTION:
882 {
883 unsigned long count = (linkage_section_count (object));
884 area += 1;
885 switch (linkage_section_type (object))
886 {
887 case LINKAGE_SECTION_TYPE_OPERATOR:
888 case LINKAGE_SECTION_TYPE_GLOBAL_OPERATOR:
889 area += (count * UUO_LINK_SIZE);
890 break;
891
892 case LINKAGE_SECTION_TYPE_REFERENCE:
893 case LINKAGE_SECTION_TYPE_ASSIGNMENT:
894 default:
895 area += count;
896 break;
897 }
898 }
899 break;
900
901 case TC_MANIFEST_CLOSURE:
902 area = (compiled_closure_objects (area + 1));
903 break;
904
905 case TC_MANIFEST_NM_VECTOR:
906 {
907 unsigned long count = (OBJECT_DATUM (object));
908 if (((char *) (area + (count + 1))) < pc_value)
909 {
910 area += (count + 1);
911 first_valid = area;
912 break;
913 }
914 {
915 SCHEME_OBJECT * block = (area - 1);
916 return
917 (((area > first_valid)
918 && ((OBJECT_TYPE (*block)) == TC_MANIFEST_VECTOR)
919 && ((OBJECT_DATUM (*block)) >= (count + 1))
920 && (plausible_cc_block_p (block)))
921 ? block
922 : 0);
923 }
924 }
925
926 default:
927 area += 1;
928 break;
929 }
930 }
931 return (0);
932 }
933
934 static void
trap_recover(DWORD code,PCONTEXT context)935 trap_recover (DWORD code, PCONTEXT context)
936 {
937 IFVERBOSE (TellUserEx (MB_OKCANCEL,
938 "trap_recover (%s, %#lx).",
939 (find_exception_name (code)), context));
940
941 if (WITHIN_CRITICAL_SECTION_P ())
942 {
943 CLEAR_CRITICAL_SECTION_HOOK ();
944 EXIT_CRITICAL_SECTION ({});
945 }
946 reset_interruptable_extent ();
947 continue_from_trap (code, context);
948 }
949
950 static void
nt_trap_handler(DWORD code,PCONTEXT context)951 nt_trap_handler (DWORD code, PCONTEXT context)
952 {
953 bool stack_overflowed_p = (STACK_OVERFLOWED_P ());
954 enum trap_state old_trap_state = trap_state;
955 int flags;
956
957 IFVERBOSE (TellUserEx (MB_OKCANCEL,
958 "nt_trap_handler (%s, %#lx).",
959 (find_exception_name (code)), context));
960
961 if (old_trap_state == trap_state_exitting_hard)
962 _exit (1);
963 else if (old_trap_state == trap_state_exitting_soft)
964 trap_immediate_termination ();
965
966 trap_state = trap_state_trapped;
967
968 trap_noise_start ();
969 if (WITHIN_CRITICAL_SECTION_P ())
970 {
971 trap_noise (">> The system has trapped within critical section \"%s\".\n",
972 (CRITICAL_SECTION_NAME ()));
973 describe_trap ("trap is", code);
974 }
975 else if (stack_overflowed_p || (old_trap_state != trap_state_recover))
976 {
977 trap_noise (">> The system has trapped.\n");
978 describe_trap ("trap is", code);
979 }
980 if (stack_overflowed_p)
981 {
982 trap_noise (">> The stack has overflowed overwriting adjacent memory.\n");
983 trap_noise (">> This was probably caused by a runaway recursion.\n");
984 }
985
986 switch (old_trap_state)
987 {
988 case trap_state_trapped:
989 if ((saved_trap_state == trap_state_recover)
990 || (saved_trap_state == trap_state_query))
991 {
992 trap_noise (">> The trap occurred while processing an earlier trap.\n");
993 describe_trap ("earlier trap was", saved_trap_code);
994 trap_noise ((WITHIN_CRITICAL_SECTION_P ())
995 ? ">> Successful recovery is extremely unlikely.\n"
996 : ">> Successful recovery is unlikely.\n");
997 break;
998 }
999 else
1000 {
1001 (void) trap_noise_end (MB_OK | MB_ICONSTOP);
1002 trap_immediate_termination ();
1003 }
1004
1005 case trap_state_recover:
1006 if ((WITHIN_CRITICAL_SECTION_P ()) || stack_overflowed_p)
1007 {
1008 trap_noise (">> Successful recovery is unlikely.\n");
1009 break;
1010 }
1011 else
1012 {
1013 saved_trap_state = old_trap_state;
1014 saved_trap_code = code;
1015 (void) trap_noise_end (MB_OK | MB_ICONSTOP);
1016 trap_recover (code, context);
1017 return;
1018 }
1019 case trap_state_exit:
1020 (void) trap_noise_end (MB_OK | MB_ICONSTOP);
1021 termination_trap ();
1022 }
1023
1024 trap_noise ("\n");
1025 saved_trap_state = old_trap_state;
1026 saved_trap_code = code;
1027 flags = MB_ICONSTOP;
1028
1029 while (1)
1030 {
1031 trap_noise ("Attempt recovery?");
1032 if ((trap_noise_end (MB_YESNO | flags)) == IDYES)
1033 {
1034 trap_recover (code, context);
1035 return;
1036 }
1037 flags = 0;
1038
1039 trap_noise ("Terminate Scheme normally?");
1040 switch (trap_noise_end (MB_YESNOCANCEL))
1041 {
1042 case IDYES:
1043 trap_normal_termination ();
1044
1045 case IDNO:
1046 trap_immediate_termination ();
1047 _exit (1);
1048
1049 default:
1050 break;
1051 }
1052 }
1053 }
1054
1055 #ifdef W32_TRAP_DEBUG
1056
1057 static void
parse_response(char * buf,unsigned long * addr,int * len)1058 parse_response (char * buf, unsigned long * addr, int * len)
1059 {
1060 const char * separators = " ,\t;";
1061 char * token;
1062
1063 token = (strtok (buf, separators));
1064 if (token == ((char *) NULL))
1065 return;
1066 * addr = (strtoul (token, ((char **) NULL), 0));
1067 token = (strtok (((char *) NULL), separators));
1068 if (token == ((char *) NULL))
1069 return;
1070 * len = ((int) (strtoul (token, ((char **) NULL), 0)));
1071 return;
1072 }
1073
1074 static void
tinyexcpdebug(DWORD code,LPEXCEPTION_POINTERS info)1075 tinyexcpdebug (DWORD code, LPEXCEPTION_POINTERS info)
1076 {
1077 int count, len;
1078 char * message;
1079 unsigned long * addr;
1080 char responsebuf[256], * response;
1081
1082 if ((MessageBox
1083 (NULL, "Debug?", "MIT/GNU Scheme Exception Debugger", MB_YESNO))
1084 != IDYES)
1085 return;
1086
1087 message = "&info =";
1088 addr = ((unsigned long *) (& info));
1089 len = 1;
1090
1091 while (1)
1092 {
1093 trap_noise_start ();
1094 trap_noise ("%s %#lx.\n", message, ((unsigned long) addr));
1095 for (count = 0; count < len; count++)
1096 trap_noise ("\n*%#08x\t= %#08x\t= %d.",
1097 (addr + count),
1098 addr[count],
1099 addr[count]);
1100 trap_noise ("\n\nMore?");
1101 if ((trap_noise_end (MB_YESNO)) != IDYES)
1102 break;
1103 response = (AskUser (&responsebuf[0], (sizeof (responsebuf))));
1104 if (response == ((char *) NULL))
1105 continue;
1106 message = "Contents of";
1107 parse_response (&responsebuf[0], &addr, &len);
1108 }
1109 return;
1110 }
1111 #endif /* W32_TRAP_DEBUG */
1112
1113 #ifndef PAGE_SIZE
1114 # define PAGE_SIZE 0x1000
1115 #endif
1116
1117 static bool stack_protected = false;
1118 unsigned long protected_stack_base;
1119 unsigned long protected_stack_end;
1120
1121 void
win32_unprotect_stack(void)1122 win32_unprotect_stack (void)
1123 {
1124 DWORD old_protection;
1125
1126 if ((stack_protected)
1127 && (VirtualProtect (((LPVOID) protected_stack_base),
1128 PAGE_SIZE,
1129 PAGE_READWRITE,
1130 (&old_protection))))
1131 stack_protected = false;
1132 }
1133
1134 void
win32_protect_stack(void)1135 win32_protect_stack (void)
1136 {
1137 DWORD old_protection;
1138
1139 if ((!stack_protected)
1140 && (VirtualProtect (((LPVOID) protected_stack_base),
1141 PAGE_SIZE,
1142 (PAGE_GUARD | PAGE_READWRITE),
1143 (&old_protection))))
1144 stack_protected = true;
1145 }
1146
1147 void
win32_stack_reset(void)1148 win32_stack_reset (void)
1149 {
1150 /* This presumes that the distance between stack_end and
1151 stack_guard is at least a page. */
1152 unsigned long boundary
1153 = ((((unsigned long) stack_guard)
1154 & (~ ((unsigned long) (PAGE_SIZE - 1))))
1155 - (2 * PAGE_SIZE));
1156 if (stack_protected && (protected_stack_base == boundary))
1157 return;
1158 win32_unprotect_stack ();
1159 protected_stack_base = boundary;
1160 protected_stack_end = (boundary + PAGE_SIZE);
1161 win32_protect_stack ();
1162 }
1163
1164 #define EXCEPTION_CODE_GUARDED_PAGE_ACCESS 0x80000001L
1165
1166 static LONG
WinntException(DWORD code,LPEXCEPTION_POINTERS info)1167 WinntException (DWORD code, LPEXCEPTION_POINTERS info)
1168 {
1169 PCONTEXT context;
1170
1171 context = info->ContextRecord;
1172 if ((info->ExceptionRecord->ExceptionFlags != 0)
1173 || (context == ((PCONTEXT) NULL))
1174 || ((context->ContextFlags & CONTEXT_CONTROL) == 0)
1175 || ((context->ContextFlags & CONTEXT_INTEGER) == 0)
1176 || ((context->ContextFlags & CONTEXT_SEGMENTS) == 0))
1177 {
1178 (void)
1179 display_exception_information (info->ExceptionRecord,
1180 info->ContextRecord,
1181 MB_OK);
1182 trap_immediate_termination ();
1183 /*NOTREACHED*/
1184 return (0);
1185 }
1186 else if (code == EXCEPTION_CODE_GUARDED_PAGE_ACCESS)
1187 {
1188 if (stack_protected
1189 && (context->Esp >= protected_stack_base)
1190 && (context->Esp <= protected_stack_end))
1191 REQUEST_INTERRUPT (INT_Stack_Overflow);
1192 /* Just in case */
1193 stack_protected = FALSE;
1194 return (EXCEPTION_CONTINUE_EXECUTION);
1195 }
1196 else
1197 {
1198 #ifdef W32_TRAP_DEBUG
1199 trap_verbose_p = ((display_exception_information
1200 (info->ExceptionRecord,
1201 info->ContextRecord,
1202 MB_YESNO))
1203 == IDYES);
1204 tinyexcpdebug (code, info);
1205 #endif /* W32_TRAP_DEBUG */
1206 nt_trap_handler (code, context);
1207 return (EXCEPTION_CONTINUE_EXECUTION);
1208 }
1209 }
1210
1211 #if (defined(__WATCOMC__) && (__WATCOMC__ < 1100))
1212 /* Watcom 10 has broken __try/__except support,
1213 which has been fixed in version 11. */
1214 #define USE_SET_UNHANDLED_EXCEPTION_FILTER
1215 #endif
1216
1217 #ifdef USE_SET_UNHANDLED_EXCEPTION_FILTER
1218 static LONG WINAPI
scheme_unhandled_exception_filter(LPEXCEPTION_POINTERS info)1219 scheme_unhandled_exception_filter (LPEXCEPTION_POINTERS info)
1220 {
1221 return (WinntException (((info -> ExceptionRecord) -> ExceptionCode), info));
1222 }
1223 #endif /* USE_SET_UNHANDLED_EXCEPTION_FILTER */
1224
1225 void
win32_enter_interpreter(void (* enter_interpreter)(void))1226 win32_enter_interpreter (void (*enter_interpreter) (void))
1227 {
1228 #ifdef USE_SET_UNHANDLED_EXCEPTION_FILTER
1229 (void) SetUnhandledExceptionFilter (scheme_unhandled_exception_filter);
1230 (* enter_interpreter) ();
1231 outf_fatal ("Exception!\n");
1232 termination_trap ();
1233 #else /* not USE_SET_UNHANDLED_EXCEPTION_FILTER */
1234 do
1235 {
1236 __try
1237 {
1238 (* enter_interpreter) ();
1239 }
1240 __except (WinntException ((GetExceptionCode ()),
1241 (GetExceptionInformation ())))
1242 {
1243 outf_fatal ("Exception!\n");
1244 termination_trap ();
1245 }
1246 } while (1);
1247 #endif /* not USE_SET_UNHANDLED_EXCEPTION_FILTER */
1248 }
1249