Fix three problems discovered by running math.floats.env tests in a loop:

- Crash if allocating error triggers a GC from a signal/SEH handler
- Crash if GC runs with floating point traps enabled on Windows
- Floating point traps didn't prettyprint properly

basis/bootstrap/image/image.factor

@@ -201,6 +201,8 @@ SPECIAL-OBJECT: jit-declare-word 41
 SPECIAL-OBJECT: c-to-factor-word 42
 SPECIAL-OBJECT: lazy-jit-compile-word 43
 SPECIAL-OBJECT: unwind-native-frames-word 44
+SPECIAL-OBJECT: get-fpu-state-word 45
+SPECIAL-OBJECT: set-fpu-state-word 46
 
 SPECIAL-OBJECT: callback-stub 48
 
@@ -540,6 +542,8 @@ M: quotation '
     \ c-to-factor c-to-factor-word set
     \ lazy-jit-compile lazy-jit-compile-word set
     \ unwind-native-frames unwind-native-frames-word set
+    \ get-fpu-state get-fpu-state-word set
+    \ set-fpu-state set-fpu-state-word set
     undefined-def undefined-quot set ;
 
 : emit-special-objects ( -- )

basis/cpu/x86/32/bootstrap.factor

@@ -64,9 +64,6 @@ IN: bootstrap.x86
     ds-reg ctx-reg context-datastack-offset [+] MOV
     rs-reg ctx-reg context-retainstack-offset [+] MOV ;
 
-: jit-scrub-return ( n -- )
-    ESP swap [+] 0 MOV ;
-
 [
     ! ctx-reg is preserved across the call because it is non-volatile
     ! in the C ABI
@@ -115,24 +112,28 @@ IN: bootstrap.x86
     ! Windows-specific setup
     ctx-reg jit-update-seh
 
-    ! Clear x87 stack, but preserve rounding mode and exception flags
-    ESP 2 SUB
-    ESP [] FNSTCW
-    FNINIT
-    ESP [] FLDCW
-    ESP 2 ADD
-
     ! Load arguments
     EAX ESP stack-frame-size [+] MOV
     EDX ESP stack-frame-size 4 + [+] MOV
 
     ! Unwind stack frames
     ESP EDX MOV
-    0 jit-scrub-return
 
     jit-jump-quot
 ] \ unwind-native-frames define-sub-primitive
 
+[
+    ESP 2 SUB
+    ESP [] FNSTCW
+    FNINIT
+    AX ESP [] MOV
+    ESP 2 ADD
+] \ get-fpu-state define-sub-primitive
+
+[
+    ESP stack-frame-size [+] FLDCW
+] \ set-fpu-state define-sub-primitive
+
 [
     ! Load callstack object
     temp3 ds-reg [] MOV
@@ -251,7 +252,9 @@ IN: bootstrap.x86
 
 ! Contexts
 : jit-switch-context ( reg -- )
-    -4 jit-scrub-return
+    ! Reset return value since its bogus right now, to avoid
+    ! confusing the GC
+    ESP -4 [+] 0 MOV
 
     ! Make the new context the current one
     ctx-reg swap MOV

basis/cpu/x86/64/bootstrap.factor

@@ -62,9 +62,6 @@ IN: bootstrap.x86
     ds-reg ctx-reg context-datastack-offset [+] MOV
     rs-reg ctx-reg context-retainstack-offset [+] MOV ;
 
-: jit-scrub-return ( n -- )
-    RSP swap [+] 0 MOV ;
-
 [
     ! ctx-reg is preserved across the call because it is non-volatile
     ! in the C ABI
@@ -102,15 +99,8 @@ IN: bootstrap.x86
 \ (call) define-combinator-primitive
 
 [
-    ! Clear x87 stack, but preserve rounding mode and exception flags
-    RSP 2 SUB
-    RSP [] FNSTCW
-    FNINIT
-    RSP [] FLDCW
-
     ! Unwind stack frames
     RSP arg2 MOV
-    0 jit-scrub-return
 
     ! Load VM pointer into vm-reg, since we're entering from
     ! C code
@@ -124,6 +114,21 @@ IN: bootstrap.x86
     jit-jump-quot
 ] \ unwind-native-frames define-sub-primitive
 
+[
+    RSP 2 SUB
+    RSP [] FNSTCW
+    FNINIT
+    AX RSP [] MOV
+    RSP 2 ADD
+] \ get-fpu-state define-sub-primitive
+
+[
+    RSP 2 SUB
+    RSP [] arg1 16-bit-vesion-of MOV
+    RSP [] FLDCW
+    RSP 2 ADD
+] \ set-fpu-state define-sub-primitive
+
 [
     ! Load callstack object
     arg4 ds-reg [] MOV
@@ -228,7 +233,9 @@ IN: bootstrap.x86
 
 ! Contexts
 : jit-switch-context ( reg -- )
-    -8 jit-scrub-return
+    ! Reset return value since its bogus right now, to avoid
+    ! confusing the GC
+    RSP -8 [+] 0 MOV
 
     ! Make the new context the current one
     ctx-reg swap MOV

basis/debugger/debugger.factor

@@ -136,7 +136,7 @@ PREDICATE: vm-error < array
     {
         { [ dup empty? ] [ drop f ] }
         { [ dup first "kernel-error" = not ] [ drop f ] }
-        [ second 0 16 between? ]
+        [ second 0 17 between? ]
     } cond ;
 
 : vm-errors ( error -- n errors )

basis/math/floats/env/env-tests.factor

@@ -1,7 +1,7 @@
 USING: kernel math math.floats.env math.floats.env.private
 math.functions math.libm sequences tools.test locals
 compiler.units kernel.private fry compiler.test math.private
-words system ;
+words system memory ;
 IN: math.floats.env.tests
 
 : set-default-fp-env ( -- )
@@ -193,6 +193,9 @@ os openbsd eq? cpu x86.32 eq? and [
 [ +denormal-keep+ ] [ denormal-mode ] unit-test
 [ { } ] [ fp-traps ] unit-test
 
+[ ] [
+    all-fp-exceptions [ compact-gc ] with-fp-traps
+] unit-test
+
 ! In case the tests screw up the FP env because of bugs in math.floats.env
 set-default-fp-env
-

core/bootstrap/primitives.factor

@@ -340,6 +340,8 @@ tuple
     { "tag" "kernel.private" (( object -- n )) }
     { "(execute)" "kernel.private" (( word -- )) }
     { "(call)" "kernel.private" (( quot -- )) }
+    { "get-fpu-state" "kernel.private" (( -- )) }
+    { "set-fpu-state" "kernel.private" (( -- )) }
     { "unwind-native-frames" "kernel.private" (( -- )) }
     { "set-callstack" "kernel.private" (( callstack -- * )) }
     { "lazy-jit-compile" "kernel.private" (( -- )) }

vm/callstack.cpp

@@ -127,6 +127,23 @@ void factor_vm::set_frame_offset(stack_frame *frame, cell offset)
 		FRAME_RETURN_ADDRESS(frame,this) = entry_point + offset;
 }
 
+void factor_vm::scrub_return_address(stack_frame *callstack_top)
+{
+	stack_frame *top = callstack_top;
+	stack_frame *bottom = ctx->callstack_bottom;
+	stack_frame *frame = bottom - 1;
+
+	while(frame >= top && frame_successor(frame) >= top)
+		frame = frame_successor(frame);
+
+	set_frame_offset(frame,0);
+
+#ifdef FACTOR_DEBUG
+	/* Doing a GC here triggers all kinds of funny errors */
+	primitive_compact_gc();
+#endif
+}
+
 cell factor_vm::frame_scan(stack_frame *frame)
 {
 	switch(frame_type(frame))

vm/entry_points.cpp

@@ -26,4 +26,18 @@ void factor_vm::unwind_native_frames(cell quot, stack_frame *to)
 	unwind_native_frames_func(quot,to);
 }
 
+cell factor_vm::get_fpu_state()
+{
+	tagged<word> get_fpu_state_word(special_objects[GET_FPU_STATE_WORD]);
+	get_fpu_state_func_type get_fpu_state_func = (get_fpu_state_func_type)get_fpu_state_word->entry_point;
+	return get_fpu_state_func();
+}
+
+void factor_vm::set_fpu_state(cell state)
+{
+	tagged<word> set_fpu_state_word(special_objects[SET_FPU_STATE_WORD]);
+	set_fpu_state_func_type set_fpu_state_func = (set_fpu_state_func_type)set_fpu_state_word->entry_point;
+	set_fpu_state_func(state);
+}
+
 }

vm/entry_points.hpp

@@ -3,5 +3,7 @@ namespace factor
 
 typedef void (* c_to_factor_func_type)(cell quot);
 typedef void (* unwind_native_frames_func_type)(cell quot, stack_frame *to);
+typedef cell (* get_fpu_state_func_type)();
+typedef void (* set_fpu_state_func_type)(cell state);
 
 }

vm/errors.cpp

@@ -128,6 +128,7 @@ void factor_vm::primitive_unimplemented()
 
 void factor_vm::memory_signal_handler_impl()
 {
+	scrub_return_address(signal_callstack_top);
 	memory_protection_error(signal_fault_addr,signal_callstack_top);
 }
 
@@ -138,6 +139,7 @@ void memory_signal_handler_impl()
 
 void factor_vm::misc_signal_handler_impl()
 {
+	scrub_return_address(signal_callstack_top);
 	signal_error(signal_number,signal_callstack_top);
 }
 
@@ -148,6 +150,10 @@ void misc_signal_handler_impl()
 
 void factor_vm::fp_signal_handler_impl()
 {
+	/* Clear pending exceptions to avoid getting stuck in a loop */
+	set_fpu_state(get_fpu_state());
+
+	scrub_return_address(signal_callstack_top);
 	fp_trap_error(signal_fpu_status,signal_callstack_top);
 }
 

vm/gc.cpp

@@ -128,6 +128,11 @@ void factor_vm::start_gc_again()
 
 void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
 {
+	/* Save and reset FPU state before, restore it after, so that
+	nano_count() doesn't bomb on Windows if inexact traps are enabled
+	(fun huh?) */
+	cell fpu_state = get_fpu_state();
+
 	assert(!gc_off);
 	assert(!current_gc);
 
@@ -192,6 +197,8 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
 
 	delete current_gc;
 	current_gc = NULL;
+
+	set_fpu_state(fpu_state);
 }
 
 /* primitive_minor_gc() is invoked by inline GC checks, and it needs to fill in

vm/mach_signal.cpp

@@ -38,6 +38,7 @@ void factor_vm::call_fault_handler(
 	MACH_STACK_POINTER(thread_state) = (cell)fix_callstack_top((stack_frame *)MACH_STACK_POINTER(thread_state));
 
 	signal_callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state);
+	ctx->callstack_top = (stack_frame *)MACH_STACK_POINTER(thread_state);
 
 	/* Now we point the program counter at the right handler function. */
 	if(exception == EXC_BAD_ACCESS)

vm/objects.hpp

@@ -55,6 +55,8 @@ enum special_object {
 	C_TO_FACTOR_WORD,
 	LAZY_JIT_COMPILE_WORD,
 	UNWIND_NATIVE_FRAMES_WORD,
+	GET_FPU_STATE_WORD,
+	SET_FPU_STATE_WORD,
 
 	/* Incremented on every modify-code-heap call; invalidates call( inline
 	caching */

vm/os-unix.cpp

@@ -119,6 +119,7 @@ void factor_vm::dispatch_signal(void *uap, void (handler)())
 	UAP_PROGRAM_COUNTER(uap) = (cell)handler;
 
 	signal_callstack_top = (stack_frame *)UAP_STACK_POINTER(uap);
+	ctx->callstack_top = (stack_frame *)UAP_STACK_POINTER(uap);
 }
 
 void memory_signal_handler(int signal, siginfo_t *siginfo, void *uap)

vm/os-windows-nt.cpp

@@ -51,6 +51,7 @@ LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c,
 {
 	c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP);
 	signal_callstack_top = (stack_frame *)c->ESP;
+	ctx->callstack_top = (stack_frame *)c->ESP;
 
 	switch (e->ExceptionCode)
 	{
@@ -72,6 +73,8 @@ LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c,
 		signal_fpu_status = fpu_status(MXCSR(c));
 #else
 		signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
+
+		/* This seems to have no effect */
 		X87SW(c) = 0;
 #endif
 		MXCSR(c) &= 0xffffffc0;

vm/vm.hpp

@@ -588,6 +588,7 @@ struct factor_vm
 	cell frame_scan(stack_frame *frame);
 	cell frame_offset(stack_frame *frame);
 	void set_frame_offset(stack_frame *frame, cell offset);
+	void scrub_return_address(stack_frame *callstack_top);
 	void primitive_callstack_to_array();
 	stack_frame *innermost_stack_frame(callstack *stack);
 	void primitive_innermost_stack_frame_executing();
@@ -654,6 +655,8 @@ struct factor_vm
 	// entry points
 	void c_to_factor(cell quot);
 	void unwind_native_frames(cell quot, stack_frame *to);
+	cell get_fpu_state();
+	void set_fpu_state(cell state);
 
 	// factor
 	void default_parameters(vm_parameters *p);