Merge branch 'master' of git://factorcode.org/git/factor

Makefile

@@ -38,7 +38,6 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/byte_arrays.o \
 	vm/callstack.o \
 	vm/code_block.o \
-	vm/code_gc.o \
 	vm/code_heap.o \
 	vm/contexts.o \
 	vm/data_gc.o \
@@ -47,6 +46,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/dispatch.o \
 	vm/errors.o \
 	vm/factor.o \
+	vm/heap.o \
 	vm/image.o \
 	vm/inline_cache.o \
 	vm/io.o \

basis/bootstrap/image/image.factor

@@ -163,6 +163,7 @@ USERENV: jit-3dip 40
 USERENV: jit-execute-word 41
 USERENV: jit-execute-jump 42
 USERENV: jit-execute-call 43
+USERENV: jit-declare-word 44
 
 ! PIC stubs
 USERENV: pic-load 47
@@ -493,6 +494,7 @@ M: quotation '
     \ inline-cache-miss-tail \ pic-miss-tail-word set
     \ mega-cache-lookup \ mega-lookup-word set
     \ mega-cache-miss \ mega-miss-word set
+    \ declare jit-declare-word set
     [ undefined ] undefined-quot set ;
 
 : emit-userenvs ( -- )

basis/compiler/cfg/builder/builder-tests.factor

@@ -4,6 +4,7 @@ compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
 compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
 compiler.cfg arrays locals byte-arrays kernel.private math
 slots.private vectors sbufs strings math.partial-dispatch
+hashtables assocs combinators.short-circuit
 strings.private accessors compiler.cfg.instructions ;
 IN: compiler.cfg.builder.tests
 
@@ -204,4 +205,7 @@ IN: compiler.cfg.builder.tests
         [ [ ##box-alien? ] contains-insn? ]
         [ [ ##box-float? ] contains-insn? ] bi
     ] unit-test
-] when
+] when
+
+! Regression. Make sure everything is inlined correctly
+[ f ] [ M\ hashtable set-at [ { [ ##call? ] [ word>> \ set-slot eq? ] } 1&& ] contains-insn? ] unit-test

basis/compiler/cfg/hats/hats.factor

@@ -46,15 +46,31 @@ insn-classes get [
         { [ dup not ] [ drop \ f tag-number ##load-immediate ] }
         { [ dup fixnum? ] [ tag-fixnum ##load-immediate ] }
         [ ##load-reference ]
-    } cond ; inline
+    } cond ;
 
 : ^^unbox-c-ptr ( src class -- dst )
-    [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ; inline
+    [ next-vreg dup ] 2dip next-vreg ##unbox-c-ptr ;
 
-: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline
+: ^^neg ( src -- dst )
-: ^^allot-tuple ( n -- dst ) 2 + cells tuple ^^allot ; inline
+    [ 0 ^^load-literal ] dip ^^sub ;
-: ^^allot-array ( n -- dst ) 2 + cells array ^^allot ; inline
+
-: ^^allot-byte-array ( n -- dst ) 2 cells + byte-array ^^allot ; inline
+: ^^allot-tuple ( n -- dst )
-: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ; inline
+    2 + cells tuple ^^allot ;
-: ^^tag-fixnum ( src -- dst ) tag-bits get ^^shl-imm ; inline
+
-: ^^untag-fixnum ( src -- dst ) tag-bits get ^^sar-imm ; inline
+: ^^allot-array ( n -- dst )
+    2 + cells array ^^allot ;
+
+: ^^allot-byte-array ( n -- dst )
+    2 cells + byte-array ^^allot ;
+
+: ^^offset>slot ( slot -- vreg' )
+    cell 4 = [ 1 ^^shr-imm ] [ any-rep ^^copy ] if ;
+
+: ^^tag-offset>slot ( slot tag -- vreg' )
+    [ ^^offset>slot ] dip ^^sub-imm ;
+
+: ^^tag-fixnum ( src -- dst )
+    tag-bits get ^^shl-imm ;
+
+: ^^untag-fixnum ( src -- dst )
+    tag-bits get ^^sar-imm ;

basis/compiler/cfg/instructions/instructions.factor

@@ -63,9 +63,7 @@ temp: temp/int-rep ;
 ! Slot access
 INSN: ##slot
 def: dst/int-rep
-use: obj/int-rep slot/int-rep
+use: obj/int-rep slot/int-rep ;
-literal: tag
-temp: temp/int-rep ;
 
 INSN: ##slot-imm
 def: dst/int-rep
@@ -73,9 +71,7 @@ use: obj/int-rep
 literal: slot tag ;
 
 INSN: ##set-slot
-use: src/int-rep obj/int-rep slot/int-rep
+use: src/int-rep obj/int-rep slot/int-rep ;
-literal: tag
-temp: temp/int-rep ;
 
 INSN: ##set-slot-imm
 use: src/int-rep obj/int-rep

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

@@ -12,5 +12,5 @@ IN: compiler.cfg.intrinsics.misc
 : emit-getenv ( node -- )
     "userenv" ^^vm-field-ptr
     swap node-input-infos first literal>>
-    [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot 0 ^^slot ] if*
+    [ ds-drop 0 ^^slot-imm ] [ ds-pop ^^offset>slot ^^slot ] if*
     ds-push ;

basis/compiler/cfg/intrinsics/slots/slots.factor

@@ -9,8 +9,8 @@ IN: compiler.cfg.intrinsics.slots
 : value-tag ( info -- n ) class>> class-tag ; inline
 
 : (emit-slot) ( infos -- dst )
-    [ 2inputs ^^offset>slot ] [ first value-tag ] bi*
+    [ 2inputs ] [ first value-tag ] bi*
-    ^^slot ;
+    ^^tag-offset>slot ^^slot ;
 
 : (emit-slot-imm) ( infos -- dst )
     ds-drop
@@ -28,8 +28,8 @@ IN: compiler.cfg.intrinsics.slots
     ] [ drop emit-primitive ] if ;
 
 : (emit-set-slot) ( infos -- obj-reg )
-    [ 3inputs ^^offset>slot ] [ second value-tag ] bi*
+    [ 3inputs ] [ second value-tag ] bi*
-    pick [ next-vreg ##set-slot ] dip ;
+    ^^tag-offset>slot over [ ##set-slot ] dip ;
 
 : (emit-set-slot-imm) ( infos -- obj-reg )
     ds-drop

basis/compiler/codegen/codegen.factor

@@ -269,7 +269,7 @@ M: _gc generate-insn
         [ data-values>> save-data-regs ]
         [ [ tagged-values>> ] [ temp1>> ] bi save-gc-roots ]
         [ [ temp1>> ] [ temp2>> ] bi t %save-context ]
-        [ tagged-values>> length %call-gc ]
+        [ [ tagged-values>> length ] [ temp1>> ] bi %call-gc ]
         [ [ tagged-values>> ] [ temp1>> ] bi load-gc-roots ]
         [ data-values>> load-data-regs ]
     } cleave
@@ -442,7 +442,7 @@ M: ##alien-indirect generate-insn
     ! Generate code for boxing input parameters in a callback.
     [
         dup \ %save-param-reg move-parameters
-        "nest_stacks" %vm-invoke-1st-arg
+        %nest-stacks
         box-parameters
     ] with-param-regs ;
 
@@ -480,8 +480,6 @@ TUPLE: callback-context ;
         [ callback-context new do-callback ] %
     ] [ ] make ;
 
-: %unnest-stacks ( -- ) "unnest_stacks" %vm-invoke-1st-arg ;
-
 M: ##callback-return generate-insn
     #! All the extra book-keeping for %unwind is only for x86.
     #! On other platforms its an alias for %return.

basis/compiler/tests/alien.factor

@@ -588,3 +588,8 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
         123 >>parents
     ffi_test_48
 ] unit-test
+
+! Regression: calling an undefined function would raise a protection fault
+FUNCTION: void this_does_not_exist ( ) ;
+
+[ this_does_not_exist ] [ { "kernel-error" 10 f f } = ] must-fail-with

basis/compiler/tests/low-level-ir.factor

@@ -64,9 +64,9 @@ IN: compiler.tests.low-level-ir
 ! one of the sources
 [ t ] [
     V{
-        T{ ##load-immediate f 1 $[ 2 cell log2 shift ] }
+        T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
         T{ ##load-reference f 0 { t f t } }
-        T{ ##slot f 0 0 1 $[ array tag-number ] 2 }
+        T{ ##slot f 0 0 1 }
     } compile-test-bb
 ] unit-test
 
@@ -79,9 +79,9 @@ IN: compiler.tests.low-level-ir
 
 [ t ] [
     V{
-        T{ ##load-immediate f 1 $[ 2 cell log2 shift ] }
+        T{ ##load-immediate f 1 $[ 2 cell log2 shift array tag-number - ] }
         T{ ##load-reference f 0 { t f t } }
-        T{ ##set-slot f 0 0 1 $[ array tag-number ] 2 }
+        T{ ##set-slot f 0 0 1 }
     } compile-test-bb
     dup first eq?
 ] unit-test

basis/compression/inflate/inflate.factor

@@ -190,14 +190,12 @@ CONSTANT: dist-table
     curr :> a
     curr 3 tail-slice :> x
     x length [0,b)
-    filter
+    filter {
-    {
         { 0 [ drop ] }
         { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
         { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
         { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
         { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
-        
     } case 
     curr 3 tail ;
 
@@ -208,10 +206,11 @@ PRIVATE>
     concat [ 128 + ] B{ } map-as ;
 
 : reverse-png-filter ( lines -- byte-array )
-    dup first [ 0 ] replicate prefix
+    dup first length 0 <array> prefix
-    [ { 0 0 } prepend  ] map
+    [ { 0 0 } prepend ] map
     2 clump [
-        first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
+        first2 dup [ third ] [ [ 0 2 ] dip set-nth ] bi
+        png-unfilter-line
     ] map B{ } concat-as ;
 
 : zlib-inflate ( bytes -- bytes )

basis/cpu/architecture/architecture.factor

@@ -153,9 +153,9 @@ HOOK: %return cpu ( -- )
 
 HOOK: %dispatch cpu ( src temp -- )
 
-HOOK: %slot cpu ( dst obj slot tag temp -- )
+HOOK: %slot cpu ( dst obj slot -- )
 HOOK: %slot-imm cpu ( dst obj slot tag -- )
-HOOK: %set-slot cpu ( src obj slot tag temp -- )
+HOOK: %set-slot cpu ( src obj slot -- )
 HOOK: %set-slot-imm cpu ( src obj slot tag -- )
 
 HOOK: %string-nth cpu ( dst obj index temp -- )
@@ -296,7 +296,7 @@ HOOK: %write-barrier cpu ( src card# table -- )
 HOOK: %check-nursery cpu ( label temp1 temp2 -- )
 HOOK: %save-gc-root cpu ( gc-root register -- )
 HOOK: %load-gc-root cpu ( gc-root register -- )
-HOOK: %call-gc cpu ( gc-root-count -- )
+HOOK: %call-gc cpu ( gc-root-count temp1 -- )
 
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )
@@ -383,9 +383,6 @@ M: object %prepare-var-args ;
 
 HOOK: %alien-invoke cpu ( function library -- )
 
-HOOK: %vm-invoke-1st-arg cpu ( function -- )
-HOOK: %vm-invoke-3rd-arg cpu ( function -- )
-
 HOOK: %cleanup cpu ( params -- )
 
 M: object %cleanup ( params -- ) drop ;
@@ -398,6 +395,10 @@ HOOK: %alien-callback cpu ( quot -- )
 
 HOOK: %callback-value cpu ( ctype -- )
 
+HOOK: %nest-stacks cpu ( -- )
+
+HOOK: %unnest-stacks cpu ( -- )
+
 ! Return to caller with stdcall unwinding (only for x86)
 HOOK: %callback-return cpu ( params -- )
 

basis/cpu/ppc/ppc.factor

@@ -40,9 +40,6 @@ enable-float-intrinsics
 
 M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ;
 
-M: ppc %vm-invoke-1st-arg ( function -- ) f %alien-invoke ;
-M: ppc %vm-invoke-3rd-arg ( function -- ) f %alien-invoke ;
-
 M: ppc machine-registers
     {
         { int-regs $[ 2 12 [a,b] 15 29 [a,b] append ] }
@@ -142,16 +139,12 @@ M:: ppc %dispatch ( src temp -- )
     temp MTCTR
     BCTR ;
 
-:: (%slot) ( obj slot tag temp -- reg offset )
-    temp slot obj ADD
-    temp tag neg ; inline
-
 : (%slot-imm) ( obj slot tag -- reg offset )
     [ cells ] dip - ; inline
 
-M: ppc %slot ( dst obj slot tag temp -- ) (%slot) LWZ ;
+M: ppc %slot ( dst obj slot -- ) swapd LWZX ;
 M: ppc %slot-imm ( dst obj slot tag -- ) (%slot-imm) LWZ ;
-M: ppc %set-slot ( src obj slot tag temp -- ) (%slot) STW ;
+M: ppc %set-slot ( src obj slot -- ) swapd STWX ;
 M: ppc %set-slot-imm ( src obj slot tag -- ) (%slot-imm) STW ;
 
 M:: ppc %string-nth ( dst src index temp -- )
@@ -513,7 +506,7 @@ M:: ppc %save-gc-root ( gc-root register -- )
 M:: ppc %load-gc-root ( gc-root register -- )
     register 1 gc-root gc-root@ LWZ ;
 
-M:: ppc %call-gc ( gc-root-count -- )
+M:: ppc %call-gc ( gc-root-count temp -- )
     3 1 gc-root-base local@ ADDI
     gc-root-count 4 LI
     "inline_gc" f %alien-invoke ;
@@ -781,6 +774,12 @@ M: ppc %box-small-struct ( c-type -- )
     4 3 4 LWZ
     3 3 0 LWZ ;
 
+M: ppc %nest-stacks ( -- )
+    "nest_stacks" f %alien-invoke ;
+
+M: ppc %unnest-stacks ( -- )
+    "unnest_stacks" f %alien-invoke ;
+
 M: ppc %unbox-small-struct ( size -- )
     #! Alien must be in EAX.
     heap-size cell align cell /i {

basis/cpu/x86/32/32.factor

@@ -38,9 +38,8 @@ M:: x86.32 %dispatch ( src temp -- )
     bi ;
 
 ! Registers for fastcall
-M: x86.32 param-reg-1 EAX ;
+: param-reg-1 ( -- reg ) EAX ;
-M: x86.32 param-reg-2 EDX ;
+: param-reg-2 ( -- reg ) EDX ;
-M: x86.32 param-reg-3 ECX ;
 
 M: x86.32 pic-tail-reg EBX ;
 
@@ -49,16 +48,7 @@ M: x86.32 reserved-area-size 0 ;
 M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
 
 : push-vm-ptr ( -- )
-    temp-reg 0 MOV rc-absolute-cell rt-vm rel-fixup ! push the vm ptr as an argument
+    0 PUSH rc-absolute-cell rt-vm rel-fixup ; ! push the vm ptr as an argument
-    temp-reg PUSH ;
-
-M: x86.32 %vm-invoke-1st-arg ( function -- )
-    push-vm-ptr
-    f %alien-invoke
-    temp-reg POP ;
-
-M: x86.32 %vm-invoke-3rd-arg ( function -- )
-    %vm-invoke-1st-arg ;    ! first 2 args are regs, 3rd is stack so vm-invoke-1st-arg works here
 
 M: x86.32 return-struct-in-registers? ( c-type -- ? )
     c-type
@@ -247,6 +237,18 @@ M:: x86.32 %unbox-large-struct ( n c-type -- )
         "to_value_struct" f %alien-invoke
     ] with-aligned-stack ;
 
+M: x86.32 %nest-stacks ( -- )
+    4 [
+        push-vm-ptr
+        "nest_stacks" f %alien-invoke
+    ] with-aligned-stack ;
+
+M: x86.32 %unnest-stacks ( -- )
+    4 [
+        push-vm-ptr
+        "unnest_stacks" f %alien-invoke
+    ] with-aligned-stack ;
+
 M: x86.32 %prepare-alien-indirect ( -- )
     push-vm-ptr "unbox_alien" f %alien-invoke
     temp-reg POP
@@ -280,6 +282,7 @@ M: x86.32 %callback-value ( ctype -- )
     ! Unbox EAX
     unbox-return ;
 
+
 M: x86.32 %cleanup ( params -- )
     #! a) If we just called an stdcall function in Windows, it
     #! cleaned up the stack frame for us. But we don't want that
@@ -311,6 +314,19 @@ M: x86.32 %callback-return ( n -- )
         [ drop 0 ]
     } cond RET ;
 
+M:: x86.32 %call-gc ( gc-root-count temp -- )
+    temp gc-root-base param@ LEA
+    12 [
+        ! Pass the VM ptr as the third parameter
+        0 PUSH rc-absolute-cell rt-vm rel-fixup
+        ! Pass number of roots as second parameter
+        gc-root-count PUSH 
+        ! Pass pointer to start of GC roots as first parameter
+        temp PUSH 
+        ! Call GC
+        "inline_gc" f %alien-invoke
+    ] with-aligned-stack ;
+
 M: x86.32 dummy-stack-params? f ;
 
 M: x86.32 dummy-int-params? f ;

basis/cpu/x86/64/64.factor

@@ -36,9 +36,10 @@ M:: x86.64 %dispatch ( src temp -- )
     [ align-code ]
     bi ;
 
-M: x86.64 param-reg-1 int-regs param-regs first ;
+: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
-M: x86.64 param-reg-2 int-regs param-regs second ;
+: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
-M: x86.64 param-reg-3 int-regs param-regs third ;
+: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
+: param-reg-4 ( -- reg ) int-regs param-regs fourth ; inline
 
 M: x86.64 pic-tail-reg RBX ;
 
@@ -74,26 +75,13 @@ M: x86.64 %prepare-unbox ( -- )
     param-reg-1 R14 [] MOV
     R14 cell SUB ;
 
-M: x86.64 %vm-invoke-1st-arg ( function -- )
+: %mov-vm-ptr ( reg -- )
-    param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
+    0 MOV rc-absolute-cell rt-vm rel-fixup ;
-    f %alien-invoke ;
-
-: %vm-invoke-2nd-arg ( function -- )
-    param-reg-2 0 MOV rc-absolute-cell rt-vm rel-fixup
-    f %alien-invoke ;
-
-M: x86.64 %vm-invoke-3rd-arg ( function -- )
-    param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup
-    f %alien-invoke ;
-
-: %vm-invoke-4th-arg ( function -- )
-    int-regs param-regs fourth 0 MOV rc-absolute-cell rt-vm rel-fixup
-    f %alien-invoke ;
-
 
 M:: x86.64 %unbox ( n rep func -- )
+    param-reg-2 %mov-vm-ptr
     ! Call the unboxer
-    func %vm-invoke-2nd-arg
+    func f %alien-invoke
     ! Store the return value on the C stack if this is an
     ! alien-invoke, otherwise leave it the return register if
     ! this is the end of alien-callback
@@ -109,10 +97,10 @@ M: x86.64 %unbox-long-long ( n func -- )
         { float-regs [ float-regs get pop swap MOVSD ] }
     } case ;
 
-
 M: x86.64 %unbox-small-struct ( c-type -- )
     ! Alien must be in param-reg-1.
-    "alien_offset" %vm-invoke-2nd-arg
+    param-reg-2 %mov-vm-ptr
+    "alien_offset" f %alien-invoke
     ! Move alien_offset() return value to R11 so that we don't
     ! clobber it.
     R11 RAX MOV
@@ -126,8 +114,9 @@ M:: x86.64 %unbox-large-struct ( n c-type -- )
     param-reg-2 n param@ LEA
     ! Load structure size into param-reg-3
     param-reg-3 c-type heap-size MOV
+    param-reg-4 %mov-vm-ptr
     ! Copy the struct to the C stack
-    "to_value_struct" %vm-invoke-4th-arg ;
+    "to_value_struct" f %alien-invoke ;
 
 : load-return-value ( rep -- )
     [ [ 0 ] dip reg-class-of param-reg ]
@@ -143,7 +132,8 @@ M:: x86.64 %box ( n rep func -- )
     ] [
         rep load-return-value
     ] if
-    rep int-rep? [ func %vm-invoke-2nd-arg ] [ func %vm-invoke-1st-arg ] if ;
+    rep int-rep? [ param-reg-2 ] [ param-reg-1 ] if %mov-vm-ptr
+    func f %alien-invoke ;
 
 M: x86.64 %box-long-long ( n func -- )
     [ int-rep ] dip %box ;
@@ -163,7 +153,8 @@ M: x86.64 %box-small-struct ( c-type -- )
         [ param-reg-3 swap heap-size MOV ] bi
         param-reg-1 0 box-struct-field@ MOV
         param-reg-2 1 box-struct-field@ MOV
-        "box_small_struct" %vm-invoke-4th-arg
+        param-reg-4 %mov-vm-ptr
+        "box_small_struct" f %alien-invoke
     ] with-return-regs ;
 
 : struct-return@ ( n -- operand )
@@ -174,8 +165,9 @@ M: x86.64 %box-large-struct ( n c-type -- )
     param-reg-2 swap heap-size MOV
     ! Compute destination address
     param-reg-1 swap struct-return@ LEA
+    param-reg-3 %mov-vm-ptr
     ! Copy the struct from the C stack
-    "box_value_struct" %vm-invoke-3rd-arg ;
+    "box_value_struct" f %alien-invoke ;
 
 M: x86.64 %prepare-box-struct ( -- )
     ! Compute target address for value struct return
@@ -190,9 +182,17 @@ M: x86.64 %alien-invoke
     rc-absolute-cell rel-dlsym
     R11 CALL ;
 
+M: x86.64 %nest-stacks ( -- )
+    param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
+    "nest_stacks" f %alien-invoke ;
+
+M: x86.64 %unnest-stacks ( -- )
+    param-reg-1 0 MOV rc-absolute-cell rt-vm rel-fixup
+    "unnest_stacks" f %alien-invoke ;
 
 M: x86.64 %prepare-alien-indirect ( -- )
-    "unbox_alien" %vm-invoke-1st-arg
+    param-reg-1 %mov-vm-ptr
+    "unbox_alien" f %alien-invoke
     RBP RAX MOV ;
 
 M: x86.64 %alien-indirect ( -- )
@@ -200,7 +200,8 @@ M: x86.64 %alien-indirect ( -- )
 
 M: x86.64 %alien-callback ( quot -- )
     param-reg-1 swap %load-reference
-    "c_to_factor" %vm-invoke-2nd-arg ;
+    param-reg-2 %mov-vm-ptr
+    "c_to_factor" f %alien-invoke ;
 
 M: x86.64 %callback-value ( ctype -- )
     ! Save top of data stack
@@ -208,8 +209,9 @@ M: x86.64 %callback-value ( ctype -- )
     ! Save top of data stack
     RSP 8 SUB
     param-reg-1 PUSH
+    param-reg-1 %mov-vm-ptr
     ! Restore data/call/retain stacks
-    "unnest_stacks" %vm-invoke-1st-arg
+    "unnest_stacks" f %alien-invoke
     ! Put former top of data stack in param-reg-1
     param-reg-1 POP
     RSP 8 ADD
@@ -233,6 +235,16 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
     func f %alien-invoke
     dst float-function-return ;
 
+M:: x86.64 %call-gc ( gc-root-count temp -- )
+    ! Pass pointer to start of GC roots as first parameter
+    param-reg-1 gc-root-base param@ LEA
+    ! Pass number of roots as second parameter
+    param-reg-2 gc-root-count MOV
+    ! Pass VM ptr as third parameter
+    param-reg-3 %mov-vm-ptr
+    ! Call GC
+    "inline_gc" f %alien-invoke ;
+
 ! The result of reading 4 bytes from memory is a fixnum on
 ! x86-64.
 enable-alien-4-intrinsics

basis/cpu/x86/x86.factor

@@ -52,11 +52,6 @@ M: x86 stack-frame-size ( stack-frame -- i )
 ! use in calls in and out of C
 HOOK: temp-reg cpu ( -- reg )
 
-! Fastcall calling convention
-HOOK: param-reg-1 cpu ( -- reg )
-HOOK: param-reg-2 cpu ( -- reg )
-HOOK: param-reg-3 cpu ( -- reg )
-
 HOOK: pic-tail-reg cpu ( -- reg )
 
 M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
@@ -99,16 +94,12 @@ M: x86 %return ( -- ) 0 RET ;
 : align-code ( n -- )
     0 <repetition> % ;
 
-:: (%slot) ( obj slot tag temp -- op )
-    temp slot obj [+] LEA
-    temp tag neg [+] ; inline
-
 :: (%slot-imm) ( obj slot tag -- op )
     obj slot cells tag - [+] ; inline
 
-M: x86 %slot ( dst obj slot tag temp -- ) (%slot) MOV ;
+M: x86 %slot ( dst obj slot -- ) [+] MOV ;
 M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
-M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ;
+M: x86 %set-slot ( src obj slot -- ) [+] swap MOV ;
 M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
 
 M: x86 %add     2over eq? [ nip ADD ] [ [+] LEA ] if ;
@@ -828,16 +819,6 @@ M: x86 %save-gc-root ( gc-root register -- ) [ gc-root@ ] dip MOV ;
 
 M: x86 %load-gc-root ( gc-root register -- ) swap gc-root@ MOV ;
 
-M:: x86 %call-gc ( gc-root-count -- )
-    ! Pass pointer to start of GC roots as first parameter
-    param-reg-1 gc-root-base param@ LEA
-    ! Pass number of roots as second parameter
-    param-reg-2 gc-root-count MOV
-    ! Pass vm as third argument
-    param-reg-3 0 MOV rc-absolute-cell rt-vm rel-fixup
-    ! Call GC
-    "inline_gc" f %alien-invoke ; 
-
 M: x86 %alien-global ( dst symbol library -- )
     [ 0 MOV ] 2dip rc-absolute-cell rel-dlsym ;    
 

basis/db/tuples/tuples-docs.factor

@@ -230,9 +230,9 @@ T{ book
 } book set
 """ }
 "Now we've created a book. Let's save it to the database."
-{ $code """USING: db db.sqlite fry io.files ;
+{ $code """USING: db db.sqlite fry io.files.temp ;
 : with-book-tutorial ( quot -- )
-     '[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ;
+     '[ "book-tutorial.db" temp-file <sqlite-db> _ with-db ] call ; inline
 
 [
     book recreate-table

basis/hints/hints-tests.factor

@@ -0,0 +1,12 @@
+USING: math hashtables accessors kernel words hints
+compiler.tree.debugger tools.test ;
+IN: hints.tests
+
+! Regression
+GENERIC: blahblah ( a b c -- )
+
+M: hashtable blahblah 2nip [ 1 + ] change-count drop ;
+
+HINTS: M\ hashtable blahblah { object fixnum object } { object word object } ;
+
+[ t ] [ M\ hashtable blahblah { count>> (>>count) } inlined? ] unit-test

basis/hints/hints.factor

@@ -37,8 +37,8 @@ M: object specializer-declaration class ;
         [ [ specializer-declaration ] map swap '[ _ declare @ ] ] 2bi
     ] with { } map>assoc ;
 
-: specialize-quot ( quot word specializer -- quot' )
+: specialize-quot ( quot specializer -- quot' )
-    [ drop nip def>> ] [ nip specializer-cases ] 3bi alist>quot ;
+    [ drop ] [ specializer-cases ] 2bi alist>quot ;
 
 ! compiler.tree.propagation.inlining sets this to f
 SYMBOL: specialize-method?
@@ -52,8 +52,8 @@ t specialize-method? set-global
 
 : specialize-method ( quot method -- quot' )
     [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
-    [ dup "method-generic" word-prop specializer ] bi
+    [ "method-generic" word-prop ] bi
-    [ specialize-quot ] [ drop ] if* ;
+    specializer [ specialize-quot ] when* ;
 
 : standard-method? ( method -- ? )
     dup method-body? [
@@ -64,7 +64,7 @@ t specialize-method? set-global
     [ def>> ] keep
     dup generic? [ drop ] [
         [ dup standard-method? [ specialize-method ] [ drop ] if ]
-        [ dup specializer [ specialize-quot ] [ drop ] if* ]
+        [ specializer [ specialize-quot ] when* ]
         bi
     ] if ;
 

basis/images/png/png.factor

@@ -14,6 +14,18 @@ TUPLE: loading-png
     width height bit-depth color-type compression-method
     filter-method interlace-method uncompressed ;
 
+CONSTANT: filter-none 0
+CONSTANT: filter-sub 1
+CONSTANT: filter-up 2
+CONSTANT: filter-average 3
+CONSTANT: filter-paeth 4
+
+CONSTANT: greyscale 0
+CONSTANT: truecolor 2
+CONSTANT: indexed-color 3
+CONSTANT: greyscale-alpha 4
+CONSTANT: truecolor-alpha 6
+
 : <loading-png> ( -- image )
     loading-png new
     V{ } clone >>chunks ;
@@ -64,23 +76,33 @@ ERROR: bad-checksum ;
     chunks>> [ type>> "IDAT" = ] filter
     [ data>> ] map concat ;
 
-
-: zlib-data ( loading-png -- bytes ) 
-    chunks>> [ type>> "IDAT" = ] find nip data>> ;
-
 ERROR: unknown-color-type n ;
 ERROR: unimplemented-color-type image ;
+ERROR: unknown-filter-method image ;
 
 : inflate-data ( loading-png -- bytes )
-    zlib-data zlib-inflate ; 
+    find-compressed-bytes zlib-inflate ; 
+
+: png-group-width ( loading-png -- n )
+    dup color-type>> {
+        { 2 [ [ bit-depth>> 8 / 3 * ] [ width>> ] bi * 1 + ] }
+        { 6 [ [ bit-depth>> 8 / 4 * ] [ width>> ] bi * 1 + ] }
+        [ unknown-color-type ]
+    } case ;
+
+: filter-png ( groups loading-png -- byte-array )
+    filter-method>> {
+        { filter-none [ reverse-png-filter ] }
+        [ unknown-filter-method ]
+    } case ;
+
+: png-image-bytes ( loading-png -- byte-array )
+    [ [ inflate-data ] [ png-group-width ] bi group ]
+    [ filter-png ] bi ;
 
 : decode-greyscale ( loading-png -- loading-png )
     unimplemented-color-type ;
 
-: png-image-bytes ( loading-png -- byte-array )
-    [ inflate-data ] [ width>> 3 * 1 + ] bi group
-    reverse-png-filter ;
-
 : decode-truecolor ( loading-png -- loading-png )
     [ <image> ] dip {
         [ png-image-bytes >>bitmap ]
@@ -101,13 +123,34 @@ ERROR: unimplemented-color-type image ;
         [ drop RGBA >>component-order ubyte-components >>component-type ]
     } cleave ;
 
+ERROR: invalid-color-type/bit-depth loading-png ;
+
+: validate-bit-depth ( loading-png seq -- loading-png )
+    [ dup bit-depth>> ] dip member?
+    [ invalid-color-type/bit-depth ] unless ;
+
+: validate-greyscale ( loading-png -- loading-png )
+    { 1 2 4 8 16 } validate-bit-depth ;
+
+: validate-truecolor ( loading-png -- loading-png )
+    { 8 16 } validate-bit-depth ;
+
+: validate-indexed-color ( loading-png -- loading-png )
+    { 1 2 4 8 } validate-bit-depth ;
+
+: validate-greyscale-alpha ( loading-png -- loading-png )
+    { 8 16 } validate-bit-depth ;
+
+: validate-truecolor-alpha ( loading-png -- loading-png )
+    { 8 16 } validate-bit-depth ;
+
 : decode-png ( loading-png -- loading-png ) 
     dup color-type>> {
-        { 0 [ decode-greyscale ] }
+        { greyscale [ validate-greyscale decode-greyscale ] }
-        { 2 [ decode-truecolor ] }
+        { truecolor [ validate-truecolor decode-truecolor ] }
-        { 3 [ decode-indexed-color ] }
+        { indexed-color [ validate-indexed-color decode-indexed-color ] }
-        { 4 [ decode-greyscale-alpha ] }
+        { greyscale-alpha [ validate-greyscale-alpha decode-greyscale-alpha ] }
-        { 6 [ decode-truecolor-alpha ] }
+        { truecolor-alpha [ validate-truecolor-alpha decode-truecolor-alpha ] }
         [ unknown-color-type ]
     } case ;
 

basis/math/vectors/simd/simd-tests.factor

@@ -81,9 +81,13 @@ CONSTANT: simd-classes
 : check-optimizer ( seq inputs quot eq-quot -- )
     '[
         @
-        [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
+        {
-        [ [ call ] dip call ]
+            [ "print-mr" get [ nip test-mr mr. ] [ 2drop ] if ]
-        [ [ call ] dip compile-call ] 2tri @ not
+            [ "print-checks" get [ [ . ] bi@ ] [ 2drop ] if ]
+            [ [ call ] dip call ]
+            [ [ call ] dip compile-call ]
+        } 2cleave
+        @ not
     ] filter ; inline
 
 "== Checking -new constructors" print

basis/math/vectors/vectors-docs.factor

@@ -209,11 +209,13 @@ HELP: vbitxor
 
 HELP: vlshift
 { $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } }
-{ $description "Shifts each element of " { $snippet "u" } " to the left by " { $snippet "n" } " bits." } ;
+{ $description "Shifts each element of " { $snippet "u" } " to the left by " { $snippet "n" } " bits." }
+{ $notes "Undefined behavior will result if " { $snippet "n" } " is negative." } ;
 
 HELP: vrshift
 { $values { "u" "a sequence of integers" } { "n" "a non-negative integer" } { "w" "a sequence of integers" } }
-{ $description "Shifts each element of " { $snippet "u" } " to the right by " { $snippet "n" } " bits." } ;
+{ $description "Shifts each element of " { $snippet "u" } " to the right by " { $snippet "n" } " bits." }
+{ $notes "Undefined behavior will result if " { $snippet "n" } " is negative." } ;
 
 HELP: norm-sq
 { $values { "v" "a sequence of numbers" } { "x" "a non-negative real number" } }

basis/math/vectors/vectors-tests.factor

@@ -1,5 +1,7 @@
 IN: math.vectors.tests
-USING: math.vectors tools.test kernel ;
+USING: math.vectors tools.test kernel specialized-arrays compiler
+kernel.private ;
+SPECIALIZED-ARRAY: int
 
 [ { 1 2 3 } ] [ 1/2 { 2 4 6 } n*v ] unit-test
 [ { 1 2 3 } ] [ { 2 4 6 } 1/2 v*n ] unit-test
@@ -21,4 +23,4 @@ USING: math.vectors tools.test kernel ;
 
 [ { 0 3 2 5 4 } ] [ { 1 2 3 4 5 } { 1 1 1 1 1 } v+- ] unit-test
 
-[ 1 ] [ { C{ 0 1 } } dup v. ] unit-test
+[ 1 ] [ { C{ 0 1 } } dup v. ] unit-test

basis/ui/backend/windows/windows.factor

@@ -537,14 +537,13 @@ SYMBOL: nc-buttons
     COLOR_BTNFACE GetSysColor RGB>color ;
 
 : ?make-glass ( world hwnd -- )
-    over {
+    over window-controls>> textured-background swap memq? [
-        [ composition-enabled? ]
+        composition-enabled? [
-        [ window-controls>> textured-background swap memq? ]
+            full-window-margins DwmExtendFrameIntoClientArea drop
-    } 1&&
+            T{ rgba f 0.0 0.0 0.0 0.0 }
-    [
+        ] [ drop system-background-color ] if >>background-color
-        full-window-margins DwmExtendFrameIntoClientArea drop
+        drop
-        T{ rgba f 0.0 0.0 0.0 0.0 }
+    ] [ 2drop ] if ;
-    ] [ system-background-color ] if >>background-color ;
 
 : handle-wm-dwmcompositionchanged ( hWnd uMsg wParam lParam -- )
     3drop [ window ] keep ?make-glass ;

basis/unix/statfs/freebsd/freebsd.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax unix.types unix.stat classes.struct ;
+USING: alien.syntax alien.c-types unix.types unix.stat classes.struct ;
 IN: unix.statfs.freebsd
 
 CONSTANT: MFSNAMELEN      16            ! length of type name including null */

core/words/words-tests.factor

@@ -125,3 +125,5 @@ DEFER: x
         keys [ "forgotten" word-prop ] filter
     ] map harvest
 ] unit-test
+
+[ "hi" word-xt ] must-fail

extra/benchmark/e-decimals/e-decimals.factor

@@ -4,9 +4,12 @@ USING: decimals kernel locals math math.combinatorics math.ranges
 sequences ;
 IN: benchmark.e-decimals
 
+: D-factorial ( n -- D! )
+    D: 1 [ 0 <decimal> D: 1 D+ D* ] reduce ; inline
+
 :: calculate-e-decimals ( n -- e )
-    n [1,b] [ factorial 0 <decimal> D: 1 swap n D/ ] map
+    n [1,b] D: 1
-    D: 1 [ D+ ] reduce ;
+    [ D-factorial D: 1 swap n D/ D+ ] reduce ;
 
 : calculate-e-decimals-benchmark ( -- )
     5 [ 800 calculate-e-decimals drop ] times ;

extra/ogg/ogg.factor

@@ -0,0 +1,141 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: 
+    alien
+    alien.c-types 
+    alien.libraries
+    alien.syntax 
+    classes.struct
+    combinators 
+    kernel 
+    system
+;
+IN: ogg
+
+<<
+"ogg" {
+    { [ os winnt? ]  [ "ogg.dll" ] }
+    { [ os macosx? ] [ "libogg.0.dylib" ] }
+    { [ os unix? ]   [ "libogg.so" ] }
+} cond "cdecl" add-library
+>>
+
+LIBRARY: ogg
+
+STRUCT: oggpack-buffer
+    { endbyte long }
+    { endbit int   }
+    { buffer uchar* }
+    { ptr uchar* }
+    { storage long } ;
+
+STRUCT: ogg-page
+    {  header uchar* }
+    {  header_len long }
+    {  body uchar* }
+    {  body_len long } ;
+
+STRUCT: ogg-stream-state
+    {  body_data uchar* }
+    {  body_storage long }
+    {  body_fill long }
+    {  body_returned long }
+    {  lacing_vals int* } 
+    {  granule_vals longlong* }
+    {  lacing_storage long }
+    {  lacing_fill long }
+    {  lacing_packet long }
+    {  lacing_returned long }
+    {  header { uchar 282 } }
+    {  header_fill int }
+    {  e_o_s int }
+    {  b_o_s int }
+    {  serialno long  }
+    {  pageno long }
+    {  packetno longlong }
+    {  granulepos longlong } ;
+
+STRUCT: ogg-packet
+    {  packet uchar* }
+    {  bytes long }
+    {  b_o_s long }
+    {  e_o_s long }
+    {  granulepos longlong }
+    {  packetno longlong } ;
+
+STRUCT: ogg-sync-state
+    { data uchar* }
+    { storage int }
+    { fill int }  
+    { returned int }
+    { unsynced int }
+    { headerbytes int }
+    { bodybytes int } ;
+
+FUNCTION: void oggpack_writeinit ( oggpack-buffer* b ) ;
+FUNCTION: void  oggpack_writetrunc ( oggpack-buffer* b, long bits ) ;
+FUNCTION: void  oggpack_writealign ( oggpack-buffer* b) ;
+FUNCTION: void  oggpack_writecopy ( oggpack-buffer* b, void* source, long bits ) ;
+FUNCTION: void  oggpack_reset ( oggpack-buffer* b ) ;
+FUNCTION: void  oggpack_writeclear ( oggpack-buffer* b ) ;
+FUNCTION: void  oggpack_readinit ( oggpack-buffer* b, uchar* buf, int bytes ) ;
+FUNCTION: void  oggpack_write ( oggpack-buffer* b, ulong value, int bits ) ;
+FUNCTION: long  oggpack_look ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long  oggpack_look1 ( oggpack-buffer* b ) ;
+FUNCTION: void  oggpack_adv ( oggpack-buffer* b, int bits ) ;
+FUNCTION: void  oggpack_adv1 ( oggpack-buffer* b ) ;
+FUNCTION: long  oggpack_read ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long  oggpack_read1 ( oggpack-buffer* b ) ;
+FUNCTION: long  oggpack_bytes ( oggpack-buffer* b ) ;
+FUNCTION: long  oggpack_bits ( oggpack-buffer* b ) ;
+FUNCTION: uchar* oggpack_get_buffer ( oggpack-buffer* b ) ;
+FUNCTION: void  oggpackB_writeinit ( oggpack-buffer* b ) ;
+FUNCTION: void  oggpackB_writetrunc ( oggpack-buffer* b, long bits ) ;
+FUNCTION: void  oggpackB_writealign ( oggpack-buffer* b ) ;
+FUNCTION: void  oggpackB_writecopy ( oggpack-buffer* b, void* source, long bits ) ;
+FUNCTION: void  oggpackB_reset ( oggpack-buffer* b ) ;
+FUNCTION: void  oggpackB_writeclear ( oggpack-buffer* b ) ;
+FUNCTION: void  oggpackB_readinit ( oggpack-buffer* b, uchar* buf, int bytes ) ;
+FUNCTION: void  oggpackB_write ( oggpack-buffer* b, ulong value, int bits ) ;
+FUNCTION: long  oggpackB_look ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long  oggpackB_look1 ( oggpack-buffer* b ) ;
+FUNCTION: void  oggpackB_adv ( oggpack-buffer* b, int bits ) ;
+FUNCTION: void  oggpackB_adv1 ( oggpack-buffer* b ) ;
+FUNCTION: long  oggpackB_read ( oggpack-buffer* b, int bits ) ;
+FUNCTION: long  oggpackB_read1 ( oggpack-buffer* b ) ;
+FUNCTION: long  oggpackB_bytes ( oggpack-buffer* b ) ;
+FUNCTION: long  oggpackB_bits ( oggpack-buffer* b ) ;
+FUNCTION: uchar* oggpackB_get_buffer ( oggpack-buffer* b ) ;
+FUNCTION: int      ogg_stream_packetin ( ogg-stream-state* os, ogg-packet* op ) ;
+FUNCTION: int      ogg_stream_pageout ( ogg-stream-state* os, ogg-page* og ) ;
+FUNCTION: int      ogg_stream_flush ( ogg-stream-state* os, ogg-page* og ) ;
+FUNCTION: int      ogg_sync_init ( ogg-sync-state* oy ) ;
+FUNCTION: int      ogg_sync_clear ( ogg-sync-state* oy ) ;
+FUNCTION: int      ogg_sync_reset ( ogg-sync-state* oy ) ;
+FUNCTION: int   ogg_sync_destroy ( ogg-sync-state* oy ) ;
+
+FUNCTION: void* ogg_sync_buffer ( ogg-sync-state* oy, long size ) ;
+FUNCTION: int      ogg_sync_wrote ( ogg-sync-state* oy, long bytes ) ;
+FUNCTION: long     ogg_sync_pageseek ( ogg-sync-state* oy, ogg-page* og ) ;
+FUNCTION: int      ogg_sync_pageout ( ogg-sync-state* oy, ogg-page* og ) ;
+FUNCTION: int      ogg_stream_pagein ( ogg-stream-state* os, ogg-page* og ) ;
+FUNCTION: int      ogg_stream_packetout ( ogg-stream-state* os, ogg-packet* op ) ;
+FUNCTION: int      ogg_stream_packetpeek ( ogg-stream-state* os, ogg-packet* op ) ;
+FUNCTION: int      ogg_stream_init (ogg-stream-state* os, int serialno ) ;
+FUNCTION: int      ogg_stream_clear ( ogg-stream-state* os ) ;
+FUNCTION: int      ogg_stream_reset ( ogg-stream-state* os ) ;
+FUNCTION: int      ogg_stream_reset_serialno ( ogg-stream-state* os, int serialno ) ;
+FUNCTION: int      ogg_stream_destroy ( ogg-stream-state* os ) ;
+FUNCTION: int      ogg_stream_eos ( ogg-stream-state* os ) ;
+FUNCTION: void     ogg_page_checksum_set ( ogg-page* og ) ;
+FUNCTION: int      ogg_page_version ( ogg-page* og ) ;
+FUNCTION: int      ogg_page_continued ( ogg-page* og ) ;
+FUNCTION: int      ogg_page_bos ( ogg-page* og ) ;
+FUNCTION: int      ogg_page_eos ( ogg-page* og ) ;
+FUNCTION: longlong  ogg_page_granulepos ( ogg-page* og ) ;
+FUNCTION: int      ogg_page_serialno ( ogg-page* og ) ;
+FUNCTION: long     ogg_page_pageno ( ogg-page* og ) ;
+FUNCTION: int      ogg_page_packets ( ogg-page* og ) ;
+FUNCTION: void     ogg_packet_clear ( ogg-packet* op ) ;
+

extra/ogg/theora/theora.factor

@@ -0,0 +1,181 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: 
+    alien
+    alien.c-types 
+    alien.libraries
+    alien.syntax 
+    classes.struct
+    combinators 
+    kernel 
+    ogg
+    system
+;
+IN: ogg.theora
+
+<<
+"theoradec" {
+    { [ os winnt? ]  [ "theoradec.dll" ] }
+    { [ os macosx? ] [ "libtheoradec.0.dylib" ] }
+    { [ os unix? ]   [ "libtheoradec.so" ] }
+} cond "cdecl" add-library
+
+"theoraenc" {
+    { [ os winnt? ]  [ "theoraenc.dll" ] }
+    { [ os macosx? ] [ "libtheoraenc.0.dylib" ] }
+    { [ os unix? ]   [ "libtheoraenc.so" ] }
+} cond "cdecl" add-library
+>>
+
+CONSTANT: TH-EFAULT      -1
+CONSTANT: TH-EINVAL     -10
+CONSTANT: TH-EBADHEADER -20
+CONSTANT: TH-ENOTFORMAT -21
+CONSTANT: TH-EVERSION   -22
+CONSTANT: TH-EIMPL      -23
+CONSTANT: TH-EBADPACKET -24
+CONSTANT: TH-DUPFRAME     1
+
+TYPEDEF: int th-colorspace 
+CONSTANT: TH-CS-UNSPECIFIED   0
+CONSTANT: TH-CS-ITU-REC-470M  1
+CONSTANT: TH-CS-ITU-REC-470BG 2
+CONSTANT: TH-CS-NSPACES       3
+
+TYPEDEF: int th-pixelformat
+CONSTANT: TH-PF-RSVD     0
+CONSTANT: TH-PF-422      1
+CONSTANT: TH-PF-444      2
+CONSTANT: TH-PF-NFORMATS 3
+
+STRUCT: th-img-plane
+    { width int }
+    { height int }
+    { stride int }
+    { data uchar* }
+;
+
+TYPEDEF: th-img-plane[3] th-ycbcr-buffer
+
+STRUCT: th-info
+    { version-major uchar }
+    { version-minor uchar }
+    { version-subminor uchar }
+    { frame-width uint }
+    { frame-height uint }
+    { pic-width uint }
+    { pic-height uint }
+    { pic-x uint }
+    { pic-y uint }
+    { fps-numerator uint }
+    { fps-denominator uint }
+    { aspect-numerator uint }
+    { aspect-denominator uint }
+    { colorspace th-colorspace }
+    { pixel-fmt th-pixelformat }
+    { target-bitrate int }
+    { quality int }
+    { keyframe-granule-shift int }
+;
+
+STRUCT: th-comment
+    { user-comments char** }
+    { comment-lengths int* }
+    { comments int }
+    { vendor char* }
+;
+
+TYPEDEF: uchar[64] th-quant-base
+
+STRUCT: th-quant-ranges
+    { nranges int }
+    { sizes int* }
+    { base-matrices th-quant-base* }
+;
+
+STRUCT: th-quant-info
+    { dc-scale { short 64 } }
+    { ac-scale { short 64 } }
+    { loop-filter-limits { uchar 64 } }
+    { qi-ranges { th-quant-ranges 2 3 } }
+;
+
+CONSTANT: TH-NHUFFMANE-TABLES 80
+CONSTANT: TH-NDCT-TOKENS 32
+
+STRUCT: th-huff-code
+    { pattern int }
+    { nbits int }
+;
+
+LIBRARY: theoradec
+FUNCTION: char* th_version_string ( ) ;
+FUNCTION: uint th_version_number ( ) ;
+FUNCTION: longlong th_granule_frame ( void* encdec, longlong granpos) ;
+FUNCTION: int th_packet_isheader ( ogg-packet* op ) ;
+FUNCTION: int th_packet_iskeyframe ( ogg-packet* op ) ;
+FUNCTION: void th_info_init ( th-info* info ) ;
+FUNCTION: void th_info_clear ( th-info* info ) ;
+FUNCTION: void th_comment_init ( th-comment* tc ) ;
+FUNCTION: void th_comment_add ( th-comment* tc, char* comment ) ;
+FUNCTION: void th_comment_add_tag ( th-comment* tc, char* tag, char* value ) ;
+FUNCTION: char* th_comment_query ( th-comment* tc, char* tag, int count ) ;
+FUNCTION: int   th_comment_query_count ( th-comment* tc, char* tag ) ;
+FUNCTION: void  th_comment_clear ( th-comment* tc ) ;
+
+CONSTANT: TH-ENCCTL-SET-HUFFMAN-CODES 0
+CONSTANT: TH-ENCCTL-SET-QUANT-PARAMS 2
+CONSTANT: TH-ENCCTL-SET-KEYFRAME-FREQUENCY-FORCE 4
+CONSTANT: TH-ENCCTL-SET-VP3-COMPATIBLE 10
+CONSTANT: TH-ENCCTL-GET-SPLEVEL-MAX 12
+CONSTANT: TH-ENCCTL-SET-SPLEVEL 14
+CONSTANT: TH-ENCCTL-SET-DUP-COUNT 18
+CONSTANT: TH-ENCCTL-SET-RATE-FLAGS 20
+CONSTANT: TH-ENCCTL-SET-RATE-BUFFER 22
+CONSTANT: TH-ENCCTL-2PASS-OUT 24
+CONSTANT: TH-ENCCTL-2PASS-IN 26
+CONSTANT: TH-ENCCTL-SET-QUALITY 28
+CONSTANT: TH-ENCCTL-SET-BITRATE 30
+
+CONSTANT: TH-RATECTL-DROP-FRAMES 1
+CONSTANT: TH-RATECTL-CAP-OVERFLOW 2
+CONSTANT: TH-RATECTL-CAP-UNDERFOW 4
+
+TYPEDEF: void* th-enc-ctx
+
+LIBRARY: theoraenc
+FUNCTION: th-enc-ctx* th_encode_alloc ( th-info* info ) ;
+FUNCTION: int th_encode_ctl ( th-enc-ctx* enc, int req, void* buf, int buf_sz ) ;
+FUNCTION: int th_encode_flushheader ( th-enc-ctx* enc, th-comment* comments, ogg-packet* op ) ;
+FUNCTION: int th_encode_ycbcr_in ( th-enc-ctx* enc, th-ycbcr-buffer ycbcr ) ;
+FUNCTION: int th_encode_packetout ( th-enc-ctx* enc, int last, ogg-packet* op ) ;
+FUNCTION: void th_encode_free ( th-enc-ctx* enc ) ;
+
+CONSTANT: TH-DECCTL-GET-PPLEVEL-MAX 1
+CONSTANT: TH-DECCTL-SET-PPLEVEL 3
+CONSTANT: TH-DECCTL-SET-GRANPOS 5
+CONSTANT: TH-DECCTL-SET-STRIPE-CB 7
+CONSTANT: TH-DECCTL-SET-TELEMETRY-MBMODE 9
+CONSTANT: TH-DECCTL-SET-TELEMETRY-MV 11
+CONSTANT: TH-DECCTL-SET-TELEMETRY-QI 13
+CONSTANT: TH-DECCTL-SET-TELEMETRY-BITS 15
+
+TYPEDEF: void* th-stripe-decoded-func
+
+STRUCT: th-stripe-callback
+    { ctx void* }
+    { stripe-decoded th-stripe-decoded-func }
+;
+
+TYPEDEF: void* th-dec-ctx
+TYPEDEF: void* th-setup-info
+
+LIBRARY: theoradec
+FUNCTION: int th_decode_headerin ( th-info* info, th-comment* tc, th-setup-info** setup, ogg-packet* op ) ;
+FUNCTION: th-dec-ctx* th_decode_alloc ( th-info* info, th-setup-info* setup ) ;
+FUNCTION: void th_setup_free ( th-setup-info* setup ) ;
+FUNCTION: int th_decode_ctl ( th-dec-ctx* dec, int req, void* buf, int buf_sz ) ;
+FUNCTION: int th_decode_packetin ( th-dec-ctx* dec, ogg-packet* op, longlong granpos ) ;
+FUNCTION: int th_decode_ycbcr_out ( th-dec-ctx* dec, th-ycbcr-buffer ycbcr ) ;
+FUNCTION: void th_decode_free ( th-dec-ctx* dec ) ;

extra/ogg/vorbis/vorbis.factor

@@ -0,0 +1,151 @@
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+USING: 
+    alien
+    alien.c-types 
+    alien.libraries
+    alien.syntax 
+    classes.struct
+    combinators 
+    kernel 
+    ogg
+    system
+;
+IN: ogg.vorbis
+
+<<
+"vorbis" {
+    { [ os winnt? ]  [ "vorbis.dll" ] }
+    { [ os macosx? ] [ "libvorbis.0.dylib" ] }
+    { [ os unix? ]   [ "libvorbis.so" ] }
+} cond "cdecl" add-library 
+>>
+
+LIBRARY: vorbis
+
+STRUCT: vorbis-info 
+    { version int  }
+    { channels int }
+    { rate long }
+    { bitrate_upper long }
+    { bitrate_nominal long }
+    { bitrate_lower long }
+    { bitrate_window long }
+    { codec_setup void* } 
+    ;
+
+STRUCT: vorbis-dsp-state
+    { analysisp int }
+    { vi vorbis-info* }
+    { pcm float** }
+    { pcmret float** }
+    { pcm_storage int }
+    { pcm_current int }
+    { pcm_returned int }
+    { preextrapolate int }
+    { eofflag int }
+    { lW long }
+    { W long }
+    { nW long }
+    { centerW long }
+    { granulepos longlong }
+    { sequence longlong }
+    { glue_bits longlong }
+    { time_bits longlong }
+    { floor_bits longlong }
+    { res_bits longlong }
+    { backend_state void* }
+    ;
+
+STRUCT: alloc-chain
+    { ptr void* }
+    { next void* }
+    ;
+
+STRUCT: vorbis-block
+    { pcm float** }
+    { opb oggpack-buffer }
+    { lW long }
+    { W long }
+    { nW long }
+    { pcmend int }
+    { mode int }
+    { eofflag int }
+    { granulepos longlong }
+    { sequence longlong }
+    { vd vorbis-dsp-state* }
+    { localstore void* }
+    { localtop long }
+    { localalloc long }
+    { totaluse long }
+    { reap alloc-chain* }
+    { glue_bits long }
+    { time_bits long }
+    { floor_bits long }
+    { res_bits long }
+    { internal void* }
+    ;
+
+STRUCT: vorbis-comment
+    { usercomments char** }
+    { comment_lengths int* }
+    { comments int }
+    { vendor char* }
+    ;
+
+FUNCTION: void     vorbis_info_init ( vorbis-info* vi ) ;
+FUNCTION: void     vorbis_info_clear ( vorbis-info* vi ) ;
+FUNCTION: int      vorbis_info_blocksize ( vorbis-info* vi, int zo ) ;
+FUNCTION: void     vorbis_comment_init ( vorbis-comment* vc ) ;
+FUNCTION: void     vorbis_comment_add ( vorbis-comment* vc, char* comment ) ;
+FUNCTION: void     vorbis_comment_add_tag ( vorbis-comment* vc, char* tag, char* contents ) ;
+FUNCTION: char*    vorbis_comment_query ( vorbis-comment* vc, char* tag, int count ) ;
+FUNCTION: int      vorbis_comment_query_count ( vorbis-comment* vc, char* tag ) ;
+FUNCTION: void     vorbis_comment_clear ( vorbis-comment* vc ) ;
+FUNCTION: int      vorbis_block_init ( vorbis-dsp-state* v, vorbis-block* vb ) ;
+FUNCTION: int      vorbis_block_clear ( vorbis-block* vb ) ;
+FUNCTION: void     vorbis_dsp_clear ( vorbis-dsp-state* v ) ;
+FUNCTION: double   vorbis_granule_time ( vorbis-dsp-state* v, longlong granulepos ) ;
+FUNCTION: int      vorbis_analysis_init ( vorbis-dsp-state* v, vorbis-info* vi ) ;
+FUNCTION: int      vorbis_commentheader_out ( vorbis-comment* vc, ogg-packet* op ) ;
+FUNCTION: int      vorbis_analysis_headerout ( vorbis-dsp-state* v,
+                                          vorbis-comment* vc,
+                                          ogg-packet* op,
+                                          ogg-packet* op_comm,
+                                          ogg-packet* op_code ) ;
+FUNCTION: float**  vorbis_analysis_buffer ( vorbis-dsp-state* v, int vals ) ;
+FUNCTION: int      vorbis_analysis_wrote ( vorbis-dsp-state* v, int vals ) ;
+FUNCTION: int      vorbis_analysis_blockout ( vorbis-dsp-state* v, vorbis-block* vb ) ;
+FUNCTION: int      vorbis_analysis ( vorbis-block* vb, ogg-packet* op ) ;
+FUNCTION: int      vorbis_bitrate_addblock ( vorbis-block* vb ) ;
+FUNCTION: int      vorbis_bitrate_flushpacket ( vorbis-dsp-state* vd,
+                                           ogg-packet* op ) ;
+FUNCTION: int      vorbis_synthesis_headerin ( vorbis-info* vi, vorbis-comment* vc,
+                                          ogg-packet* op ) ;
+FUNCTION: int      vorbis_synthesis_init ( vorbis-dsp-state* v, vorbis-info* vi ) ;
+FUNCTION: int      vorbis_synthesis_restart ( vorbis-dsp-state* v ) ;
+FUNCTION: int      vorbis_synthesis ( vorbis-block* vb, ogg-packet* op ) ;
+FUNCTION: int      vorbis_synthesis_trackonly ( vorbis-block* vb, ogg-packet* op ) ;
+FUNCTION: int      vorbis_synthesis_blockin ( vorbis-dsp-state* v, vorbis-block* vb ) ;
+FUNCTION: int      vorbis_synthesis_pcmout ( vorbis-dsp-state* v, float*** pcm ) ;
+FUNCTION: int      vorbis_synthesis_lapout ( vorbis-dsp-state* v, float*** pcm ) ;
+FUNCTION: int      vorbis_synthesis_read ( vorbis-dsp-state* v, int samples ) ;
+FUNCTION: long     vorbis_packet_blocksize ( vorbis-info* vi, ogg-packet* op ) ;
+FUNCTION: int      vorbis_synthesis_halfrate ( vorbis-info* v, int flag ) ;
+FUNCTION: int      vorbis_synthesis_halfrate_p ( vorbis-info* v ) ;
+
+CONSTANT: OV_FALSE -1
+CONSTANT: OV_EOF -2
+CONSTANT: OV_HOLE -3
+CONSTANT: OV_EREAD -128
+CONSTANT: OV_EFAULT -129
+CONSTANT: OV_EIMPL -130
+CONSTANT: OV_EINVAL -131
+CONSTANT: OV_ENOTVORBIS -132
+CONSTANT: OV_EBADHEADER -133
+CONSTANT: OV_EVERSION -134
+CONSTANT: OV_ENOTAUDIO -135
+CONSTANT: OV_EBADPACKET -136
+CONSTANT: OV_EBADLINK -137
+CONSTANT: OV_ENOSEEK -138

extra/webapps/mason/mason.factor

@@ -135,18 +135,18 @@ CONSTANT: cpus
 : requirements ( builder -- xml )
     [
         os>> {
-            { "winnt" "Windows XP (also tested on Vista)" }
+            { "winnt" "Windows XP, Windows Vista or Windows 7" }
             { "macosx" "Mac OS X 10.5 Leopard" }
             { "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
-            { "freebsd" "FreeBSD 7.0" }
+            { "freebsd" "FreeBSD 7.1" }
-            { "netbsd" "NetBSD 4.0" }
+            { "netbsd" "NetBSD 5.0" }
             { "openbsd" "OpenBSD 4.4" }
         } at
     ] [
         dup cpu>> "x86.32" = [
             os>> {
-                { [ dup { "winnt" "linux" "freebsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
+                { [ dup { "winnt" "linux" "freebsd"  "netbsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
-                { [ dup { "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
+                { [ dup { "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
                 { [ t ] [ drop f ] }
             } cond
         ] [ drop f ] if

unmaintained/ogg/ogg.factor

@@ -1,132 +0,0 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel system combinators alien alien.syntax ;
-IN: ogg
-
-<<
-"ogg" {
-    { [ os winnt? ]  [ "ogg.dll" ] }
-    { [ os macosx? ] [ "libogg.0.dylib" ] }
-    { [ os unix? ]   [ "libogg.so" ] }
-} cond "cdecl" add-library
->>
-
-LIBRARY: ogg
-
-C-STRUCT: oggpack_buffer
-    { "long" "endbyte" }
-    { "int" "endbit" }
-    { "uchar*" "buffer" }
-    { "uchar*" "ptr" }
-    { "long" "storage" } ;
-
-C-STRUCT: ogg_page
-    { "uchar*" "header" }
-    { "long" "header_len" }
-    { "uchar*" "body" }
-    { "long" "body_len" } ;
-
-C-STRUCT: ogg_stream_state
-    { "uchar*" "body_data" }
-    { "long" "body_storage" }
-    { "long" "body_fill" }
-    { "long" "body_returned" }
-    { "int*" "lacing_vals" } 
-    { "longlong*" "granule_vals" }
-    { "long" "lacing_storage" }
-    { "long" "lacing_fill" }
-    { "long" "lacing_packet" }
-    { "long" "lacing_returned" }
-    { { "uchar" 282 } "header" }
-    { "int" "header_fill" }
-    { "int" "e_o_s" }
-    { "int" "b_o_s" }
-    { "long" "serialno" }
-    { "long" "pageno" }
-    { "longlong" "packetno" }
-    { "longlong" "granulepos" } ;
-
-C-STRUCT: ogg_packet
-    { "uchar*" "packet" }
-    { "long" "bytes" }
-    { "long" "b_o_s" }
-    { "long" "e_o_s" }
-    { "longlong" "granulepos" }
-    { "longlong" "packetno" } ;
-
-C-STRUCT: ogg_sync_state
-    { "uchar*" "data" }
-    { "int" "storage" }
-    { "int" "fill" }  
-    { "int" "returned" }
-    { "int" "unsynced" }
-    { "int" "headerbytes" }
-    { "int" "bodybytes" } ;
-
-FUNCTION: void oggpack_writeinit ( oggpack_buffer* b ) ;
-FUNCTION: void  oggpack_writetrunc ( oggpack_buffer* b, long bits ) ;
-FUNCTION: void  oggpack_writealign ( oggpack_buffer* b) ;
-FUNCTION: void  oggpack_writecopy ( oggpack_buffer* b, void* source, long bits ) ;
-FUNCTION: void  oggpack_reset ( oggpack_buffer* b ) ;
-FUNCTION: void  oggpack_writeclear ( oggpack_buffer* b ) ;
-FUNCTION: void  oggpack_readinit ( oggpack_buffer* b, uchar* buf, int bytes ) ;
-FUNCTION: void  oggpack_write ( oggpack_buffer* b, ulong value, int bits ) ;
-FUNCTION: long  oggpack_look ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long  oggpack_look1 ( oggpack_buffer* b ) ;
-FUNCTION: void  oggpack_adv ( oggpack_buffer* b, int bits ) ;
-FUNCTION: void  oggpack_adv1 ( oggpack_buffer* b ) ;
-FUNCTION: long  oggpack_read ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long  oggpack_read1 ( oggpack_buffer* b ) ;
-FUNCTION: long  oggpack_bytes ( oggpack_buffer* b ) ;
-FUNCTION: long  oggpack_bits ( oggpack_buffer* b ) ;
-FUNCTION: uchar* oggpack_get_buffer ( oggpack_buffer* b ) ;
-FUNCTION: void  oggpackB_writeinit ( oggpack_buffer* b ) ;
-FUNCTION: void  oggpackB_writetrunc ( oggpack_buffer* b, long bits ) ;
-FUNCTION: void  oggpackB_writealign ( oggpack_buffer* b ) ;
-FUNCTION: void  oggpackB_writecopy ( oggpack_buffer* b, void* source, long bits ) ;
-FUNCTION: void  oggpackB_reset ( oggpack_buffer* b ) ;
-FUNCTION: void  oggpackB_writeclear ( oggpack_buffer* b ) ;
-FUNCTION: void  oggpackB_readinit ( oggpack_buffer* b, uchar* buf, int bytes ) ;
-FUNCTION: void  oggpackB_write ( oggpack_buffer* b, ulong value, int bits ) ;
-FUNCTION: long  oggpackB_look ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long  oggpackB_look1 ( oggpack_buffer* b ) ;
-FUNCTION: void  oggpackB_adv ( oggpack_buffer* b, int bits ) ;
-FUNCTION: void  oggpackB_adv1 ( oggpack_buffer* b ) ;
-FUNCTION: long  oggpackB_read ( oggpack_buffer* b, int bits ) ;
-FUNCTION: long  oggpackB_read1 ( oggpack_buffer* b ) ;
-FUNCTION: long  oggpackB_bytes ( oggpack_buffer* b ) ;
-FUNCTION: long  oggpackB_bits ( oggpack_buffer* b ) ;
-FUNCTION: uchar* oggpackB_get_buffer ( oggpack_buffer* b ) ;
-FUNCTION: int      ogg_stream_packetin ( ogg_stream_state* os, ogg_packet* op ) ;
-FUNCTION: int      ogg_stream_pageout ( ogg_stream_state* os, ogg_page* og ) ;
-FUNCTION: int      ogg_stream_flush ( ogg_stream_state* os, ogg_page* og ) ;
-FUNCTION: int      ogg_sync_init ( ogg_sync_state* oy ) ;
-FUNCTION: int      ogg_sync_clear ( ogg_sync_state* oy ) ;
-FUNCTION: int      ogg_sync_reset ( ogg_sync_state* oy ) ;
-FUNCTION: int   ogg_sync_destroy ( ogg_sync_state* oy ) ;
-
-FUNCTION: void* ogg_sync_buffer ( ogg_sync_state* oy, long size ) ;
-FUNCTION: int      ogg_sync_wrote ( ogg_sync_state* oy, long bytes ) ;
-FUNCTION: long     ogg_sync_pageseek ( ogg_sync_state* oy, ogg_page* og ) ;
-FUNCTION: int      ogg_sync_pageout ( ogg_sync_state* oy, ogg_page* og ) ;
-FUNCTION: int      ogg_stream_pagein ( ogg_stream_state* os, ogg_page* og ) ;
-FUNCTION: int      ogg_stream_packetout ( ogg_stream_state* os, ogg_packet* op ) ;
-FUNCTION: int      ogg_stream_packetpeek ( ogg_stream_state* os, ogg_packet* op ) ;
-FUNCTION: int      ogg_stream_init (ogg_stream_state* os, int serialno ) ;
-FUNCTION: int      ogg_stream_clear ( ogg_stream_state* os ) ;
-FUNCTION: int      ogg_stream_reset ( ogg_stream_state* os ) ;
-FUNCTION: int      ogg_stream_reset_serialno ( ogg_stream_state* os, int serialno ) ;
-FUNCTION: int      ogg_stream_destroy ( ogg_stream_state* os ) ;
-FUNCTION: int      ogg_stream_eos ( ogg_stream_state* os ) ;
-FUNCTION: void     ogg_page_checksum_set ( ogg_page* og ) ;
-FUNCTION: int      ogg_page_version ( ogg_page* og ) ;
-FUNCTION: int      ogg_page_continued ( ogg_page* og ) ;
-FUNCTION: int      ogg_page_bos ( ogg_page* og ) ;
-FUNCTION: int      ogg_page_eos ( ogg_page* og ) ;
-FUNCTION: longlong  ogg_page_granulepos ( ogg_page* og ) ;
-FUNCTION: int      ogg_page_serialno ( ogg_page* og ) ;
-FUNCTION: long     ogg_page_pageno ( ogg_page* og ) ;
-FUNCTION: int      ogg_page_packets ( ogg_page* og ) ;
-FUNCTION: void     ogg_packet_clear ( ogg_packet* op ) ;
-

unmaintained/ogg/theora/theora.factor

@@ -1,120 +0,0 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel system combinators alien alien.syntax ;
-IN: ogg.theora
-
-<<
-"theora" {
-    { [ os winnt? ]  [ "theora.dll" ] }
-    { [ os macosx? ] [ "libtheora.0.dylib" ] }
-    { [ os unix? ]   [ "libtheora.so" ] }
-} cond "cdecl" add-library
->>
-
-LIBRARY: theora
-
-C-STRUCT: yuv_buffer
-    { "int" "y_width" }
-    { "int" "y_height" }
-    { "int" "y_stride" }
-    { "int" "uv_width" }
-    { "int" "uv_height" }
-    { "int" "uv_stride" }
-    { "void*" "y" }
-    { "void*" "u" }
-    { "void*" "v" } ;
-
-: OC_CS_UNSPECIFIED ( -- number ) 0 ; inline
-: OC_CS_ITU_REC_470M ( -- number ) 1 ; inline
-: OC_CS_ITU_REC_470BG ( -- number ) 2 ; inline
-: OC_CS_NSPACES ( -- number ) 3 ; inline
-
-TYPEDEF: int theora_colorspace 
-
-: OC_PF_420 ( -- number ) 0 ; inline
-: OC_PF_RSVD ( -- number ) 1 ; inline
-: OC_PF_422 ( -- number ) 2 ; inline
-: OC_PF_444 ( -- number ) 3 ; inline
-
-TYPEDEF: int theora_pixelformat
-
-C-STRUCT: theora_info
-    { "uint" "width" }
-    { "uint" "height" }
-    { "uint" "frame_width" }
-    { "uint" "frame_height" }
-    { "uint" "offset_x" }
-    { "uint" "offset_y" }
-    { "uint" "fps_numerator" }
-    { "uint" "fps_denominator" }
-    { "uint" "aspect_numerator" }
-    { "uint" "aspect_denominator" }
-    { "theora_colorspace" "colorspace" }
-    { "int" "target_bitrate" }
-    { "int" "quality" }
-    { "int" "quick_p" }
-    { "uchar" "version_major" }
-    { "uchar" "version_minor" } 
-    { "uchar" "version_subminor" }
-    { "void*" "codec_setup" }
-    { "int" "dropframes_p" }
-    { "int" "keyframe_auto_p" }
-    { "uint" "keyframe_frequency" }
-    { "uint" "keyframe_frequency_force" }
-    { "uint" "keyframe_data_target_bitrate" }
-    { "int" "keyframe_auto_threshold" }
-    { "uint" "keyframe_mindistance" }
-    { "int" "noise_sensitivity" }
-    { "int" "sharpness" }
-    { "theora_pixelformat" "pixelformat" } ;
-
-C-STRUCT: theora_state
-    { "theora_info*" "i" }
-    { "longlong" "granulepos" }
-    { "void*" "internal_encode" }
-    { "void*" "internal_decode" } ;
-
-C-STRUCT: theora_comment
-    { "char**" "user_comments" }
-    { "int*" "comment_lengths" }
-    { "int" "comments" }
-    { "char*" "vendor" } ;
-
-: OC_FAULT ( -- number ) -1 ; inline
-: OC_EINVAL ( -- number ) -10 ; inline
-: OC_DISABLED ( -- number ) -11 ; inline
-: OC_BADHEADER ( -- number ) -20 ; inline
-: OC_NOTFORMAT ( -- number ) -21 ; inline
-: OC_VERSION ( -- number ) -22 ; inline
-: OC_IMPL ( -- number ) -23 ; inline
-: OC_BADPACKET ( -- number ) -24 ; inline
-: OC_NEWPACKET ( -- number ) -25 ; inline
-: OC_DUPFRAME ( -- number ) 1 ; inline
-
-FUNCTION: char* theora_version_string ( ) ;
-FUNCTION: uint theora_version_number ( ) ;
-FUNCTION: int theora_encode_init ( theora_state* th, theora_info* ti ) ;
-FUNCTION: int theora_encode_YUVin ( theora_state* t, yuv_buffer* yuv ) ;
-FUNCTION: int theora_encode_packetout ( theora_state* t, int last_p, ogg_packet* op ) ;
-FUNCTION: int theora_encode_header ( theora_state* t, ogg_packet* op ) ;
-FUNCTION: int theora_encode_comment ( theora_comment* tc, ogg_packet* op ) ;
-FUNCTION: int theora_encode_tables ( theora_state* t, ogg_packet* op ) ;
-FUNCTION: int theora_decode_header ( theora_info* ci, theora_comment* cc, ogg_packet* op ) ;
-FUNCTION: int theora_decode_init ( theora_state* th, theora_info* c ) ;
-FUNCTION: int theora_decode_packetin ( theora_state* th, ogg_packet* op ) ;
-FUNCTION: int theora_decode_YUVout ( theora_state* th, yuv_buffer* yuv ) ;
-FUNCTION: int theora_packet_isheader ( ogg_packet* op ) ;
-FUNCTION: int theora_packet_iskeyframe ( ogg_packet* op ) ;
-FUNCTION: int theora_granule_shift ( theora_info* ti ) ;
-FUNCTION: longlong theora_granule_frame ( theora_state* th, longlong granulepos ) ;
-FUNCTION: double theora_granule_time ( theora_state* th, longlong granulepos ) ;
-FUNCTION: void theora_info_init ( theora_info* c ) ;
-FUNCTION: void theora_info_clear ( theora_info* c ) ;
-FUNCTION: void theora_clear ( theora_state* t ) ;
-FUNCTION: void theora_comment_init ( theora_comment* tc ) ;
-FUNCTION: void theora_comment_add ( theora_comment* tc, char* comment ) ;
-FUNCTION: void theora_comment_add_tag ( theora_comment* tc, char* tag, char* value ) ;
-FUNCTION: char* theora_comment_query ( theora_comment* tc, char* tag, int count ) ;
-FUNCTION: int   theora_comment_query_count ( theora_comment* tc, char* tag ) ;
-FUNCTION: void  theora_comment_clear ( theora_comment* tc ) ;

unmaintained/ogg/vorbis/vorbis.factor

@@ -1,141 +0,0 @@
-! Copyright (C) 2007 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: kernel system combinators alien alien.syntax ogg ;
-IN: ogg.vorbis
-
-<<
-"vorbis" {
-    { [ os winnt? ]  [ "vorbis.dll" ] }
-    { [ os macosx? ] [ "libvorbis.0.dylib" ] }
-    { [ os unix? ]   [ "libvorbis.so" ] }
-} cond "cdecl" add-library 
->>
-
-LIBRARY: vorbis
-
-C-STRUCT: vorbis_info 
-    { "int" "version" }
-    { "int" "channels" }
-    { "long" "rate" }
-    { "long" "bitrate_upper" }
-    { "long" "bitrate_nominal" }
-    { "long" "bitrate_lower" }
-    { "long" "bitrate_window" }
-    { "void*" "codec_setup"} 
-    ;
-
-C-STRUCT: vorbis_dsp_state
-    { "int" "analysisp" }
-    { "vorbis_info*" "vi" }
-    { "float**" "pcm" }
-    { "float**" "pcmret" }
-    { "int" "pcm_storage" }
-    { "int" "pcm_current" }
-    { "int" "pcm_returned" }
-    { "int" "preextrapolate" }
-    { "int" "eofflag" }
-    { "long" "lW" }
-    { "long" "W" }
-    { "long" "nW" }
-    { "long" "centerW" }
-    { "longlong" "granulepos" }
-    { "longlong" "sequence" }
-    { "longlong" "glue_bits" }
-    { "longlong" "time_bits" }
-    { "longlong" "floor_bits" }
-    { "longlong" "res_bits" }
-    { "void*" "backend_state" }
-    ;
-
-C-STRUCT: alloc_chain
-    { "void*" "ptr" }
-    { "void*" "next" }
-    ;
-
-C-STRUCT: vorbis_block
-    { "float**" "pcm" }
-    { "oggpack_buffer" "opb" }
-    { "long" "lW" }
-    { "long" "W" }
-    { "long" "nW" }
-    { "int" "pcmend" }
-    { "int" "mode" }
-    { "int" "eofflag" }
-    { "longlong" "granulepos" }
-    { "longlong" "sequence" }
-    { "vorbis_dsp_state*" "vd" }
-    { "void*" "localstore" }
-    { "long" "localtop" }
-    { "long" "localalloc" }
-    { "long" "totaluse" }
-    { "alloc_chain*" "reap" }
-    { "long" "glue_bits" }
-    { "long" "time_bits" }
-    { "long" "floor_bits" }
-    { "long" "res_bits" }
-    { "void*" "internal" }
-    ;
-
-C-STRUCT: vorbis_comment
-    { "char**" "usercomments" }
-    { "int*" "comment_lengths" }
-    { "int" "comments" }
-    { "char*" "vendor" }
-    ;
-
-FUNCTION: void     vorbis_info_init ( vorbis_info* vi ) ;
-FUNCTION: void     vorbis_info_clear ( vorbis_info* vi ) ;
-FUNCTION: int      vorbis_info_blocksize ( vorbis_info* vi, int zo ) ;
-FUNCTION: void     vorbis_comment_init ( vorbis_comment* vc ) ;
-FUNCTION: void     vorbis_comment_add ( vorbis_comment* vc, char* comment ) ;
-FUNCTION: void     vorbis_comment_add_tag ( vorbis_comment* vc, char* tag, char* contents ) ;
-FUNCTION: char*    vorbis_comment_query ( vorbis_comment* vc, char* tag, int count ) ;
-FUNCTION: int      vorbis_comment_query_count ( vorbis_comment* vc, char* tag ) ;
-FUNCTION: void     vorbis_comment_clear ( vorbis_comment* vc ) ;
-FUNCTION: int      vorbis_block_init ( vorbis_dsp_state* v, vorbis_block* vb ) ;
-FUNCTION: int      vorbis_block_clear ( vorbis_block* vb ) ;
-FUNCTION: void     vorbis_dsp_clear ( vorbis_dsp_state* v ) ;
-FUNCTION: double   vorbis_granule_time ( vorbis_dsp_state* v, longlong granulepos ) ;
-FUNCTION: int      vorbis_analysis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ;
-FUNCTION: int      vorbis_commentheader_out ( vorbis_comment* vc, ogg_packet* op ) ;
-FUNCTION: int      vorbis_analysis_headerout ( vorbis_dsp_state* v,
-                                          vorbis_comment* vc,
-                                          ogg_packet* op,
-                                          ogg_packet* op_comm,
-                                          ogg_packet* op_code ) ;
-FUNCTION: float**  vorbis_analysis_buffer ( vorbis_dsp_state* v, int vals ) ;
-FUNCTION: int      vorbis_analysis_wrote ( vorbis_dsp_state* v, int vals ) ;
-FUNCTION: int      vorbis_analysis_blockout ( vorbis_dsp_state* v, vorbis_block* vb ) ;
-FUNCTION: int      vorbis_analysis ( vorbis_block* vb, ogg_packet* op ) ;
-FUNCTION: int      vorbis_bitrate_addblock ( vorbis_block* vb ) ;
-FUNCTION: int      vorbis_bitrate_flushpacket ( vorbis_dsp_state* vd,
-                                           ogg_packet* op ) ;
-FUNCTION: int      vorbis_synthesis_headerin ( vorbis_info* vi, vorbis_comment* vc,
-                                          ogg_packet* op ) ;
-FUNCTION: int      vorbis_synthesis_init ( vorbis_dsp_state* v, vorbis_info* vi ) ;
-FUNCTION: int      vorbis_synthesis_restart ( vorbis_dsp_state* v ) ;
-FUNCTION: int      vorbis_synthesis ( vorbis_block* vb, ogg_packet* op ) ;
-FUNCTION: int      vorbis_synthesis_trackonly ( vorbis_block* vb, ogg_packet* op ) ;
-FUNCTION: int      vorbis_synthesis_blockin ( vorbis_dsp_state* v, vorbis_block* vb ) ;
-FUNCTION: int      vorbis_synthesis_pcmout ( vorbis_dsp_state* v, float*** pcm ) ;
-FUNCTION: int      vorbis_synthesis_lapout ( vorbis_dsp_state* v, float*** pcm ) ;
-FUNCTION: int      vorbis_synthesis_read ( vorbis_dsp_state* v, int samples ) ;
-FUNCTION: long     vorbis_packet_blocksize ( vorbis_info* vi, ogg_packet* op ) ;
-FUNCTION: int      vorbis_synthesis_halfrate ( vorbis_info* v, int flag ) ;
-FUNCTION: int      vorbis_synthesis_halfrate_p ( vorbis_info* v ) ;
-
-: OV_FALSE ( -- number ) -1 ; inline
-: OV_EOF ( -- number ) -2 ; inline
-: OV_HOLE ( -- number ) -3 ; inline
-: OV_EREAD ( -- number ) -128 ; inline
-: OV_EFAULT ( -- number ) -129 ; inline
-: OV_EIMPL ( -- number ) -130 ; inline
-: OV_EINVAL ( -- number ) -131 ; inline
-: OV_ENOTVORBIS ( -- number ) -132 ; inline
-: OV_EBADHEADER ( -- number ) -133 ; inline
-: OV_EVERSION ( -- number ) -134 ; inline
-: OV_ENOTAUDIO ( -- number ) -135 ; inline
-: OV_EBADPACKET ( -- number ) -136 ; inline
-: OV_EBADLINK ( -- number ) -137 ; inline
-: OV_ENOSEEK ( -- number ) -138 ; inline

vm/alien.cpp

@@ -69,10 +69,7 @@ inline void factor_vm::primitive_displaced_alien()
 	}
 }
 
-PRIMITIVE(displaced_alien)
+PRIMITIVE_FORWARD(displaced_alien)
-{
-	PRIMITIVE_GETVM()->primitive_displaced_alien();
-}
 
 /* address of an object representing a C pointer. Explicitly throw an error
 if the object is a byte array, as a sanity check. */
@@ -81,10 +78,7 @@ inline void factor_vm::primitive_alien_address()
 	box_unsigned_cell((cell)pinned_alien_offset(dpop()));
 }
 
-PRIMITIVE(alien_address)
+PRIMITIVE_FORWARD(alien_address)
-{
-	PRIMITIVE_GETVM()->primitive_alien_address();
-}
 
 /* pop ( alien n ) from datastack, return alien's address plus n */
 void *factor_vm::alien_pointer()
@@ -131,10 +125,7 @@ inline void factor_vm::primitive_dlopen()
 	dpush(library.value());
 }
 
-PRIMITIVE(dlopen)
+PRIMITIVE_FORWARD(dlopen)
-{
-	PRIMITIVE_GETVM()->primitive_dlopen();
-}
 
 /* look up a symbol in a native library */
 inline void factor_vm::primitive_dlsym()
@@ -158,10 +149,7 @@ inline void factor_vm::primitive_dlsym()
 	}
 }
 
-PRIMITIVE(dlsym)
+PRIMITIVE_FORWARD(dlsym)
-{
-	PRIMITIVE_GETVM()->primitive_dlsym();
-}
 
 /* close a native library handle */
 inline void factor_vm::primitive_dlclose()
@@ -171,10 +159,7 @@ inline void factor_vm::primitive_dlclose()
 		ffi_dlclose(d);
 }
 
-PRIMITIVE(dlclose)
+PRIMITIVE_FORWARD(dlclose)
-{
-	PRIMITIVE_GETVM()->primitive_dlclose();
-}
 
 inline void factor_vm::primitive_dll_validp()
 {
@@ -185,10 +170,7 @@ inline void factor_vm::primitive_dll_validp()
 		dpush(untag_check<dll>(library)->dll == NULL ? F : T);
 }
 
-PRIMITIVE(dll_validp)
+PRIMITIVE_FORWARD(dll_validp)
-{
-	PRIMITIVE_GETVM()->primitive_dll_validp();
-}
 
 /* gets the address of an object representing a C pointer */
 char *factor_vm::alien_offset(cell obj)
@@ -308,9 +290,6 @@ inline void factor_vm::primitive_vm_ptr()
 	box_alien(this);
 }
 
-PRIMITIVE(vm_ptr)
+PRIMITIVE_FORWARD(vm_ptr)
-{
-	PRIMITIVE_GETVM()->primitive_vm_ptr();
-}
 
 }

vm/arrays.cpp

@@ -31,10 +31,7 @@ inline void factor_vm::primitive_array()
 	dpush(tag<array>(allot_array(size,initial)));
 }
 
-PRIMITIVE(array)
+PRIMITIVE_FORWARD(array)
-{
-	PRIMITIVE_GETVM()->primitive_array();
-}
 
 cell factor_vm::allot_array_1(cell obj_)
 {
@@ -75,10 +72,7 @@ inline void factor_vm::primitive_resize_array()
 	dpush(tag<array>(reallot_array(a,capacity)));
 }
 
-PRIMITIVE(resize_array)
+PRIMITIVE_FORWARD(resize_array)
-{
-	PRIMITIVE_GETVM()->primitive_resize_array();
-}
 
 void growable_array::add(cell elt_)
 {

vm/byte_arrays.cpp

@@ -16,10 +16,7 @@ inline void factor_vm::primitive_byte_array()
 	dpush(tag<byte_array>(allot_byte_array(size)));
 }
 
-PRIMITIVE(byte_array)
+PRIMITIVE_FORWARD(byte_array)
-{
-	PRIMITIVE_GETVM()->primitive_byte_array();
-}
 
 inline void factor_vm::primitive_uninitialized_byte_array()
 {
@@ -27,10 +24,7 @@ inline void factor_vm::primitive_uninitialized_byte_array()
 	dpush(tag<byte_array>(allot_array_internal<byte_array>(size)));
 }
 
-PRIMITIVE(uninitialized_byte_array)
+PRIMITIVE_FORWARD(uninitialized_byte_array)
-{
-	PRIMITIVE_GETVM()->primitive_uninitialized_byte_array();
-}
 
 inline void factor_vm::primitive_resize_byte_array()
 {
@@ -39,10 +33,7 @@ inline void factor_vm::primitive_resize_byte_array()
 	dpush(tag<byte_array>(reallot_array(array,capacity)));
 }
 
-PRIMITIVE(resize_byte_array)
+PRIMITIVE_FORWARD(resize_byte_array)
-{
-	PRIMITIVE_GETVM()->primitive_resize_byte_array();
-}
 
 void growable_byte_array::append_bytes(void *elts, cell len)
 {

vm/callstack.cpp

@@ -60,10 +60,7 @@ inline void factor_vm::primitive_callstack()
 	dpush(tag<callstack>(stack));
 }
 
-PRIMITIVE(callstack)
+PRIMITIVE_FORWARD(callstack)
-{
-	PRIMITIVE_GETVM()->primitive_callstack();
-}
 
 inline void factor_vm::primitive_set_callstack()
 {
@@ -78,10 +75,7 @@ inline void factor_vm::primitive_set_callstack()
 	critical_error("Bug in set_callstack()",0);
 }
 
-PRIMITIVE(set_callstack)
+PRIMITIVE_FORWARD(set_callstack)
-{
-	PRIMITIVE_GETVM()->primitive_set_callstack();
-}
 
 code_block *factor_vm::frame_code(stack_frame *frame)
 {
@@ -172,10 +166,7 @@ inline void factor_vm::primitive_callstack_to_array()
 	dpush(accum.frames.elements.value());
 }
 
-PRIMITIVE(callstack_to_array)
+PRIMITIVE_FORWARD(callstack_to_array)
-{
-	PRIMITIVE_GETVM()->primitive_callstack_to_array();
-}
 
 stack_frame *factor_vm::innermost_stack_frame(callstack *stack)
 {
@@ -203,20 +194,14 @@ inline void factor_vm::primitive_innermost_stack_frame_executing()
 	dpush(frame_executing(innermost_stack_frame(untag_check<callstack>(dpop()))));
 }
 
-PRIMITIVE(innermost_stack_frame_executing)
+PRIMITIVE_FORWARD(innermost_stack_frame_executing)
-{
-	PRIMITIVE_GETVM()->primitive_innermost_stack_frame_executing();
-}
 
 inline void factor_vm::primitive_innermost_stack_frame_scan()
 {
 	dpush(frame_scan(innermost_stack_frame_quot(untag_check<callstack>(dpop()))));
 }
 
-PRIMITIVE(innermost_stack_frame_scan)
+PRIMITIVE_FORWARD(innermost_stack_frame_scan)
-{
-	PRIMITIVE_GETVM()->primitive_innermost_stack_frame_scan();
-}
 
 inline void factor_vm::primitive_set_innermost_stack_frame_quot()
 {
@@ -234,10 +219,7 @@ inline void factor_vm::primitive_set_innermost_stack_frame_quot()
 	FRAME_RETURN_ADDRESS(inner) = (char *)quot->xt + offset;
 }
 
-PRIMITIVE(set_innermost_stack_frame_quot)
+PRIMITIVE_FORWARD(set_innermost_stack_frame_quot)
-{
-	PRIMITIVE_GETVM()->primitive_set_innermost_stack_frame_quot();
-}
 
 /* called before entry into Factor code. */
 void factor_vm::save_callstack_bottom(stack_frame *callstack_bottom)

vm/callstack.hpp

@@ -13,7 +13,7 @@ PRIMITIVE(innermost_stack_frame_executing);
 PRIMITIVE(innermost_stack_frame_scan);
 PRIMITIVE(set_innermost_stack_frame_quot);
 
-VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom,factor_vm *vm);
+VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom, factor_vm *vm);
 
 
 }

vm/code_block.cpp

@@ -93,9 +93,9 @@ void factor_vm::undefined_symbol()
 	general_error(ERROR_UNDEFINED_SYMBOL,F,F,NULL);
 }
 
-void undefined_symbol(factor_vm *myvm)
+void undefined_symbol()
 {
-	return myvm->undefined_symbol();
+	return SIGNAL_VM_PTR()->undefined_symbol();
 }
 
 /* Look up an external library symbol referenced by a compiled code block */
@@ -371,7 +371,7 @@ void factor_vm::update_word_references(code_block *compiled)
 	   the code heap with dead PICs that will be freed on the next
 	   GC, we add them to the free list immediately. */
 	else if(compiled->type == PIC_TYPE)
-		heap_free(&code,compiled);
+		code->heap_free(compiled);
 	else
 	{
 		iterate_relocations(compiled,factor::update_word_references_step);
@@ -411,7 +411,7 @@ void factor_vm::mark_code_block(code_block *compiled)
 {
 	check_code_address((cell)compiled);
 
-	mark_block(compiled);
+	code->mark_block(compiled);
 
 	copy_handle(&compiled->literals);
 	copy_handle(&compiled->relocation);
@@ -503,19 +503,19 @@ void factor_vm::fixup_labels(array *labels, code_block *compiled)
 /* Might GC */
 code_block *factor_vm::allot_code_block(cell size)
 {
-	heap_block *block = heap_allot(&code,size + sizeof(code_block));
+	heap_block *block = code->heap_allot(size + sizeof(code_block));
 
 	/* If allocation failed, do a code GC */
 	if(block == NULL)
 	{
 		gc();
-		block = heap_allot(&code,size + sizeof(code_block));
+		block = code->heap_allot(size + sizeof(code_block));
 
 		/* Insufficient room even after code GC, give up */
 		if(block == NULL)
 		{
 			cell used, total_free, max_free;
-			heap_usage(&code,&used,&total_free,&max_free);
+			code->heap_usage(&used,&total_free,&max_free);
 
 			print_string("Code heap stats:\n");
 			print_string("Used: "); print_cell(used); nl();

vm/code_gc.hpp

@@ -1,38 +0,0 @@
-namespace factor
-{
-
-static const cell free_list_count = 16;
-static const cell block_size_increment = 32;
-
-struct heap_free_list {
-	free_heap_block *small_blocks[free_list_count];
-	free_heap_block *large_blocks;
-};
-
-struct heap {
-	segment *seg;
-	heap_free_list free;
-};
-
-typedef void (*heap_iterator)(heap_block *compiled,factor_vm *vm);
-
-inline static heap_block *next_block(heap *h, heap_block *block)
-{
-	cell next = ((cell)block + block->size);
-	if(next == h->seg->end)
-		return NULL;
-	else
-		return (heap_block *)next;
-}
-
-inline static heap_block *first_block(heap *h)
-{
-	return (heap_block *)h->seg->start;
-}
-
-inline static heap_block *last_block(heap *h)
-{
-	return (heap_block *)h->seg->end;
-}
-
-}

vm/code_heap.cpp

@@ -6,12 +6,12 @@ namespace factor
 /* Allocate a code heap during startup */
 void factor_vm::init_code_heap(cell size)
 {
-	new_heap(&code,size);
+	code = new heap(this,size);
 }
 
 bool factor_vm::in_code_heap_p(cell ptr)
 {
-	return (ptr >= code.seg->start && ptr <= code.seg->end);
+	return (ptr >= code->seg->start && ptr <= code->seg->end);
 }
 
 /* Compile a word definition with the non-optimizing compiler. Allocates memory */
@@ -31,13 +31,13 @@ void factor_vm::jit_compile_word(cell word_, cell def_, bool relocate)
 /* Apply a function to every code block */
 void factor_vm::iterate_code_heap(code_heap_iterator iter)
 {
-	heap_block *scan = first_block(&code);
+	heap_block *scan = code->first_block();
 
 	while(scan)
 	{
 		if(scan->status != B_FREE)
 			iter((code_block *)scan,this);
-		scan = next_block(&code,scan);
+		scan = code->next_block(scan);
 	}
 }
 
@@ -106,26 +106,20 @@ inline void factor_vm::primitive_modify_code_heap()
 	update_code_heap_words();
 }
 
-PRIMITIVE(modify_code_heap)
+PRIMITIVE_FORWARD(modify_code_heap)
-{
-	PRIMITIVE_GETVM()->primitive_modify_code_heap();
-}
 
 /* Push the free space and total size of the code heap */
 inline void factor_vm::primitive_code_room()
 {
 	cell used, total_free, max_free;
-	heap_usage(&code,&used,&total_free,&max_free);
+	code->heap_usage(&used,&total_free,&max_free);
-	dpush(tag_fixnum(code.seg->size / 1024));
+	dpush(tag_fixnum(code->seg->size / 1024));
 	dpush(tag_fixnum(used / 1024));
 	dpush(tag_fixnum(total_free / 1024));
 	dpush(tag_fixnum(max_free / 1024));
 }
 
-PRIMITIVE(code_room)
+PRIMITIVE_FORWARD(code_room)
-{
-	PRIMITIVE_GETVM()->primitive_code_room();
-}
 
 code_block *factor_vm::forward_xt(code_block *compiled)
 {
@@ -226,20 +220,20 @@ void factor_vm::compact_code_heap()
 	gc();
 
 	/* Figure out where the code heap blocks are going to end up */
-	cell size = compute_heap_forwarding(&code, forwarding);
+	cell size = code->compute_heap_forwarding(forwarding);
 
 	/* Update word and quotation code pointers */
 	forward_object_xts();
 
 	/* Actually perform the compaction */
-	compact_heap(&code,forwarding);
+	code->compact_heap(forwarding);
 
 	/* Update word and quotation XTs */
 	fixup_object_xts();
 
 	/* Now update the free list; there will be a single free block at
 	the end */
-	build_free_list(&code,size);
+	code->build_free_list(size);
 }
 
 }

vm/code_heap.hpp

@@ -1,7 +1,8 @@
 namespace factor
 {
+
 struct factor_vm;
-typedef void (*code_heap_iterator)(code_block *compiled,factor_vm *myvm);
+typedef void (*code_heap_iterator)(code_block *compiled, factor_vm *myvm);
 
 PRIMITIVE(modify_code_heap);
 PRIMITIVE(code_room);

vm/contexts.cpp

@@ -43,9 +43,9 @@ context *factor_vm::alloc_context()
 	}
 	else
 	{
-		new_context = (context *)safe_malloc(sizeof(context));
+		new_context = new context;
-		new_context->datastack_region = alloc_segment(ds_size);
+		new_context->datastack_region = new segment(this,ds_size);
-		new_context->retainstack_region = alloc_segment(rs_size);
+		new_context->retainstack_region = new segment(this,rs_size);
 	}
 
 	return new_context;
@@ -146,10 +146,7 @@ inline void factor_vm::primitive_datastack()
 		general_error(ERROR_DS_UNDERFLOW,F,F,NULL);
 }
 
-PRIMITIVE(datastack)
+PRIMITIVE_FORWARD(datastack)
-{
-	PRIMITIVE_GETVM()->primitive_datastack();
-}
 
 inline void factor_vm::primitive_retainstack()
 {
@@ -157,10 +154,7 @@ inline void factor_vm::primitive_retainstack()
 		general_error(ERROR_RS_UNDERFLOW,F,F,NULL);
 }
 
-PRIMITIVE(retainstack)
+PRIMITIVE_FORWARD(retainstack)
-{
-	PRIMITIVE_GETVM()->primitive_retainstack();
-}
 
 /* returns pointer to top of stack */
 cell factor_vm::array_to_stack(array *array, cell bottom)
@@ -175,20 +169,14 @@ inline void factor_vm::primitive_set_datastack()
 	ds = array_to_stack(untag_check<array>(dpop()),ds_bot);
 }
 
-PRIMITIVE(set_datastack)
+PRIMITIVE_FORWARD(set_datastack)
-{
-	PRIMITIVE_GETVM()->primitive_set_datastack();
-}
 
 inline void factor_vm::primitive_set_retainstack()
 {
 	rs = array_to_stack(untag_check<array>(dpop()),rs_bot);
 }
 
-PRIMITIVE(set_retainstack)
+PRIMITIVE_FORWARD(set_retainstack)
-{
-	PRIMITIVE_GETVM()->primitive_set_retainstack();
-}
 
 /* Used to implement call( */
 inline void factor_vm::primitive_check_datastack()
@@ -216,9 +204,6 @@ inline void factor_vm::primitive_check_datastack()
 	}
 }
 
-PRIMITIVE(check_datastack)
+PRIMITIVE_FORWARD(check_datastack)
-{
-	PRIMITIVE_GETVM()->primitive_check_datastack();
-}
 
 }

vm/cpu-ppc.hpp

@@ -3,7 +3,6 @@ namespace factor
 
 #define FACTOR_CPU_STRING "ppc"
 #define VM_ASM_API VM_C_API
-#define VM_ASM_API_OVERFLOW VM_C_API
 
 register cell ds asm("r13");
 register cell rs asm("r14");

vm/cpu-x86.32.S

@@ -82,7 +82,7 @@ DEF(void,set_x87_env,(const void*)):
 	ret
 
 DEF(F_FASTCALL void,throw_impl,(CELL quot, F_STACK_FRAME *rewind_to, void *vm)):
-	mov CELL_SIZE(STACK_REG),NV_TEMP_REG  /* get vm ptr in case quot_xt = lazy_jit_compile */		
+	mov ARG2,NV_TEMP_REG  /* remember vm ptr in case quot_xt = lazy_jit_compile */		
 	/* clear x87 stack, but preserve rounding mode and exception flags */
 	sub $2,STACK_REG
 	fnstcw (STACK_REG)

vm/cpu-x86.32.hpp

@@ -6,6 +6,5 @@ namespace factor
 register cell ds asm("esi");
 register cell rs asm("edi");
 
-#define VM_ASM_API VM_C_API __attribute__ ((regparm (2)))
+#define VM_ASM_API VM_C_API __attribute__ ((regparm (3)))
-#define VM_ASM_API_OVERFLOW VM_C_API __attribute__ ((regparm (3)))
 }

vm/cpu-x86.64.hpp

@@ -7,5 +7,4 @@ register cell ds asm("r14");
 register cell rs asm("r15");
 
 #define VM_ASM_API VM_C_API
-#define VM_ASM_API_OVERFLOW VM_C_API
 }

vm/cpu-x86.hpp

@@ -69,7 +69,7 @@ inline static unsigned int fpu_status(unsigned int status)
 }
 
 /* Defined in assembly */
-VM_ASM_API void c_to_factor(cell quot,void *vm);
+VM_ASM_API void c_to_factor(cell quot, void *vm);
 VM_ASM_API void throw_impl(cell quot, stack_frame *rewind_to, void *vm);
 VM_ASM_API void lazy_jit_compile(cell quot, void *vm);
 

vm/data_gc.cpp

@@ -455,7 +455,7 @@ void factor_vm::end_gc(cell gc_elapsed)
 
 	if(growing_data_heap)
 	{
-		dealloc_data_heap(old_data_heap);
+		delete old_data_heap;
 		old_data_heap = NULL;
 		growing_data_heap = false;
 	}
@@ -509,7 +509,7 @@ void factor_vm::garbage_collection(cell gen,bool growing_data_heap_,cell request
 			growing_data_heap = true;
 
 			/* see the comment in unmark_marked() */
-			unmark_marked(&code);
+			code->unmark_marked();
 		}
 		/* we try collecting aging space twice before going on to
 		collect tenured */
@@ -546,7 +546,7 @@ void factor_vm::garbage_collection(cell gen,bool growing_data_heap_,cell request
 		code_heap_scans++;
 
 		if(collecting_gen == data->tenured())
-			free_unmarked(&code,(heap_iterator)factor::update_literal_and_word_references);
+			code->free_unmarked((heap_iterator)factor::update_literal_and_word_references);
 		else
 			copy_code_heap_roots();
 
@@ -573,10 +573,7 @@ inline void factor_vm::primitive_gc()
 	gc();
 }
 
-PRIMITIVE(gc)
+PRIMITIVE_FORWARD(gc)
-{
-	PRIMITIVE_GETVM()->primitive_gc();
-}
 
 inline void factor_vm::primitive_gc_stats()
 {
@@ -608,10 +605,7 @@ inline void factor_vm::primitive_gc_stats()
 	dpush(result.elements.value());
 }
 
-PRIMITIVE(gc_stats)
+PRIMITIVE_FORWARD(gc_stats)
-{
-	PRIMITIVE_GETVM()->primitive_gc_stats();
-}
 
 void factor_vm::clear_gc_stats()
 {
@@ -629,10 +623,7 @@ inline void factor_vm::primitive_clear_gc_stats()
 	clear_gc_stats();
 }
 
-PRIMITIVE(clear_gc_stats)
+PRIMITIVE_FORWARD(clear_gc_stats)
-{
-	PRIMITIVE_GETVM()->primitive_clear_gc_stats();
-}
 
 /* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
    to coalesce equal but distinct quotations and wrappers. */
@@ -665,10 +656,7 @@ inline void factor_vm::primitive_become()
 	compile_all_words();
 }
 
-PRIMITIVE(become)
+PRIMITIVE_FORWARD(become)
-{
-	PRIMITIVE_GETVM()->primitive_become();
-}
 
 void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
 {
@@ -681,7 +669,7 @@ void factor_vm::inline_gc(cell *gc_roots_base, cell gc_roots_size)
 		gc_locals.pop_back();
 }
 
-VM_ASM_API_OVERFLOW void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm)
+VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm)
 {
 	ASSERTVM();
 	VM_PTR->inline_gc(gc_roots_base,gc_roots_size);

vm/data_gc.hpp

@@ -20,6 +20,6 @@ PRIMITIVE(gc_stats);
 PRIMITIVE(clear_gc_stats);
 PRIMITIVE(become);
 struct factor_vm;
-VM_ASM_API_OVERFLOW void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm);
+VM_C_API void inline_gc(cell *gc_roots_base, cell gc_roots_size, factor_vm *myvm);
 
 }

vm/data_heap.cpp

@@ -3,14 +3,6 @@
 namespace factor
 {
 
-cell factor_vm::init_zone(zone *z, cell size, cell start)
-{
-	z->size = size;
-	z->start = z->here = start;
-	z->end = start + size;
-	return z->end;
-}
-
 void factor_vm::init_card_decks()
 {
 	cell start = align(data->seg->start,deck_size);
@@ -19,89 +11,86 @@ void factor_vm::init_card_decks()
 	decks_offset = (cell)data->decks - (start >> deck_bits);
 }
 
-data_heap *factor_vm::alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size)
+data_heap::data_heap(factor_vm *myvm, cell gen_count_, cell young_size_, cell aging_size_, cell tenured_size_)
 {
-	young_size = align(young_size,deck_size);
+	young_size_ = align(young_size_,deck_size);
-	aging_size = align(aging_size,deck_size);
+	aging_size_ = align(aging_size_,deck_size);
-	tenured_size = align(tenured_size,deck_size);
+	tenured_size_ = align(tenured_size_,deck_size);
 
-	data_heap *data = (data_heap *)safe_malloc(sizeof(data_heap));
+	young_size = young_size_;
-	data->young_size = young_size;
+	aging_size = aging_size_;
-	data->aging_size = aging_size;
+	tenured_size = tenured_size_;
-	data->tenured_size = tenured_size;
+	gen_count = gen_count_;
-	data->gen_count = gens;
 
 	cell total_size;
-	if(data->gen_count == 2)
+	if(gen_count == 2)
 		total_size = young_size + 2 * tenured_size;
-	else if(data->gen_count == 3)
+	else if(gen_count == 3)
 		total_size = young_size + 2 * aging_size + 2 * tenured_size;
 	else
 	{
-		fatal_error("Invalid number of generations",data->gen_count);
+		total_size = 0;
-		return NULL; /* can't happen */
+		fatal_error("Invalid number of generations",gen_count);
 	}
 
 	total_size += deck_size;
 
-	data->seg = alloc_segment(total_size);
+	seg = new segment(myvm,total_size);
 
-	data->generations = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
+	generations = new zone[gen_count];
-	data->semispaces = (zone *)safe_malloc(sizeof(zone) * data->gen_count);
+	semispaces = new zone[gen_count];
 
 	cell cards_size = total_size >> card_bits;
-	data->allot_markers = (cell *)safe_malloc(cards_size);
+	allot_markers = new char[cards_size];
-	data->allot_markers_end = data->allot_markers + cards_size;
+	allot_markers_end = allot_markers + cards_size;
 
-	data->cards = (cell *)safe_malloc(cards_size);
+	cards = new char[cards_size];
-	data->cards_end = data->cards + cards_size;
+	cards_end = cards + cards_size;
 
 	cell decks_size = total_size >> deck_bits;
-	data->decks = (cell *)safe_malloc(decks_size);
+	decks = new char[decks_size];
-	data->decks_end = data->decks + decks_size;
+	decks_end = decks + decks_size;
 
-	cell alloter = align(data->seg->start,deck_size);
+	cell alloter = align(seg->start,deck_size);
 
-	alloter = init_zone(&data->generations[data->tenured()],tenured_size,alloter);
+	alloter = generations[tenured()].init_zone(tenured_size,alloter);
-	alloter = init_zone(&data->semispaces[data->tenured()],tenured_size,alloter);
+	alloter = semispaces[tenured()].init_zone(tenured_size,alloter);
 
-	if(data->gen_count == 3)
+	if(gen_count == 3)
 	{
-		alloter = init_zone(&data->generations[data->aging()],aging_size,alloter);
+		alloter = generations[aging()].init_zone(aging_size,alloter);
-		alloter = init_zone(&data->semispaces[data->aging()],aging_size,alloter);
+		alloter = semispaces[aging()].init_zone(aging_size,alloter);
 	}
 
-	if(data->gen_count >= 2)
+	if(gen_count >= 2)
 	{
-		alloter = init_zone(&data->generations[data->nursery()],young_size,alloter);
+		alloter = generations[nursery()].init_zone(young_size,alloter);
-		alloter = init_zone(&data->semispaces[data->nursery()],0,alloter);
+		alloter = semispaces[nursery()].init_zone(0,alloter);
 	}
 
-	if(data->seg->end - alloter > deck_size)
+	if(seg->end - alloter > deck_size)
-		critical_error("Bug in alloc_data_heap",alloter);
+		myvm->critical_error("Bug in alloc_data_heap",alloter);
-
-	return data;
 }
 
 data_heap *factor_vm::grow_data_heap(data_heap *data, cell requested_bytes)
 {
 	cell new_tenured_size = (data->tenured_size * 2) + requested_bytes;
 
-	return alloc_data_heap(data->gen_count,
+	return new data_heap(this,
+		data->gen_count,
 		data->young_size,
 		data->aging_size,
 		new_tenured_size);
 }
 
-void factor_vm::dealloc_data_heap(data_heap *data)
+data_heap::~data_heap()
 {
-	dealloc_segment(data->seg);
+	delete seg;
-	free(data->generations);
+	delete[] generations;
-	free(data->semispaces);
+	delete[] semispaces;
-	free(data->allot_markers);
+	delete[] allot_markers;
-	free(data->cards);
+	delete[] cards;
-	free(data->decks);
+	delete[] decks;
-	free(data);
 }
 
 void factor_vm::clear_cards(cell from, cell to)
@@ -162,7 +151,7 @@ void factor_vm::set_data_heap(data_heap *data_)
 
 void factor_vm::init_data_heap(cell gens,cell young_size,cell aging_size,cell tenured_size,bool secure_gc_)
 {
-	set_data_heap(alloc_data_heap(gens,young_size,aging_size,tenured_size));
+	set_data_heap(new data_heap(this,gens,young_size,aging_size,tenured_size));
 	secure_gc = secure_gc_;
 	init_data_gc();
 }
@@ -222,10 +211,7 @@ inline void factor_vm::primitive_size()
 	box_unsigned_cell(object_size(dpop()));
 }
 
-PRIMITIVE(size)
+PRIMITIVE_FORWARD(size)
-{
-	PRIMITIVE_GETVM()->primitive_size();
-}
 
 /* The number of cells from the start of the object which should be scanned by
 the GC. Some types have a binary payload at the end (string, word, DLL) which
@@ -284,10 +270,7 @@ inline void factor_vm::primitive_data_room()
 	dpush(a.elements.value());
 }
 
-PRIMITIVE(data_room)
+PRIMITIVE_FORWARD(data_room)
-{
-	PRIMITIVE_GETVM()->primitive_data_room();
-}
 
 /* Disables GC and activates next-object ( -- obj ) primitive */
 void factor_vm::begin_scan()
@@ -306,10 +289,7 @@ inline void factor_vm::primitive_begin_scan()
 	begin_scan();
 }
 
-PRIMITIVE(begin_scan)
+PRIMITIVE_FORWARD(begin_scan)
-{
-	PRIMITIVE_GETVM()->primitive_begin_scan();
-}
 
 cell factor_vm::next_object()
 {
@@ -330,10 +310,7 @@ inline void factor_vm::primitive_next_object()
 	dpush(next_object());
 }
 
-PRIMITIVE(next_object)
+PRIMITIVE_FORWARD(next_object)
-{
-	PRIMITIVE_GETVM()->primitive_next_object();
-}
 
 /* Re-enables GC */
 inline void factor_vm::primitive_end_scan()
@@ -341,10 +318,7 @@ inline void factor_vm::primitive_end_scan()
 	gc_off = false;
 }
 
-PRIMITIVE(end_scan)
+PRIMITIVE_FORWARD(end_scan)
-{
-	PRIMITIVE_GETVM()->primitive_end_scan();
-}
 
 template<typename TYPE> void factor_vm::each_object(TYPE &functor)
 {

vm/data_heap.hpp

@@ -9,6 +9,14 @@ struct zone {
 	cell here;
 	cell size;
 	cell end;
+	
+	cell init_zone(cell size_, cell start_)
+	{
+		size = size_;
+		start = here = start_;
+		end = start_ + size_;
+		return end;
+	}
 };
 
 struct data_heap {
@@ -23,14 +31,14 @@ struct data_heap {
 	zone *generations;
 	zone *semispaces;
 
-	cell *allot_markers;
+	char *allot_markers;
-	cell *allot_markers_end;
+	char *allot_markers_end;
 
-	cell *cards;
+	char *cards;
-	cell *cards_end;
+	char *cards_end;
 
-	cell *decks;
+	char *decks;
-	cell *decks_end;
+	char *decks_end;
 	
 	/* the 0th generation is where new objects are allocated. */
 	cell nursery() { return 0; }
@@ -42,6 +50,9 @@ struct data_heap {
 	cell tenured() { return gen_count - 1; }
 	
 	bool have_aging_p() { return gen_count > 2; }
+
+	data_heap(factor_vm *myvm, cell gen_count, cell young_size, cell aging_size, cell tenured_size);
+	~data_heap();
 };
 
 static const cell max_gen_count = 3;
@@ -51,11 +62,6 @@ inline static bool in_zone(zone *z, object *pointer)
 	return (cell)pointer >= z->start && (cell)pointer < z->end;
 }
 
-/* set up guard pages to check for under/overflow.
-size must be a multiple of the page size */
-segment *alloc_segment(cell size);    //  defined in OS-*.cpp files PD
-void dealloc_segment(segment *block);
-
 PRIMITIVE(data_room);
 PRIMITIVE(size);
 

vm/debug.cpp

@@ -297,7 +297,7 @@ void factor_vm::dump_code_heap()
 {
 	cell reloc_size = 0, literal_size = 0;
 
-	heap_block *scan = first_block(&code);
+	heap_block *scan = code->first_block();
 
 	while(scan)
 	{
@@ -326,7 +326,7 @@ void factor_vm::dump_code_heap()
 		print_cell_hex(scan->size); print_string(" ");
 		print_string(status); print_string("\n");
 
-		scan = next_block(&code,scan);
+		scan = code->next_block(scan);
 	}
 	
 	print_cell(reloc_size); print_string(" bytes of relocation data\n");
@@ -484,9 +484,6 @@ inline void factor_vm::primitive_die()
 	factorbug();
 }
 
-PRIMITIVE(die)
+PRIMITIVE_FORWARD(die)
-{
-	PRIMITIVE_GETVM()->primitive_die();
-}
 
 }

vm/dispatch.cpp

@@ -120,10 +120,7 @@ inline void factor_vm::primitive_lookup_method()
 	dpush(lookup_method(obj,methods));
 }
 
-PRIMITIVE(lookup_method)
+PRIMITIVE_FORWARD(lookup_method)
-{
-	PRIMITIVE_GETVM()->primitive_lookup_method();
-}
 
 cell factor_vm::object_class(cell obj)
 {
@@ -169,20 +166,14 @@ inline void factor_vm::primitive_mega_cache_miss()
 	dpush(method);
 }
 
-PRIMITIVE(mega_cache_miss)
+PRIMITIVE_FORWARD(mega_cache_miss)
-{
-	PRIMITIVE_GETVM()->primitive_mega_cache_miss();
-}
 
 inline void factor_vm::primitive_reset_dispatch_stats()
 {
 	megamorphic_cache_hits = megamorphic_cache_misses = 0;
 }
 
-PRIMITIVE(reset_dispatch_stats)
+PRIMITIVE_FORWARD(reset_dispatch_stats)
-{
-	PRIMITIVE_GETVM()->primitive_reset_dispatch_stats();
-}
 
 inline void factor_vm::primitive_dispatch_stats()
 {
@@ -193,10 +184,7 @@ inline void factor_vm::primitive_dispatch_stats()
 	dpush(stats.elements.value());
 }
 
-PRIMITIVE(dispatch_stats)
+PRIMITIVE_FORWARD(dispatch_stats)
-{
-	PRIMITIVE_GETVM()->primitive_dispatch_stats();
-}
 
 void quotation_jit::emit_mega_cache_lookup(cell methods_, fixnum index, cell cache_)
 {

vm/errors.cpp

@@ -133,10 +133,7 @@ inline void factor_vm::primitive_call_clear()
 	throw_impl(dpop(),stack_chain->callstack_bottom,this);
 }
 
-PRIMITIVE(call_clear)
+PRIMITIVE_FORWARD(call_clear)
-{
-	PRIMITIVE_GETVM()->primitive_call_clear();
-}
 
 /* For testing purposes */
 inline void factor_vm::primitive_unimplemented()
@@ -144,10 +141,7 @@ inline void factor_vm::primitive_unimplemented()
 	not_implemented_error();
 }
 
-PRIMITIVE(unimplemented)
+PRIMITIVE_FORWARD(unimplemented)
-{
-	PRIMITIVE_GETVM()->primitive_unimplemented();
-}
 
 void factor_vm::memory_signal_handler_impl()
 {

vm/heap.cpp

@@ -1,37 +1,36 @@
 #include "master.hpp"
 
+/* This malloc-style heap code is reasonably generic. Maybe in the future, it
+will be used for the data heap too, if we ever get mark/sweep/compact GC. */
+
 namespace factor
 {
 
-void factor_vm::clear_free_list(heap *heap)
+void heap::clear_free_list()
 {
-	memset(&heap->free,0,sizeof(heap_free_list));
+	memset(&free,0,sizeof(heap_free_list));
 }
 
-/* This malloc-style heap code is reasonably generic. Maybe in the future, it
+heap::heap(factor_vm *myvm_, cell size)
-will be used for the data heap too, if we ever get incremental
-mark/sweep/compact GC. */
-void factor_vm::new_heap(heap *heap, cell size)
 {
-	heap->seg = alloc_segment(align_page(size));
+	myvm = myvm_;
-	if(!heap->seg)
+	seg = new segment(myvm,align_page(size));
-		fatal_error("Out of memory in new_heap",size);
+	if(!seg) fatal_error("Out of memory in new_heap",size);
-
+	clear_free_list();
-	clear_free_list(heap);
 }
 
-void factor_vm::add_to_free_list(heap *heap, free_heap_block *block)
+void heap::add_to_free_list(free_heap_block *block)
 {
 	if(block->size < free_list_count * block_size_increment)
 	{
 		int index = block->size / block_size_increment;
-		block->next_free = heap->free.small_blocks[index];
+		block->next_free = free.small_blocks[index];
-		heap->free.small_blocks[index] = block;
+		free.small_blocks[index] = block;
 	}
 	else
 	{
-		block->next_free = heap->free.large_blocks;
+		block->next_free = free.large_blocks;
-		heap->free.large_blocks = block;
+		free.large_blocks = block;
 	}
 }
 
@@ -39,16 +38,16 @@ void factor_vm::add_to_free_list(heap *heap, free_heap_block *block)
 
 In the former case, we must add a large free block from compiling.base + size to
 compiling.limit. */
-void factor_vm::build_free_list(heap *heap, cell size)
+void heap::build_free_list(cell size)
 {
 	heap_block *prev = NULL;
 
-	clear_free_list(heap);
+	clear_free_list();
 
 	size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
 
-	heap_block *scan = first_block(heap);
+	heap_block *scan = first_block();
-	free_heap_block *end = (free_heap_block *)(heap->seg->start + size);
+	free_heap_block *end = (free_heap_block *)(seg->start + size);
 
 	/* Add all free blocks to the free list */
 	while(scan && scan < (heap_block *)end)
@@ -56,28 +55,28 @@ void factor_vm::build_free_list(heap *heap, cell size)
 		switch(scan->status)
 		{
 		case B_FREE:
-			add_to_free_list(heap,(free_heap_block *)scan);
+			add_to_free_list((free_heap_block *)scan);
 			break;
 		case B_ALLOCATED:
 			break;
 		default:
-			critical_error("Invalid scan->status",(cell)scan);
+			myvm->critical_error("Invalid scan->status",(cell)scan);
 			break;
 		}
 
 		prev = scan;
-		scan = next_block(heap,scan);
+		scan = next_block(scan);
 	}
 
 	/* If there is room at the end of the heap, add a free block. This
 	branch is only taken after loading a new image, not after code GC */
-	if((cell)(end + 1) <= heap->seg->end)
+	if((cell)(end + 1) <= seg->end)
 	{
 		end->status = B_FREE;
-		end->size = heap->seg->end - (cell)end;
+		end->size = seg->end - (cell)end;
 
 		/* add final free block */
-		add_to_free_list(heap,end);
+		add_to_free_list(end);
 	}
 	/* This branch is taken if the newly loaded image fits exactly, or
 	after code GC */
@@ -86,30 +85,30 @@ void factor_vm::build_free_list(heap *heap, cell size)
 		/* even if there's no room at the end of the heap for a new
 		free block, we might have to jigger it up by a few bytes in
 		case prev + prev->size */
-		if(prev) prev->size = heap->seg->end - (cell)prev;
+		if(prev) prev->size = seg->end - (cell)prev;
 	}
 
 }
 
-void factor_vm::assert_free_block(free_heap_block *block)
+void heap::assert_free_block(free_heap_block *block)
 {
 	if(block->status != B_FREE)
-		critical_error("Invalid block in free list",(cell)block);
+		myvm->critical_error("Invalid block in free list",(cell)block);
 }
 
 		
-free_heap_block *factor_vm::find_free_block(heap *heap, cell size)
+free_heap_block *heap::find_free_block(cell size)
 {
 	cell attempt = size;
 
 	while(attempt < free_list_count * block_size_increment)
 	{
 		int index = attempt / block_size_increment;
-		free_heap_block *block = heap->free.small_blocks[index];
+		free_heap_block *block = free.small_blocks[index];
 		if(block)
 		{
 			assert_free_block(block);
-			heap->free.small_blocks[index] = block->next_free;
+			free.small_blocks[index] = block->next_free;
 			return block;
 		}
 
@@ -117,7 +116,7 @@ free_heap_block *factor_vm::find_free_block(heap *heap, cell size)
 	}
 
 	free_heap_block *prev = NULL;
-	free_heap_block *block = heap->free.large_blocks;
+	free_heap_block *block = free.large_blocks;
 
 	while(block)
 	{
@@ -127,7 +126,7 @@ free_heap_block *factor_vm::find_free_block(heap *heap, cell size)
 			if(prev)
 				prev->next_free = block->next_free;
 			else
-				heap->free.large_blocks = block->next_free;
+				free.large_blocks = block->next_free;
 			return block;
 		}
 
@@ -138,7 +137,7 @@ free_heap_block *factor_vm::find_free_block(heap *heap, cell size)
 	return NULL;
 }
 
-free_heap_block *factor_vm::split_free_block(heap *heap, free_heap_block *block, cell size)
+free_heap_block *heap::split_free_block(free_heap_block *block, cell size)
 {
 	if(block->size != size )
 	{
@@ -148,21 +147,21 @@ free_heap_block *factor_vm::split_free_block(heap *heap, free_heap_block *block,
 		split->size = block->size - size;
 		split->next_free = block->next_free;
 		block->size = size;
-		add_to_free_list(heap,split);
+		add_to_free_list(split);
 	}
 
 	return block;
 }
 
 /* Allocate a block of memory from the mark and sweep GC heap */
-heap_block *factor_vm::heap_allot(heap *heap, cell size)
+heap_block *heap::heap_allot(cell size)
 {
 	size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
 
-	free_heap_block *block = find_free_block(heap,size);
+	free_heap_block *block = find_free_block(size);
 	if(block)
 	{
-		block = split_free_block(heap,block,size);
+		block = split_free_block(block,size);
 
 		block->status = B_ALLOCATED;
 		return block;
@@ -172,13 +171,13 @@ heap_block *factor_vm::heap_allot(heap *heap, cell size)
 }
 
 /* Deallocates a block manually */
-void factor_vm::heap_free(heap *heap, heap_block *block)
+void heap::heap_free(heap_block *block)
 {
 	block->status = B_FREE;
-	add_to_free_list(heap,(free_heap_block *)block);
+	add_to_free_list((free_heap_block *)block);
 }
 
-void factor_vm::mark_block(heap_block *block)
+void heap::mark_block(heap_block *block)
 {
 	/* If already marked, do nothing */
 	switch(block->status)
@@ -189,41 +188,41 @@ void factor_vm::mark_block(heap_block *block)
 		block->status = B_MARKED;
 		break;
 	default:
-		critical_error("Marking the wrong block",(cell)block);
+		myvm->critical_error("Marking the wrong block",(cell)block);
 		break;
 	}
 }
 
 /* If in the middle of code GC, we have to grow the heap, data GC restarts from
 scratch, so we have to unmark any marked blocks. */
-void factor_vm::unmark_marked(heap *heap)
+void heap::unmark_marked()
 {
-	heap_block *scan = first_block(heap);
+	heap_block *scan = first_block();
 
 	while(scan)
 	{
 		if(scan->status == B_MARKED)
 			scan->status = B_ALLOCATED;
 
-		scan = next_block(heap,scan);
+		scan = next_block(scan);
 	}
 }
 
 /* After code GC, all referenced code blocks have status set to B_MARKED, so any
 which are allocated and not marked can be reclaimed. */
-void factor_vm::free_unmarked(heap *heap, heap_iterator iter)
+void heap::free_unmarked(heap_iterator iter)
 {
-	clear_free_list(heap);
+	clear_free_list();
 
 	heap_block *prev = NULL;
-	heap_block *scan = first_block(heap);
+	heap_block *scan = first_block();
 
 	while(scan)
 	{
 		switch(scan->status)
 		{
 		case B_ALLOCATED:
-			if(secure_gc)
+			if(myvm->secure_gc)
 				memset(scan + 1,0,scan->size - sizeof(heap_block));
 
 			if(prev && prev->status == B_FREE)
@@ -242,30 +241,30 @@ void factor_vm::free_unmarked(heap *heap, heap_iterator iter)
 			break;
 		case B_MARKED:
 			if(prev && prev->status == B_FREE)
-				add_to_free_list(heap,(free_heap_block *)prev);
+				add_to_free_list((free_heap_block *)prev);
 			scan->status = B_ALLOCATED;
 			prev = scan;
-			iter(scan,this);
+			iter(scan,myvm);
 			break;
 		default:
-			critical_error("Invalid scan->status",(cell)scan);
+			myvm->critical_error("Invalid scan->status",(cell)scan);
 		}
 
-		scan = next_block(heap,scan);
+		scan = next_block(scan);
 	}
 
 	if(prev && prev->status == B_FREE)
-		add_to_free_list(heap,(free_heap_block *)prev);
+		add_to_free_list((free_heap_block *)prev);
 }
 
 /* Compute total sum of sizes of free blocks, and size of largest free block */
-void factor_vm::heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free)
+void heap::heap_usage(cell *used, cell *total_free, cell *max_free)
 {
 	*used = 0;
 	*total_free = 0;
 	*max_free = 0;
 
-	heap_block *scan = first_block(heap);
+	heap_block *scan = first_block();
 
 	while(scan)
 	{
@@ -280,34 +279,34 @@ void factor_vm::heap_usage(heap *heap, cell *used, cell *total_free, cell *max_f
 				*max_free = scan->size;
 			break;
 		default:
-			critical_error("Invalid scan->status",(cell)scan);
+			myvm->critical_error("Invalid scan->status",(cell)scan);
 		}
 
-		scan = next_block(heap,scan);
+		scan = next_block(scan);
 	}
 }
 
 /* The size of the heap, not including the last block if it's free */
-cell factor_vm::heap_size(heap *heap)
+cell heap::heap_size()
 {
-	heap_block *scan = first_block(heap);
+	heap_block *scan = first_block();
 
-	while(next_block(heap,scan) != NULL)
+	while(next_block(scan) != NULL)
-		scan = next_block(heap,scan);
+		scan = next_block(scan);
 
 	/* this is the last block in the heap, and it is free */
 	if(scan->status == B_FREE)
-		return (cell)scan - heap->seg->start;
+		return (cell)scan - seg->start;
 	/* otherwise the last block is allocated */
 	else
-		return heap->seg->size;
+		return seg->size;
 }
 
 /* Compute where each block is going to go, after compaction */
-cell factor_vm::compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+cell heap::compute_heap_forwarding(unordered_map<heap_block *,char *> &forwarding)
 {
-	heap_block *scan = first_block(heap);
+	heap_block *scan = first_block();
-	char *address = (char *)first_block(heap);
+	char *address = (char *)first_block();
 
 	while(scan)
 	{
@@ -317,21 +316,21 @@ cell factor_vm::compute_heap_forwarding(heap *heap, unordered_map<heap_block *,c
 			address += scan->size;
 		}
 		else if(scan->status == B_MARKED)
-			critical_error("Why is the block marked?",0);
+			myvm->critical_error("Why is the block marked?",0);
 
-		scan = next_block(heap,scan);
+		scan = next_block(scan);
 	}
 
-	return (cell)address - heap->seg->start;
+	return (cell)address - seg->start;
 }
 
-void factor_vm::compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+void heap::compact_heap(unordered_map<heap_block *,char *> &forwarding)
 {
-	heap_block *scan = first_block(heap);
+	heap_block *scan = first_block();
 
 	while(scan)
 	{
-		heap_block *next = next_block(heap,scan);
+		heap_block *next = next_block(scan);
 
 		if(scan->status == B_ALLOCATED)
 			memmove(forwarding[scan],scan,scan->size);

vm/heap.hpp

@@ -0,0 +1,59 @@
+namespace factor
+{
+
+static const cell free_list_count = 16;
+static const cell block_size_increment = 32;
+
+struct heap_free_list {
+	free_heap_block *small_blocks[free_list_count];
+	free_heap_block *large_blocks;
+};
+
+typedef void (*heap_iterator)(heap_block *compiled, factor_vm *vm);
+
+struct heap {
+	factor_vm *myvm;
+	segment *seg;
+	heap_free_list free;
+
+	heap(factor_vm *myvm, cell size);
+
+	inline heap_block *next_block(heap_block *block)
+	{
+		cell next = ((cell)block + block->size);
+		if(next == seg->end)
+			return NULL;
+		else
+			return (heap_block *)next;
+	}
+	
+	inline heap_block *first_block()
+	{
+		return (heap_block *)seg->start;
+	}
+	
+	inline heap_block *last_block()
+	{
+		return (heap_block *)seg->end;
+	}
+
+	void clear_free_list();
+	void new_heap(cell size);
+	void add_to_free_list(free_heap_block *block);
+	void build_free_list(cell size);
+	void assert_free_block(free_heap_block *block);
+	free_heap_block *find_free_block(cell size);
+	free_heap_block *split_free_block(free_heap_block *block, cell size);
+	heap_block *heap_allot(cell size);
+	void heap_free(heap_block *block);
+	void mark_block(heap_block *block);
+	void unmark_marked();
+	void free_unmarked(heap_iterator iter);
+	void heap_usage(cell *used, cell *total_free, cell *max_free);
+	cell heap_size();
+	cell compute_heap_forwarding(unordered_map<heap_block *,char *> &forwarding);
+	void compact_heap(unordered_map<heap_block *,char *> &forwarding);
+
+};
+
+}

vm/image.cpp

@@ -56,7 +56,7 @@ void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
 
 	if(h->code_size != 0)
 	{
-		size_t bytes_read = fread(first_block(&code),1,h->code_size,file);
+		size_t bytes_read = fread(code->first_block(),1,h->code_size,file);
 		if(bytes_read != h->code_size)
 		{
 			print_string("truncated image: ");
@@ -69,7 +69,7 @@ void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
 	}
 
 	code_relocation_base = h->code_relocation_base;
-	build_free_list(&code,h->code_size);
+	code->build_free_list(h->code_size);
 }
 
 /* Save the current image to disk */
@@ -92,8 +92,8 @@ bool factor_vm::save_image(const vm_char *filename)
 	h.version = image_version;
 	h.data_relocation_base = tenured->start;
 	h.data_size = tenured->here - tenured->start;
-	h.code_relocation_base = code.seg->start;
+	h.code_relocation_base = code->seg->start;
-	h.code_size = heap_size(&code);
+	h.code_size = code->heap_size();
 
 	h.t = T;
 	h.bignum_zero = bignum_zero;
@@ -107,7 +107,7 @@ bool factor_vm::save_image(const vm_char *filename)
 
 	if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
 	if(fwrite((void*)tenured->start,h.data_size,1,file) != 1) ok = false;
-	if(fwrite(first_block(&code),h.code_size,1,file) != 1) ok = false;
+	if(fwrite(code->first_block(),h.code_size,1,file) != 1) ok = false;
 	if(fclose(file)) ok = false;
 
 	if(!ok)
@@ -128,10 +128,7 @@ inline void factor_vm::primitive_save_image()
 	save_image((vm_char *)(path.untagged() + 1));
 }
 
-PRIMITIVE(save_image)
+PRIMITIVE_FORWARD(save_image)
-{
-	PRIMITIVE_GETVM()->primitive_save_image();
-}
 
 inline void factor_vm::primitive_save_image_and_exit()
 {
@@ -159,10 +156,7 @@ inline void factor_vm::primitive_save_image_and_exit()
 		exit(1);
 }
 
-PRIMITIVE(save_image_and_exit)
+PRIMITIVE_FORWARD(save_image_and_exit)
-{	
-	PRIMITIVE_GETVM()->primitive_save_image_and_exit();
-}
 
 void factor_vm::data_fixup(cell *cell)
 {
@@ -181,7 +175,7 @@ void data_fixup(cell *cell, factor_vm *myvm)
 template <typename TYPE> void factor_vm::code_fixup(TYPE **handle)
 {
 	TYPE *ptr = *handle;
-	TYPE *new_ptr = (TYPE *)(((cell)ptr) + (code.seg->start - code_relocation_base));
+	TYPE *new_ptr = (TYPE *)(((cell)ptr) + (code->seg->start - code_relocation_base));
 	*handle = new_ptr;
 }
 

vm/inline_cache.cpp

@@ -24,7 +24,7 @@ void factor_vm::deallocate_inline_cache(cell return_address)
 #endif
 
 	if(old_type == PIC_TYPE)
-		heap_free(&code,old_block);
+		code->heap_free(old_block);
 }
 
 /* Figure out what kind of type check the PIC needs based on the methods
@@ -257,10 +257,7 @@ inline void factor_vm::primitive_reset_inline_cache_stats()
 	for(i = 0; i < 4; i++) pic_counts[i] = 0;
 }
 
-PRIMITIVE(reset_inline_cache_stats)
+PRIMITIVE_FORWARD(reset_inline_cache_stats)
-{
-	PRIMITIVE_GETVM()->primitive_reset_inline_cache_stats();
-}
 
 inline void factor_vm::primitive_inline_cache_stats()
 {
@@ -275,9 +272,6 @@ inline void factor_vm::primitive_inline_cache_stats()
 	dpush(stats.elements.value());
 }
 
-PRIMITIVE(inline_cache_stats)
+PRIMITIVE_FORWARD(inline_cache_stats)
-{
-	PRIMITIVE_GETVM()->primitive_inline_cache_stats();
-}
 
 }

vm/inlineimpls.hpp

@@ -4,13 +4,6 @@ namespace factor
 // I've had to copy inline implementations here to make dependencies work. Am hoping to move this code back into include files
 // once the rest of the reentrant changes are done. -PD
 
-// segments.hpp
-
-inline cell factor_vm::align_page(cell a)
-{
-	return align(a,getpagesize());
-}
-
 // write_barrier.hpp
 
 inline card *factor_vm::addr_to_card(cell a)

vm/io.cpp

@@ -52,10 +52,7 @@ inline void factor_vm::primitive_fopen()
 	}
 }
 
-PRIMITIVE(fopen)
+PRIMITIVE_FORWARD(fopen)
-{
-	PRIMITIVE_GETVM()->primitive_fopen();
-}
 
 inline void factor_vm::primitive_fgetc()
 {
@@ -82,10 +79,7 @@ inline void factor_vm::primitive_fgetc()
 	}
 }
 
-PRIMITIVE(fgetc)
+PRIMITIVE_FORWARD(fgetc)
-{
-	PRIMITIVE_GETVM()->primitive_fgetc();
-}
 
 inline void factor_vm::primitive_fread()
 {
@@ -127,10 +121,7 @@ inline void factor_vm::primitive_fread()
 	}
 }
 
-PRIMITIVE(fread)
+PRIMITIVE_FORWARD(fread)
-{
-	PRIMITIVE_GETVM()->primitive_fread();
-}
 
 inline void factor_vm::primitive_fputc()
 {
@@ -150,10 +141,7 @@ inline void factor_vm::primitive_fputc()
 	}
 }
 
-PRIMITIVE(fputc)
+PRIMITIVE_FORWARD(fputc)
-{
-	PRIMITIVE_GETVM()->primitive_fputc();
-}
 
 inline void factor_vm::primitive_fwrite()
 {
@@ -184,10 +172,7 @@ inline void factor_vm::primitive_fwrite()
 	}
 }
 
-PRIMITIVE(fwrite)
+PRIMITIVE_FORWARD(fwrite)
-{
-	PRIMITIVE_GETVM()->primitive_fwrite();
-}
 
 inline void factor_vm::primitive_fseek()
 {
@@ -214,10 +199,7 @@ inline void factor_vm::primitive_fseek()
 	}
 }
 
-PRIMITIVE(fseek)
+PRIMITIVE_FORWARD(fseek)
-{
-	PRIMITIVE_GETVM()->primitive_fseek();
-}
 
 inline void factor_vm::primitive_fflush()
 {
@@ -231,10 +213,7 @@ inline void factor_vm::primitive_fflush()
 	}
 }
 
-PRIMITIVE(fflush)
+PRIMITIVE_FORWARD(fflush)
-{
-	PRIMITIVE_GETVM()->primitive_fflush();
-}
 
 inline void factor_vm::primitive_fclose()
 {
@@ -248,10 +227,7 @@ inline void factor_vm::primitive_fclose()
 	}
 }
 
-PRIMITIVE(fclose)
+PRIMITIVE_FORWARD(fclose)
-{
-	PRIMITIVE_GETVM()->primitive_fclose();
-}
 
 /* This function is used by FFI I/O. Accessing the errno global directly is
 not portable, since on some libc's errno is not a global but a funky macro that

vm/master.hpp

@@ -64,7 +64,7 @@
 #include "math.hpp"
 #include "float_bits.hpp"
 #include "io.hpp"
-#include "code_gc.hpp"
+#include "heap.hpp"
 #include "code_heap.hpp"
 #include "image.hpp"
 #include "callstack.hpp"

vm/math.cpp

@@ -8,20 +8,14 @@ inline void factor_vm::primitive_bignum_to_fixnum()
 	drepl(tag_fixnum(bignum_to_fixnum(untag<bignum>(dpeek()))));
 }
 
-PRIMITIVE(bignum_to_fixnum)
+PRIMITIVE_FORWARD(bignum_to_fixnum)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_to_fixnum();
-}
 
 inline void factor_vm::primitive_float_to_fixnum()
 {
 	drepl(tag_fixnum(float_to_fixnum(dpeek())));
 }
 
-PRIMITIVE(float_to_fixnum)
+PRIMITIVE_FORWARD(float_to_fixnum)
-{
-	PRIMITIVE_GETVM()->primitive_float_to_fixnum();
-}
 
 /* Division can only overflow when we are dividing the most negative fixnum
 by -1. */
@@ -36,10 +30,7 @@ inline void factor_vm::primitive_fixnum_divint()
 		drepl(tag_fixnum(result));
 }
 
-PRIMITIVE(fixnum_divint)
+PRIMITIVE_FORWARD(fixnum_divint)
-{
-	PRIMITIVE_GETVM()->primitive_fixnum_divint();
-}
 
 inline void factor_vm::primitive_fixnum_divmod()
 {
@@ -57,10 +48,7 @@ inline void factor_vm::primitive_fixnum_divmod()
 	}
 }
 
-PRIMITIVE(fixnum_divmod)
+PRIMITIVE_FORWARD(fixnum_divmod)
-{
-	PRIMITIVE_GETVM()->primitive_fixnum_divmod();
-}
 
 /*
  * If we're shifting right by n bits, we won't overflow as long as none of the
@@ -108,30 +96,21 @@ inline void factor_vm::primitive_fixnum_shift()
 		fixnum_to_bignum(x),y)));
 }
 
-PRIMITIVE(fixnum_shift)
+PRIMITIVE_FORWARD(fixnum_shift)
-{
-	PRIMITIVE_GETVM()->primitive_fixnum_shift();
-}
 
 inline void factor_vm::primitive_fixnum_to_bignum()
 {
 	drepl(tag<bignum>(fixnum_to_bignum(untag_fixnum(dpeek()))));
 }
 
-PRIMITIVE(fixnum_to_bignum)
+PRIMITIVE_FORWARD(fixnum_to_bignum)
-{
-	PRIMITIVE_GETVM()->primitive_fixnum_to_bignum();
-}
 
 inline void factor_vm::primitive_float_to_bignum()
 {
 	drepl(tag<bignum>(float_to_bignum(dpeek())));
 }
 
-PRIMITIVE(float_to_bignum)
+PRIMITIVE_FORWARD(float_to_bignum)
-{
-	PRIMITIVE_GETVM()->primitive_float_to_bignum();
-}
 
 #define POP_BIGNUMS(x,y) \
 	bignum * y = untag<bignum>(dpop()); \
@@ -143,10 +122,7 @@ inline void factor_vm::primitive_bignum_eq()
 	box_boolean(bignum_equal_p(x,y));
 }
 
-PRIMITIVE(bignum_eq)
+PRIMITIVE_FORWARD(bignum_eq)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_eq();
-}
 
 inline void factor_vm::primitive_bignum_add()
 {
@@ -154,10 +130,7 @@ inline void factor_vm::primitive_bignum_add()
 	dpush(tag<bignum>(bignum_add(x,y)));
 }
 
-PRIMITIVE(bignum_add)
+PRIMITIVE_FORWARD(bignum_add)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_add();
-}
 
 inline void factor_vm::primitive_bignum_subtract()
 {
@@ -165,10 +138,7 @@ inline void factor_vm::primitive_bignum_subtract()
 	dpush(tag<bignum>(bignum_subtract(x,y)));
 }
 
-PRIMITIVE(bignum_subtract)
+PRIMITIVE_FORWARD(bignum_subtract)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_subtract();
-}
 
 inline void factor_vm::primitive_bignum_multiply()
 {
@@ -176,10 +146,7 @@ inline void factor_vm::primitive_bignum_multiply()
 	dpush(tag<bignum>(bignum_multiply(x,y)));
 }
 
-PRIMITIVE(bignum_multiply)
+PRIMITIVE_FORWARD(bignum_multiply)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_multiply();
-}
 
 inline void factor_vm::primitive_bignum_divint()
 {
@@ -187,10 +154,7 @@ inline void factor_vm::primitive_bignum_divint()
 	dpush(tag<bignum>(bignum_quotient(x,y)));
 }
 
-PRIMITIVE(bignum_divint)
+PRIMITIVE_FORWARD(bignum_divint)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_divint();
-}
 
 inline void factor_vm::primitive_bignum_divmod()
 {
@@ -201,10 +165,7 @@ inline void factor_vm::primitive_bignum_divmod()
 	dpush(tag<bignum>(r));
 }
 
-PRIMITIVE(bignum_divmod)
+PRIMITIVE_FORWARD(bignum_divmod)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_divmod();
-}
 
 inline void factor_vm::primitive_bignum_mod()
 {
@@ -212,10 +173,7 @@ inline void factor_vm::primitive_bignum_mod()
 	dpush(tag<bignum>(bignum_remainder(x,y)));
 }
 
-PRIMITIVE(bignum_mod)
+PRIMITIVE_FORWARD(bignum_mod)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_mod();
-}
 
 inline void factor_vm::primitive_bignum_and()
 {
@@ -223,10 +181,7 @@ inline void factor_vm::primitive_bignum_and()
 	dpush(tag<bignum>(bignum_bitwise_and(x,y)));
 }
 
-PRIMITIVE(bignum_and)
+PRIMITIVE_FORWARD(bignum_and)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_and();
-}
 
 inline void factor_vm::primitive_bignum_or()
 {
@@ -234,10 +189,7 @@ inline void factor_vm::primitive_bignum_or()
 	dpush(tag<bignum>(bignum_bitwise_ior(x,y)));
 }
 
-PRIMITIVE(bignum_or)
+PRIMITIVE_FORWARD(bignum_or)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_or();
-}
 
 inline void factor_vm::primitive_bignum_xor()
 {
@@ -245,10 +197,7 @@ inline void factor_vm::primitive_bignum_xor()
 	dpush(tag<bignum>(bignum_bitwise_xor(x,y)));
 }
 
-PRIMITIVE(bignum_xor)
+PRIMITIVE_FORWARD(bignum_xor)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_xor();
-}
 
 inline void factor_vm::primitive_bignum_shift()
 {
@@ -257,10 +206,7 @@ inline void factor_vm::primitive_bignum_shift()
 	dpush(tag<bignum>(bignum_arithmetic_shift(x,y)));
 }
 
-PRIMITIVE(bignum_shift)
+PRIMITIVE_FORWARD(bignum_shift)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_shift();
-}
 
 inline void factor_vm::primitive_bignum_less()
 {
@@ -268,10 +214,7 @@ inline void factor_vm::primitive_bignum_less()
 	box_boolean(bignum_compare(x,y) == bignum_comparison_less);
 }
 
-PRIMITIVE(bignum_less)
+PRIMITIVE_FORWARD(bignum_less)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_less();
-}
 
 inline void factor_vm::primitive_bignum_lesseq()
 {
@@ -279,10 +222,7 @@ inline void factor_vm::primitive_bignum_lesseq()
 	box_boolean(bignum_compare(x,y) != bignum_comparison_greater);
 }
 
-PRIMITIVE(bignum_lesseq)
+PRIMITIVE_FORWARD(bignum_lesseq)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_lesseq();
-}
 
 inline void factor_vm::primitive_bignum_greater()
 {
@@ -290,10 +230,7 @@ inline void factor_vm::primitive_bignum_greater()
 	box_boolean(bignum_compare(x,y) == bignum_comparison_greater);
 }
 
-PRIMITIVE(bignum_greater)
+PRIMITIVE_FORWARD(bignum_greater)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_greater();
-}
 
 inline void factor_vm::primitive_bignum_greatereq()
 {
@@ -301,20 +238,14 @@ inline void factor_vm::primitive_bignum_greatereq()
 	box_boolean(bignum_compare(x,y) != bignum_comparison_less);
 }
 
-PRIMITIVE(bignum_greatereq)
+PRIMITIVE_FORWARD(bignum_greatereq)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_greatereq();
-}
 
 inline void factor_vm::primitive_bignum_not()
 {
 	drepl(tag<bignum>(bignum_bitwise_not(untag<bignum>(dpeek()))));
 }
 
-PRIMITIVE(bignum_not)
+PRIMITIVE_FORWARD(bignum_not)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_not();
-}
 
 inline void factor_vm::primitive_bignum_bitp()
 {
@@ -323,20 +254,14 @@ inline void factor_vm::primitive_bignum_bitp()
 	box_boolean(bignum_logbitp(bit,x));
 }
 
-PRIMITIVE(bignum_bitp)
+PRIMITIVE_FORWARD(bignum_bitp)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_bitp();
-}
 
 inline void factor_vm::primitive_bignum_log2()
 {
 	drepl(tag<bignum>(bignum_integer_length(untag<bignum>(dpeek()))));
 }
 
-PRIMITIVE(bignum_log2)
+PRIMITIVE_FORWARD(bignum_log2)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_log2();
-}
 
 unsigned int factor_vm::bignum_producer(unsigned int digit)
 {
@@ -356,10 +281,7 @@ inline void factor_vm::primitive_byte_array_to_bignum()
 	drepl(tag<bignum>(result));
 }
 
-PRIMITIVE(byte_array_to_bignum)
+PRIMITIVE_FORWARD(byte_array_to_bignum)
-{
-	PRIMITIVE_GETVM()->primitive_byte_array_to_bignum();
-}
 
 cell factor_vm::unbox_array_size()
 {
@@ -399,20 +321,14 @@ inline void factor_vm::primitive_fixnum_to_float()
 	drepl(allot_float(fixnum_to_float(dpeek())));
 }
 
-PRIMITIVE(fixnum_to_float)
+PRIMITIVE_FORWARD(fixnum_to_float)
-{
-	PRIMITIVE_GETVM()->primitive_fixnum_to_float();
-}
 
 inline void factor_vm::primitive_bignum_to_float()
 {
 	drepl(allot_float(bignum_to_float(dpeek())));
 }
 
-PRIMITIVE(bignum_to_float)
+PRIMITIVE_FORWARD(bignum_to_float)
-{
-	PRIMITIVE_GETVM()->primitive_bignum_to_float();
-}
 
 inline void factor_vm::primitive_str_to_float()
 {
@@ -428,10 +344,7 @@ inline void factor_vm::primitive_str_to_float()
 		drepl(F);
 }
 
-PRIMITIVE(str_to_float)
+PRIMITIVE_FORWARD(str_to_float)
-{
-	PRIMITIVE_GETVM()->primitive_str_to_float();
-}
 
 inline void factor_vm::primitive_float_to_str()
 {
@@ -440,10 +353,7 @@ inline void factor_vm::primitive_float_to_str()
 	dpush(tag<byte_array>(array));
 }
 
-PRIMITIVE(float_to_str)
+PRIMITIVE_FORWARD(float_to_str)
-{
-	PRIMITIVE_GETVM()->primitive_float_to_str();
-}
 
 #define POP_FLOATS(x,y) \
 	double y = untag_float(dpop()); \
@@ -455,10 +365,7 @@ inline void factor_vm::primitive_float_eq()
 	box_boolean(x == y);
 }
 
-PRIMITIVE(float_eq)
+PRIMITIVE_FORWARD(float_eq)
-{
-	PRIMITIVE_GETVM()->primitive_float_eq();
-}
 
 inline void factor_vm::primitive_float_add()
 {
@@ -466,10 +373,7 @@ inline void factor_vm::primitive_float_add()
 	box_double(x + y);
 }
 
-PRIMITIVE(float_add)
+PRIMITIVE_FORWARD(float_add)
-{
-	PRIMITIVE_GETVM()->primitive_float_add();
-}
 
 inline void factor_vm::primitive_float_subtract()
 {
@@ -477,10 +381,7 @@ inline void factor_vm::primitive_float_subtract()
 	box_double(x - y);
 }
 
-PRIMITIVE(float_subtract)
+PRIMITIVE_FORWARD(float_subtract)
-{
-	PRIMITIVE_GETVM()->primitive_float_subtract();
-}
 
 inline void factor_vm::primitive_float_multiply()
 {
@@ -488,10 +389,7 @@ inline void factor_vm::primitive_float_multiply()
 	box_double(x * y);
 }
 
-PRIMITIVE(float_multiply)
+PRIMITIVE_FORWARD(float_multiply)
-{
-	PRIMITIVE_GETVM()->primitive_float_multiply();
-}
 
 inline void factor_vm::primitive_float_divfloat()
 {
@@ -499,10 +397,7 @@ inline void factor_vm::primitive_float_divfloat()
 	box_double(x / y);
 }
 
-PRIMITIVE(float_divfloat)
+PRIMITIVE_FORWARD(float_divfloat)
-{
-	PRIMITIVE_GETVM()->primitive_float_divfloat();
-}
 
 inline void factor_vm::primitive_float_mod()
 {
@@ -510,10 +405,7 @@ inline void factor_vm::primitive_float_mod()
 	box_double(fmod(x,y));
 }
 
-PRIMITIVE(float_mod)
+PRIMITIVE_FORWARD(float_mod)
-{
-	PRIMITIVE_GETVM()->primitive_float_mod();
-}
 
 inline void factor_vm::primitive_float_less()
 {
@@ -521,10 +413,7 @@ inline void factor_vm::primitive_float_less()
 	box_boolean(x < y);
 }
 
-PRIMITIVE(float_less)
+PRIMITIVE_FORWARD(float_less)
-{
-	PRIMITIVE_GETVM()->primitive_float_less();
-}
 
 inline void factor_vm::primitive_float_lesseq()
 {
@@ -532,10 +421,7 @@ inline void factor_vm::primitive_float_lesseq()
 	box_boolean(x <= y);
 }
 
-PRIMITIVE(float_lesseq)
+PRIMITIVE_FORWARD(float_lesseq)
-{
-	PRIMITIVE_GETVM()->primitive_float_lesseq();
-}
 
 inline void factor_vm::primitive_float_greater()
 {
@@ -543,10 +429,7 @@ inline void factor_vm::primitive_float_greater()
 	box_boolean(x > y);
 }
 
-PRIMITIVE(float_greater)
+PRIMITIVE_FORWARD(float_greater)
-{
-	PRIMITIVE_GETVM()->primitive_float_greater();
-}
 
 inline void factor_vm::primitive_float_greatereq()
 {
@@ -554,50 +437,35 @@ inline void factor_vm::primitive_float_greatereq()
 	box_boolean(x >= y);
 }
 
-PRIMITIVE(float_greatereq)
+PRIMITIVE_FORWARD(float_greatereq)
-{
-	PRIMITIVE_GETVM()->primitive_float_greatereq();
-}
 
 inline void factor_vm::primitive_float_bits()
 {
 	box_unsigned_4(float_bits(untag_float_check(dpop())));
 }
 
-PRIMITIVE(float_bits)
+PRIMITIVE_FORWARD(float_bits)
-{
-	PRIMITIVE_GETVM()->primitive_float_bits();
-}
 
 inline void factor_vm::primitive_bits_float()
 {
 	box_float(bits_float(to_cell(dpop())));
 }
 
-PRIMITIVE(bits_float)
+PRIMITIVE_FORWARD(bits_float)
-{
-	PRIMITIVE_GETVM()->primitive_bits_float();
-}
 
 inline void factor_vm::primitive_double_bits()
 {
 	box_unsigned_8(double_bits(untag_float_check(dpop())));
 }
 
-PRIMITIVE(double_bits)
+PRIMITIVE_FORWARD(double_bits)
-{
-	PRIMITIVE_GETVM()->primitive_double_bits();
-}
 
 inline void factor_vm::primitive_bits_double()
 {
 	box_double(bits_double(to_unsigned_8(dpop())));
 }
 
-PRIMITIVE(bits_double)
+PRIMITIVE_FORWARD(bits_double)
-{
-	PRIMITIVE_GETVM()->primitive_bits_double();
-}
 
 fixnum factor_vm::to_fixnum(cell tagged)
 {
@@ -838,7 +706,7 @@ inline void factor_vm::overflow_fixnum_add(fixnum x, fixnum y)
 		untag_fixnum(x) + untag_fixnum(y))));
 }
 
-VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *myvm)
+VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *myvm)
 {
 	PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_add(x,y);
 }
@@ -849,7 +717,7 @@ inline void factor_vm::overflow_fixnum_subtract(fixnum x, fixnum y)
 		untag_fixnum(x) - untag_fixnum(y))));
 }
 
-VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *myvm)
+VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *myvm)
 {
 	PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_subtract(x,y);
 }
@@ -863,7 +731,7 @@ inline void factor_vm::overflow_fixnum_multiply(fixnum x, fixnum y)
 	drepl(tag<bignum>(bignum_multiply(bx,by)));
 }
 
-VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *myvm)
+VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *myvm)
 {
 	PRIMITIVE_OVERFLOW_GETVM()->overflow_fixnum_multiply(x,y);
 }

vm/math.hpp

@@ -83,8 +83,8 @@ VM_C_API u64 to_unsigned_8(cell obj, factor_vm *vm);
 VM_C_API fixnum to_fixnum(cell tagged, factor_vm *vm);
 VM_C_API cell to_cell(cell tagged, factor_vm *vm);
 
-VM_ASM_API_OVERFLOW void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *vm);
+VM_ASM_API void overflow_fixnum_add(fixnum x, fixnum y, factor_vm *vm);
-VM_ASM_API_OVERFLOW void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *vm);
+VM_ASM_API void overflow_fixnum_subtract(fixnum x, fixnum y, factor_vm *vm);
-VM_ASM_API_OVERFLOW void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *vm);
+VM_ASM_API void overflow_fixnum_multiply(fixnum x, fixnum y, factor_vm *vm);
 
 }

vm/os-genunix.cpp

@@ -18,6 +18,7 @@ void early_init() { }
 #define SUFFIX ".image"
 #define SUFFIX_LEN 6
 
+/* You must delete[] the result yourself. */
 const char *default_image_path()
 {
 	const char *path = vm_executable_path();
@@ -31,7 +32,7 @@ const char *default_image_path()
 	const char *iter = path;
 	while(*iter) { len++; iter++; }
 
-	char *new_path = (char *)safe_malloc(PATH_MAX + SUFFIX_LEN + 1);
+	char *new_path = new char[PATH_MAX + SUFFIX_LEN + 1];
 	memcpy(new_path,path,len + 1);
 	memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1);
 	return new_path;

vm/os-linux.cpp

@@ -3,10 +3,10 @@
 namespace factor
 {
 
-/* Snarfed from SBCL linux-so.c. You must free() this yourself. */
+/* Snarfed from SBCL linux-so.c. You must delete[] the result yourself. */
 const char *vm_executable_path()
 {
-	char *path = (char *)safe_malloc(PATH_MAX + 1);
+	char *path = new char[PATH_MAX + 1];
 
 	int size = readlink("/proc/self/exe", path, PATH_MAX);
 	if (size < 0)

vm/os-unix.cpp

@@ -21,9 +21,8 @@ pthread_key_t tlsKey = 0;
 
 void init_platform_globals()
 {
-	if (pthread_key_create(&tlsKey, NULL) != 0){
+	if (pthread_key_create(&tlsKey, NULL) != 0)
 		fatal_error("pthread_key_create() failed",0);
-	}
 
 }
 
@@ -75,8 +74,6 @@ void factor_vm::ffi_dlclose(dll *dll)
 	dll->dll = NULL;
 }
 
-
-
 inline void factor_vm::primitive_existsp()
 {
 	struct stat sb;
@@ -84,13 +81,13 @@ inline void factor_vm::primitive_existsp()
 	box_boolean(stat(path,&sb) >= 0);
 }
 
-PRIMITIVE(existsp)
+PRIMITIVE_FORWARD(existsp)
-{
-	PRIMITIVE_GETVM()->primitive_existsp();
-}
 
-segment *factor_vm::alloc_segment(cell size)
+segment::segment(factor_vm *myvm_, cell size_)
 {
+	myvm = myvm_;
+	size = size_;
+
 	int pagesize = getpagesize();
 
 	char *array = (char *)mmap(NULL,pagesize + size + pagesize,
@@ -98,7 +95,7 @@ segment *factor_vm::alloc_segment(cell size)
 		MAP_ANON | MAP_PRIVATE,-1,0);
 
 	if(array == (char*)-1)
-		out_of_memory();
+		myvm->out_of_memory();
 
 	if(mprotect(array,pagesize,PROT_NONE) == -1)
 		fatal_error("Cannot protect low guard page",(cell)array);
@@ -106,26 +103,16 @@ segment *factor_vm::alloc_segment(cell size)
 	if(mprotect(array + pagesize + size,pagesize,PROT_NONE) == -1)
 		fatal_error("Cannot protect high guard page",(cell)array);
 
-	segment *retval = (segment *)safe_malloc(sizeof(segment));
+	start = (cell)(array + pagesize);
-
+	end = start + size;
-	retval->start = (cell)(array + pagesize);
-	retval->size = size;
-	retval->end = retval->start + size;
-
-	return retval;
 }
 
-void dealloc_segment(segment *block)
+segment::~segment()
 {
 	int pagesize = getpagesize();
-
+	int retval = munmap((void*)(start - pagesize),pagesize + size + pagesize);
-	int retval = munmap((void*)(block->start - pagesize),
-		pagesize + block->size + pagesize);
-	
 	if(retval)
-		fatal_error("dealloc_segment failed",0);
+		fatal_error("Segment deallocation failed",0);
-
-	free(block);
 }
   
 stack_frame *factor_vm::uap_stack_pointer(void *uap)

vm/os-windows-ce.cpp

@@ -30,10 +30,7 @@ char *getenv(char *name)
 	return 0; /* unreachable */
 }
 
-PRIMITIVE(os_envs)
+PRIMITIVE_FORWARD(os_envs)
-{
-	vm->not_implemented_error();
-}
 
 void c_to_factor_toplevel(cell quot)
 {

vm/os-windows.cpp

@@ -96,19 +96,19 @@ inline void factor_vm::primitive_existsp()
 	box_boolean(windows_stat(path));
 }
 
-PRIMITIVE(existsp)
+PRIMITIVE_FORWARD(existsp)
-{
-	PRIMITIVE_GETVM()->primitive_existsp();
-}
 
-segment *factor_vm::alloc_segment(cell size)
+segment::segment(factor_vm *myvm_, cell size_)
 {
+	myvm = myvm_;
+	size = size_;
+
 	char *mem;
 	DWORD ignore;
 
 	if((mem = (char *)VirtualAlloc(NULL, getpagesize() * 2 + size,
 		MEM_COMMIT, PAGE_EXECUTE_READWRITE)) == 0)
-		out_of_memory();
+		myvm->out_of_memory();
 
 	if (!VirtualProtect(mem, getpagesize(), PAGE_NOACCESS, &ignore))
 		fatal_error("Cannot allocate low guard page", (cell)mem);
@@ -117,25 +117,24 @@ segment *factor_vm::alloc_segment(cell size)
 		getpagesize(), PAGE_NOACCESS, &ignore))
 		fatal_error("Cannot allocate high guard page", (cell)mem);
 
-	segment *block = (segment *)safe_malloc(sizeof(segment));
+	start = (cell)mem + getpagesize();
-
+	end = start + size;
-	block->start = (cell)mem + getpagesize();
-	block->size = size;
-	block->end = block->start + size;
-
-	return block;
 }
 
-void factor_vm::dealloc_segment(segment *block)
+segment::~segment()
 {
 	SYSTEM_INFO si;
 	GetSystemInfo(&si);
-	if(!VirtualFree((void*)(block->start - si.dwPageSize), 0, MEM_RELEASE))
+	if(!VirtualFree((void*)(start - si.dwPageSize), 0, MEM_RELEASE))
-		fatal_error("dealloc_segment failed",0);
+		fatal_error("Segment deallocation failed",0);
-	free(block);
 }
 
-long factor_vm::getpagesize()
+void factor_vm::sleep_micros(u64 usec)
+{
+	Sleep((DWORD)(usec / 1000));
+}
+
+long getpagesize()
 {
 	static long g_pagesize = 0;
 	if (! g_pagesize)
@@ -147,9 +146,4 @@ long factor_vm::getpagesize()
 	return g_pagesize;
 }
 
-void factor_vm::sleep_micros(u64 usec)
-{
-	Sleep((DWORD)(usec / 1000));
-}
-
 }

vm/os-windows.hpp

@@ -45,5 +45,6 @@ inline static void init_signals() {}
 inline static void early_init() {}
 
 s64 current_micros();
+long getpagesize();
 
 }

vm/primitives.hpp

@@ -4,10 +4,17 @@ namespace factor
 #if defined(FACTOR_X86)
   extern "C" __attribute__ ((regparm (1))) typedef void (*primitive_type)(void *myvm);
   #define PRIMITIVE(name) extern "C" __attribute__ ((regparm (1)))  void primitive_##name(void *myvm)
+  #define PRIMITIVE_FORWARD(name) extern "C" __attribute__ ((regparm (1)))  void primitive_##name(void *myvm) \
+  {									\
+	PRIMITIVE_GETVM()->primitive_##name();				\
+  }
 #else
   extern "C" typedef void (*primitive_type)(void *myvm);
   #define PRIMITIVE(name) extern "C" void primitive_##name(void *myvm)
+  #define PRIMITIVE_FORWARD(name) extern "C" void primitive_##name(void *myvm) \
+  {									\
+	PRIMITIVE_GETVM()->primitive_##name();				\
+  }
 #endif
-
 extern const primitive_type primitives[];
 }

vm/profiler.cpp

@@ -52,9 +52,6 @@ inline void factor_vm::primitive_profiling()
 	set_profiling(to_boolean(dpop()));
 }
 
-PRIMITIVE(profiling)
+PRIMITIVE_FORWARD(profiling)
-{
-	PRIMITIVE_GETVM()->primitive_profiling();
-}
 
 }

vm/quotations.cpp

@@ -36,51 +36,47 @@ includes stack shufflers, some fixnum arithmetic words, and words such as tag,
 slot and eq?. A primitive call is relatively expensive (two subroutine calls)
 so this results in a big speedup for relatively little effort. */
 
-bool quotation_jit::primitive_call_p(cell i)
+bool quotation_jit::primitive_call_p(cell i, cell length)
 {
-	return (i + 2) == array_capacity(elements.untagged())
+	return (i + 2) == length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_PRIMITIVE_WORD];
-		&& tagged<object>(array_nth(elements.untagged(),i)).type_p(FIXNUM_TYPE)
-		&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_PRIMITIVE_WORD];
 }
 
-bool quotation_jit::fast_if_p(cell i)
+bool quotation_jit::fast_if_p(cell i, cell length)
 {
-	return (i + 3) == array_capacity(elements.untagged())
+	return (i + 3) == length
-		&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
 		&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(QUOTATION_TYPE)
 		&& array_nth(elements.untagged(),i + 2) == parent_vm->userenv[JIT_IF_WORD];
 }
 
-bool quotation_jit::fast_dip_p(cell i)
+bool quotation_jit::fast_dip_p(cell i, cell length)
 {
-	return (i + 2) <= array_capacity(elements.untagged())
+	return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DIP_WORD];
-		&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
-		&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DIP_WORD];
 }
 
-bool quotation_jit::fast_2dip_p(cell i)
+bool quotation_jit::fast_2dip_p(cell i, cell length)
 {
-	return (i + 2) <= array_capacity(elements.untagged())
+	return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_2DIP_WORD];
-		&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
-		&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_2DIP_WORD];
 }
 
-bool quotation_jit::fast_3dip_p(cell i)
+bool quotation_jit::fast_3dip_p(cell i, cell length)
 {
-	return (i + 2) <= array_capacity(elements.untagged())
+	return (i + 2) <= length && array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_3DIP_WORD];
-		&& tagged<object>(array_nth(elements.untagged(),i)).type_p(QUOTATION_TYPE)
-		&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_3DIP_WORD];
 }
 
-bool quotation_jit::mega_lookup_p(cell i)
+bool quotation_jit::mega_lookup_p(cell i, cell length)
 {
-	return (i + 3) < array_capacity(elements.untagged())
+	return (i + 4) <= length
-		&& tagged<object>(array_nth(elements.untagged(),i)).type_p(ARRAY_TYPE)
 		&& tagged<object>(array_nth(elements.untagged(),i + 1)).type_p(FIXNUM_TYPE)
 		&& tagged<object>(array_nth(elements.untagged(),i + 2)).type_p(ARRAY_TYPE)
 		&& array_nth(elements.untagged(),i + 3) == parent_vm->userenv[MEGA_LOOKUP_WORD];
 }
 
+bool quotation_jit::declare_p(cell i, cell length)
+{
+	return (i + 2) <= length
+		&& array_nth(elements.untagged(),i + 1) == parent_vm->userenv[JIT_DECLARE_WORD];
+}
+
 bool quotation_jit::stack_frame_p()
 {
 	fixnum length = array_capacity(elements.untagged());
@@ -96,7 +92,7 @@ bool quotation_jit::stack_frame_p()
 				return true;
 			break;
 		case QUOTATION_TYPE:
-			if(fast_dip_p(i) || fast_2dip_p(i) || fast_3dip_p(i))
+			if(fast_dip_p(i,length) || fast_2dip_p(i,length) || fast_3dip_p(i,length))
 				return true;
 			break;
 		default:
@@ -179,19 +175,21 @@ void quotation_jit::iterate_quotation()
 			break;
 		case FIXNUM_TYPE:
 			/* Primitive calls */
-			if(primitive_call_p(i))
+			if(primitive_call_p(i,length))
 			{
 				emit_with(parent_vm->userenv[JIT_PRIMITIVE],obj.value());
 
 				i++;
 
 				tail_call = true;
-				break;
 			}
+			else
+				push(obj.value());
+			break;
 		case QUOTATION_TYPE:
 			/* 'if' preceeded by two literal quotations (this is why if and ? are
 			   mutually recursive in the library, but both still work) */
-			if(fast_if_p(i))
+			if(fast_if_p(i,length))
 			{
 				if(stack_frame) emit(parent_vm->userenv[JIT_EPILOG]);
 				tail_call = true;
@@ -207,39 +205,37 @@ void quotation_jit::iterate_quotation()
 				emit(parent_vm->userenv[JIT_IF]);
 
 				i += 2;
-
-				break;
 			}
 			/* dip */
-			else if(fast_dip_p(i))
+			else if(fast_dip_p(i,length))
 			{
 				if(compiling)
 					parent_vm->jit_compile(obj.value(),relocate);
 				emit_with(parent_vm->userenv[JIT_DIP],obj.value());
 				i++;
-				break;
 			}
 			/* 2dip */
-			else if(fast_2dip_p(i))
+			else if(fast_2dip_p(i,length))
 			{
 				if(compiling)
 					parent_vm->jit_compile(obj.value(),relocate);
 				emit_with(parent_vm->userenv[JIT_2DIP],obj.value());
 				i++;
-				break;
 			}
 			/* 3dip */
-			else if(fast_3dip_p(i))
+			else if(fast_3dip_p(i,length))
 			{
 				if(compiling)
 					parent_vm->jit_compile(obj.value(),relocate);
 				emit_with(parent_vm->userenv[JIT_3DIP],obj.value());
 				i++;
-				break;
 			}
+			else
+				push(obj.value());
+			break;
 		case ARRAY_TYPE:
 			/* Method dispatch */
-			if(mega_lookup_p(i))
+			if(mega_lookup_p(i,length))
 			{
 				emit_mega_cache_lookup(
 					array_nth(elements.untagged(),i),
@@ -247,8 +243,13 @@ void quotation_jit::iterate_quotation()
 					array_nth(elements.untagged(),i + 2));
 				i += 3;
 				tail_call = true;
-				break;
 			}
+			/* Non-optimizing compiler ignores declarations */
+			else if(declare_p(i,length))
+				i++;
+			else
+				push(obj.value());
+			break;
 		default:
 			push(obj.value());
 			break;
@@ -294,10 +295,7 @@ inline void factor_vm::primitive_jit_compile()
 	jit_compile(dpop(),true);
 }
 
-PRIMITIVE(jit_compile)
+PRIMITIVE_FORWARD(jit_compile)
-{
-	PRIMITIVE_GETVM()->primitive_jit_compile();
-}
 
 /* push a new quotation on the stack */
 inline void factor_vm::primitive_array_to_quotation()
@@ -311,10 +309,7 @@ inline void factor_vm::primitive_array_to_quotation()
 	drepl(tag<quotation>(quot));
 }
 
-PRIMITIVE(array_to_quotation)
+PRIMITIVE_FORWARD(array_to_quotation)
-{
-	PRIMITIVE_GETVM()->primitive_array_to_quotation();
-}
 
 inline void factor_vm::primitive_quotation_xt()
 {
@@ -322,10 +317,7 @@ inline void factor_vm::primitive_quotation_xt()
 	drepl(allot_cell((cell)quot->xt));
 }
 
-PRIMITIVE(quotation_xt)
+PRIMITIVE_FORWARD(quotation_xt)
-{
-	PRIMITIVE_GETVM()->primitive_quotation_xt();
-}
 
 void factor_vm::compile_all_words()
 {
@@ -368,7 +360,7 @@ cell factor_vm::lazy_jit_compile_impl(cell quot_, stack_frame *stack)
 	return quot.value();
 }
 
-VM_ASM_API_OVERFLOW cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *myvm)
+VM_ASM_API cell lazy_jit_compile_impl(cell quot_, stack_frame *stack, factor_vm *myvm)
 {
 	ASSERTVM();
 	return VM_PTR->lazy_jit_compile_impl(quot_,stack);
@@ -381,9 +373,6 @@ inline void factor_vm::primitive_quot_compiled_p()
 	dpush(tag_boolean(quot->code != NULL));
 }
 
-PRIMITIVE(quot_compiled_p)
+PRIMITIVE_FORWARD(quot_compiled_p)
-{
-	PRIMITIVE_GETVM()->primitive_quot_compiled_p();
-}
 
 }

vm/quotations.hpp

@@ -12,12 +12,13 @@ struct quotation_jit : public jit {
 		  relocate(relocate_){};
 
 	void emit_mega_cache_lookup(cell methods, fixnum index, cell cache);
-	bool primitive_call_p(cell i);
+	bool primitive_call_p(cell i, cell length);
-	bool fast_if_p(cell i);
+	bool fast_if_p(cell i, cell length);
-	bool fast_dip_p(cell i);
+	bool fast_dip_p(cell i, cell length);
-	bool fast_2dip_p(cell i);
+	bool fast_2dip_p(cell i, cell length);
-	bool fast_3dip_p(cell i);
+	bool fast_3dip_p(cell i, cell length);
-	bool mega_lookup_p(cell i);
+	bool mega_lookup_p(cell i, cell length);
+	bool declare_p(cell i, cell length);
 	bool stack_frame_p();
 	void iterate_quotation();
 };
@@ -27,7 +28,7 @@ PRIMITIVE(jit_compile);
 PRIMITIVE(array_to_quotation);
 PRIMITIVE(quotation_xt);
 
-VM_ASM_API_OVERFLOW cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *myvm);
+VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack, factor_vm *myvm);
 
 PRIMITIVE(quot_compiled_p);
 

vm/run.cpp

@@ -9,10 +9,7 @@ inline void factor_vm::primitive_getenv()
 	drepl(userenv[e]);
 }
 
-PRIMITIVE(getenv)
+PRIMITIVE_FORWARD(getenv)
-{
-	PRIMITIVE_GETVM()->primitive_getenv();
-}
 
 inline void factor_vm::primitive_setenv()
 {
@@ -21,40 +18,28 @@ inline void factor_vm::primitive_setenv()
 	userenv[e] = value;
 }
 
-PRIMITIVE(setenv)
+PRIMITIVE_FORWARD(setenv)
-{
-	PRIMITIVE_GETVM()->primitive_setenv();
-}
 
 inline void factor_vm::primitive_exit()
 {
 	exit(to_fixnum(dpop()));
 }
 
-PRIMITIVE(exit)
+PRIMITIVE_FORWARD(exit)
-{
-	PRIMITIVE_GETVM()->primitive_exit();
-}
 
 inline void factor_vm::primitive_micros()
 {
 	box_unsigned_8(current_micros());
 }
 
-PRIMITIVE(micros)
+PRIMITIVE_FORWARD(micros)
-{
-	PRIMITIVE_GETVM()->primitive_micros();
-}
 
 inline void factor_vm::primitive_sleep()
 {
 	sleep_micros(to_cell(dpop()));
 }
 
-PRIMITIVE(sleep)
+PRIMITIVE_FORWARD(sleep)
-{
-	PRIMITIVE_GETVM()->primitive_sleep();
-}
 
 inline void factor_vm::primitive_set_slot()
 {
@@ -66,10 +51,7 @@ inline void factor_vm::primitive_set_slot()
 	write_barrier(obj);
 }
 
-PRIMITIVE(set_slot)
+PRIMITIVE_FORWARD(set_slot)
-{
-	PRIMITIVE_GETVM()->primitive_set_slot();
-}
 
 inline void factor_vm::primitive_load_locals()
 {
@@ -79,10 +61,7 @@ inline void factor_vm::primitive_load_locals()
 	rs += sizeof(cell) * count;
 }
 
-PRIMITIVE(load_locals)
+PRIMITIVE_FORWARD(load_locals)
-{
-	PRIMITIVE_GETVM()->primitive_load_locals();
-}
 
 cell factor_vm::clone_object(cell obj_)
 {
@@ -104,9 +83,6 @@ inline void factor_vm::primitive_clone()
 	drepl(clone_object(dpeek()));
 }
 
-PRIMITIVE(clone)
+PRIMITIVE_FORWARD(clone)
-{
-	PRIMITIVE_GETVM()->primitive_clone();
-}
 
 }

vm/run.hpp

@@ -57,6 +57,7 @@ enum special_object {
 	JIT_EXECUTE_WORD,
 	JIT_EXECUTE_JUMP,
 	JIT_EXECUTE_CALL,
+	JIT_DECLARE_WORD,
 
 	/* Polymorphic inline cache generation in inline_cache.c */
 	PIC_LOAD            = 47,

vm/segments.hpp

@@ -1,10 +1,23 @@
 namespace factor
 {
 
+struct factor_vm;
+
+inline cell align_page(cell a)
+{
+	return align(a,getpagesize());
+}
+
+/* segments set up guard pages to check for under/overflow.
+size must be a multiple of the page size */
 struct segment {
+	factor_vm *myvm;
 	cell start;
 	cell size;
 	cell end;
+
+	segment(factor_vm *myvm, cell size);
+	~segment();
 };
 
 }

vm/strings.cpp

@@ -106,10 +106,7 @@ inline void factor_vm::primitive_string()
 	dpush(tag<string>(allot_string(length,initial)));
 }
 
-PRIMITIVE(string)
+PRIMITIVE_FORWARD(string)
-{
-	PRIMITIVE_GETVM()->primitive_string();
-}
 
 bool factor_vm::reallot_string_in_place_p(string *str, cell capacity)
 {
@@ -167,10 +164,7 @@ inline void factor_vm::primitive_resize_string()
 	dpush(tag<string>(reallot_string(str,capacity)));
 }
 
-PRIMITIVE(resize_string)
+PRIMITIVE_FORWARD(resize_string)
-{
-	PRIMITIVE_GETVM()->primitive_resize_string();
-}
 
 inline void factor_vm::primitive_string_nth()
 {
@@ -179,10 +173,7 @@ inline void factor_vm::primitive_string_nth()
 	dpush(tag_fixnum(string_nth(str,index)));
 }
 
-PRIMITIVE(string_nth)
+PRIMITIVE_FORWARD(string_nth)
-{
-	PRIMITIVE_GETVM()->primitive_string_nth();
-}
 
 inline void factor_vm::primitive_set_string_nth_fast()
 {
@@ -192,10 +183,7 @@ inline void factor_vm::primitive_set_string_nth_fast()
 	set_string_nth_fast(str,index,value);
 }
 
-PRIMITIVE(set_string_nth_fast)
+PRIMITIVE_FORWARD(set_string_nth_fast)
-{
-	PRIMITIVE_GETVM()->primitive_set_string_nth_fast();
-}
 
 inline void factor_vm::primitive_set_string_nth_slow()
 {
@@ -205,9 +193,6 @@ inline void factor_vm::primitive_set_string_nth_slow()
 	set_string_nth_slow(str,index,value);
 }
 
-PRIMITIVE(set_string_nth_slow)
+PRIMITIVE_FORWARD(set_string_nth_slow)
-{
-	PRIMITIVE_GETVM()->primitive_set_string_nth_slow();
-}
 
 }

vm/tuples.cpp

@@ -23,10 +23,7 @@ inline void factor_vm::primitive_tuple()
 	dpush(tag<tuple>(t));
 }
 
-PRIMITIVE(tuple)
+PRIMITIVE_FORWARD(tuple)
-{
-	PRIMITIVE_GETVM()->primitive_tuple();
-}
 
 /* push a new tuple on the stack, filling its slots from the stack */
 inline void factor_vm::primitive_tuple_boa()
@@ -39,9 +36,6 @@ inline void factor_vm::primitive_tuple_boa()
 	dpush(t.value());
 }
 
-PRIMITIVE(tuple_boa)
+PRIMITIVE_FORWARD(tuple_boa)
-{
-	PRIMITIVE_GETVM()->primitive_tuple_boa();
-}
 
 }

vm/utilities.cpp

@@ -4,13 +4,6 @@ namespace factor
 {
 
 /* If memory allocation fails, bail out */
-void *safe_malloc(size_t size)
-{
-	void *ptr = malloc(size);
-	if(!ptr) fatal_error("Out of memory in safe_malloc", 0);
-	return ptr;
-}
-
 vm_char *safe_strdup(const vm_char *str)
 {
 	vm_char *ptr = STRDUP(str);

vm/utilities.hpp

@@ -1,6 +1,5 @@
 namespace factor
 {
-	void *safe_malloc(size_t size);
 	vm_char *safe_strdup(const vm_char *str);
 	void print_string(const char *str);
 	void nl();

vm/vm-data.hpp

@@ -83,8 +83,8 @@ struct factor_vm_data {
 	cell bignum_neg_one;	
 
 	//code_heap
-	heap code;
+	heap *code;
-	unordered_map<heap_block *,char *> forwarding;
+	unordered_map<heap_block *, char *> forwarding;
 
 	//image
 	cell code_relocation_base;

vm/vm.hpp

@@ -5,9 +5,6 @@ namespace factor
 
 struct factor_vm : factor_vm_data {
 
-	// segments
-	inline cell align_page(cell a);
-
 	// contexts
 	void reset_datastack();
 	void reset_retainstack();
@@ -127,11 +124,8 @@ struct factor_vm : factor_vm_data {
 	bignum *digit_stream_to_bignum(unsigned int n_digits, unsigned int (*producer)(unsigned int, factor_vm *), unsigned int radix, int negative_p);
 
 	//data_heap
-	cell init_zone(zone *z, cell size, cell start);
 	void init_card_decks();
-	data_heap *alloc_data_heap(cell gens, cell young_size,cell aging_size,cell tenured_size);
 	data_heap *grow_data_heap(data_heap *data, cell requested_bytes);
-	void dealloc_data_heap(data_heap *data);
 	void clear_cards(cell from, cell to);
 	void clear_decks(cell from, cell to);
 	void clear_allot_markers(cell from, cell to);
@@ -381,24 +375,6 @@ struct factor_vm : factor_vm_data {
 	inline void primitive_fflush();
 	inline void primitive_fclose();
 
-	//code_gc
-	void clear_free_list(heap *heap);
-	void new_heap(heap *heap, cell size);
-	void add_to_free_list(heap *heap, free_heap_block *block);
-	void build_free_list(heap *heap, cell size);
-	void assert_free_block(free_heap_block *block);
-	free_heap_block *find_free_block(heap *heap, cell size);
-	free_heap_block *split_free_block(heap *heap, free_heap_block *block, cell size);
-	heap_block *heap_allot(heap *heap, cell size);
-	void heap_free(heap *heap, heap_block *block);
-	void mark_block(heap_block *block);
-	void unmark_marked(heap *heap);
-	void free_unmarked(heap *heap, heap_iterator iter);
-	void heap_usage(heap *heap, cell *used, cell *total_free, cell *max_free);
-	cell heap_size(heap *heap);
-	cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding);
-	void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding);
-
 	//code_block
 	relocation_type relocation_type_of(relocation_entry r);
 	relocation_class relocation_class_of(relocation_entry r);
@@ -578,14 +554,11 @@ struct factor_vm : factor_vm_data {
 	void ffi_dlopen(dll *dll);
 	void *ffi_dlsym(dll *dll, symbol_char *symbol);
 	void ffi_dlclose(dll *dll);
-	segment *alloc_segment(cell size);
 	void c_to_factor_toplevel(cell quot);
 
 	// os-windows
   #if defined(WINDOWS)
 	void sleep_micros(u64 usec);
-	long getpagesize();
-	void dealloc_segment(segment *block);
 	const vm_char *vm_executable_path();
 	const vm_char *default_image_path();
 	void windows_image_path(vm_char *full_path, vm_char *temp_path, unsigned int length);

vm/words.cpp

@@ -39,24 +39,27 @@ inline void factor_vm::primitive_word()
 	dpush(tag<word>(allot_word(vocab,name)));
 }
 
-PRIMITIVE(word)
+PRIMITIVE_FORWARD(word)
-{
-	PRIMITIVE_GETVM()->primitive_word();
-}
 
 /* word-xt ( word -- start end ) */
 inline void factor_vm::primitive_word_xt()
 {
-	word *w = untag_check<word>(dpop());
+	gc_root<word> w(dpop(),this);
-	code_block *code = (profiling_p ? w->profiling : w->code);
+	w.untag_check(this);
-	dpush(allot_cell((cell)code->xt()));
+
-	dpush(allot_cell((cell)code + code->size));
+	if(profiling_p)
+	{
+		dpush(allot_cell((cell)w->profiling->xt()));
+		dpush(allot_cell((cell)w->profiling + w->profiling->size));
+	}
+	else
+	{
+		dpush(allot_cell((cell)w->code->xt()));
+		dpush(allot_cell((cell)w->code + w->code->size));
+	}
 }
 
-PRIMITIVE(word_xt)
+PRIMITIVE_FORWARD(word_xt)
-{
-	PRIMITIVE_GETVM()->primitive_word_xt();
-}
 
 /* Allocates memory */
 void factor_vm::update_word_xt(cell w_)
@@ -85,10 +88,7 @@ inline void factor_vm::primitive_optimized_p()
 	drepl(tag_boolean(word_optimized_p(untag_check<word>(dpeek()))));
 }
 
-PRIMITIVE(optimized_p)
+PRIMITIVE_FORWARD(optimized_p)
-{
-	PRIMITIVE_GETVM()->primitive_optimized_p();
-}
 
 inline void factor_vm::primitive_wrapper()
 {
@@ -97,9 +97,6 @@ inline void factor_vm::primitive_wrapper()
 	drepl(tag<wrapper>(new_wrapper));
 }
 
-PRIMITIVE(wrapper)
+PRIMITIVE_FORWARD(wrapper)
-{
-	PRIMITIVE_GETVM()->primitive_wrapper();
-}
 
 }