Merge branch 'master' of git://factorcode.org/git/factor into abi-symbols

Conflicts:
	basis/compiler/tests/alien.factor

Nmakefile

@@ -1,12 +1,14 @@
 !IF DEFINED(DEBUG)
-LINK_FLAGS = /nologo /DEBUG shell32.lib
+LINK_FLAGS = /nologo /safeseh /DEBUG shell32.lib
 CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
 !ELSE
-LINK_FLAGS = /nologo shell32.lib
+LINK_FLAGS = /nologo /safeseh shell32.lib
 CL_FLAGS = /nologo /O2 /W3
 !ENDIF
 
-EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
+ML_FLAGS = /nologo /safeseh
+
+EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
 
 DLL_OBJS = vm\os-windows-nt.obj \
 	vm\os-windows.obj \
@@ -47,6 +49,7 @@ DLL_OBJS = vm\os-windows-nt.obj \
 	vm\profiler.obj \
 	vm\quotations.obj \
 	vm\run.obj \
+	vm\safeseh.obj \
 	vm\strings.obj \
 	vm\to_tenured_collector.obj \
 	vm\tuples.obj \
@@ -60,10 +63,13 @@ DLL_OBJS = vm\os-windows-nt.obj \
 .c.obj:
 	cl $(CL_FLAGS) /Fo$@ /c $<
 
+.asm.obj:
+	ml $(ML_FLAGS) /Fo$@ /c $<
+
 .rs.res:
 	rc $<
 
-all: factor.com factor.exe libfactor-ffi-test.dll
+all: factor.com factor.exe factor.dll.lib libfactor-ffi-test.dll
 
 libfactor-ffi-test.dll: vm/ffi_test.obj
 	link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
@@ -71,11 +77,11 @@ libfactor-ffi-test.dll: vm/ffi_test.obj
 factor.dll.lib: $(DLL_OBJS)
 	link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
 
-factor.com: $(EXE_OBJS)
+factor.com: $(EXE_OBJS) $(DLL_OBJS)
-	link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
+	link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) $(DLL_OBJS)
 
-factor.exe: $(EXE_OBJS)
+factor.exe: $(EXE_OBJS) $(DLL_OBJS)
-	link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
+	link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) $(DLL_OBJS)
 
 clean:
 	del vm\*.obj

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/boxes/boxes.factor

@@ -11,7 +11,7 @@ ERROR: box-full box ;
 
 : >box ( value box -- )
     dup occupied>>
-    [ box-full ] [ t >>occupied (>>value) ] if ;
+    [ box-full ] [ t >>occupied (>>value) ] if ; inline
 
 ERROR: box-empty box ;
 
@@ -19,10 +19,10 @@ ERROR: box-empty box ;
     dup occupied>> [ box-empty ] unless ; inline
 
 : box> ( box -- value )
-    check-box [ f ] change-value f >>occupied drop ;
+    check-box [ f ] change-value f >>occupied drop ; inline
 
 : ?box ( box -- value/f ? )
-    dup occupied>> [ box> t ] [ drop f f ] if ;
+    dup occupied>> [ box> t ] [ drop f f ] if ; inline
 
 : if-box? ( box quot -- )
     [ ?box ] dip [ drop ] if ; inline

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -202,14 +202,16 @@ M: ##slot-imm insn-slot# slot>> ;
 M: ##set-slot insn-slot# slot>> constant ;
 M: ##set-slot-imm insn-slot# slot>> ;
 M: ##alien-global insn-slot# [ library>> ] [ symbol>> ] bi 2array ;
-M: ##vm-field-ptr insn-slot# field-name>> ;
+M: ##vm-field insn-slot# offset>> ;
+M: ##set-vm-field insn-slot# offset>> ;
 
 M: ##slot insn-object obj>> resolve ;
 M: ##slot-imm insn-object obj>> resolve ;
 M: ##set-slot insn-object obj>> resolve ;
 M: ##set-slot-imm insn-object obj>> resolve ;
 M: ##alien-global insn-object drop \ ##alien-global ;
-M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
+M: ##vm-field insn-object drop \ ##vm-field ;
+M: ##set-vm-field insn-object drop \ ##vm-field ;
 
 : init-alias-analysis ( insns -- insns' )
     H{ } clone histories set
@@ -222,7 +224,7 @@ M: ##vm-field-ptr insn-object drop \ ##vm-field-ptr ;
     0 ac-counter set
     next-ac heap-ac set
 
-    \ ##vm-field-ptr set-new-ac
+    \ ##vm-field set-new-ac
     \ ##alien-global set-new-ac
 
     dup local-live-in [ set-heap-ac ] each ;

basis/compiler/cfg/instructions/instructions.factor

@@ -660,13 +660,13 @@ INSN: ##alien-global
 def: dst/int-rep
 literal: symbol library ;
 
-INSN: ##vm-field-ptr
-def: dst/int-rep
-literal: field-name ;
-
 INSN: ##vm-field
 def: dst/int-rep
-literal: field-name ;
+literal: offset ;
+
+INSN: ##set-vm-field
+use: src/int-rep
+literal: offset ;
 
 ! FFI
 INSN: ##alien-invoke
@@ -835,8 +835,8 @@ UNION: ##allocation
 ##box-displaced-alien ;
 
 ! For alias analysis
-UNION: ##read ##slot ##slot-imm ##vm-field-ptr ##alien-global ;
+UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
-UNION: ##write ##set-slot ##set-slot-imm ;
+UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
 
 ! Instructions that kill all live vregs but cannot trigger GC
 UNION: partial-sync-insn

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -32,6 +32,7 @@ IN: compiler.cfg.intrinsics
     { kernel.private:tag [ drop emit-tag ] }
     { kernel.private:context-object [ emit-context-object ] }
     { kernel.private:special-object [ emit-special-object ] }
+    { kernel.private:set-special-object [ emit-set-special-object ] }
     { kernel.private:(identity-hashcode) [ drop emit-identity-hashcode ] }
     { math.private:both-fixnums? [ drop emit-both-fixnums? ] }
     { math.private:fixnum+ [ drop emit-fixnum+ ] }

basis/compiler/cfg/intrinsics/misc/misc.factor

@@ -1,30 +1,39 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces layouts sequences kernel math accessors
 compiler.tree.propagation.info compiler.cfg.stacks
 compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.builder.blocks
 compiler.cfg.utilities ;
-FROM: vm => context-field-offset ;
+FROM: vm => context-field-offset vm-field-offset ;
 IN: compiler.cfg.intrinsics.misc
 
 : emit-tag ( -- )
     ds-pop tag-mask get ^^and-imm ^^tag-fixnum ds-push ;
 
+: special-object-offset ( n -- offset )
+    cells "special-objects" vm-field-offset + ;
+
 : emit-special-object ( node -- )
     dup node-input-infos first literal>> [
-        "special-objects" ^^vm-field-ptr
+        ds-drop
-        ds-drop swap 0 ^^slot-imm
+        special-object-offset ^^vm-field
         ds-push
     ] [ emit-primitive ] ?if ;
 
-: context-object-offset ( -- n )
+: emit-set-special-object ( node -- )
-    "context-objects" context-field-offset cell /i ;
+    dup node-input-infos second literal>> [
+        ds-drop
+        [ ds-pop ] dip special-object-offset ##set-vm-field
+    ] [ emit-primitive ] ?if ;
+
+: context-object-offset ( n -- n )
+    cells "context-objects" context-field-offset + ;
 
 : emit-context-object ( node -- )
     dup node-input-infos first literal>> [
-        "ctx" ^^vm-field
+        "ctx" vm-field-offset ^^vm-field
-        ds-drop swap context-object-offset + 0 ^^slot-imm ds-push
+        ds-drop swap context-object-offset cell /i 0 ^^slot-imm ds-push
     ] [ emit-primitive ] ?if ;
 
 : emit-identity-hashcode ( -- )

basis/compiler/codegen/codegen.factor

@@ -210,8 +210,8 @@ CODEGEN: ##compare-imm %compare-imm
 CODEGEN: ##compare-float-ordered %compare-float-ordered
 CODEGEN: ##compare-float-unordered %compare-float-unordered
 CODEGEN: ##save-context %save-context
-CODEGEN: ##vm-field-ptr %vm-field-ptr
 CODEGEN: ##vm-field %vm-field
+CODEGEN: ##set-vm-field %set-vm-field
 
 CODEGEN: _fixnum-add %fixnum-add
 CODEGEN: _fixnum-sub %fixnum-sub

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/compiler/tests/alien.factor

@@ -445,13 +445,17 @@ STRUCT: double-rect
     [ "example" set-global 2drop ] alien-callback ;
 
 : double-rect-test ( arg -- arg' )
-    f f rot
+    [ f f ] 2dip
     double-rect-callback
     void { void* void* double-rect } cdecl alien-indirect
     "example" get-global ;
 
 [ 1.0 2.0 3.0 4.0 ]
-[ 1.0 2.0 3.0 4.0 <double-rect> double-rect-test >double-rect< ] unit-test
+[
+    1.0 2.0 3.0 4.0 <double-rect>
+    double-rect-callback double-rect-test
+    >double-rect<
+] unit-test
 
 STRUCT: test_struct_14
     { x1 double }

basis/concurrency/conditions/conditions.factor

@@ -4,10 +4,10 @@ USING: deques threads kernel arrays sequences alarms fry ;
 IN: concurrency.conditions
 
 : notify-1 ( deque -- )
-    dup deque-empty? [ drop ] [ pop-back resume-now ] if ;
+    dup deque-empty? [ drop ] [ pop-back resume-now ] if ; inline
 
 : notify-all ( deque -- )
-    [ resume-now ] slurp-deque ;
+    [ resume-now ] slurp-deque ; inline
 
 : queue-timeout ( queue timeout -- alarm )
     #! Add an alarm which removes the current thread from the
@@ -23,7 +23,7 @@ IN: concurrency.conditions
 ERROR: wait-timeout ;
 
 : queue ( queue -- )
-    [ self ] dip push-front ;
+    [ self ] dip push-front ; inline
 
 : wait ( queue timeout status -- )
     over [
@@ -31,4 +31,4 @@ ERROR: wait-timeout ;
         [ wait-timeout ] [ cancel-alarm ] if
     ] [
         [ drop queue ] dip suspend drop
-    ] if ;
+    ] if ; inline

basis/concurrency/mailboxes/mailboxes.factor

@@ -6,22 +6,24 @@ concurrency.conditions accessors debugger debugger.threads
 locals fry ;
 IN: concurrency.mailboxes
 
-TUPLE: mailbox threads data ;
+TUPLE: mailbox { threads dlist } { data dlist } ;
 
 : <mailbox> ( -- mailbox )
     mailbox new
         <dlist> >>threads
-        <dlist> >>data ;
+        <dlist> >>data ; inline
 
 : mailbox-empty? ( mailbox -- bool )
-    data>> deque-empty? ;
+    data>> deque-empty? ; inline
 
-: mailbox-put ( obj mailbox -- )
+GENERIC: mailbox-put ( obj mailbox -- )
+
+M: mailbox mailbox-put
     [ data>> push-front ]
     [ threads>> notify-all ] bi yield ;
 
 : wait-for-mailbox ( mailbox timeout -- )
-    [ threads>> ] dip "mailbox" wait ;
+    [ threads>> ] dip "mailbox" wait ; inline
 
 :: block-unless-pred ( ... mailbox timeout pred: ( ... message -- ... ? ) -- ... )
     mailbox data>> pred dlist-any? [
@@ -34,16 +36,17 @@ TUPLE: mailbox threads data ;
         2dup wait-for-mailbox block-if-empty
     ] [
         drop
-    ] if ;
+    ] if ; inline recursive
 
 : mailbox-peek ( mailbox -- obj )
     data>> peek-back ;
 
-: mailbox-get-timeout ( mailbox timeout -- obj )
+GENERIC# mailbox-get-timeout 1 ( mailbox timeout -- obj )
-    block-if-empty data>> pop-back ;
+
+M: mailbox mailbox-get-timeout block-if-empty data>> pop-back ;
 
 : mailbox-get ( mailbox -- obj )
-    f mailbox-get-timeout ;
+    f mailbox-get-timeout ; inline
 
 : mailbox-get-all-timeout ( mailbox timeout -- array )
     block-if-empty

basis/concurrency/messaging/messaging.factor

@@ -1,20 +1,22 @@
-! Copyright (C) 2005, 2008 Chris Double, Slava Pestov.
+! Copyright (C) 2005, 2010 Chris Double, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel threads concurrency.mailboxes continuations
+USING: kernel kernel.private threads concurrency.mailboxes
-namespaces assocs accessors summary fry ;
+continuations namespaces assocs accessors summary fry ;
 IN: concurrency.messaging
 
 GENERIC: send ( message thread -- )
 
-: mailbox-of ( thread -- mailbox )
+GENERIC: mailbox-of ( thread -- mailbox )
-    dup mailbox>> [ ] [
+
-        <mailbox> [ >>mailbox drop ] keep
+M: thread mailbox-of
-    ] ?if ;
+    dup mailbox>>
+    [ { mailbox } declare ]
+    [ <mailbox> [ >>mailbox drop ] keep ] ?if ; inline
 
 M: thread send ( message thread -- )
-    check-registered mailbox-of mailbox-put ;
+    mailbox-of mailbox-put ;
 
-: my-mailbox ( -- mailbox ) self mailbox-of ;
+: my-mailbox ( -- mailbox ) self mailbox-of ; inline
 
 : receive ( -- message )
     my-mailbox mailbox-get ?linked ;

basis/cpu/architecture/architecture.factor

@@ -447,8 +447,10 @@ HOOK: %set-alien-double    cpu ( ptr offset value -- )
 HOOK: %set-alien-vector    cpu ( ptr offset value rep -- )
 
 HOOK: %alien-global cpu ( dst symbol library -- )
-HOOK: %vm-field cpu ( dst fieldname -- )
+HOOK: %vm-field cpu ( dst offset -- )
-HOOK: %vm-field-ptr cpu ( dst fieldname -- )
+HOOK: %set-vm-field cpu ( src offset -- )
+
+: %context ( dst -- ) 0 %vm-field ;
 
 HOOK: %allot cpu ( dst size class temp -- )
 HOOK: %write-barrier cpu ( src slot temp1 temp2 -- )

basis/cpu/ppc/bootstrap.factor

@@ -76,9 +76,12 @@ CONSTANT: nv-reg 17
     432 save-at ;
 
 [
+    ! Save old stack pointer
+    11 1 MR
+
     ! Create stack frame
     0 MFLR
-    1 1 callback-frame-size neg STWU
+    1 1 callback-frame-size SUBI
     0 1 callback-frame-size lr-save + STW
 
     ! Save all non-volatile registers
@@ -86,6 +89,10 @@ CONSTANT: nv-reg 17
     nv-fp-regs [ 8 * 80 + save-fp ] each-index
     nv-vec-regs [ 16 * 224 + save-vec ] each-index
 
+    ! Stick old stack pointer in a non-volatile register so that
+    ! callbacks can access their arguments
+    nv-reg 11 MR
+
     ! Load VM into vm-reg
     0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
 
@@ -126,7 +133,7 @@ CONSTANT: nv-reg 17
 
     ! Tear down stack frame and return
     0 1 callback-frame-size lr-save + LWZ
-    1 1 0 LWZ
+    1 1 callback-frame-size ADDI
     0 MTLR
     BLR
 ] callback-stub jit-define

basis/cpu/ppc/ppc.factor

@@ -58,11 +58,9 @@ CONSTANT: vm-reg 15
 
 : %load-vm-addr ( reg -- ) vm-reg MR ;
 
-M: ppc %vm-field ( dst field -- )
+M: ppc %vm-field ( dst field -- ) [ vm-reg ] dip LWZ ;
-    [ vm-reg ] dip vm-field-offset LWZ ;
 
-M: ppc %vm-field-ptr ( dst field -- )
+M: ppc %set-vm-field ( src field -- ) [ vm-reg ] dip STW ;
-    [ vm-reg ] dip vm-field-offset ADDI ;
 
 GENERIC: loc-reg ( loc -- reg )
 
@@ -385,7 +383,7 @@ M: ppc %set-alien-float -rot STFS ;
 M: ppc %set-alien-double -rot STFD ;
 
 : load-zone-ptr ( reg -- )
-    "nursery" %vm-field-ptr ;
+    vm-reg "nursery" vm-field-offset ADDI ;
 
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
     [ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
@@ -567,8 +565,7 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- )
     } case ;
 
 : next-param@ ( n -- reg x )
-    2 1 stack-frame get total-size>> LWZ
+    [ 17 ] dip param@ ;
-    [ 2 ] dip param@ ;
 
 : store-to-frame ( src n rep -- )
     {
@@ -604,14 +601,14 @@ M: ppc %push-stack ( -- )
     int-regs return-reg ds-reg 0 STW ;
 
 M: ppc %push-context-stack ( -- )
-    11 "ctx" %vm-field
+    11 %context
     12 11 "datastack" context-field-offset LWZ
     12 12 4 ADDI
     12 11 "datastack" context-field-offset STW
     int-regs return-reg 12 0 STW ;
 
 M: ppc %pop-context-stack ( -- )
-    11 "ctx" %vm-field
+    11 %context
     12 11 "datastack" context-field-offset LWZ
     int-regs return-reg 12 0 LWZ
     12 12 4 SUBI
@@ -677,12 +674,12 @@ M: ppc %box-large-struct ( n c-type -- )
     "from_value_struct" f %alien-invoke ;
 
 M:: ppc %restore-context ( temp1 temp2 -- )
-    temp1 "ctx" %vm-field
+    temp1 %context
     ds-reg temp1 "datastack" context-field-offset LWZ
     rs-reg temp1 "retainstack" context-field-offset LWZ ;
 
 M:: ppc %save-context ( temp1 temp2 -- )
-    temp1 "ctx" %vm-field
+    temp1 %context
     1 temp1 "callstack-top" context-field-offset STW
     ds-reg temp1 "datastack" context-field-offset STW
     rs-reg temp1 "retainstack" context-field-offset STW ;
@@ -751,14 +748,14 @@ M: ppc %alien-callback ( quot -- )
 
 M: ppc %end-callback ( -- )
     3 %load-vm-addr
-    "unnest_context" f %alien-invoke ;
+    "end_callback" f %alien-invoke ;
 
 M: ppc %end-callback-value ( ctype -- )
     ! Save top of data stack
-    12 ds-reg 0 LWZ
+    16 ds-reg 0 LWZ
     %end-callback
     ! Restore top of data stack
-    3 12 MR
+    3 16 MR
     ! Unbox former top of data stack to return registers
     unbox-return ;
 

basis/cpu/x86/32/32.factor

@@ -29,10 +29,13 @@ M: x86.32 %mov-vm-ptr ( reg -- )
     0 MOV 0 rc-absolute-cell rel-vm ;
 
 M: x86.32 %vm-field ( dst field -- )
-    [ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+    [ 0 [] MOV ] dip rc-absolute-cell rel-vm ;
+
+M: x86.32 %set-vm-field ( dst field -- )
+    [ 0 [] swap MOV ] dip rc-absolute-cell rel-vm ;
 
 M: x86.32 %vm-field-ptr ( dst field -- )
-    [ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+    [ 0 MOV ] dip rc-absolute-cell rel-vm ;
 
 : local@ ( n -- op )
     stack-frame get extra-stack-space dup 16 assert= + stack@ ;
@@ -182,7 +185,7 @@ M: x86.32 %pop-stack ( n -- )
     EAX swap ds-reg reg-stack MOV ;
 
 M: x86.32 %pop-context-stack ( -- )
-    temp-reg "ctx" %vm-field
+    temp-reg %context
     EAX temp-reg "datastack" context-field-offset [+] MOV
     EAX EAX [] MOV
     temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
@@ -257,6 +260,7 @@ M: x86.32 %alien-indirect ( -- )
 
 M: x86.32 %begin-callback ( -- )
     0 save-vm-ptr
+    ESP 4 [+] 0 MOV
     "begin_callback" f %alien-invoke ;
 
 M: x86.32 %alien-callback ( quot -- )

basis/cpu/x86/32/bootstrap.factor

@@ -82,11 +82,9 @@ IN: bootstrap.x86
 [
     jit-load-vm
     ESP [] vm-reg MOV
-    "begin_callback" jit-call
-
-    ! load quotation - EBP is ctx-reg so it will get clobbered
-    ! later on
     EAX EBP 8 [+] MOV
+    ESP 4 [+] EAX MOV
+    "begin_callback" jit-call
 
     jit-load-vm
     jit-load-context
@@ -110,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
@@ -124,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
 
@@ -255,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 ;
 
@@ -268,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
 
@@ -295,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 ;
@@ -317,6 +330,3 @@ IN: bootstrap.x86
     jit-delete-current-context
     jit-start-context
 ] \ (start-context-and-delete) define-sub-primitive
-
-<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
-call

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

@@ -0,0 +1,8 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel parser sequences ;
+IN: bootstrap.x86
+
+<< "vocab:cpu/x86/unix/bootstrap.factor" parse-file suffix! >> call
+<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> call
+<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call

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

@@ -0,0 +1,36 @@
+! 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-segment ( -- ) FS ;
+: tib-temp ( -- reg ) EAX ;
+
+<< "vocab:cpu/x86/winnt/bootstrap.factor" parse-file suffix! >> call
+
+: jit-install-seh ( -- )
+    ! Create a new exception record and store it in the TIB.
+    ! Clobbers tib-temp.
+    ! Align stack
+    ESP 3 bootstrap-cells ADD
+    ! Exception handler address filled in by callback.cpp
+    tib-temp 0 MOV rc-absolute-cell rt-exception-handler jit-rel
+    tib-temp PUSH
+    ! No next handler
+    0 PUSH
+    ! This is the new exception handler
+    tib-exception-list-offset [] ESP tib-segment MOV ;
+
+:: jit-update-seh ( ctx-reg -- )
+    ! Load exception record structure that jit-install-seh
+    ! created from the bottom of the callstack.
+    ! Clobbers tib-temp.
+    tib-temp ctx-reg context-callstack-bottom-offset [+] MOV
+    tib-temp bootstrap-cell ADD
+    ! Store exception record in TIB.
+    tib-exception-list-offset [] tib-temp tib-segment MOV ;
+
+<< "vocab:cpu/x86/32/bootstrap.factor" parse-file suffix! >> call
+<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call

basis/cpu/x86/64/64.factor

@@ -43,20 +43,23 @@ M: x86.64 machine-registers
 M: x86.64 %mov-vm-ptr ( reg -- )
     vm-reg MOV ;
 
-M: x86.64 %vm-field ( dst field -- )
+M: x86.64 %vm-field ( dst offset -- )
-    [ vm-reg ] dip vm-field-offset [+] MOV ;
+    [ vm-reg ] dip [+] MOV ;
 
-M: x86.64 %vm-field-ptr ( dst field -- )
+M: x86.64 %set-vm-field ( src offset -- )
-    [ vm-reg ] dip vm-field-offset [+] LEA ;
+    [ vm-reg ] dip [+] swap MOV ;
+
+M: x86.64 %vm-field-ptr ( dst offset -- )
+    [ vm-reg ] dip [+] LEA ;
 
 M: x86.64 %prologue ( n -- )
-    temp-reg -7 [] LEA
+    temp-reg -7 [RIP+] LEA
     dup PUSH
     temp-reg PUSH
     stack-reg swap 3 cells - SUB ;
 
 M: x86.64 %prepare-jump
-    pic-tail-reg xt-tail-pic-offset [] LEA ;
+    pic-tail-reg xt-tail-pic-offset [RIP+] LEA ;
 
 : load-cards-offset ( dst -- )
     0 MOV rc-absolute-cell rel-cards-offset ;
@@ -109,7 +112,7 @@ M: x86.64 %pop-stack ( n -- )
     param-reg-0 swap ds-reg reg-stack MOV ;
 
 M: x86.64 %pop-context-stack ( -- )
-    temp-reg "ctx" %vm-field
+    temp-reg %context
     param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
     param-reg-0 param-reg-0 [] MOV
     temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
@@ -226,6 +229,7 @@ M: x86.64 %alien-indirect ( -- )
 
 M: x86.64 %begin-callback ( -- )
     param-reg-0 %mov-vm-ptr
+    param-reg-1 0 MOV
     "begin_callback" f %alien-invoke ;
 
 M: x86.64 %alien-callback ( quot -- )

basis/cpu/x86/64/bootstrap.factor

@@ -42,7 +42,7 @@ IN: bootstrap.x86
 ] jit-prolog jit-define
 
 [
-    temp3 5 [] LEA
+    temp3 5 [RIP+] LEA
     0 JMP rc-relative rt-entry-point-pic-tail jit-rel
 ] jit-word-jump jit-define
 
@@ -76,8 +76,7 @@ IN: bootstrap.x86
 : jit-call-quot ( -- ) arg1 quot-entry-point-offset [+] CALL ;
 
 [
-    nv-reg arg1 MOV
+    arg2 arg1 MOV
-
     arg1 vm-reg MOV
     "begin_callback" jit-call
 
@@ -85,7 +84,7 @@ IN: bootstrap.x86
     jit-restore-context
 
     ! call the quotation
-    arg1 nv-reg MOV
+    arg1 return-reg MOV
     jit-call-quot
 
     jit-save-context
@@ -234,7 +233,9 @@ IN: bootstrap.x86
     RSP ctx-reg context-callstack-top-offset [+] MOV
 
     ! Load new ds, rs registers
-    jit-restore-context ;
+    jit-restore-context
+
+    ctx-reg jit-update-tib ;
 
 : jit-pop-context-and-param ( -- )
     arg1 ds-reg [] MOV
@@ -289,6 +290,3 @@ IN: bootstrap.x86
     jit-delete-current-context
     jit-start-context
 ] \ (start-context-and-delete) define-sub-primitive
-
-<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >>
-call

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

@@ -12,5 +12,6 @@ IN: bootstrap.x86
 : arg3 ( -- reg ) RDX ;
 : arg4 ( -- reg ) RCX ;
 
-<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
+<< "vocab:cpu/x86/unix/bootstrap.factor" parse-file suffix! >> call
-call
+<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call
+<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call

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

@@ -5,6 +5,8 @@ vocabs sequences cpu.x86.assembler parser
 cpu.x86.assembler.operands ;
 IN: bootstrap.x86
 
+DEFER: stack-reg
+
 : stack-frame-size ( -- n ) 8 bootstrap-cells ;
 : nv-regs ( -- seq ) { RBX RSI RDI R12 R13 R14 R15 } ;
 : arg1 ( -- reg ) RCX ;
@@ -12,5 +14,12 @@ IN: bootstrap.x86
 : arg3 ( -- reg ) R8 ;
 : arg4 ( -- reg ) R9 ;
 
-<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >>
+: tib-segment ( -- ) GS ;
-call
+: tib-temp ( -- reg ) R11 ;
+
+: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
+: jit-update-seh ( ctx-reg -- ) drop ;
+
+<< "vocab:cpu/x86/winnt/bootstrap.factor" parse-file suffix! >> call
+<< "vocab:cpu/x86/64/bootstrap.factor" parse-file suffix! >> call
+<< "vocab:cpu/x86/bootstrap.factor" parse-file suffix! >> call

basis/cpu/x86/assembler/assembler-tests.factor

@@ -1,5 +1,5 @@
 USING: cpu.x86.assembler cpu.x86.assembler.operands
-kernel tools.test namespaces make ;
+kernel tools.test namespaces make layouts ;
 IN: cpu.x86.assembler.tests
 
 [ { HEX: 40 HEX: 8a HEX: 2a } ] [ [ BPL RDX [] MOV ] { } make ] unit-test
@@ -164,5 +164,11 @@ IN: cpu.x86.assembler.tests
 
 [ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test
 
-[ { 100 199 5 0 0 0 0 123 0 0 0 } ] [ [ 0 [] FS 123 MOV ] { } make ] unit-test
+bootstrap-cell 4 = [
+    [ { 100 199 5 0 0 0 0 123 0 0 0 } ] [ [ 0 [] FS 123 MOV ] { } make ] unit-test
+] when
 
+bootstrap-cell 8 = [
+    [ { 72 137 13 123 0 0 0 } ] [ [ 123 [RIP+] RCX MOV ] { } make ] unit-test
+    [ { 101 72 137 12 37 123 0 0 0 } ] [ [ 123 [] GS RCX MOV ] { } make ] unit-test
+] when

basis/cpu/x86/assembler/assembler.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2005, 2009 Slava Pestov, Joe Groff.
+! Copyright (C) 2005, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays io.binary kernel combinators kernel.private math
+USING: arrays io.binary kernel combinators
-math.bitwise locals namespaces make sequences words system
+combinators.short-circuit math math.bitwise locals namespaces
-layouts math.order accessors cpu.x86.assembler.operands
+make sequences words system layouts math.order accessors
-cpu.x86.assembler.operands.private ;
+cpu.x86.assembler.operands cpu.x86.assembler.operands.private ;
 QUALIFIED: sequences
 IN: cpu.x86.assembler
 
@@ -22,7 +22,11 @@ IN: cpu.x86.assembler
 GENERIC: sib-present? ( op -- ? )
 
 M: indirect sib-present?
-    [ base>> { ESP RSP R12 } member? ] [ index>> ] [ scale>> ] tri or or ;
+    {
+        [ base>> { ESP RSP R12 } member? ]
+        [ index>> ]
+        [ scale>> ]
+    } 1|| ;
 
 M: register sib-present? drop f ;
 

basis/cpu/x86/assembler/operands/operands.factor

@@ -1,13 +1,9 @@
-! Copyright (C) 2008, 2009 Slava Pestov, Joe Groff.
+! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel words math accessors sequences namespaces
 assocs layouts cpu.x86.assembler.syntax ;
 IN: cpu.x86.assembler.operands
 
-! In 32-bit mode, { 1234 } is absolute indirect addressing.
-! In 64-bit mode, { 1234 } is RIP-relative.
-! Beware!
-
 REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ;
 
 ALIAS: AH SPL
@@ -90,7 +86,13 @@ M: object operand-64? drop f ;
 PRIVATE>
 
 : [] ( reg/displacement -- indirect )
-    dup integer? [ [ f f f ] dip ] [ f f f ] if <indirect> ;
+    dup integer?
+    [ [ f f bootstrap-cell 8 = 0 f ? ] dip <indirect> ]
+    [ f f f <indirect> ]
+    if ;
+
+: [RIP+] ( displacement -- indirect )
+    [ f f f ] dip <indirect> ;
 
 : [+] ( reg displacement -- indirect )
     dup integer?

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/cpu/x86/unix/bootstrap.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cpu.x86.assembler cpu.x86.assembler.operands kernel
+layouts ;
+IN: bootstrap.x86
+
+DEFER: stack-reg
+
+: jit-save-tib ( -- ) ;
+: jit-restore-tib ( -- ) ;
+: jit-update-tib ( ctx-reg -- ) drop ;
+: jit-install-seh ( -- ) stack-reg bootstrap-cell ADD ;
+: jit-update-seh ( ctx-reg -- ) drop ;

basis/cpu/x86/winnt/bootstrap.factor

@@ -0,0 +1,32 @@
+! 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 [] tib-segment PUSH
+    tib-stack-base-offset [] tib-segment PUSH
+    tib-stack-limit-offset [] tib-segment PUSH ;
+
+: jit-restore-tib ( -- )
+    tib-stack-limit-offset [] tib-segment POP
+    tib-stack-base-offset [] tib-segment POP
+    tib-exception-list-offset [] tib-segment POP ;
+
+:: jit-update-tib ( ctx-reg -- )
+    ! There's a redundant load here because we're not allowed
+    ! to clobber ctx-reg. Clobbers tib-temp.
+    ! Save callstack base in TIB
+    tib-temp ctx-reg context-callstack-seg-offset [+] MOV
+    tib-temp tib-temp segment-end-offset [+] MOV
+    tib-stack-base-offset [] tib-temp tib-segment MOV
+    ! Save callstack limit in TIB
+    tib-temp ctx-reg context-callstack-seg-offset [+] MOV
+    tib-temp tib-temp segment-start-offset [+] MOV
+    tib-stack-limit-offset [] tib-temp tib-segment MOV ;

basis/cpu/x86/x86.factor

@@ -425,8 +425,13 @@ M: x86 %sar int-rep two-operand [ SAR ] emit-shift ;
 
 HOOK: %mov-vm-ptr cpu ( reg -- )
 
+HOOK: %vm-field-ptr cpu ( reg offset -- )
+
+: load-zone-offset ( nursery-ptr -- )
+    "nursery" vm-field-offset %vm-field-ptr ;
+
 : load-allot-ptr ( nursery-ptr allot-ptr -- )
-    [ drop "nursery" %vm-field-ptr ] [ swap [] MOV ] 2bi ;
+    [ drop load-zone-offset ] [ swap [] MOV ] 2bi ;
 
 : inc-allot-ptr ( nursery-ptr n -- )
     [ [] ] dip data-alignment get align ADD ;
@@ -458,7 +463,7 @@ M: x86 %write-barrier ( src slot temp1 temp2 -- ) (%write-barrier) ;
 M: x86 %write-barrier-imm ( src slot temp1 temp2 -- ) (%write-barrier) ;
 
 M:: x86 %check-nursery ( label size temp1 temp2 -- )
-    temp1 "nursery" %vm-field-ptr
+    temp1 load-zone-offset
     ! Load 'here' into temp2
     temp2 temp1 [] MOV
     temp2 size ADD
@@ -479,7 +484,7 @@ M: x86 %push-stack ( -- )
     ds-reg [] int-regs return-reg MOV ;
 
 M: x86 %push-context-stack ( -- )
-    temp-reg "ctx" %vm-field
+    temp-reg %context
     temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
     temp-reg temp-reg "datastack" context-field-offset [+] MOV
     temp-reg [] int-regs return-reg MOV ;
@@ -1405,7 +1410,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
 
 M:: x86 %restore-context ( temp1 temp2 -- )
     #! Load Factor stack pointers on entry from C to Factor.
-    temp1 "ctx" %vm-field
+    temp1 %context
     ds-reg temp1 "datastack" context-field-offset [+] MOV
     rs-reg temp1 "retainstack" context-field-offset [+] MOV ;
 
@@ -1413,7 +1418,7 @@ M:: x86 %save-context ( temp1 temp2 -- )
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
-    temp1 "ctx" %vm-field
+    temp1 %context
     temp2 stack-reg cell neg [+] LEA
     temp1 "callstack-top" context-field-offset [+] temp2 MOV
     temp1 "datastack" context-field-offset [+] ds-reg MOV

basis/dlists/dlists.factor

@@ -29,7 +29,7 @@ TUPLE: dlist
 : <hashed-dlist> ( -- search-deque )
     20 <hashtable> <dlist> <search-deque> ;
 
-M: dlist deque-empty? front>> not ;
+M: dlist deque-empty? front>> not ; inline
 
 M: dlist-node node-value obj>> ;
 

basis/heaps/heaps.factor

@@ -35,7 +35,7 @@ TUPLE: max-heap < heap ;
 : <max-heap> ( -- max-heap ) max-heap <heap> ;
 
 M: heap heap-empty? ( heap -- ? )
-    data>> empty? ;
+    data>> empty? ; inline
 
 M: heap heap-size ( heap -- n )
     data>> length ;

basis/io/pipes/windows/nt/nt.factor

@@ -3,7 +3,7 @@
 USING: alien alien.c-types arrays destructors io io.backend.windows libc
 windows.types math.bitwise windows.kernel32 windows namespaces
 make kernel sequences windows.errors assocs math.parser system
-random combinators accessors io.pipes io.ports ;
+random combinators accessors io.pipes io.ports literals ;
 IN: io.pipes.windows.nt
 
 ! This code is based on

basis/stack-checker/known-words/known-words.factor

@@ -355,7 +355,6 @@ M: bad-executable summary
 \ code-room { } { byte-array } define-primitive \ code-room  make-flushable
 \ compact-gc { } { } define-primitive
 \ compute-identity-hashcode { object } { } define-primitive
-\ context { } { c-ptr } define-primitive \ context make-flushable
 \ context-object { fixnum } { object } define-primitive \ context-object make-flushable
 \ context-object-for { fixnum c-ptr } { object } define-primitive \ context-object-for make-flushable
 \ current-callback { } { fixnum } define-primitive \ current-callback make-flushable

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

basis/threads/threads.factor

@@ -11,17 +11,20 @@ IN: threads
 
 ! Wrap sub-primitives; we don't want them inlined into callers
 ! since their behavior depends on what frames are on the callstack
+: context ( -- context )
+    2 context-object ; inline
+
 : set-context ( obj context -- obj' )
-    (set-context) ;
+    (set-context) ; inline
 
 : start-context ( obj quot: ( obj -- * ) -- obj' )
-    (start-context) ;
+    (start-context) ; inline
 
 : set-context-and-delete ( obj context -- * )
-    (set-context-and-delete) ;
+    (set-context-and-delete) ; inline
 
 : start-context-and-delete ( obj quot: ( obj -- * ) -- * )
-    (start-context-and-delete) ;
+    (start-context-and-delete) ; inline
 
 ! Context introspection
 : namestack-for ( context -- namestack )
@@ -80,23 +83,13 @@ sleep-entry ;
 : thread-registered? ( thread -- ? )
     id>> threads key? ;
 
-ERROR: already-stopped thread ;
-
-: check-unregistered ( thread -- thread )
-    dup thread-registered? [ already-stopped ] when ;
-
-ERROR: not-running thread ;
-
-: check-registered ( thread -- thread )
-    dup thread-registered? [ not-running ] unless ;
-
 <PRIVATE
 
 : register-thread ( thread -- )
-    check-unregistered dup id>> threads set-at ;
+    dup id>> threads set-at ;
 
 : unregister-thread ( thread -- )
-    check-registered id>> threads delete-at ;
+    id>> threads delete-at ;
 
 : set-self ( thread -- ) 63 set-special-object ; inline
 
@@ -106,7 +99,7 @@ PRIVATE>
     65 special-object { dlist } declare ; inline
 
 : sleep-queue ( -- heap )
-    66 special-object { dlist } declare ; inline
+    66 special-object { min-heap } declare ; inline
 
 : new-thread ( quot name class -- thread )
     new
@@ -120,16 +113,13 @@ PRIVATE>
     \ thread new-thread ;
 
 : resume ( thread -- )
-    f >>state
+    f >>state run-queue push-front ;
-    check-registered run-queue push-front ;
 
 : resume-now ( thread -- )
-    f >>state
+    f >>state run-queue push-back ;
-    check-registered run-queue push-back ;
 
 : resume-with ( obj thread -- )
-    f >>state
+    f >>state 2array run-queue push-front ;
-    check-registered 2array run-queue push-front ;
 
 : sleep-time ( -- nanos/f )
     {
@@ -150,22 +140,19 @@ DEFER: stop
 <PRIVATE
 
 : schedule-sleep ( thread dt -- )
-    [ check-registered dup ] dip sleep-queue heap-push*
+    dupd sleep-queue heap-push* >>sleep-entry drop ;
-    >>sleep-entry drop ;
 
-: expire-sleep? ( heap -- ? )
+: expire-sleep? ( -- ? )
-    dup heap-empty?
+    sleep-queue dup heap-empty?
     [ drop f ] [ heap-peek nip nano-count <= ] if ;
 
 : expire-sleep ( thread -- )
     f >>sleep-entry resume ;
 
 : expire-sleep-loop ( -- )
-    sleep-queue
+    [ expire-sleep? ]
-    [ dup expire-sleep? ]
+    [ sleep-queue heap-pop drop expire-sleep ]
-    [ dup heap-pop drop expire-sleep ]
+    while ;
-    while
-    drop ;
 
 CONSTANT: [start]
     [
@@ -177,7 +164,9 @@ CONSTANT: [start]
 
 : no-runnable-threads ( -- ) die ;
 
-: (next) ( obj thread -- obj' )
+GENERIC: (next) ( obj thread -- obj' )
+
+M: thread (next)
     dup runnable>>
     [ context>> box> set-context ]
     [ t >>runnable drop [start] start-context ] if ;

basis/vm/vm.factor

@@ -11,10 +11,10 @@ STRUCT: context
 { datastack cell }
 { retainstack cell }
 { callstack-save cell }
-{ context-objects cell[10] }
 { datastack-region void* }
 { retainstack-region void* }
-{ callstack-region void* } ;
+{ callstack-region void* }
+{ context-objects cell[10] } ;
 
 : context-field-offset ( field -- offset ) context offset-of ; inline
 

basis/windows/directx/d3d9types/d3d9types.factor

@@ -759,25 +759,25 @@ CONSTANT: D3DSHADER_ADDRMODE_FORCE_DWORD HEX: 7fffffff
 CONSTANT: D3DVS_SWIZZLE_SHIFT     16
 CONSTANT: D3DVS_SWIZZLE_MASK      HEX: 00FF0000
 
-: D3DVS_X_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT shift ; inline
+CONSTANT: D3DVS_X_X $[ 0 16 shift ]
-: D3DVS_X_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT shift ; inline
+CONSTANT: D3DVS_X_Y $[ 1 16 shift ]
-: D3DVS_X_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT shift ; inline
+CONSTANT: D3DVS_X_Z $[ 2 16 shift ]
-: D3DVS_X_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT shift ; inline
+CONSTANT: D3DVS_X_W $[ 3 16 shift ]
 
-: D3DVS_Y_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
+CONSTANT: D3DVS_Y_X $[ 0 16 2 + shift ]
-: D3DVS_Y_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
+CONSTANT: D3DVS_Y_Y $[ 1 16 2 + shift ]
-: D3DVS_Y_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
+CONSTANT: D3DVS_Y_Z $[ 2 16 2 + shift ]
-: D3DVS_Y_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 2 + shift ; inline
+CONSTANT: D3DVS_Y_W $[ 3 16 2 + shift ]
 
-: D3DVS_Z_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
+CONSTANT: D3DVS_Z_X $[ 0 16 4 + shift ]
-: D3DVS_Z_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
+CONSTANT: D3DVS_Z_Y $[ 1 16 4 + shift ]
-: D3DVS_Z_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
+CONSTANT: D3DVS_Z_Z $[ 2 16 4 + shift ]
-: D3DVS_Z_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 4 + shift ; inline
+CONSTANT: D3DVS_Z_W $[ 3 16 4 + shift ]
 
-: D3DVS_W_X ( -- n ) 0 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
+CONSTANT: D3DVS_W_X $[ 0 16 6 + shift ]
-: D3DVS_W_Y ( -- n ) 1 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
+CONSTANT: D3DVS_W_Y $[ 1 16 6 + shift ]
-: D3DVS_W_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
+CONSTANT: D3DVS_W_Z $[ 2 16 6 + shift ]
-: D3DVS_W_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
+CONSTANT: D3DVS_W_W $[ 3 16 6 + shift ]
 
 CONSTANT: D3DVS_NOSWIZZLE flags{ D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W }
 
@@ -787,20 +787,20 @@ CONSTANT: D3DSP_SRCMOD_SHIFT      24
 CONSTANT: D3DSP_SRCMOD_MASK       HEX: 0F000000
 
 TYPEDEF: int D3DSHADER_PARAM_SRCMOD_TYPE
-: D3DSPSM_NONE    ( -- n ) 0 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_NONE    $[ 0 24 shift ]
-: D3DSPSM_NEG     ( -- n ) 1 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_NEG     $[ 1 24 shift ]
-: D3DSPSM_BIAS    ( -- n ) 2 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_BIAS    $[ 2 24 shift ]
-: D3DSPSM_BIASNEG ( -- n ) 3 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_BIASNEG $[ 3 24 shift ]
-: D3DSPSM_SIGN    ( -- n ) 4 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_SIGN    $[ 4 24 shift ]
-: D3DSPSM_SIGNNEG ( -- n ) 5 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_SIGNNEG $[ 5 24 shift ]
-: D3DSPSM_COMP    ( -- n ) 6 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_COMP    $[ 6 24 shift ]
-: D3DSPSM_X2      ( -- n ) 7 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_X2      $[ 7 24 shift ]
-: D3DSPSM_X2NEG   ( -- n ) 8 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_X2NEG   $[ 8 24 shift ]
-: D3DSPSM_DZ      ( -- n ) 9 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_DZ      $[ 9 24 shift ]
-: D3DSPSM_DW      ( -- n ) 10 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_DW      $[ 10 24 shift ]
-: D3DSPSM_ABS     ( -- n ) 11 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_ABS     $[ 11 24 shift ]
-: D3DSPSM_ABSNEG  ( -- n ) 12 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_ABSNEG  $[ 12 24 shift ]
-: D3DSPSM_NOT     ( -- n ) 13 D3DSP_SRCMOD_SHIFT shift ; inline
+CONSTANT: D3DSPSM_NOT     $[ 13 24 shift ]
 CONSTANT: D3DSPSM_FORCE_DWORD HEX: 7fffffff
 
 : D3DPS_VERSION ( major minor -- n )

basis/windows/errors/errors.factor

@@ -1,7 +1,7 @@
 USING: alien.data kernel locals math math.bitwise
 windows.kernel32 sequences byte-arrays unicode.categories
 io.encodings.string io.encodings.utf16n alien.strings
-arrays literals windows.types specialized-arrays literals ;
+arrays literals windows.types specialized-arrays ;
 SPECIALIZED-ARRAY: TCHAR
 IN: windows.errors
 

basis/windows/winsock/winsock.factor

@@ -3,7 +3,7 @@
 USING: alien alien.c-types alien.strings alien.syntax arrays
 byte-arrays kernel literals math sequences windows.types
 windows.kernel32 windows.errors math.bitwise io.encodings.utf16n
-classes.struct windows.com.syntax init literals ;
+classes.struct windows.com.syntax init ;
 FROM: alien.c-types => short ;
 IN: windows.winsock
 

build-support/factor.sh

@@ -68,7 +68,7 @@ set_downloader() {
     if [[ $? -ne 0 ]] ; then
         DOWNLOADER=wget
     else
-        DOWNLOADER="curl -O"
+        DOWNLOADER="curl -f -O"
     fi
 }
 
@@ -291,9 +291,15 @@ set_build_info() {
     elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then
         MAKE_IMAGE_TARGET=winnt-x86.64
         MAKE_TARGET=winnt-x86-64
+    elif [[ $OS == winnt && $ARCH == x86 && $WORD == 32 ]] ; then
+        MAKE_IMAGE_TARGET=winnt-x86.32
+        MAKE_TARGET=winnt-x86-32
     elif [[ $ARCH == x86 && $WORD == 64 ]] ; then
         MAKE_IMAGE_TARGET=unix-x86.64
         MAKE_TARGET=$OS-x86-64
+    elif [[ $ARCH == x86 && $WORD == 32 ]] ; then
+        MAKE_IMAGE_TARGET=unix-x86.32
+        MAKE_TARGET=$OS-x86-32
     else
         MAKE_IMAGE_TARGET=$ARCH.$WORD
         MAKE_TARGET=$OS-$ARCH-$WORD

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" }
@@ -538,7 +539,6 @@ tuple
     { "system-micros" "system" "primitive_system_micros" (( -- us )) }
     { "(sleep)" "threads.private" "primitive_sleep" (( nanos -- )) }
     { "callstack-for" "threads.private" "primitive_callstack_for" (( context -- array )) }
-    { "context" "threads.private" "primitive_context" (( -- context )) }
     { "context-object-for" "threads.private" "primitive_context_object_for" (( n context -- obj )) }
     { "datastack-for" "threads.private" "primitive_datastack_for" (( context -- array )) }
     { "retainstack-for" "threads.private" "primitive_retainstack_for" (( context -- array )) }

core/continuations/continuations-docs.factor

@@ -235,7 +235,7 @@ HELP: save-error
 $low-level-note ;
 
 HELP: with-datastack
-{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
+{ $values { "stack" sequence } { "quot" quotation } { "new-stack" sequence } }
 { $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
 { $examples
     { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }

core/continuations/continuations.factor

@@ -1,10 +1,17 @@
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays vectors kernel kernel.private sequences
 namespaces make math splitting sorting quotations assocs
 combinators combinators.private accessors words ;
 IN: continuations
 
+: with-datastack ( stack quot -- new-stack )
+    [
+        [ [ datastack ] dip swap [ { } like set-datastack ] dip ] dip
+        swap [ call datastack ] dip
+        swap [ set-datastack ] dip
+    ] (( stack quot -- new-stack )) call-effect-unsafe ;
+
 SYMBOL: error
 SYMBOL: error-continuation
 SYMBOL: error-thread
@@ -90,14 +97,6 @@ SYMBOL: return-continuation
 : return ( -- * )
     return-continuation get continue ;
 
-: with-datastack ( stack quot -- newstack )
-    [
-        [
-            [ [ { } like set-datastack ] dip call datastack ] dip
-            continue-with
-        ] (( stack quot continuation -- * )) call-effect-unsafe
-    ] callcc1 2nip ;
-
 GENERIC: compute-restarts ( error -- seq )
 
 <PRIVATE

core/kernel/kernel-docs.factor

@@ -575,19 +575,51 @@ HELP: if
 { $values { "?" "a generalized boolean" } { "true" quotation } { "false" quotation } }
 { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation. Otherwise calls the " { $snippet "true" } " quotation."
 $nl
-"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." } ;
+"The " { $snippet "cond" } " value is removed from the stack before either quotation is called." }
+{ $examples
+    { $example
+        "USING: io kernel math ;"
+        "10 3 < [ \"Math is broken\" print ] [ \"Math is good\" print ] if"
+        "Math is good"
+    }
+} ;
 
 HELP: when
 { $values { "?" "a generalized boolean" } { "true" quotation } }
 { $description "If " { $snippet "cond" } " is not " { $link f } ", calls the " { $snippet "true" } " quotation."
 $nl
-"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
+"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." }
+{ $examples
+    { $example
+        "USING: kernel math prettyprint ;"
+        "-5 dup 0 < [ 3 + ] when ."
+        "-2"
+    }
+} ;
 
 HELP: unless
 { $values { "?" "a generalized boolean" } { "false" quotation } }
 { $description "If " { $snippet "cond" } " is " { $link f } ", calls the " { $snippet "false" } " quotation."
 $nl
-"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." } ;
+"The " { $snippet "cond" } " value is removed from the stack before the quotation is called." }
+{ $examples
+    { $example
+        "USING: kernel math prettyprint sequences ;"
+        "IN: scratchpad"
+        ""
+        "CONSTANT: american-cities {"
+        "    \"San Francisco\""
+        "    \"Los Angeles\""
+        "    \"New York\""
+        "}"
+        ""
+        ": add-tax ( price city -- price' )"
+        "    american-cities member? [ 1.1 * ] unless ;"
+        ""
+        "123 \"Ottawa\" add-tax ."
+        "135.3"
+    }
+} ;
 
 HELP: if*
 { $values { "?" "a generalized boolean" } { "true" { $quotation "( ..a ? -- ..b )" } } { "false" { $quotation "( ..a -- ..b )" } } }
@@ -596,7 +628,31 @@ $nl
 "If the condition is true, it is retained on the stack before the " { $snippet "true" } " quotation is called. Otherwise, the condition is removed from the stack and the " { $snippet "false" } " quotation is called."
 $nl
 "The following two lines are equivalent:"
-{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } } ;
+{ $code "X [ Y ] [ Z ] if*" "X dup [ Y ] [ drop Z ] if" } }
+{ $examples
+    "Notice how in this example, the same value is tested by the conditional, and then used in the true branch; the false branch does not need to drop the value because of how " { $link if* } " works:"
+    { $example
+        "USING: assocs io kernel math.parser ;"
+        "IN: scratchpad"
+        ""
+        ": curry-price ( meat -- price )
+    {
+        { \"Beef\" 10 }
+        { \"Chicken\" 12 }
+        { \"Lamb\" 13 }
+    } at ;
+
+: order-curry ( meat -- )
+    curry-price [
+        \"Your order will be \" write
+        number>string write
+        \" dollars.\" write
+    ] [ \"Invalid order.\" print ] if* ;"
+        ""
+        "\"Deer\" order-curry"
+        "Invalid order."
+    }
+} ;
 
 HELP: when*
 { $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } }

extra/mason/child/child-tests.factor

@@ -33,7 +33,7 @@ USING: mason.child mason.config tools.test namespaces io kernel sequences ;
     ] with-scope
 ] unit-test
 
-[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
+[ { "./factor.com" "-i=boot.winnt-x86.32.image" "-no-user-init" } ] [
     [
         "winnt" target-os set
         "x86.32" target-cpu set

extra/mason/common/common.factor

@@ -17,8 +17,8 @@ SYMBOL: current-git-id
 
 : short-running-process ( command -- )
     #! Give network operations and shell commands at most
-    #! 15 minutes to complete, to catch hangs.
+    #! 30 minutes to complete, to catch hangs.
-    >process 15 minutes >>timeout try-output-process ;
+    >process 30 minutes >>timeout try-output-process ;
 
 HOOK: really-delete-tree os ( path -- )
 

extra/webkit-demo/webkit-demo.factor

@@ -13,7 +13,7 @@ IMPORT: WebView
     WebView -> alloc
     rect f f -> initWithFrame:frameName:groupName: ;
 
-CONSTANT: window-style ( -- n )
+CONSTANT: window-style
     flags{
         NSClosableWindowMask
         NSMiniaturizableWindowMask

vm/callbacks.cpp

@@ -19,7 +19,25 @@ void factor_vm::init_callbacks(cell size)
 	callbacks = new callback_heap(size,this);
 }
 
-void callback_heap::store_callback_operand(code_block *stub, cell index, cell value)
+bool callback_heap::setup_seh_p()
+{
+#if defined(WINDOWS) && defined(FACTOR_X86)
+	return true;
+#else
+	return false;
+#endif
+}
+
+bool callback_heap::return_takes_param_p()
+{
+#if defined(FACTOR_X86) || defined(FACTOR_AMD64)
+	return true;
+#else
+	return false;
+#endif
+}
+
+instruction_operand callback_heap::callback_operand(code_block *stub, cell index)
 {
 	tagged<array> code_template(parent->special_objects[CALLBACK_STUB]);
 
@@ -33,12 +51,23 @@ void callback_heap::store_callback_operand(code_block *stub, cell index, cell va
 		offset);
 
 	instruction_operand op(rel,stub,0);
-	op.store_value(value);
+
+	return op;
+}
+
+void callback_heap::store_callback_operand(code_block *stub, cell index)
+{
+	parent->store_external_address(callback_operand(stub,index));
+}
+
+void callback_heap::store_callback_operand(code_block *stub, cell index, cell value)
+{
+	callback_operand(stub,index).store_value(value);
 }
 
 void callback_heap::update(code_block *stub)
 {
-	store_callback_operand(stub,1,(cell)callback_entry_point(stub));
+	store_callback_operand(stub,setup_seh_p() ? 2 : 1,(cell)callback_entry_point(stub));
 	stub->flush_icache();
 }
 
@@ -64,13 +93,24 @@ 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);
+
+	cell index;
+
+	if(setup_seh_p())
+	{
+		store_callback_operand(stub,1);
+		index = 1;
+	}
+	else
+		index = 0;
+
+	/* 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)
+	if(return_takes_param_p())
-	store_callback_operand(stub,3,return_rewind);
+		store_callback_operand(stub,index + 3,return_rewind);
-#endif
 
 	update(stub);
 

vm/callbacks.hpp

@@ -38,6 +38,10 @@ struct callback_heap {
 		return w->entry_point;
 	}
 
+	bool setup_seh_p();
+	bool return_takes_param_p();
+	instruction_operand callback_operand(code_block *stub, cell index);
+	void store_callback_operand(code_block *stub, cell index);
 	void store_callback_operand(code_block *stub, cell index, cell value);
 
 	void update(code_block *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((cell)&factor::exception_handler);
+		break;
+#endif
 	default:
 		critical_error("Bad rel type",op.rel_type());
 		break;

vm/collector.hpp

@@ -1,6 +1,8 @@
 namespace factor
 {
 
+struct must_start_gc_again {};
+
 template<typename TargetGeneration, typename Policy> struct data_workhorse {
 	factor_vm *parent;
 	TargetGeneration *target;
@@ -27,8 +29,7 @@ template<typename TargetGeneration, typename Policy> struct data_workhorse {
 	{
 		cell size = untagged->size();
 		object *newpointer = target->allot(size);
-		/* XXX not exception-safe */
+		if(!newpointer) throw must_start_gc_again();
-		if(!newpointer) longjmp(parent->current_gc->gc_unwind,1);
 
 		memcpy(newpointer,untagged,size);
 		untagged->forward_to(newpointer);

vm/contexts.cpp

@@ -108,9 +108,16 @@ context *factor_vm::new_context()
 	return new_context;
 }
 
+void factor_vm::init_context(context *ctx)
+{
+	ctx->context_objects[OBJ_CONTEXT] = allot_alien(ctx);
+}
+
 context *new_context(factor_vm *parent)
 {
-	return parent->new_context();
+	context *new_context = parent->new_context();
+	parent->init_context(new_context);
+	return new_context;
 }
 
 void factor_vm::delete_context(context *old_context)
@@ -124,16 +131,22 @@ VM_C_API void delete_context(factor_vm *parent, context *old_context)
 	parent->delete_context(old_context);
 }
 
-void factor_vm::begin_callback()
+cell factor_vm::begin_callback(cell quot_)
 {
+	data_root<object> quot(quot_,this);
+
 	ctx->reset();
 	spare_ctx = new_context();
 	callback_ids.push_back(callback_id++);
+
+	init_context(ctx);
+
+	return quot.value();
 }
 
-void begin_callback(factor_vm *parent)
+cell begin_callback(factor_vm *parent, cell quot)
 {
-	parent->begin_callback();
+	return parent->begin_callback(quot);
 }
 
 void factor_vm::end_callback()
@@ -296,9 +309,4 @@ void factor_vm::primitive_load_locals()
 	ctx->retainstack += sizeof(cell) * count;
 }
 
-void factor_vm::primitive_context()
-{
-	ctx->push(allot_alien(ctx));
-}
-
 }

vm/contexts.hpp

@@ -6,6 +6,7 @@ static const cell context_object_count = 10;
 enum context_object {
 	OBJ_NAMESTACK,
 	OBJ_CATCHSTACK,
+	OBJ_CONTEXT,
 };
 
 static const cell stack_reserved = 1024;
@@ -27,14 +28,14 @@ struct context {
 	/* C callstack pointer */
 	cell callstack_save;
 
-	/* context-specific special objects, accessed by context-object and
-	set-context-object primitives */
-	cell context_objects[context_object_count];
-
 	segment *datastack_seg;
 	segment *retainstack_seg;
 	segment *callstack_seg;
 
+	/* context-specific special objects, accessed by context-object and
+	set-context-object primitives */
+	cell context_objects[context_object_count];
+
 	context(cell datastack_size, cell retainstack_size, cell callstack_size);
 	~context();
 
@@ -71,7 +72,7 @@ struct context {
 
 VM_C_API context *new_context(factor_vm *parent);
 VM_C_API void delete_context(factor_vm *parent, context *old_context);
-VM_C_API void begin_callback(factor_vm *parent);
+VM_C_API cell begin_callback(factor_vm *parent, cell quot);
 VM_C_API void end_callback(factor_vm *parent);
 
 }

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/factor.cpp

@@ -14,7 +14,12 @@ void factor_vm::default_parameters(vm_parameters *p)
 
 	p->datastack_size = 32 * sizeof(cell);
 	p->retainstack_size = 32 * sizeof(cell);
+
+#ifdef FACTOR_PPC
+	p->callstack_size = 256 * sizeof(cell);
+#else
 	p->callstack_size = 128 * sizeof(cell);
+#endif
 
 	p->code_size = 8 * sizeof(cell);
 	p->young_size = sizeof(cell) / 4;

vm/gc.cpp

@@ -135,49 +135,57 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
 
 	/* Keep trying to GC higher and higher generations until we don't run out
 	of space */
-	if(setjmp(current_gc->gc_unwind))
+	for(;;)
 	{
-		/* We come back here if a generation is full */
+		try
-		start_gc_again();
-	}
-
-	current_gc->event->op = current_gc->op;
-
-	switch(current_gc->op)
-	{
-	case collect_nursery_op:
-		collect_nursery();
-		break;
-	case collect_aging_op:
-		collect_aging();
-		if(data->high_fragmentation_p())
 		{
-			current_gc->op = collect_full_op;
+			current_gc->event->op = current_gc->op;
-			current_gc->event->op = collect_full_op;
+
-			collect_full(trace_contexts_p);
+			switch(current_gc->op)
+			{
+			case collect_nursery_op:
+				collect_nursery();
+				break;
+			case collect_aging_op:
+				collect_aging();
+				if(data->high_fragmentation_p())
+				{
+					current_gc->op = collect_full_op;
+					current_gc->event->op = collect_full_op;
+					collect_full(trace_contexts_p);
+				}
+				break;
+			case collect_to_tenured_op:
+				collect_to_tenured();
+				if(data->high_fragmentation_p())
+				{
+					current_gc->op = collect_full_op;
+					current_gc->event->op = collect_full_op;
+					collect_full(trace_contexts_p);
+				}
+				break;
+			case collect_full_op:
+				collect_full(trace_contexts_p);
+				break;
+			case collect_compact_op:
+				collect_compact(trace_contexts_p);
+				break;
+			case collect_growing_heap_op:
+				collect_growing_heap(requested_bytes,trace_contexts_p);
+				break;
+			default:
+				critical_error("Bad GC op",current_gc->op);
+				break;
+			}
+
+			break;
 		}
-		break;
+		catch(const must_start_gc_again e)
-	case collect_to_tenured_op:
-		collect_to_tenured();
-		if(data->high_fragmentation_p())
 		{
-			current_gc->op = collect_full_op;
+			/* We come back here if a generation is full */
-			current_gc->event->op = collect_full_op;
+			start_gc_again();
-			collect_full(trace_contexts_p);
+			continue;
 		}
-		break;
-	case collect_full_op:
-		collect_full(trace_contexts_p);
-		break;
-	case collect_compact_op:
-		collect_compact(trace_contexts_p);
-		break;
-	case collect_growing_heap_op:
-		collect_growing_heap(requested_bytes,trace_contexts_p);
-		break;
-	default:
-		critical_error("Bad GC op",current_gc->op);
-		break;
 	}
 
 	end_gc();

vm/gc.hpp

@@ -45,7 +45,6 @@ struct gc_event {
 struct gc_state {
 	gc_op op;
 	u64 start_time;
-	jmp_buf gc_unwind;
 	gc_event *event;
 
 	explicit gc_state(gc_op op_, factor_vm *parent);

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/master.hpp

@@ -16,7 +16,6 @@
 #include <fcntl.h>
 #include <limits.h>
 #include <math.h>
-#include <setjmp.h>
 #include <stdio.h>
 #include <stdlib.h>
 #include <string.h>

vm/os-genunix.hpp

@@ -2,7 +2,6 @@ namespace factor
 {
 
 #define VM_C_API extern "C"
-#define NULL_DLL NULL
 
 void early_init();
 const char *vm_executable_path();

vm/os-macosx.hpp

@@ -3,7 +3,6 @@ namespace factor
 
 #define VM_C_API extern "C" __attribute__((visibility("default")))
 #define FACTOR_OS_STRING "macosx"
-#define NULL_DLL NULL
 
 void early_init();
 

vm/os-unix.cpp

@@ -46,7 +46,7 @@ void sleep_nanos(u64 nsec)
 
 void factor_vm::init_ffi()
 {
-	null_dll = dlopen(NULL_DLL,RTLD_LAZY);
+	null_dll = dlopen(NULL,RTLD_LAZY);
 }
 
 void factor_vm::ffi_dlopen(dll *dll)

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)
+VM_C_API 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

@@ -20,15 +20,9 @@ typedef char symbol_char;
 
 #define FACTOR_OS_STRING "winnt"
 
-#define FACTOR_DLL L"factor.dll"
+#define FACTOR_DLL NULL
 
-#ifdef _MSC_VER
+VM_C_API 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/platform.hpp

@@ -3,8 +3,8 @@
 		#include "os-windows-ce.hpp"
 		#include "os-windows.hpp"
 	#elif defined(WINNT)
-		#include "os-windows-nt.hpp"
 		#include "os-windows.hpp"
+		#include "os-windows-nt.hpp"
 
 		#if defined(FACTOR_AMD64)
 			#include "os-windows-nt.64.hpp"

vm/primitives.hpp

@@ -43,7 +43,6 @@ namespace factor
 	_(code_room) \
 	_(compact_gc) \
 	_(compute_identity_hashcode) \
-	_(context) \
 	_(context_object) \
 	_(context_object_for) \
 	_(current_callback) \

vm/safeseh.asm

@@ -0,0 +1,5 @@
+.386
+.model flat
+exception_handler proto
+.safeseh exception_handler
+end

vm/vm.hpp

@@ -112,10 +112,11 @@ struct factor_vm
 
 	// contexts
 	context *new_context();
+	void init_context(context *ctx);
 	void delete_context(context *old_context);
 	void init_contexts(cell datastack_size_, cell retainstack_size_, cell callstack_size_);
 	void delete_contexts();
-	void begin_callback();
+	cell begin_callback(cell quot);
 	void end_callback();
 	void primitive_current_callback();
 	void primitive_context_object();
@@ -135,7 +136,6 @@ struct factor_vm
 	void primitive_set_retainstack();
 	void primitive_check_datastack();
 	void primitive_load_locals();
-	void primitive_context();
 
 	template<typename Iterator> void iterate_active_callstacks(Iterator &iter)
 	{
@@ -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