Get green threads working on Windows

- store stack base and limit in TIB
- set up a frame-based structured exception handler in each context's callstack
- boot.x86.32.image has now been replaced by boot.winnt-x86.32.image and boot.unix-x86.32.image

Nmakefile

@@ -2,7 +2,7 @@
 LINK_FLAGS = /nologo /DEBUG shell32.lib
 CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
 !ELSE
-LINK_FLAGS = /nologo shell32.lib
+LINK_FLAGS = /nologo /safeseh:no shell32.lib
 CL_FLAGS = /nologo /O2 /W3
 !ENDIF
 

basis/bootstrap/image/image.factor

@@ -15,10 +15,11 @@ generalizations ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
+    [ dup "winnt" = "winnt" "unix" ? ] dip
     {
-        { "ppc" [ "-ppc" append ] }
+        { "ppc" [ drop "-ppc" append ] }
-        { "x86.64" [ "winnt" = "winnt" "unix" ? "-x86.64" append ] }
+        { "x86.32" [ nip "-x86.32" append ] }
-        [ nip ]
+        { "x86.64" [ nip "-x86.64" append ] }
     } case ;
 
 : my-arch ( -- arch )
@@ -32,7 +33,7 @@ IN: bootstrap.image
 
 : images ( -- seq )
     {
-        "x86.32"
+        "winnt-x86.32" "unix-x86.32"
         "winnt-x86.64" "unix-x86.64"
         "linux-ppc" "macosx-ppc"
     } ;

basis/compiler/constants/constants.factor

@@ -34,6 +34,10 @@ CONSTANT: deck-bits 18
 : context-datastack-offset ( -- n ) 2 bootstrap-cells ; inline
 : context-retainstack-offset ( -- n ) 3 bootstrap-cells ; inline
 : context-callstack-save-offset ( -- n ) 4 bootstrap-cells ; inline
+: context-callstack-seg-offset ( -- n ) 7 bootstrap-cells ; inline
+: segment-start-offset ( -- n ) 0 bootstrap-cells ; inline
+: segment-size-offset ( -- n ) 1 bootstrap-cells ; inline
+: segment-end-offset ( -- n ) 2 bootstrap-cells ; inline
 
 ! Relocation classes
 CONSTANT: rc-absolute-cell 0
@@ -61,6 +65,7 @@ CONSTANT: rt-megamorphic-cache-hits 8
 CONSTANT: rt-vm 9
 CONSTANT: rt-cards-offset 10
 CONSTANT: rt-decks-offset 11
+CONSTANT: rt-exception-handler 12
 
 : rc-absolute? ( n -- ? )
     ${ rc-absolute-ppc-2/2 rc-absolute-cell rc-absolute } member? ;

basis/cpu/x86/32/bootstrap.factor

@@ -108,6 +108,14 @@ IN: bootstrap.x86
 \ (call) define-combinator-primitive
 
 [
+    ! Load ds and rs registers
+    jit-load-vm
+    jit-load-context
+    jit-restore-context
+
+    ! Windows-specific setup
+    ctx-reg jit-update-seh
+
     ! Clear x87 stack, but preserve rounding mode and exception flags
     ESP 2 SUB
     ESP [] FNSTCW
@@ -122,11 +130,6 @@ IN: bootstrap.x86
     ! Unwind stack frames
     ESP EDX MOV
 
-    ! Load ds and rs registers
-    jit-load-vm
-    jit-load-context
-    jit-restore-context
-
     jit-jump-quot
 ] \ unwind-native-frames define-sub-primitive
 
@@ -253,6 +256,9 @@ IN: bootstrap.x86
     ! Load new stack pointer
     ESP ctx-reg context-callstack-top-offset [+] MOV
 
+    ! Windows-specific setup
+    ctx-reg jit-update-tib
+
     ! Load new ds, rs registers
     jit-restore-context ;
 
@@ -266,6 +272,9 @@ IN: bootstrap.x86
     ! Make the new context active
     EAX jit-switch-context
 
+    ! Windows-specific setup
+    ctx-reg jit-update-seh
+
     ! Twiddle stack for return
     ESP 4 ADD
 
@@ -293,6 +302,12 @@ IN: bootstrap.x86
     ds-reg 4 ADD
     ds-reg [] EAX MOV
 
+    ! Windows-specific setup
+    jit-install-seh
+
+    ! Push a fake return address
+    0 PUSH
+
     ! Jump to initial quotation
     EAX EBX [] MOV
     jit-jump-quot ;

basis/cpu/x86/32/unix/bootstrap.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cpu.x86.assembler cpu.x86.assembler.operands kernel
+layouts parser sequences ;
+IN: bootstrap.x86
+
+: jit-save-tib ( -- ) ;
+: jit-restore-tib ( -- ) ;
+: jit-update-tib ( ctx-reg -- ) drop ;
+: jit-install-seh ( -- ) ESP bootstrap-cell ADD ;
+: jit-update-seh ( ctx-reg -- ) drop ;
+
+<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
+call

basis/cpu/x86/32/winnt/bootstrap.factor

@@ -0,0 +1,54 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: bootstrap.image.private compiler.constants
+cpu.x86.assembler cpu.x86.assembler.operands kernel layouts
+locals parser sequences ;
+IN: bootstrap.x86
+
+: tib-exception-list-offset ( -- n ) 0 bootstrap-cells ;
+: tib-stack-base-offset ( -- n ) 1 bootstrap-cells ;
+: tib-stack-limit-offset ( -- n ) 2 bootstrap-cells ;
+
+: jit-save-tib ( -- )
+    tib-exception-list-offset [] FS PUSH
+    tib-stack-base-offset [] FS PUSH
+    tib-stack-limit-offset [] FS PUSH ;
+
+: jit-restore-tib ( -- )
+    tib-stack-limit-offset [] FS POP
+    tib-stack-base-offset [] FS POP
+    tib-exception-list-offset [] FS POP ;
+
+:: jit-update-tib ( ctx-reg -- )
+    ! There's a redundant load here because we're not allowed
+    ! to clobber ctx-reg. Clobbers EAX.
+    ! Save callstack base in TIB
+    EAX ctx-reg context-callstack-seg-offset [+] MOV
+    EAX EAX segment-end-offset [+] MOV
+    tib-stack-base-offset [] EAX FS MOV
+    ! Save callstack limit in TIB
+    EAX ctx-reg context-callstack-seg-offset [+] MOV
+    EAX EAX segment-start-offset [+] MOV
+    tib-stack-limit-offset [] EAX FS MOV ;
+
+: jit-install-seh ( -- )
+    ! Create a new exception record and store it in the TIB.
+    ! Align stack
+    ESP 3 bootstrap-cells ADD
+    ! Exception handler address filled in by callback.cpp
+    0 PUSH rc-absolute-cell rt-exception-handler jit-rel
+    ! No next handler
+    0 PUSH
+    ! This is the new exception handler
+    tib-exception-list-offset [] ESP FS MOV ;
+
+:: jit-update-seh ( ctx-reg -- )
+    ! Load exception record structure that jit-install-seh
+    ! created from the bottom of the callstack. Clobbers EAX.
+    EAX ctx-reg context-callstack-bottom-offset [+] MOV
+    EAX bootstrap-cell ADD
+    ! Store exception record in TIB.
+    tib-exception-list-offset [] EAX FS MOV ;
+
+<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >>
+call

basis/cpu/x86/64/bootstrap.factor

@@ -26,6 +26,11 @@ IN: bootstrap.x86
 : fixnum>slot@ ( -- ) temp0 1 SAR ;
 : rex-length ( -- n ) 1 ;
 
+: jit-save-tib ( -- ) ;
+: jit-restore-tib ( -- ) ;
+: jit-update-tib ( ctx-reg -- ) drop ;
+: jit-install-seh ( -- ) ESP bootstrap-cell ADD ;
+
 : jit-call ( name -- )
     RAX 0 MOV rc-absolute-cell jit-dlsym
     RAX CALL ;

basis/cpu/x86/bootstrap.factor

@@ -20,6 +20,8 @@ big-endian off
     ! Save all non-volatile registers
     nv-regs [ PUSH ] each
 
+    jit-save-tib
+
     ! Load VM into vm-reg
     vm-reg 0 MOV rc-absolute-cell rt-vm jit-rel
 
@@ -36,7 +38,9 @@ big-endian off
 
     ! Load Factor callstack pointer
     stack-reg nv-reg context-callstack-bottom-offset [+] MOV
-    stack-reg bootstrap-cell ADD
+
+    nv-reg jit-update-tib
+    jit-install-seh
 
     ! Call into Factor code
     nv-reg 0 MOV rc-absolute-cell rt-entry-point jit-rel
@@ -55,6 +59,8 @@ big-endian off
     vm-reg vm-context-offset [+] nv-reg MOV
 
     ! Restore non-volatile registers
+    jit-restore-tib
+
     nv-regs <reversed> [ POP ] each
 
     frame-reg POP

basis/threads/threads-tests.factor

@@ -56,3 +56,6 @@ yield
 [ "x" tget "p" get fulfill ] in-thread
 
 [ f ] [ "p" get ?promise ] unit-test
+
+! Test system traps inside threads
+[ ] [ [ dup ] in-thread yield ] unit-test

core/bootstrap/primitives.factor

@@ -18,7 +18,8 @@ H{ } clone sub-primitives set
 "vocab:bootstrap/syntax.factor" parse-file
 
 architecture get {
-    { "x86.32" "x86/32" }
+    { "winnt-x86.32" "x86/32/winnt" }
+    { "unix-x86.32" "x86/32/unix" }
     { "winnt-x86.64" "x86/64/winnt" }
     { "unix-x86.64" "x86/64/unix" }
     { "linux-ppc" "ppc/linux" }

vm/callbacks.cpp

@@ -38,7 +38,12 @@ void callback_heap::store_callback_operand(code_block *stub, cell index, cell va
 
 void callback_heap::update(code_block *stub)
 {
-	store_callback_operand(stub,1,(cell)callback_entry_point(stub));
+#ifdef WIN32
+	cell index = 2;
+#else
+	cell index = 1;
+#endif
+	store_callback_operand(stub,index,(cell)callback_entry_point(stub));
 	stub->flush_icache();
 }
 
@@ -64,12 +69,21 @@ code_block *callback_heap::add(cell owner, cell return_rewind)
 
 	/* Store VM pointer */
 	store_callback_operand(stub,0,(cell)parent);
-	store_callback_operand(stub,2,(cell)parent);
+
+#ifdef WIN32
+	store_callback_operand(stub,1,(cell)&exception_handler);
+	cell index = 1;
+#else
+	cell index = 0;
+#endif
+
+	/* Store VM pointer */
+	store_callback_operand(stub,index + 2,(cell)parent);
 
 	/* On x86, the RET instruction takes an argument which depends on
 	the callback's calling convention */
 #if defined(FACTOR_X86) || defined(FACTOR_AMD64)
-	store_callback_operand(stub,3,return_rewind);
+	store_callback_operand(stub,index + 3,return_rewind);
 #endif
 
 	update(stub);

vm/code_blocks.cpp

@@ -225,6 +225,11 @@ void factor_vm::store_external_address(instruction_operand op)
 	case RT_DECKS_OFFSET:
 		op.store_value(decks_offset);
 		break;
+#ifdef WINDOWS
+	case RT_EXCEPTION_HANDLER:
+		op.store_value(&factor::exception_handler);
+		break;
+#endif
 	default:
 		critical_error("Bad rel type",op.rel_type());
 		break;

vm/cpu-x86.hpp

@@ -5,7 +5,7 @@ namespace factor
 
 #define FRAME_RETURN_ADDRESS(frame,vm) *(void **)(vm->frame_successor(frame) + 1)
 
-#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell))
+#define CALLSTACK_BOTTOM(ctx) (stack_frame *)(ctx->callstack_seg->end - sizeof(cell) * 5)
 
 inline static void flush_icache(cell start, cell len) {}
 

vm/instruction_operands.hpp

@@ -26,6 +26,10 @@ enum relocation_type {
 	RT_CARDS_OFFSET,
 	/* value of vm->decks_offset */
 	RT_DECKS_OFFSET,
+	/* address of exception_handler -- this exists as a separate relocation
+	type since its used in a situation where relocation arguments cannot
+	be passed in, and so RT_DLSYM is inappropriate (Windows only) */
+	RT_EXCEPTION_HANDLER,
 };
 
 enum relocation_class {
@@ -105,6 +109,7 @@ struct relocation_entry {
 		case RT_MEGAMORPHIC_CACHE_HITS:
 		case RT_CARDS_OFFSET:
 		case RT_DECKS_OFFSET:
+		case RT_EXCEPTION_HANDLER:
 			return 0;
 		default:
 			critical_error("Bad rel type",rel_type());

vm/os-windows-nt.cpp

@@ -48,11 +48,8 @@ void sleep_nanos(u64 nsec)
 	Sleep((DWORD)(nsec/1000000));
 }
 
-LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe)
+LONG factor_vm::exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
 {
-	PEXCEPTION_RECORD e = (PEXCEPTION_RECORD)pe->ExceptionRecord;
-	CONTEXT *c = (CONTEXT*)pe->ContextRecord;
-
 	c->ESP = (cell)fix_callstack_top((stack_frame *)c->ESP);
 	signal_callstack_top = (stack_frame *)c->ESP;
 
@@ -81,35 +78,23 @@ LONG factor_vm::exception_handler(PEXCEPTION_POINTERS pe)
 		MXCSR(c) &= 0xffffffc0;
 		c->EIP = (cell)factor::fp_signal_handler_impl;
 		break;
-	case 0x40010006:
-		/* If the Widcomm bluetooth stack is installed, the BTTray.exe
-		process injects code into running programs. For some reason this
-		results in random SEH exceptions with this (undocumented)
-		exception code being raised. The workaround seems to be ignoring
-		this altogether, since that is what happens if SEH is not
-		enabled. Don't really have any idea what this exception means. */
-		break;
 	default:
 		signal_number = e->ExceptionCode;
 		c->EIP = (cell)factor::misc_signal_handler_impl;
 		break;
 	}
-	return EXCEPTION_CONTINUE_EXECUTION;
+
+	return ExceptionContinueExecution;
 }
 
-FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe)
+LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch)
 {
-	return current_vm()->exception_handler(pe);
+	return current_vm()->exception_handler(e,frame,c,dispatch);
 }
 
 void factor_vm::c_to_factor_toplevel(cell quot)
 {
-	if(!AddVectoredExceptionHandler(0, (PVECTORED_EXCEPTION_HANDLER)factor::exception_handler))
-		fatal_error("AddVectoredExceptionHandler failed", 0);
-
 	c_to_factor(quot);
-
- 	RemoveVectoredExceptionHandler((void *)factor::exception_handler);
 }
 
 void factor_vm::open_console()

vm/os-windows-nt.hpp

@@ -22,13 +22,7 @@ typedef char symbol_char;
 
 #define FACTOR_DLL NULL
 
-#ifdef _MSC_VER
+LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch);
-	#define FACTOR_STDCALL(return_type) return_type __stdcall
-#else
-	#define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type
-#endif
-
-FACTOR_STDCALL(LONG) exception_handler(PEXCEPTION_POINTERS pe);
 
 // SSE traps raise these exception codes, which are defined in internal NT headers
 // but not winbase.h

vm/vm.hpp

@@ -706,7 +706,7 @@ struct factor_vm
 
   #if defined(WINNT)
 	void open_console();
-	LONG exception_handler(PEXCEPTION_POINTERS pe);
+	LONG exception_handler(PEXCEPTION_RECORD e, void *frame, PCONTEXT c, void *dispatch);
   #endif
 
   #else  // UNIX