Merge branch 'master' of git://github.com/slavapestov/factor into techniques

GNUmakefile

@@ -169,22 +169,16 @@ macosx.app: factor
 	mkdir -p $(BUNDLE)/Contents/Frameworks
 	mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
 	ln -s Factor.app/Contents/MacOS/factor ./factor
-	cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
-
-	install_name_tool \
-		-change libfactor.dylib \
-		@executable_path/../Frameworks/libfactor.dylib \
-		Factor.app/Contents/MacOS/factor
 
 $(ENGINE): $(DLL_OBJS)
 	$(TOOLCHAIN_PREFIX)$(LINKER) $(ENGINE) $(DLL_OBJS)
 
-factor: $(EXE_OBJS) $(ENGINE)
+factor: $(EXE_OBJS) $(DLL_OBJS)
-	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
 		$(CFLAGS) -o $(EXECUTABLE) $(EXE_OBJS)
 
-factor-console: $(EXE_OBJS) $(ENGINE)
+factor-console: $(EXE_OBJS) $(DLL_OBJS)
-	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+	$(TOOLCHAIN_PREFIX)$(CPP) $(LIBS) $(LIBPATH) -L. $(DLL_OBJS) \
 		$(CFLAGS) $(CFLAGS_CONSOLE) -o $(CONSOLE_EXECUTABLE) $(EXE_OBJS)
 
 factor-ffi-test: $(FFI_TEST_LIBRARY)

Nmakefile

@@ -2,11 +2,11 @@
 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
 
-EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
+EXE_OBJS = vm\main-windows-nt.obj vm\factor.res
 
 DLL_OBJS = vm\os-windows-nt.obj \
 	vm\os-windows.obj \
@@ -63,7 +63,7 @@ DLL_OBJS = vm\os-windows-nt.obj \
 .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 +71,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/calendar/calendar-docs.factor

@@ -76,27 +76,27 @@ HELP: day-abbreviation3
 } related-words
 
 HELP: average-month
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
 { $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
 
 HELP: months-per-year
-{ $values { "integer" integer } }
+{ $values { "value" integer } }
 { $description "Returns the number of months in a year." } ;
 
 HELP: days-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
 { $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
 
 HELP: hours-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
 { $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
 
 HELP: minutes-per-year
-{ $values { "ratio" ratio } }
+{ $values { "value" ratio } }
 { $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
 
 HELP: seconds-per-year
-{ $values { "integer" integer } }
+{ $values { "value" integer } }
 { $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
 
 HELP: julian-day-number

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

@@ -432,14 +432,17 @@ STRUCT: double-rect
     void { void* void* double-rect } "cdecl"
     [ "example" set-global 2drop ] alien-callback ;
 
-: double-rect-test ( arg -- arg' )
+: double-rect-test ( arg callback -- 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/core-foundation/file-descriptors/file-descriptors.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ;
+USING: alien.c-types alien.syntax kernel math.bitwise core-foundation
+literals ;
 IN: core-foundation.file-descriptors
 
 TYPEDEF: void* CFFileDescriptorRef
@@ -25,7 +26,7 @@ FUNCTION: void CFFileDescriptorEnableCallBacks (
 ) ;
 
 : enable-all-callbacks ( fd -- )
-    { kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack } flags
+    flags{ kCFFileDescriptorReadCallBack kCFFileDescriptorWriteCallBack }
     CFFileDescriptorEnableCallBacks ;
 
 : <CFFileDescriptor> ( fd callback -- handle )

basis/core-graphics/core-graphics.factor

@@ -3,7 +3,7 @@
 USING: alien alien.c-types alien.destructors alien.syntax accessors
 destructors fry kernel math math.bitwise sequences libc colors
 images images.memory core-graphics.types core-foundation.utilities
-opengl.gl ;
+opengl.gl literals ;
 IN: core-graphics
 
 ! CGImageAlphaInfo
@@ -16,15 +16,15 @@ kCGImageAlphaFirst
 kCGImageAlphaNoneSkipLast
 kCGImageAlphaNoneSkipFirst ;
 
-: kCGBitmapAlphaInfoMask ( -- n ) HEX: 1f ; inline
+CONSTANT: kCGBitmapAlphaInfoMask HEX: 1f
-: kCGBitmapFloatComponents ( -- n ) 1 8 shift ; inline
+CONSTANT: kCGBitmapFloatComponents 256
 
-: kCGBitmapByteOrderMask ( -- n ) HEX: 7000 ; inline
+CONSTANT: kCGBitmapByteOrderMask HEX: 7000
-: kCGBitmapByteOrderDefault ( -- n ) 0 12 shift ; inline
+CONSTANT: kCGBitmapByteOrderDefault 0
-: kCGBitmapByteOrder16Little ( -- n ) 1 12 shift ; inline
+CONSTANT: kCGBitmapByteOrder16Little 4096
-: kCGBitmapByteOrder32Little ( -- n ) 2 12 shift ; inline
+CONSTANT: kCGBitmapByteOrder32Little 8192
-: kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline
+CONSTANT: kCGBitmapByteOrder16Big 12288
-: kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline
+CONSTANT: kCGBitmapByteOrder32Big 16384
 
 : kCGBitmapByteOrder16Host ( -- n )
     little-endian?
@@ -121,8 +121,8 @@ FUNCTION: uint GetCurrentButtonState ( ) ;
 
 <PRIVATE
 
-: bitmap-flags ( -- flags )
+: bitmap-flags ( -- n )
-    { kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host } flags ;
+    kCGImageAlphaPremultipliedFirst kCGBitmapByteOrder32Host bitor ;
 
 : bitmap-color-space ( -- color-space )
     CGColorSpaceCreateDeviceRGB &CGColorSpaceRelease ;

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
 
@@ -98,7 +105,7 @@ CONSTANT: nv-reg 17
     2 vm-reg vm-context-offset STW
 
     ! Save C callstack pointer
-    2 context-callstack-save-offset 1 STW
+    1 2 context-callstack-save-offset STW
 
     ! Load Factor callstack pointer
     1 2 context-callstack-bottom-offset LWZ
@@ -108,6 +115,9 @@ CONSTANT: nv-reg 17
     2 MTLR
     BLRL
 
+    ! Load VM again, pointlessly
+    0 vm-reg LOAD32 rc-absolute-ppc-2/2 rt-vm jit-rel
+
     ! Load C callstack pointer
     2 vm-reg vm-context-offset LWZ
     1 2 context-callstack-save-offset LWZ
@@ -123,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
@@ -141,7 +151,6 @@ CONSTANT: nv-reg 17
     rs-reg ctx-reg context-retainstack-offset STW ;
 
 : jit-restore-context ( -- )
-    jit-load-context
     ds-reg ctx-reg context-datastack-offset LWZ
     rs-reg ctx-reg context-retainstack-offset LWZ ;
 
@@ -317,6 +326,7 @@ CONSTANT: nv-reg 17
     3 6 MR
     4 vm-reg MR
     "inline_cache_miss" jit-call
+    jit-load-context
     jit-restore-context ;
 
 [ jit-load-return-address jit-inline-cache-miss ]
@@ -394,9 +404,11 @@ CONSTANT: nv-reg 17
     3 vm-reg MR
     "begin_callback" jit-call
 
+    jit-load-context
     jit-restore-context
 
     ! Call quotation
+    3 nv-reg MR
     jit-call-quot
 
     jit-save-context
@@ -414,6 +426,7 @@ CONSTANT: nv-reg 17
     0 vm-reg LOAD32 0 rc-absolute-ppc-2/2 jit-vm
 
     ! Load ds and rs registers
+    jit-load-context
     jit-restore-context
 
     ! We have changed the stack; load return address again
@@ -755,33 +768,34 @@ CONSTANT: nv-reg 17
 : jit-pop-context-and-param ( -- )
     3 ds-reg 0 LWZ
     3 3 alien-offset LWZ
-    4 ds-reg -8 LWZ
+    4 ds-reg -4 LWZ
-    ds-reg ds-reg 16 SUBI ;
+    ds-reg ds-reg 8 SUBI ;
 
 : jit-push-param ( -- )
-    ds-reg ds-reg 8 ADDI
+    ds-reg ds-reg 4 ADDI
     4 ds-reg 0 STW ;
 
 : jit-set-context ( -- )
     jit-pop-context-and-param
-    4 jit-switch-context
+    3 jit-switch-context
     jit-push-param ;
 
 [ jit-set-context ] \ (set-context) define-sub-primitive
 
 : jit-pop-quot-and-param ( -- )
     3 ds-reg 0 LWZ
-    4 ds-reg -8 LWZ
+    4 ds-reg -4 LWZ
-    ds-reg ds-reg 16 SUBI ;
+    ds-reg ds-reg 8 SUBI ;
 
 : jit-start-context ( -- )
     ! Create the new context in return-reg
     3 vm-reg MR
     "new_context" jit-call
+    6 3 MR
 
     jit-pop-quot-and-param
 
-    3 jit-switch-context
+    6 jit-switch-context
 
     jit-push-param
 

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,14 +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
-    temp2 1 stack-frame get total-size>> ADDI
-    temp2 temp1 "callstack-bottom" context-field-offset STW
     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 ;
@@ -692,14 +687,6 @@ M:: ppc %save-context ( temp1 temp2 -- )
 M: ppc %alien-invoke ( symbol dll -- )
     [ 11 ] 2dip %alien-global 11 MTLR BLRL ;
 
-M: ppc %alien-callback ( quot -- )
-    3 4 %restore-context
-    3 swap %load-reference
-    4 3 quot-entry-point-offset LWZ
-    4 MTLR
-    BLRL
-    3 4 %save-context ;
-
 M: ppc %prepare-alien-indirect ( -- )
     3 ds-reg 0 LWZ
     ds-reg ds-reg 4 SUBI
@@ -710,18 +697,6 @@ M: ppc %prepare-alien-indirect ( -- )
 M: ppc %alien-indirect ( -- )
     16 MTLR BLRL ;
 
-M: ppc %callback-value ( ctype -- )
-    ! Save top of data stack
-    3 ds-reg 0 LWZ
-    3 1 0 local@ STW
-    3 %load-vm-addr
-    ! Restore data/call/retain stacks
-    "unnest_context" f %alien-invoke
-    ! Restore top of data stack
-    3 1 0 local@ LWZ
-    ! Unbox former top of data stack to return registers
-    unbox-return ;
-
 M: ppc immediate-arithmetic? ( n -- ? ) -32768 32767 between? ;
 
 M: ppc immediate-bitwise? ( n -- ? ) 0 65535 between? ;
@@ -757,13 +732,30 @@ M: ppc %box-small-struct ( c-type -- )
     4 3 4 LWZ
     3 3 0 LWZ ;
 
-M: ppc %nest-context ( -- )
+M: ppc %begin-callback ( -- )
     3 %load-vm-addr
-    "nest_context" f %alien-invoke ;
+    "begin_callback" f %alien-invoke ;
 
-M: ppc %unnest-context ( -- )
+M: ppc %alien-callback ( quot -- )
+    3 4 %restore-context
+    3 swap %load-reference
+    4 3 quot-entry-point-offset LWZ
+    4 MTLR
+    BLRL
+    3 4 %save-context ;
+
+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
+    16 ds-reg 0 LWZ
+    %end-callback
+    ! Restore top of data stack
+    3 16 MR
+    ! Unbox former top of data stack to return registers
+    unbox-return ;
 
 M: ppc %unbox-small-struct ( size -- )
     heap-size cell align cell /i {

basis/cpu/x86/32/32.factor

@@ -28,10 +28,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@ ;
@@ -166,7 +169,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 ;
@@ -241,6 +244,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

@@ -63,12 +63,13 @@ IN: bootstrap.x86
     rs-reg ctx-reg context-retainstack-offset [+] MOV ;
 
 [
+    ! ctx-reg is preserved across the call because it is non-volatile
+    ! in the C ABI
     jit-load-vm
     jit-save-context
     ! call the primitive
     ESP [] vm-reg MOV
     0 CALL rc-relative rt-dlsym jit-rel
-    ! restore ds, rs registers
     jit-restore-context
 ] jit-primitive jit-define
 
@@ -81,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
@@ -109,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
@@ -123,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
 
@@ -254,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 ;
 
@@ -267,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
 
@@ -294,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/64.factor

@@ -43,22 +43,25 @@ 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 ;
 
 : param@ ( n -- op ) reserved-stack-space + stack@ ;
 
 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 ;
@@ -111,7 +114,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 ;
@@ -228,6 +231,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

@@ -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 ( -- ) stack-reg bootstrap-cell ADD ;
+
 : jit-call ( name -- )
     RAX 0 MOV rc-absolute-cell jit-dlsym
     RAX CALL ;
@@ -42,7 +47,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
 
@@ -57,11 +62,12 @@ IN: bootstrap.x86
     ctx-reg context-retainstack-offset [+] rs-reg MOV ;
 
 : jit-restore-context ( -- )
-    jit-load-context
     ds-reg ctx-reg context-datastack-offset [+] MOV
     rs-reg ctx-reg context-retainstack-offset [+] MOV ;
 
 [
+    ! ctx-reg is preserved across the call because it is non-volatile
+    ! in the C ABI
     jit-save-context
     ! call the primitive
     arg1 vm-reg MOV
@@ -75,15 +81,15 @@ 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
 
+    jit-load-context
     jit-restore-context
 
     ! call the quotation
-    arg1 nv-reg MOV
+    arg1 return-reg MOV
     jit-call-quot
 
     jit-save-context
@@ -115,6 +121,7 @@ IN: bootstrap.x86
     vm-reg 0 MOV 0 rc-absolute-cell jit-vm
 
     ! Load ds and rs registers
+    jit-load-context
     jit-restore-context
 
     ! Call quotation
@@ -168,6 +175,7 @@ IN: bootstrap.x86
     arg1 RBX MOV
     arg2 vm-reg MOV
     "inline_cache_miss" jit-call
+    jit-load-context
     jit-restore-context ;
 
 [ jit-load-return-address jit-inline-cache-miss ]

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,3 +164,11 @@ IN: cpu.x86.assembler.tests
 
 [ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } 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 ;
 
@@ -188,6 +192,13 @@ M: register displacement, drop ;
 
 PRIVATE>
 
+! Segment override prefixes
+: CS ( -- ) HEX: 2e , ;
+: ES ( -- ) HEX: 26 , ;
+: SS ( -- ) HEX: 36 , ;
+: FS ( -- ) HEX: 64 , ;
+: GS ( -- ) HEX: 65 , ;
+
 ! Moving stuff
 GENERIC: PUSH ( op -- )
 M: register PUSH f HEX: 50 short-operand ;

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

@@ -423,8 +423,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 ;
@@ -456,7 +461,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
@@ -477,7 +482,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 ;
@@ -1403,7 +1408,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 ;
 
@@ -1411,7 +1416,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/backend/unix/multiplexers/kqueue/kqueue.factor

@@ -3,7 +3,7 @@
 USING: accessors alien.c-types combinators destructors
 io.backend.unix kernel math.bitwise sequences
 specialized-arrays unix unix.kqueue unix.time assocs
-io.backend.unix.multiplexers classes.struct ;
+io.backend.unix.multiplexers classes.struct literals ;
 SPECIALIZED-ARRAY: kevent
 IN: io.backend.unix.multiplexers.kqueue
 
@@ -31,13 +31,13 @@ M: kqueue-mx dispose* fd>> close-file ;
 
 M: kqueue-mx add-input-callback ( thread fd mx -- )
     [ call-next-method ] [
-        [ EVFILT_READ { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+        [ EVFILT_READ flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
         register-kevent
     ] 2bi ;
 
 M: kqueue-mx add-output-callback ( thread fd mx -- )
     [ call-next-method ] [
-        [ EVFILT_WRITE { EV_ADD EV_ONESHOT } flags make-kevent ] dip
+        [ EVFILT_WRITE flags{ EV_ADD EV_ONESHOT } make-kevent ] dip
         register-kevent
     ] 2bi ;
 

basis/io/backend/windows/nt/privileges/privileges.factor

@@ -2,7 +2,7 @@ USING: alien alien.c-types alien.data alien.syntax arrays continuations
 destructors generic io.mmap io.ports io.backend.windows io.files.windows
 kernel libc locals math math.bitwise namespaces quotations sequences windows
 windows.advapi32 windows.kernel32 windows.types io.backend system accessors
-io.backend.windows.privileges classes.struct windows.errors ;
+io.backend.windows.privileges classes.struct windows.errors literals ;
 IN: io.backend.windows.nt.privileges
 
 TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
@@ -11,7 +11,7 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
 !  http://msdn.microsoft.com/msdnmag/issues/05/03/TokenPrivileges/
 
 : (open-process-token) ( handle -- handle )
-    { TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } flags PHANDLE <c-object>
+    flags{ TOKEN_ADJUST_PRIVILEGES TOKEN_QUERY } PHANDLE <c-object>
     [ OpenProcessToken win32-error=0/f ] keep *void* ;
 
 : open-process-token ( -- handle )

basis/io/backend/windows/windows.factor

@@ -5,7 +5,7 @@ io.buffers io.files io.ports io.binary io.timeouts system
 strings kernel math namespaces sequences windows.errors
 windows.kernel32 windows.shell32 windows.types splitting
 continuations math.bitwise accessors init sets assocs
-classes.struct classes ;
+classes.struct classes literals ;
 IN: io.backend.windows
 
 TUPLE: win32-handle < disposable handle ;
@@ -43,12 +43,12 @@ HOOK: add-completion io-backend ( port -- )
     <win32-file> |dispose
     dup add-completion ;
 
-: share-mode ( -- n )
+CONSTANT: share-mode
-    {
+    flags{
         FILE_SHARE_READ
         FILE_SHARE_WRITE
         FILE_SHARE_DELETE
-    } flags ; foldable
+    }
 
 : default-security-attributes ( -- obj )
     SECURITY_ATTRIBUTES <struct>

basis/io/directories/unix/unix.factor

@@ -4,11 +4,10 @@ USING: accessors alien.c-types alien.strings combinators
 continuations destructors fry io io.backend io.backend.unix
 io.directories io.encodings.binary io.encodings.utf8 io.files
 io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat vocabs.loader classes.struct unix.ffi ;
+unix unix.stat vocabs.loader classes.struct unix.ffi literals ;
 IN: io.directories.unix
 
-: touch-mode ( -- n )
+CONSTANT: touch-mode flags{ O_WRONLY O_APPEND O_CREAT O_EXCL }
-    { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
 
 M: unix touch-file ( path -- )
     normalize-path

basis/io/files/unique/unix/unix.factor

@@ -1,11 +1,10 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel io.ports io.backend.unix math.bitwise
-unix system io.files.unique unix.ffi ;
+unix system io.files.unique unix.ffi literals ;
 IN: io.files.unique.unix
 
-: open-unique-flags ( -- flags )
+CONSTANT: open-unique-flags flags{ O_RDWR O_CREAT O_EXCL }
-    { O_RDWR O_CREAT O_EXCL } flags ;
 
 M: unix (touch-unique-file) ( path -- )
     open-unique-flags file-mode open-file close-file ;

basis/io/files/unix/unix-tests.factor

@@ -2,7 +2,7 @@ USING: tools.test io.files io.files.temp io.pathnames
 io.directories io.files.info io.files.info.unix continuations
 kernel io.files.unix math.bitwise calendar accessors
 math.functions math unix.users unix.groups arrays sequences
-grouping io.pathnames.private ;
+grouping io.pathnames.private literals ;
 IN: io.files.unix.tests
 
 [ "/usr/libexec/" ] [ "/usr/libexec/awk/" parent-directory ] unit-test
@@ -45,7 +45,7 @@ IN: io.files.unix.tests
 prepare-test-file
 
 [ t ]
-[ test-file { USER-ALL GROUP-ALL OTHER-ALL } flags set-file-permissions perms OCT: 777 = ] unit-test
+[ test-file flags{ USER-ALL GROUP-ALL OTHER-ALL } set-file-permissions perms OCT: 777 = ] unit-test
 
 [ t ] [ test-file user-read? ] unit-test
 [ t ] [ test-file user-write? ] unit-test
@@ -85,7 +85,7 @@ prepare-test-file
 [ f ] [ test-file file-info other-read? ] unit-test
 
 [ t ]
-[ test-file { USER-ALL GROUP-ALL OTHER-EXECUTE } flags set-file-permissions perms OCT: 771 = ] unit-test
+[ test-file flags{ USER-ALL GROUP-ALL OTHER-EXECUTE } set-file-permissions perms OCT: 771 = ] unit-test
 
 prepare-test-file
 

basis/io/files/unix/unix.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: unix byte-arrays kernel io.backend.unix math.bitwise
 io.ports io.files io.files.private io.pathnames environment
-destructors system unix.ffi ;
+destructors system unix.ffi literals ;
 IN: io.files.unix
 
 M: unix cwd ( -- path )
@@ -12,15 +12,14 @@ M: unix cwd ( -- path )
 
 M: unix cd ( path -- ) [ chdir ] unix-system-call drop ;
 
-: read-flags ( -- n ) O_RDONLY ; inline
+CONSTANT: read-flags flags{ O_RDONLY }
 
-: open-read ( path -- fd ) O_RDONLY file-mode open-file ;
+: open-read ( path -- fd ) read-flags file-mode open-file ;
 
 M: unix (file-reader) ( path -- stream )
     open-read <fd> init-fd <input-port> ;
 
-: write-flags ( -- n )
+CONSTANT: write-flags flags{ O_WRONLY O_CREAT O_TRUNC }
-    { O_WRONLY O_CREAT O_TRUNC } flags ; inline
 
 : open-write ( path -- fd )
     write-flags file-mode open-file ;
@@ -28,8 +27,7 @@ M: unix (file-reader) ( path -- stream )
 M: unix (file-writer) ( path -- stream )
     open-write <fd> init-fd <output-port> ;
 
-: append-flags ( -- n )
+CONSTANT: append-flags flags{ O_WRONLY O_APPEND O_CREAT }
-    { O_WRONLY O_APPEND O_CREAT } flags ; inline
 
 : open-append ( path -- fd )
     [

basis/io/files/windows/windows.factor

@@ -6,7 +6,8 @@ io.backend.windows kernel math splitting fry alien.strings
 windows windows.kernel32 windows.time windows.types calendar
 combinators math.functions sequences namespaces make words
 system destructors accessors math.bitwise continuations
-windows.errors arrays byte-arrays generalizations alien.data ;
+windows.errors arrays byte-arrays generalizations alien.data
+literals ;
 IN: io.files.windows
 
 : open-file ( path access-mode create-mode flags -- handle )
@@ -16,7 +17,7 @@ IN: io.files.windows
     ] with-destructors ;
 
 : open-r/w ( path -- win32-file )
-    { GENERIC_READ GENERIC_WRITE } flags
+    flags{ GENERIC_READ GENERIC_WRITE }
     OPEN_EXISTING 0 open-file ;
 
 : open-read ( path -- win32-file )
@@ -29,7 +30,7 @@ IN: io.files.windows
     GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
 
 : open-existing ( path -- win32-file )
-    { GENERIC_READ GENERIC_WRITE } flags
+    flags{ GENERIC_READ GENERIC_WRITE }
     share-mode
     f
     OPEN_EXISTING
@@ -38,7 +39,7 @@ IN: io.files.windows
 
 : maybe-create-file ( path -- win32-file ? )
     #! return true if file was just created
-    { GENERIC_READ GENERIC_WRITE } flags
+    flags{ GENERIC_READ GENERIC_WRITE }
     share-mode
     f
     OPEN_ALWAYS

basis/io/mmap/unix/unix.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors destructors io.backend.unix io.mmap
+USING: accessors destructors io.backend.unix io.mmap literals
 io.mmap.private kernel locals math.bitwise system unix unix.ffi ;
 IN: io.mmap.unix
 
@@ -12,13 +12,13 @@ IN: io.mmap.unix
     ] with-destructors ;
 
 M: unix (mapped-file-r/w)
-    { PROT_READ PROT_WRITE } flags
+    flags{ PROT_READ PROT_WRITE }
-    { MAP_FILE MAP_SHARED } flags
+    flags{ MAP_FILE MAP_SHARED }
     O_RDWR mmap-open ;
 
 M: unix (mapped-file-reader)
-    { PROT_READ } flags
+    flags{ PROT_READ }
-    { MAP_FILE MAP_SHARED } flags
+    flags{ MAP_FILE MAP_SHARED }
     O_RDONLY mmap-open ;
 
 M: unix close-mapped-file ( mmap -- )

basis/io/mmap/windows/windows.factor

@@ -2,7 +2,7 @@ USING: alien alien.c-types arrays destructors generic io.mmap
 io.ports io.backend.windows io.files.windows io.backend.windows.privileges
 io.mmap.private kernel libc math math.bitwise namespaces quotations sequences
 windows windows.advapi32 windows.kernel32 io.backend system
-accessors locals windows.errors ;
+accessors locals windows.errors literals ;
 IN: io.mmap.windows
 
 : create-file-mapping ( hFile lpAttributes flProtect dwMaximumSizeHigh dwMaximumSizeLow lpName -- HANDLE )
@@ -29,9 +29,9 @@ C: <win32-mapped-file> win32-mapped-file
 
 M: windows (mapped-file-r/w)
     [
-        { GENERIC_WRITE GENERIC_READ } flags
+        flags{ GENERIC_WRITE GENERIC_READ }
         OPEN_ALWAYS
-        { PAGE_READWRITE SEC_COMMIT } flags
+        flags{ PAGE_READWRITE SEC_COMMIT }
         FILE_MAP_ALL_ACCESS mmap-open
         -rot <win32-mapped-file>
     ] with-destructors ;
@@ -40,7 +40,7 @@ M: windows (mapped-file-reader)
     [
         GENERIC_READ
         OPEN_ALWAYS
-        { PAGE_READONLY SEC_COMMIT } flags
+        flags{ PAGE_READONLY SEC_COMMIT }
         FILE_MAP_READ mmap-open
         -rot <win32-mapped-file>
     ] with-destructors ;

basis/io/monitors/linux/linux.factor

@@ -5,7 +5,7 @@ io.files io.pathnames io.buffers io.ports io.timeouts
 io.backend.unix io.encodings.utf8 unix.linux.inotify assocs
 namespaces make threads continuations init math math.bitwise
 sets alien alien.strings alien.c-types vocabs.loader accessors
-system hashtables destructors unix classes.struct ;
+system hashtables destructors unix classes.struct literals ;
 FROM: namespaces => set ;
 IN: io.monitors.linux
 
@@ -65,13 +65,13 @@ M: linux-monitor dispose* ( monitor -- )
     tri ;
 
 : ignore-flags? ( mask -- ? )
-    {
+    flags{
         IN_DELETE_SELF
         IN_MOVE_SELF
         IN_UNMOUNT
         IN_Q_OVERFLOW
         IN_IGNORED
-    } flags bitand 0 > ;
+    } bitand 0 > ;
 
 : parse-action ( mask -- changed )
     [

basis/io/monitors/windows/nt/nt.factor

@@ -5,7 +5,7 @@ locals kernel math assocs namespaces make continuations sequences
 hashtables sorting arrays combinators math.bitwise strings
 system accessors threads splitting io.backend io.backend.windows
 io.backend.windows.nt io.files.windows.nt io.monitors io.ports
-io.buffers io.files io.timeouts io.encodings.string
+io.buffers io.files io.timeouts io.encodings.string literals
 io.encodings.utf16n io windows.errors windows.kernel32 windows.types
 io.pathnames classes.struct ;
 IN: io.monitors.windows.nt
@@ -16,7 +16,7 @@ IN: io.monitors.windows.nt
     share-mode
     f
     OPEN_EXISTING
-    { FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED } flags
+    flags{ FILE_FLAG_BACKUP_SEMANTICS FILE_FLAG_OVERLAPPED }
     f
     CreateFile opened-file ;
 

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

@@ -3,14 +3,14 @@
 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
 ! http://twistedmatrix.com/trac/browser/trunk/twisted/internet/iocpreactor/process.py
 
 : create-named-pipe ( name -- handle )
-    { PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED } flags
+    flags{ PIPE_ACCESS_INBOUND FILE_FLAG_OVERLAPPED }
     PIPE_TYPE_BYTE
     1
     4096
@@ -21,7 +21,7 @@ IN: io.pipes.windows.nt
 
 : open-other-end ( name -- handle )
     GENERIC_WRITE
-    { FILE_SHARE_READ FILE_SHARE_WRITE } flags
+    flags{ FILE_SHARE_READ FILE_SHARE_WRITE }
     default-security-attributes
     OPEN_EXISTING
     FILE_FLAG_OVERLAPPED

basis/literals/literals-docs.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel multiline ;
+USING: help.markup help.syntax kernel multiline sequences ;
 IN: literals
 
 HELP: $
@@ -62,6 +62,19 @@ ${ five six 7 } .
 
 { POSTPONE: $ POSTPONE: $[ POSTPONE: ${ } related-words
 
+HELP: flags{
+{ $values { "values" sequence } }
+{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at parse-time, which makes this word as efficient as using a literal integer." }
+{ $examples
+    { $example "USING: literals kernel prettyprint ;"
+        "IN: scratchpad"
+        "CONSTANT: x HEX: 1"
+        "flags{ HEX: 20 x BIN: 100 } .h"
+        "25"
+    }
+} ;
+
+
 ARTICLE: "literals" "Interpolating code results into literal values"
 "The " { $vocab-link "literals" } " vocabulary contains words to run code at parse time and insert the results into more complex literal values."
 { $example """

basis/literals/literals-tests.factor

@@ -1,4 +1,4 @@
-USING: kernel literals math tools.test ;
+USING: accessors kernel literals math tools.test ;
 IN: literals.tests
 
 <<
@@ -27,3 +27,16 @@ CONSTANT: constant-a 3
 : sixty-nine ( -- a b ) 6 9 ;
 
 [ { 6 9 } ] [ ${ sixty-nine } ] unit-test
+
+CONSTANT: a 1
+CONSTANT: b 2
+ALIAS: c b
+ALIAS: d c
+
+CONSTANT: foo flags{ a b d }
+
+[ 3 ] [ foo ] unit-test
+[ 3 ] [ flags{ a b d } ] unit-test
+\ foo def>> must-infer
+
+[ 1 ] [ flags{ 1 } ] unit-test

basis/literals/literals.factor

@@ -25,6 +25,7 @@ SYNTAX: $ scan-word expand-literal >vector ;
 SYNTAX: $[ parse-quotation with-datastack >vector ;
 SYNTAX: ${ \ } [ expand-literals ] parse-literal ;
 SYNTAX: flags{
-    "}" [ parse-word ] map-tokens
+    \ } [
         expand-literals
-    0 [ bitor ] reduce suffix! ;
+        0 [ bitor ] reduce
+    ] parse-literal ;

basis/math/bitwise/bitwise-docs.factor

@@ -135,18 +135,6 @@ HELP: clear-bit
     }
 } ;
 
-HELP: flags
-{ $values { "values" sequence } }
-{ $description "Constructs a constant flag value from a sequence of integers or words that output integers. The resulting constant is computed at compile-time, which makes this word as efficient as using a literal integer." }
-{ $examples
-    { $example "USING: math.bitwise kernel prettyprint ;"
-        "IN: scratchpad"
-        "CONSTANT: x HEX: 1"
-        "{ HEX: 20 x BIN: 100 } flags .h"
-        "25"
-    }
-} ;
-
 HELP: symbols>flags
 { $values { "symbols" sequence } { "assoc" assoc } { "flag-bits" integer } }
 { $description "Constructs an integer value by mapping the values in the " { $snippet "symbols" } " sequence to integer values using " { $snippet "assoc" } " and " { $link bitor } "ing the values together." }
@@ -408,7 +396,6 @@ $nl
 }
 "Bitfields:"
 { $subsections
-    flags
     "math-bitfields"
 } ;
 

basis/math/bitwise/bitwise-tests.factor

@@ -1,6 +1,6 @@
 USING: accessors math math.bitwise tools.test kernel words
 specialized-arrays alien.c-types math.vectors.simd
-sequences destructors libc ;
+sequences destructors libc literals ;
 SPECIALIZED-ARRAY: int
 IN: math.bitwise.tests
 
@@ -23,17 +23,6 @@ IN: math.bitwise.tests
 : test-1+ ( x -- y ) 1 + ;
 [ 512 ] [ 1 { { test-1+ 8 } } bitfield ] unit-test
 
-CONSTANT: a 1
-CONSTANT: b 2
-
-: foo ( -- flags ) { a b } flags ;
-
-[ 3 ] [ foo ] unit-test
-[ 3 ] [ { a b } flags ] unit-test
-\ foo def>> must-infer
-
-[ 1 ] [ { 1 } flags ] unit-test
-
 [ 8 ] [ 0 3 toggle-bit ] unit-test
 [ 0 ] [ 8 3 toggle-bit ] unit-test
 

basis/math/bitwise/bitwise.factor

@@ -44,10 +44,6 @@ IN: math.bitwise
 : W- ( x y -- z ) - 64 bits ; inline
 : W* ( x y -- z ) * 64 bits ; inline
 
-! flags
-MACRO: flags ( values -- )
-    [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
-
 : symbols>flags ( symbols assoc -- flag-bits )
     [ at ] curry map
     0 [ bitor ] reduce ;

basis/openssl/libssl/libssl.factor

@@ -3,7 +3,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax combinators kernel
 system namespaces assocs parser lexer sequences words
-quotations math.bitwise alien.libraries ;
+quotations math.bitwise alien.libraries literals ;
 
 IN: openssl.libssl
 
@@ -258,15 +258,14 @@ CONSTANT: SSL_SESS_CACHE_OFF    HEX: 0000
 CONSTANT: SSL_SESS_CACHE_CLIENT HEX: 0001
 CONSTANT: SSL_SESS_CACHE_SERVER HEX: 0002
 
-: SSL_SESS_CACHE_BOTH ( -- n )
+CONSTANT: SSL_SESS_CACHE_BOTH flags{ SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER }
-    { SSL_SESS_CACHE_CLIENT SSL_SESS_CACHE_SERVER } flags ; inline
 
 CONSTANT: SSL_SESS_CACHE_NO_AUTO_CLEAR      HEX: 0080
 CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_LOOKUP HEX: 0100
 CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE  HEX: 0200
 
-: SSL_SESS_CACHE_NO_INTERNAL ( -- n )
+CONSTANT: SSL_SESS_CACHE_NO_INTERNAL
-    { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline
+    flags{ SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE }
 
 ! ===============================================
 ! x509_vfy.h

basis/random/windows/windows.factor

@@ -36,7 +36,7 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer"
     ] if ;
 
 : create-crypto-context ( provider type -- handle )
-    { CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags
+    flags{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET }
     (acquire-crypto-context) win32-error=0/f *void* ;
 
 ERROR: acquire-crypto-context-failed provider type ;

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/tools/deploy/deploy-docs.factor

@@ -17,7 +17,7 @@ $nl
 
 ARTICLE: "tools.deploy.usage" "Deploy tool usage"
 "Once the necessary deployment flags have been set, the application can be deployed:"
-{ $subsections deploy }
+{ $subsections deploy deploy-image-only }
 "For example, you can deploy the " { $vocab-link "hello-ui" } " demo which comes with Factor. Note that this demo already has a deployment configuration, so nothing needs to be configured:"
 { $code "\"hello-ui\" deploy" }
 { $list
@@ -61,4 +61,10 @@ ABOUT: "tools.deploy"
 
 HELP: deploy
 { $values { "vocab" "a vocabulary specifier" } }
-{ $description "Deploys " { $snippet "vocab" } ", saving the deployed image as " { $snippet { $emphasis "vocab" } ".image" } "." } ;
+{ $description "Deploys " { $snippet "vocab" } " into a packaged application. This will create a directory containing the Factor VM, a deployed image set up to run the " { $link POSTPONE: MAIN: } " entry point of " { $snippet "vocab" } " at startup, and any " { $link "deploy-resources" } " and shared libraries the application depends on. On Mac OS X, the deployment directory will be a standard " { $snippet ".app" } " bundle executable from Finder. To only generate the Factor image, use " { $link deploy-image-only } "." } ;
+
+HELP: deploy-image-only
+{ $values { "vocab" "a vocabulary specifier" } { "image" "a pathname" } }
+{ $description "Deploys " { $snippet "vocab" } ", saving the deployed image to the location specified by " { $snippet "image" } ". This only builds the Factor image for the vocabulary; to create a complete packaged application, use " { $link deploy } "." } ;
+
+{ deploy deploy-image-only } related-words

basis/tools/deploy/deploy.factor

@@ -1,11 +1,14 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: tools.deploy.backend system vocabs.loader kernel
-combinators ;
+combinators tools.deploy.config.editor ;
 IN: tools.deploy
 
 : deploy ( vocab -- ) deploy* ;
 
+: deploy-image-only ( vocab image -- ) 
+    [ vm ] 2dip swap dup deploy-config make-deploy-image drop ;
+
 {
     { [ os macosx? ] [ "tools.deploy.macosx" ] }
     { [ os winnt? ] [ "tools.deploy.windows" ] }

basis/tools/deploy/macosx/macosx.factor

@@ -34,9 +34,6 @@ IN: tools.deploy.macosx
     "Contents/Info.plist" append-path
     write-plist ;
 
-: copy-dll ( bundle-name -- )
-    "Frameworks/libfactor.dylib" copy-bundle-dir ;
-
 : copy-nib ( bundle-name -- )
     deploy-ui? get [
         "Resources/English.lproj/MiniFactor.nib" copy-bundle-dir
@@ -50,11 +47,10 @@ IN: tools.deploy.macosx
 : create-app-dir ( vocab bundle-name -- vm )
     {
         [
-            nip {
+            nip
-                [ copy-dll ]
             [ copy-nib ]
             [ "Contents/Resources" append-path make-directories ]
-            } cleave
+            [ "Contents/Frameworks" append-path make-directories ] tri
         ]
         [ copy-icns ]
         [ create-app-plist ]

basis/tools/deploy/windows/windows.factor

@@ -11,16 +11,12 @@ IN: tools.deploy.windows
 
 CONSTANT: app-icon-resource-id "APPICON"
 
-: copy-dll ( bundle-name -- )
-    "resource:factor.dll" swap copy-file-into ;
-
 :: copy-vm ( executable bundle-name extension -- vm )
     vm "." split1-last drop extension append
     bundle-name executable ".exe" append append-path
     [ copy-file ] keep ;
 
 : create-exe-dir ( vocab bundle-name -- vm )
-    dup copy-dll
     deploy-console? get ".com" ".exe" ? copy-vm ;
 
 : open-in-explorer ( dir -- )

basis/ui/backend/windows/windows.factor

@@ -628,7 +628,7 @@ M: windows-ui-backend do-events
     WNDCLASSEX <struct> f GetModuleHandle
     class-name-ptr pick GetClassInfoEx 0 = [
         WNDCLASSEX heap-size >>cbSize
-        { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags >>style
+        flags{ CS_HREDRAW CS_VREDRAW CS_OWNDC } >>style
         ui-wndproc >>lpfnWndProc
         0 >>cbClsExtra
         0 >>cbWndExtra
@@ -811,8 +811,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
     f ClipCursor drop
     1 ShowCursor drop ;
 
-: fullscreen-flags ( -- n )
+CONSTANT: fullscreen-flags { WS_CAPTION WS_BORDER WS_THICKFRAME }
-    { WS_CAPTION WS_BORDER WS_THICKFRAME } flags ; inline
 
 : enter-fullscreen ( world -- )
     handle>> hWnd>>
@@ -838,7 +837,7 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
         [
             f
             over hwnd>RECT get-RECT-dimensions
-            { SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED } flags
+            flags{ SWP_NOMOVE SWP_NOSIZE SWP_NOZORDER SWP_FRAMECHANGED }
             SetWindowPos win32-error=0/f
         ]
         [ SW_RESTORE ShowWindow win32-error=0/f ]

basis/unix/linux/inotify/inotify.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax math math.bitwise classes.struct ;
+USING: alien.c-types alien.syntax math math.bitwise classes.struct
+literals ;
 IN: unix.linux.inotify
 
 STRUCT: inotify-event
@@ -27,8 +28,8 @@ CONSTANT: IN_UNMOUNT HEX: 2000     ! Backing fs was unmounted
 CONSTANT: IN_Q_OVERFLOW HEX: 4000  ! Event queued overflowed
 CONSTANT: IN_IGNORED HEX: 8000     ! File was ignored
 
-: IN_CLOSE ( -- n ) { IN_CLOSE_WRITE IN_CLOSE_NOWRITE } flags ; foldable ! close
+CONSTANT: IN_CLOSE flags{ IN_CLOSE_WRITE IN_CLOSE_NOWRITE }
-: IN_MOVE ( -- n ) { IN_MOVED_FROM IN_MOVED_TO } flags        ; foldable ! moves
+CONSTANT: IN_MOVE flags{ IN_MOVED_FROM IN_MOVED_TO }
 
 CONSTANT: IN_ONLYDIR HEX: 1000000     ! only watch the path if it is a directory
 CONSTANT: IN_DONT_FOLLOW HEX: 2000000 ! don't follow a sym link
@@ -36,20 +37,20 @@ CONSTANT: IN_MASK_ADD HEX: 20000000   ! add to the mask of an already existing w
 CONSTANT: IN_ISDIR HEX: 40000000      ! event occurred against dir
 CONSTANT: IN_ONESHOT HEX: 80000000    ! only send event once
 
-: IN_CHANGE_EVENTS ( -- n )
+CONSTANT: IN_CHANGE_EVENTS 
-    {
+    flags{
         IN_MODIFY IN_ATTRIB IN_MOVED_FROM
         IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF
         IN_MOVE_SELF
-    } flags ; foldable
+    }
 
-: IN_ALL_EVENTS ( -- n )
+CONSTANT: IN_ALL_EVENTS
-    {
+    flags{
         IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE
         IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM
         IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF
         IN_MOVE_SELF
-    } flags ; foldable
+    }
 
 FUNCTION: int inotify_init ( ) ;
 FUNCTION: int inotify_add_watch ( int fd, c-string name, uint mask  ) ;

basis/unix/statfs/macosx/macosx.factor

@@ -3,7 +3,7 @@
 USING: alien.c-types io.encodings.utf8 io.encodings.string
 kernel sequences unix.stat accessors unix combinators math
 grouping system alien.strings math.bitwise alien.syntax
-unix.types classes.struct unix.ffi ;
+unix.types classes.struct unix.ffi literals ;
 IN: unix.statfs.macosx
 
 CONSTANT: MNT_RDONLY  HEX: 00000001
@@ -29,8 +29,8 @@ CONSTANT: MNT_MULTILABEL  HEX: 04000000
 CONSTANT: MNT_NOATIME HEX: 10000000
 ALIAS: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP
 
-: MNT_VISFLAGMASK ( -- n )
+CONSTANT: MNT_VISFLAGMASK
-    {
+    flags{
         MNT_RDONLY MNT_SYNCHRONOUS MNT_NOEXEC
         MNT_NOSUID MNT_NODEV MNT_UNION
         MNT_ASYNC MNT_EXPORTED MNT_QUARANTINE
@@ -38,14 +38,13 @@ ALIAS: MNT_UNKNOWNPERMISSIONS MNT_IGNORE_OWNERSHIP
         MNT_ROOTFS MNT_DOVOLFS MNT_DONTBROWSE
         MNT_IGNORE_OWNERSHIP MNT_AUTOMOUNTED MNT_JOURNALED
         MNT_NOUSERXATTR MNT_DEFWRITE MNT_MULTILABEL MNT_NOATIME
-    } flags ; inline
+    }
 
 CONSTANT: MNT_UPDATE  HEX: 00010000
 CONSTANT: MNT_RELOAD  HEX: 00040000
 CONSTANT: MNT_FORCE   HEX: 00080000
 
-: MNT_CMDFLAGS ( -- n )
+CONSTANT: MNT_CMDFLAGS flags{ MNT_UPDATE MNT_RELOAD MNT_FORCE }
-    { MNT_UPDATE MNT_RELOAD MNT_FORCE } flags ; inline
 
 CONSTANT: VFS_GENERIC 0
 CONSTANT: VFS_NUMMNTOPS 1

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

@@ -1,5 +1,5 @@
 USING: alien.syntax windows.types classes.struct math alien.c-types
-math.bitwise kernel locals windows.kernel32 ;
+math.bitwise kernel locals windows.kernel32 literals ;
 IN: windows.directx.d3d9types
 
 TYPEDEF: DWORD D3DCOLOR
@@ -54,8 +54,9 @@ CONSTANT: D3DCS_PLANE3      HEX: 00000200
 CONSTANT: D3DCS_PLANE4      HEX: 00000400
 CONSTANT: D3DCS_PLANE5      HEX: 00000800
 
-: D3DCS_ALL ( -- n )
+CONSTANT: D3DCS_ALL
-    { D3DCS_LEFT
+    flags{
+        D3DCS_LEFT
         D3DCS_RIGHT
         D3DCS_TOP
         D3DCS_BOTTOM
@@ -66,7 +67,8 @@ CONSTANT: D3DCS_PLANE5      HEX: 00000800
         D3DCS_PLANE2
         D3DCS_PLANE3
         D3DCS_PLANE4
-      D3DCS_PLANE5 } flags ; inline
+        D3DCS_PLANE5
+    }
 
 STRUCT: D3DCLIPSTATUS9
     { ClipUnion        DWORD }
@@ -777,8 +779,7 @@ CONSTANT: D3DVS_SWIZZLE_MASK      HEX: 00FF0000
 : D3DVS_W_Z ( -- n ) 2 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
 : D3DVS_W_W ( -- n ) 3 D3DVS_SWIZZLE_SHIFT 6 + shift ; inline
 
-: D3DVS_NOSWIZZLE ( -- n )
+CONSTANT: D3DVS_NOSWIZZLE flags{ D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W }
-    { D3DVS_X_X D3DVS_Y_Y D3DVS_Z_Z D3DVS_W_W } flags ; inline
 
 CONSTANT: D3DSP_SWIZZLE_SHIFT     16
 CONSTANT: D3DSP_SWIZZLE_MASK      HEX: 00FF0000

basis/windows/errors/errors.factor

@@ -705,10 +705,10 @@ CONSTANT: FORMAT_MESSAGE_MAX_WIDTH_MASK   HEX: 000000FF
 
 ERROR: error-message-failed id ;
 :: n>win32-error-string ( id -- string )
-    {
+    flags{
         FORMAT_MESSAGE_FROM_SYSTEM
         FORMAT_MESSAGE_ARGUMENT_ARRAY
-    } flags
+    }
     f
     id
     LANG_NEUTRAL SUBLANG_DEFAULT make-lang-id

basis/windows/gdi32/gdi32.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax alien.destructors
-kernel windows.types math.bitwise ;
+kernel windows.types math.bitwise literals ;
 IN: windows.gdi32
 
 CONSTANT: BI_RGB 0
@@ -818,7 +818,7 @@ CONSTANT: TA_RIGHT 2
 CONSTANT: TA_RTLREADING 256
 CONSTANT: TA_NOUPDATECP 0
 CONSTANT: TA_UPDATECP 1
-: TA_MASK ( -- n ) { TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING } flags ; foldable
+CONSTANT: TA_MASK flags{ TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING }
 CONSTANT: VTA_BASELINE 24
 CONSTANT: VTA_CENTER 6
 ALIAS: VTA_LEFT TA_BOTTOM

basis/windows/user32/user32.factor

@@ -33,18 +33,17 @@ CONSTANT: WS_MINIMIZEBOX      HEX: 00020000
 CONSTANT: WS_MAXIMIZEBOX      HEX: 00010000
 
 ! Common window styles
-: WS_OVERLAPPEDWINDOW ( -- n )
+CONSTANT: WS_OVERLAPPEDWINDOW
-    {
+    flags{
         WS_OVERLAPPED
         WS_CAPTION
         WS_SYSMENU
         WS_THICKFRAME
         WS_MINIMIZEBOX
         WS_MAXIMIZEBOX
-    } flags ; foldable
+    }
 
-: WS_POPUPWINDOW ( -- n )
+CONSTANT: WS_POPUPWINDOW flags{ WS_POPUP WS_BORDER WS_SYSMENU }
-    { WS_POPUP WS_BORDER WS_SYSMENU } flags ; foldable
 
 ALIAS: WS_CHILDWINDOW      WS_CHILD
 
@@ -76,11 +75,11 @@ CONSTANT: WS_EX_CONTROLPARENT     HEX: 00010000
 CONSTANT: WS_EX_STATICEDGE        HEX: 00020000
 CONSTANT: WS_EX_APPWINDOW         HEX: 00040000
 
-: WS_EX_OVERLAPPEDWINDOW ( -- n )
+CONSTANT: WS_EX_OVERLAPPEDWINDOW
-    WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable
+    flags{ WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE }
 
-: WS_EX_PALETTEWINDOW ( -- n )
+CONSTANT: WS_EX_PALETTEWINDOW 
-    { WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable
+    flags{ WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST }
 
 CONSTANT: CS_VREDRAW          HEX: 0001
 CONSTANT: CS_HREDRAW          HEX: 0002

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 ;
+classes.struct windows.com.syntax init literals ;
 FROM: alien.c-types => short ;
 IN: windows.winsock
 
@@ -73,8 +73,7 @@ CONSTANT: AI_PASSIVE     1
 CONSTANT: AI_CANONNAME   2
 CONSTANT: AI_NUMERICHOST 4
 
-: AI_MASK ( -- n )
+CONSTANT: AI_MASK flags{ AI_PASSIVE AI_CANONNAME AI_NUMERICHOST }
-    { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; inline
 
 CONSTANT: NI_NUMERICHOST 1
 CONSTANT: NI_NUMERICSERV 2

basis/x11/windows/windows.factor

@@ -2,18 +2,18 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel math math.bitwise math.vectors
 namespaces sequences x11 x11.xlib x11.constants x11.glx arrays
-fry classes.struct ;
+fry classes.struct literals ;
 IN: x11.windows
 
-: create-window-mask ( -- n )
+CONSTANT: create-window-mask
-    { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ;
+    flags{ CWBackPixel CWBorderPixel CWColormap CWEventMask }
 
 : create-colormap ( visinfo -- colormap )
     [ dpy get root get ] dip visual>> AllocNone
     XCreateColormap ;
 
-: event-mask ( -- n )
+CONSTANT: event-mask
-    {
+    flags{
         ExposureMask
         StructureNotifyMask
         KeyPressMask
@@ -25,7 +25,7 @@ IN: x11.windows
         EnterWindowMask
         LeaveWindowMask
         PropertyChangeMask
-    } flags ;
+    }
 
 : window-attributes ( visinfo -- attributes )
     XSetWindowAttributes <struct>

basis/x11/xlib/xlib.factor

@@ -12,7 +12,8 @@
 ! and note the section.
 USING: accessors kernel arrays alien alien.c-types alien.data
 alien.strings alien.syntax classes.struct math math.bitwise words
-sequences namespaces continuations io io.encodings.ascii x11.syntax ;
+sequences namespaces continuations io io.encodings.ascii x11.syntax
+literals ;
 FROM: alien.c-types => short ;
 IN: x11.xlib
 
@@ -1134,8 +1135,8 @@ X-FUNCTION: Status XWithdrawWindow (
 : PAspect      ( -- n ) 7 2^ ; inline
 : PBaseSize    ( -- n ) 8 2^ ; inline
 : PWinGravity  ( -- n ) 9 2^ ; inline
-: PAllHints    ( -- n )
+CONSTANT: PAllHints
-    { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
+    flags{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect }
 
 STRUCT: XSizeHints
     { flags long }

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

extra/fullscreen/fullscreen.factor

@@ -16,7 +16,7 @@ IN: fullscreen
 :: (monitor-info>devmodes) ( monitor-info n -- )
     DEVMODE <struct>
         DEVMODE heap-size >>dmSize
-        { DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } flags >>dmFields
+        flags{ DM_BITSPERPEL DM_PELSWIDTH DM_PELSHEIGHT } >>dmFields
     :> devmode
 
     monitor-info szDevice>>
@@ -73,11 +73,11 @@ ERROR: display-change-error n ;
 
 : set-fullscreen-styles ( hwnd -- )
     [ GWL_STYLE [ WS_OVERLAPPEDWINDOW unmask ] change-style ]
-    [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags bitor ] change-style ] bi ;
+    [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } bitor ] change-style ] bi ;
 
 : set-non-fullscreen-styles ( hwnd -- )
     [ GWL_STYLE [ WS_OVERLAPPEDWINDOW bitor ] change-style ]
-    [ GWL_EXSTYLE [ { WS_EX_APPWINDOW WS_EX_TOPMOST } flags unmask ] change-style ] bi ;
+    [ GWL_EXSTYLE [ flags{ WS_EX_APPWINDOW WS_EX_TOPMOST } unmask ] change-style ] bi ;
 
 ERROR: unsupported-resolution triple ;
 
@@ -92,10 +92,10 @@ ERROR: unsupported-resolution triple ;
     hwnd f
     desktop-monitor-info rcMonitor>> slots{ left top } first2
     triple first2
-    {
+    flags{
         SWP_NOACTIVATE SWP_NOCOPYBITS SWP_NOOWNERZORDER
         SWP_NOREPOSITION SWP_NOZORDER
-    } flags
+    }
     SetWindowPos win32-error=0/f ;
 
 :: enable-fullscreen ( triple hwnd -- rect )

extra/io/serial/unix/bsd/bsd.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel math.bitwise sequences system io.serial ;
+USING: alien.syntax kernel math.bitwise sequences system io.serial
+literals ;
 IN: io.serial.unix
 
 M: bsd lookup-baud ( m -- n )
@@ -60,7 +61,7 @@ CONSTANT: HUPCL       HEX: 00004000
 CONSTANT: CLOCAL      HEX: 00008000
 CONSTANT: CCTS_OFLOW  HEX: 00010000
 CONSTANT: CRTS_IFLOW  HEX: 00020000
-: CRTSCTS ( -- n )  { CCTS_OFLOW CRTS_IFLOW } flags ; inline
+CONSTANT: CRTSCTS flags{ CCTS_OFLOW CRTS_IFLOW }
 CONSTANT: CDTR_IFLOW  HEX: 00040000
 CONSTANT: CDSR_OFLOW  HEX: 00080000
 CONSTANT: CCAR_OFLOW  HEX: 00100000

extra/io/serial/unix/unix-tests.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel math.bitwise io.serial io.serial.unix ;
+USING: accessors kernel math.bitwise io.serial io.serial.unix
+literals ;
 IN: io.serial.unix
 
 : serial-obj ( -- obj )
@@ -10,10 +11,10 @@ IN: io.serial.unix
     ! "/dev/ttyd0" >>path ! freebsd
     ! "/dev/ttyU0" >>path ! openbsd
     19200 >>baud
-    { IGNPAR ICRNL } flags >>iflag
+    flags{ IGNPAR ICRNL } >>iflag
-    { } flags >>oflag
+    flags{ } >>oflag
-    { CS8 CLOCAL CREAD } flags >>cflag
+    flags{ CS8 CLOCAL CREAD } >>cflag
-    { ICANON } flags >>lflag ;
+    flags{ ICANON } >>lflag ;
 
 : serial-test ( -- serial )
     serial-obj

extra/io/serial/unix/unix.factor

@@ -3,7 +3,8 @@
 USING: accessors alien.c-types alien.syntax alien.data 
 classes.struct combinators io.ports io.streams.duplex
 system kernel math math.bitwise vocabs.loader io.serial
-io.serial.unix.termios io.backend.unix unix unix.ffi ;
+io.serial.unix.termios io.backend.unix unix unix.ffi
+literals ;
 IN: io.serial.unix
 
 << {
@@ -33,7 +34,7 @@ FUNCTION: int cfsetspeed ( termios* t, speed_t s ) ;
 
 M: unix open-serial ( serial -- serial' )
     dup
-    path>> { O_RDWR O_NOCTTY O_NDELAY } flags file-mode open-file
+    path>> flags{ O_RDWR O_NOCTTY O_NDELAY } file-mode open-file
     fd>duplex-stream >>stream ;
 
 : serial-fd ( serial -- fd )

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/model-viewer/model-viewer.factor

@@ -11,7 +11,7 @@ ui.gadgets.worlds ui.pixel-formats specialized-arrays
 specialized-vectors literals fry
 sequences.deep destructors math.bitwise opengl.gl
 game.models game.models.obj game.models.loader game.models.collada
-prettyprint images.tga ;
+prettyprint images.tga literals ;
 FROM: alien.c-types => float ;
 SPECIALIZED-ARRAY: float
 SPECIALIZED-VECTOR: uint
@@ -164,9 +164,9 @@ TUPLE: vbo
     0 0 0 0 glClearColor 
     1 glClearDepth
     HEX: ffffffff glClearStencil
-    { GL_COLOR_BUFFER_BIT
+    flags{ GL_COLOR_BUFFER_BIT
       GL_DEPTH_BUFFER_BIT
-      GL_STENCIL_BUFFER_BIT } flags glClear ;
+      GL_STENCIL_BUFFER_BIT } glClear ;
     
 : draw-model ( world -- )
     clear-screen

extra/webkit-demo/webkit-demo.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: cocoa cocoa.application cocoa.types cocoa.classes cocoa.windows
-core-graphics.types kernel math.bitwise ;
+core-graphics.types kernel math.bitwise literals ;
 IN: webkit-demo
 
 FRAMEWORK: /System/Library/Frameworks/WebKit.framework
@@ -13,13 +13,13 @@ IMPORT: WebView
     WebView -> alloc
     rect f f -> initWithFrame:frameName:groupName: ;
 
-: window-style ( -- n )
+CONSTANT: window-style
-    {
+    flags{
         NSClosableWindowMask
         NSMiniaturizableWindowMask
         NSResizableWindowMask
         NSTitledWindowMask
-    } flags ;
+    }
 
 : <WebWindow> ( -- id )
     <WebView> rect window-style <ViewWindow> ;

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,12 +135,10 @@ 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(;;)
+	{
+		try
 		{
-		/* We come back here if a generation is full */
-		start_gc_again();
-	}
-
 			current_gc->event->op = current_gc->op;
 
 			switch(current_gc->op)
@@ -180,6 +178,16 @@ void factor_vm::gc(gc_op op, cell requested_bytes, bool trace_contexts_p)
 				break;
 			}
 
+			break;
+		}
+		catch(const must_start_gc_again e)
+		{
+			/* We come back here if a generation is full */
+			start_gc_again();
+			continue;
+		}
+	}
+
 	end_gc();
 
 	delete current_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 "libfactor.dylib"
 
 void early_init();
 

vm/os-unix.cpp

@@ -46,8 +46,7 @@ void sleep_nanos(u64 nsec)
 
 void factor_vm::init_ffi()
 {
-	/* NULL_DLL is "libfactor.dylib" for OS X and NULL for generic Unix */
+	null_dll = dlopen(NULL,RTLD_LAZY);
-	null_dll = dlopen(NULL_DLL,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)
+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()