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

basis/alien/remote-control/remote-control.factor

@@ -1,18 +1,19 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.data alien.strings parser
+USING: accessors alien alien.c-types alien.data alien.strings
-threads words kernel.private kernel io.encodings.utf8 eval ;
+parser threads words kernel.private kernel io.encodings.utf8
+eval ;
 IN: alien.remote-control
 
 : eval-callback ( -- callback )
-    "void*" { "char*" } "cdecl"
+    void* { char* } "cdecl"
     [ eval>string utf8 malloc-string ] alien-callback ;
 
 : yield-callback ( -- callback )
-    "void" { } "cdecl" [ yield ] alien-callback ;
+    void { } "cdecl" [ yield ] alien-callback ;
 
 : sleep-callback ( -- callback )
-    "void" { "long" } "cdecl" [ sleep ] alien-callback ;
+    void { long } "cdecl" [ sleep ] alien-callback ;
 
 : ?callback ( word -- alien )
     dup optimized? [ execute ] [ drop f ] if ; inline

basis/compiler/alien/alien.factor

@@ -9,10 +9,10 @@ IN: compiler.alien
 
 : alien-parameters ( params -- seq )
     dup parameters>>
-    swap return>> large-struct? [ "void*" prefix ] when ;
+    swap return>> large-struct? [ void* prefix ] when ;
 
 : alien-return ( params -- ctype )
-    return>> dup large-struct? [ drop "void" ] when ;
+    return>> dup large-struct? [ drop void ] when ;
 
 : c-type-stack-align ( type -- align )
     dup c-type-stack-align? [ c-type-align ] [ drop cell ] if ;
@@ -20,8 +20,7 @@ IN: compiler.alien
 : parameter-align ( n type -- n delta )
     [ c-type-stack-align align dup ] [ drop ] 2bi - ;
 
-: parameter-sizes ( types -- total offsets )
+: parameter-offsets ( types -- total offsets )
-    #! Compute stack frame locations.
     [
         0 [
             [ parameter-align drop dup , ] keep stack-size +

basis/compiler/cfg/build-stack-frame/build-stack-frame.factor

@@ -27,7 +27,9 @@ M: ##call compute-stack-frame*
 
 M: ##gc compute-stack-frame*
     frame-required? on
-    stack-frame new swap tagged-values>> length cells >>gc-root-size
+    stack-frame new
+        swap tagged-values>> length cells >>gc-root-size
+        t >>calls-vm?
     request-stack-frame ;
 
 M: _spill-area-size compute-stack-frame*

basis/compiler/cfg/builder/builder.factor

@@ -212,7 +212,8 @@ M: #terminate emit-node drop ##no-tco end-basic-block ;
     stack-frame new
         swap
         [ return>> return-size >>return ]
-        [ alien-parameters parameter-sizes drop >>params ] bi ;
+        [ alien-parameters parameter-offsets drop >>params ] bi
+        t >>calls-vm? ;
 
 : alien-node-height ( params -- )
     [ out-d>> length ] [ in-d>> length ] bi - adjust-d ;

basis/compiler/cfg/stack-frame/stack-frame.factor

@@ -9,7 +9,8 @@ TUPLE: stack-frame
 { return integer }
 { total-size integer }
 { gc-root-size integer }
-{ spill-area-size integer } ;
+{ spill-area-size integer }
+{ calls-vm? boolean } ;
 
 ! Stack frame utilities
 : param-base ( -- n )
@@ -35,7 +36,9 @@ TUPLE: stack-frame
 
 : max-stack-frame ( frame1 frame2 -- frame3 )
     [ stack-frame new ] 2dip
+    {
         [ [ params>> ] bi@ max >>params ]
         [ [ return>> ] bi@ max >>return ]
         [ [ gc-root-size>> ] bi@ max >>gc-root-size ]
-        2tri ;
+        [ [ calls-vm?>> ] bi@ or >>calls-vm? ]
+    } 2cleave ;

basis/compiler/codegen/codegen.factor

@@ -333,35 +333,29 @@ M: reg-class reg-class-full?
     [ alloc-stack-param ] [ alloc-fastcall-param ] if
     [ param-reg ] dip ;
 
-: (flatten-int-type) ( size -- seq )
+: (flatten-int-type) ( type -- seq )
-    cell /i "void*" c-type <repetition> ;
+    stack-size cell align cell /i void* c-type <repetition> ;
 
 GENERIC: flatten-value-type ( type -- types )
 
 M: object flatten-value-type 1array ;
-
+M: struct-c-type flatten-value-type (flatten-int-type) ;
-M: struct-c-type flatten-value-type ( type -- types )
+M: long-long-type flatten-value-type (flatten-int-type) ;
-    stack-size cell align (flatten-int-type) ;
+M: c-type-name flatten-value-type c-type flatten-value-type ;
-
-M: long-long-type flatten-value-type ( type -- types )
-    stack-size cell align (flatten-int-type) ;
 
 : flatten-value-types ( params -- params )
     #! Convert value type structs to consecutive void*s.
     [
         0 [
             c-type
-            [ parameter-align (flatten-int-type) % ] keep
+            [ parameter-align cell /i void* c-type <repetition> % ] keep
             [ stack-size cell align + ] keep
             flatten-value-type %
         ] reduce drop
     ] { } make ;
 
 : each-parameter ( parameters quot -- )
-    [ [ parameter-sizes nip ] keep ] dip 2each ; inline
+    [ [ parameter-offsets nip ] keep ] dip 2each ; inline
-
-: reverse-each-parameter ( parameters quot -- )
-    [ [ parameter-sizes nip ] keep ] dip 2reverse-each ; inline
 
 : reset-fastcall-counts ( -- )
     { int-regs float-regs stack-params } [ 0 swap set ] each ;
@@ -378,10 +372,17 @@ M: long-long-type flatten-value-type ( type -- types )
     [ '[ alloc-parameter _ execute ] ]
     bi* each-parameter ; inline
 
+: reverse-each-parameter ( parameters quot -- )
+    [ [ parameter-offsets nip ] keep ] dip 2reverse-each ; inline
+
+: prepare-unbox-parameters ( parameters -- offsets types indices )
+    [ parameter-offsets nip ] [ ] [ length iota reverse ] tri ;
+
 : unbox-parameters ( offset node -- )
-    parameters>> [
+    parameters>> swap
-        %prepare-unbox [ over + ] dip unbox-parameter
+    '[ prepare-unbox-parameters [ %prepare-unbox [ _ + ] dip unbox-parameter ] 3each ]
-    ] reverse-each-parameter drop ;
+    [ length neg %inc-d ]
+    bi ;
 
 : prepare-box-struct ( node -- offset )
     #! Return offset on C stack where to store unboxed
@@ -413,7 +414,7 @@ M: long-long-type flatten-value-type ( type -- types )
     ] if ;
 
 : stdcall-mangle ( symbol params -- symbol )
-    parameters>> parameter-sizes drop number>string "@" glue ;
+    parameters>> parameter-offsets drop number>string "@" glue ;
 
 : alien-invoke-dlsym ( params -- symbols dll )
     [ [ function>> dup ] keep stdcall-mangle 2array ]

basis/cpu/architecture/architecture.factor

@@ -463,7 +463,7 @@ HOOK: dummy-int-params? cpu ( -- ? )
 ! If t, all int parameters are shadowed by dummy FP parameters
 HOOK: dummy-fp-params? cpu ( -- ? )
 
-HOOK: %prepare-unbox cpu ( -- )
+HOOK: %prepare-unbox cpu ( n -- )
 
 HOOK: %unbox cpu ( n rep func -- )
 

basis/cpu/ppc/ppc.factor

@@ -577,10 +577,8 @@ M:: ppc %save-param-reg ( stack reg rep -- )
 M:: ppc %load-param-reg ( stack reg rep -- )
     reg stack local@ rep load-from-frame ;
 
-M: ppc %prepare-unbox ( -- )
+M: ppc %prepare-unbox ( n -- )
-    ! First parameter is top of stack
+    [ 3 ] dip <ds-loc> loc>operand LWZ ;
-    3 ds-reg 0 LWZ
-    ds-reg dup cell SUBI ;
 
 M: ppc %unbox ( n rep func -- )
     ! Value must be in r3

basis/cpu/x86/32/32.factor

@@ -25,6 +25,11 @@ M: x86.32 rs-reg EDI ;
 M: x86.32 stack-reg ESP ;
 M: x86.32 temp-reg ECX ;
 
+: local@ ( n -- op )
+    stack-frame get extra-stack-space dup 16 assert= + stack@ ;
+
+M: x86.32 extra-stack-space calls-vm?>> 16 0 ? ;
+
 M: x86.32 %mark-card
     drop HEX: ffffffff [+] card-mark <byte> MOV
     building get pop
@@ -57,12 +62,12 @@ M:: x86.32 %dispatch ( src temp -- )
 
 M: x86.32 pic-tail-reg EBX ;
 
-M: x86.32 reserved-area-size 0 ;
+M: x86.32 reserved-stack-space 4 cells ;
 
 M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
 
-: push-vm-ptr ( -- )
+: save-vm-ptr ( n -- )
-    0 PUSH 0 rc-absolute-cell rel-vm ; ! push the vm ptr as an argument
+    stack@ 0 MOV 0 rc-absolute-cell rel-vm ;
 
 M: x86.32 return-struct-in-registers? ( c-type -- ? )
     c-type
@@ -72,44 +77,34 @@ M: x86.32 return-struct-in-registers? ( c-type -- ? )
     and or ;
 
 : struct-return@ ( n -- operand )
-    [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
+    [ next-stack@ ] [ stack-frame get params>> local@ ] if* ;
 
 ! On x86, parameters are never passed in registers.
 M: int-regs return-reg drop EAX ;
 M: int-regs param-regs drop { } ;
 M: float-regs param-regs drop { } ;
 
-GENERIC: push-return-reg ( rep -- )
+GENERIC: load-return-reg ( src rep -- )
-GENERIC: load-return-reg ( n rep -- )
+GENERIC: store-return-reg ( dst rep -- )
-GENERIC: store-return-reg ( n rep -- )
 
-M: int-rep push-return-reg drop EAX PUSH ;
+M: int-rep load-return-reg drop EAX swap MOV ;
-M: int-rep load-return-reg drop EAX swap next-stack@ MOV ;
+M: int-rep store-return-reg drop EAX MOV ;
-M: int-rep store-return-reg drop stack@ EAX MOV ;
 
-M: float-rep push-return-reg drop ESP 4 SUB ESP [] FSTPS ;
+M: float-rep load-return-reg drop FLDS ;
-M: float-rep load-return-reg drop next-stack@ FLDS ;
+M: float-rep store-return-reg drop FSTPS ;
-M: float-rep store-return-reg drop stack@ FSTPS ;
 
-M: double-rep push-return-reg drop ESP 8 SUB ESP [] FSTPL ;
+M: double-rep load-return-reg drop FLDL ;
-M: double-rep load-return-reg drop next-stack@ FLDL ;
+M: double-rep store-return-reg drop FSTPL ;
-M: double-rep store-return-reg drop stack@ FSTPL ;
-
-: align-sub ( n -- )
-    [ align-stack ] keep - decr-stack-reg ;
-
-: align-add ( n -- )
-    align-stack incr-stack-reg ;
-
-: with-aligned-stack ( n quot -- )
-    '[ align-sub @ ] [ align-add ] bi ; inline
 
 M: x86.32 %prologue ( n -- )
     dup PUSH
     0 PUSH rc-absolute-cell rel-this
     3 cells - decr-stack-reg ;
 
-M: x86.32 %load-param-reg 3drop ;
+M: x86.32 %load-param-reg
+    stack-params assert=
+    [ [ EAX ] dip local@ MOV ] dip
+    stack@ EAX MOV ;
 
 M: x86.32 %save-param-reg 3drop ;
 
@@ -118,16 +113,14 @@ M: x86.32 %save-param-reg 3drop ;
     #! are boxing a return value of a C function. If n is an
     #! integer, push [ESP+n] on the stack; we are boxing a
     #! parameter being passed to a callback from C.
-    over [ load-return-reg ] [ 2drop ] if ;
+    over [ [ next-stack@ ] dip load-return-reg ] [ 2drop ] if ;
 
 M:: x86.32 %box ( n rep func -- )
     n rep (%box)
-    rep rep-size cell + [
+    rep rep-size save-vm-ptr
-        push-vm-ptr
+    0 stack@ rep store-return-reg
-        rep push-return-reg
+    func f %alien-invoke ;
-        func f %alien-invoke
+
-    ] with-aligned-stack ;
-    
 : (%box-long-long) ( n -- )
     [
         EDX over next-stack@ MOV
@@ -136,56 +129,39 @@ M:: x86.32 %box ( n rep func -- )
 
 M: x86.32 %box-long-long ( n func -- )
     [ (%box-long-long) ] dip
-    12 [
+    8 save-vm-ptr
-        push-vm-ptr
+    4 stack@ EDX MOV
-        EDX PUSH
+    0 stack@ EAX MOV
-        EAX PUSH
+    f %alien-invoke ;
-        f %alien-invoke
-    ] with-aligned-stack ;
 
 M:: x86.32 %box-large-struct ( n c-type -- )
-    ! Compute destination address
     EDX n struct-return@ LEA
-    12 [
+    8 save-vm-ptr
-        push-vm-ptr
+    4 stack@ c-type heap-size MOV
-        ! Push struct size
+    0 stack@ EDX MOV
-        c-type heap-size PUSH
+    "box_value_struct" f %alien-invoke ;
-        ! Push destination address
-        EDX PUSH
-        ! Copy the struct from the C stack
-        "box_value_struct" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %prepare-box-struct ( -- )
     ! Compute target address for value struct return
     EAX f struct-return@ LEA
     ! Store it as the first parameter
-    0 stack@ EAX MOV ;
+    0 local@ EAX MOV ;
 
 M: x86.32 %box-small-struct ( c-type -- )
     #! Box a <= 8-byte struct returned in EAX:EDX. OS X only.
-    16 [
+    12 save-vm-ptr
-        push-vm-ptr
+    8 stack@ swap heap-size MOV
-        heap-size PUSH
+    4 stack@ EDX MOV
-        EDX PUSH
+    0 stack@ EAX MOV
-        EAX PUSH
+    "box_small_struct" f %alien-invoke ;
-        "box_small_struct" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %prepare-unbox ( -- )
-    #! Move top of data stack to EAX.
+    EAX swap ds-reg reg-stack MOV ;
-    EAX ESI [] MOV
-    ESI 4 SUB ;
 
 : call-unbox-func ( func -- )
-    8 [
+    4 save-vm-ptr
-        ! push the vm ptr as an argument
+    0 stack@ EAX MOV
-        push-vm-ptr
+    f %alien-invoke ;
-        ! Push parameter
-        EAX PUSH
-        ! Call the unboxer
-        f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %unbox ( n rep func -- )
     #! The value being unboxed must already be in EAX.
@@ -194,37 +170,33 @@ M: x86.32 %unbox ( n rep func -- )
     #! a parameter to a C function about to be called.
     call-unbox-func
     ! Store the return value on the C stack
-    over [ store-return-reg ] [ 2drop ] if ;
+    over [ [ local@ ] dip store-return-reg ] [ 2drop ] if ;
 
 M: x86.32 %unbox-long-long ( n func -- )
     call-unbox-func
     ! Store the return value on the C stack
     [
-        dup stack@ EAX MOV
+        [ local@ EAX MOV ]
-        cell + stack@ EDX MOV
+        [ 4 + local@ EDX MOV ] bi
     ] when* ;
 
 : %unbox-struct-1 ( -- )
     #! Alien must be in EAX.
-    8 [
+    4 save-vm-ptr
-        push-vm-ptr
+    0 stack@ EAX MOV
-        EAX PUSH
+    "alien_offset" f %alien-invoke
-        "alien_offset" f %alien-invoke
+    ! Load first cell
-        ! Load first cell
+    EAX EAX [] MOV ;
-        EAX EAX [] MOV
-    ] with-aligned-stack ;
 
 : %unbox-struct-2 ( -- )
     #! Alien must be in EAX.
-    8 [
+    4 save-vm-ptr
-        push-vm-ptr
+    0 stack@ EAX MOV
-        EAX PUSH
+    "alien_offset" f %alien-invoke
-        "alien_offset" f %alien-invoke
+    ! Load second cell
-        ! Load second cell
+    EDX EAX 4 [+] MOV
-        EDX EAX 4 [+] MOV
+    ! Load first cell
-        ! Load first cell
+    EAX EAX [] MOV ;
-        EAX EAX [] MOV
-    ] with-aligned-stack ;
 
 M: x86 %unbox-small-struct ( size -- )
     #! Alien must be in EAX.
@@ -236,63 +208,46 @@ M: x86 %unbox-small-struct ( size -- )
 M:: x86.32 %unbox-large-struct ( n c-type -- )
     ! Alien must be in EAX.
     ! Compute destination address
-    EDX n stack@ LEA
+    EDX n local@ LEA
-    16 [
+    12 save-vm-ptr
-        push-vm-ptr
+    8 stack@ c-type heap-size MOV
-        ! Push struct size
+    4 stack@ EDX MOV
-        c-type heap-size PUSH
+    0 stack@ EAX MOV
-        ! Push destination address
+    "to_value_struct" f %alien-invoke ;
-        EDX PUSH
-        ! Push source address
-        EAX PUSH
-        ! Copy the struct to the stack
-        "to_value_struct" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %nest-stacks ( -- )
     ! Save current frame. See comment in vm/contexts.hpp
     EAX stack-reg stack-frame get total-size>> 3 cells - [+] LEA
-    8 [
+    4 save-vm-ptr
-        push-vm-ptr
+    0 stack@ EAX MOV
-        EAX PUSH
+    "nest_stacks" f %alien-invoke ;
-        "nest_stacks" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %unnest-stacks ( -- )
-    4 [
+    0 save-vm-ptr
-        push-vm-ptr
+    "unnest_stacks" f %alien-invoke ;
-        "unnest_stacks" f %alien-invoke
-    ] with-aligned-stack ;
 
 M: x86.32 %prepare-alien-indirect ( -- )
-    4 [
+    0 save-vm-ptr
-        push-vm-ptr
+    "unbox_alien" f %alien-invoke
-        "unbox_alien" f %alien-invoke
-    ] with-aligned-stack
     EBP EAX MOV ;
 
 M: x86.32 %alien-indirect ( -- )
     EBP CALL ;
 
 M: x86.32 %alien-callback ( quot -- )
+    ! Fastcall
     param-reg-1 swap %load-reference
     param-reg-2 %mov-vm-ptr
     "c_to_factor" f %alien-invoke ;
 
 M: x86.32 %callback-value ( ctype -- )
-    ! Align C stack
+    0 %prepare-unbox
-    ESP 12 SUB
+    4 stack@ EAX MOV
-    ! Save top of data stack in non-volatile register
+    0 save-vm-ptr
-    %prepare-unbox
-    EAX PUSH
-    push-vm-ptr
     ! Restore data/call/retain stacks
     "unnest_stacks" f %alien-invoke
-    ! Place top of data stack in EAX
+    ! Place former top of data stack back in EAX
-    temp-reg POP
+    EAX 4 stack@ MOV
-    EAX POP
-    ! Restore C stack
-    ESP 12 ADD
     ! Unbox EAX
     unbox-return ;
 
@@ -357,17 +312,11 @@ M: x86.32 %callback-return ( n -- )
     } cond RET ;
 
 M:: x86.32 %call-gc ( gc-root-count temp -- )
-    temp gc-root-base param@ LEA
+    temp gc-root-base special@ LEA
-    12 [
+    8 save-vm-ptr
-        ! Pass the VM ptr as the third parameter
+    4 stack@ gc-root-count MOV
-        push-vm-ptr
+    0 stack@ temp MOV
-        ! Pass number of roots as second parameter
+    "inline_gc" f %alien-invoke ;
-        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 ;
 
@@ -375,10 +324,13 @@ M: x86.32 dummy-int-params? f ;
 
 M: x86.32 dummy-fp-params? f ;
 
+! Dreadful
+M: object flatten-value-type (flatten-int-type) ;
+
 os windows? [
-    cell "longlong" c-type (>>align)
+    cell longlong c-type (>>align)
-    cell "ulonglong" c-type (>>align)
+    cell ulonglong c-type (>>align)
-    4 "double" c-type (>>align)
+    4 double c-type (>>align)
 ] unless
 
 check-sse

basis/cpu/x86/64/64.factor

@@ -8,6 +8,22 @@ compiler.cfg.builder compiler.cfg.intrinsics compiler.cfg.stack-frame
 cpu.x86.assembler cpu.x86.assembler.operands cpu.x86 cpu.architecture ;
 IN: cpu.x86.64
 
+: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
+: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
+: 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 ;
+
+M: int-regs return-reg drop RAX ;
+M: float-regs return-reg drop XMM0 ;
+
+M: x86.64 ds-reg R14 ;
+M: x86.64 rs-reg R15 ;
+M: x86.64 stack-reg RSP ;
+
+M: x86.64 extra-stack-space drop 0 ;
+
 M: x86.64 machine-registers
     {
         { int-regs { RAX RCX RDX RBX RBP RSI RDI R8 R9 R10 R11 R12 R13 } }
@@ -17,9 +33,13 @@ M: x86.64 machine-registers
         } }
     } ;
 
-M: x86.64 ds-reg R14 ;
+: param@ ( n -- op ) reserved-stack-space + stack@ ;
-M: x86.64 rs-reg R15 ;
+
-M: x86.64 stack-reg RSP ;
+M: x86.64 %prologue ( n -- )
+    temp-reg 0 MOV rc-absolute-cell rel-this
+    dup PUSH
+    temp-reg PUSH
+    stack-reg swap 3 cells - SUB ;
 
 : load-cards-offset ( dst -- )
     0 MOV rc-absolute-cell rel-cards-offset ;
@@ -50,22 +70,6 @@ M:: x86.64 %dispatch ( src temp -- )
     [ align-code ]
     bi ;
 
-: param-reg-1 ( -- reg ) int-regs param-regs first ; inline
-: param-reg-2 ( -- reg ) int-regs param-regs second ; inline
-: 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 ;
-
-M: int-regs return-reg drop RAX ;
-M: float-regs return-reg drop XMM0 ;
-
-M: x86.64 %prologue ( n -- )
-    temp-reg 0 MOV rc-absolute-cell rel-this
-    dup PUSH
-    temp-reg PUSH
-    stack-reg swap 3 cells - SUB ;
-
 M: stack-params copy-register*
     drop
     {
@@ -84,10 +88,8 @@ M: x86 %load-param-reg [ swap param@ ] dip %copy ;
         call
     ] with-scope ; inline
 
-M: x86.64 %prepare-unbox ( -- )
+M: x86.64 %prepare-unbox ( n -- )
-    ! First parameter is top of stack
+    param-reg-1 swap ds-reg reg-stack MOV ;
-    param-reg-1 R14 [] MOV
-    R14 cell SUB ;
 
 M:: x86.64 %unbox ( n rep func -- )
     param-reg-2 %mov-vm-ptr
@@ -217,9 +219,7 @@ M: x86.64 %alien-callback ( quot -- )
     "c_to_factor" f %alien-invoke ;
 
 M: x86.64 %callback-value ( ctype -- )
-    ! Save top of data stack
+    0 %prepare-unbox
-    %prepare-unbox
-    ! Save top of data stack
     RSP 8 SUB
     param-reg-1 PUSH
     param-reg-1 %mov-vm-ptr

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

@@ -12,7 +12,7 @@ M: int-regs param-regs
 M: float-regs param-regs
     drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
-M: x86.64 reserved-area-size 0 ;
+M: x86.64 reserved-stack-space 0 ;
 
 SYMBOL: (stack-value)
 ! The ABI for passing structs by value is pretty great

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

@@ -9,7 +9,7 @@ M: int-regs param-regs drop { RCX RDX R8 R9 } ;
 
 M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
 
-M: x86.64 reserved-area-size 4 cells ;
+M: x86.64 reserved-stack-space 4 cells ;
 
 M: x86.64 return-struct-in-registers? ( c-type -- ? )
     heap-size { 1 2 4 8 } member? ;

basis/cpu/x86/x86.factor

@@ -24,15 +24,20 @@ M: x86 vector-regs float-regs ;
 
 HOOK: stack-reg cpu ( -- reg )
 
-HOOK: reserved-area-size cpu ( -- n )
+HOOK: reserved-stack-space cpu ( -- n )
+
+HOOK: extra-stack-space cpu ( stack-frame -- n )
 
 : stack@ ( n -- op ) stack-reg swap [+] ;
 
-: param@ ( n -- op ) reserved-area-size + stack@ ;
+: special@ ( n -- op )
+    stack-frame get extra-stack-space +
+    reserved-stack-space +
+    stack@ ;
 
-: spill@ ( n -- op ) spill-offset param@ ;
+: spill@ ( n -- op ) spill-offset special@ ;
 
-: gc-root@ ( n -- op ) gc-root-offset param@ ;
+: gc-root@ ( n -- op ) gc-root-offset special@ ;
 
 : decr-stack-reg ( n -- )
     dup 0 = [ drop ] [ stack-reg swap SUB ] if ;
@@ -44,7 +49,11 @@ HOOK: reserved-area-size cpu ( -- n )
     os macosx? cpu x86.64? or [ 16 align ] when ;
 
 M: x86 stack-frame-size ( stack-frame -- i )
-    (stack-frame-size) 3 cells reserved-area-size + + align-stack ;
+    [ (stack-frame-size) ]
+    [ extra-stack-space ] bi +
+    reserved-stack-space +
+    3 cells +
+    align-stack ;
 
 ! Must be a volatile register not used for parameter passing, for safe
 ! use in calls in and out of C

basis/help/handbook/handbook-tests.factor

@@ -4,5 +4,4 @@ IN: help.handbook.tests
 [ ] [ "article-index" print-topic ] unit-test
 [ ] [ "primitive-index" print-topic ] unit-test
 [ ] [ "error-index" print-topic ] unit-test
-[ ] [ "type-index" print-topic ] unit-test
 [ ] [ "class-index" print-topic ] unit-test

basis/help/handbook/handbook.factor

@@ -239,9 +239,6 @@ ARTICLE: "primitive-index" "Primitive index"
 ARTICLE: "error-index" "Error index"
 { $index [ all-errors ] } ;
 
-ARTICLE: "type-index" "Type index"
-{ $index [ builtins get sift ] } ;
-
 ARTICLE: "class-index" "Class index"
 { $heading "Built-in classes" }
 { $index [ classes [ builtin-class? ] filter ] }
@@ -387,7 +384,6 @@ ARTICLE: "handbook" "Factor handbook"
     "article-index"
     "primitive-index"
     "error-index"
-    "type-index"
     "class-index"
 }
 { $heading "Explore the code base" }

basis/help/tutorial/tutorial.factor

@@ -33,7 +33,7 @@ ARTICLE: "first-program-logic" "Writing some logic in your first program"
 $nl
 "In order to be able to call the words defined in the " { $snippet "palindrome" } " vocabulary, you need to issue the following command in the listener:"
 { $code "USE: palindrome" }
-"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload:"
+"Now, we will be making some additions to the file. Since the file was loaded by the scaffold tool in the previous step, you need to tell Factor to reload it if it changes. Factor has a handy feature for this; pressing " { $command tool "common" refresh-all } " in the listener window will reload any changed source files. You can also force a single vocabulary to reload, in case the refresh feature does not pick up changes from disk:"
 { $code "\"palindrome\" reload" }
 "We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
 $nl

basis/math/vectors/vectors.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: arrays alien.c-types assocs kernel sequences math math.functions
-hints math.order math.libm fry combinators byte-arrays accessors
+hints math.order math.libm math.floats.private fry combinators
-locals ;
+byte-arrays accessors locals ;
 QUALIFIED-WITH: alien.c-types c
 IN: math.vectors
 
@@ -29,8 +29,16 @@ M: object element-type drop f ; inline
 : [v-] ( u v -- w ) [ [-] ] 2map ;
 : v*   ( u v -- w ) [ * ] 2map ;
 : v/   ( u v -- w ) [ / ] 2map ;
-: vmax ( u v -- w ) [ max ] 2map ;
+
-: vmin ( u v -- w ) [ min ] 2map ;
+<PRIVATE
+
+: if-both-floats ( x y p q -- )
+    [ 2dup [ float? ] both? ] 2dip if ; inline
+
+PRIVATE>
+
+: vmax ( u v -- w ) [ [ float-max ] [ max ] if-both-floats ] 2map ;
+: vmin ( u v -- w ) [ [ float-min ] [ min ] if-both-floats ] 2map ;
 
 : v+- ( u v -- w )
     [ t ] 2dip

basis/specialized-arrays/specialized-arrays-tests.factor

@@ -122,10 +122,6 @@ SPECIALIZED-ARRAY: fixed-string
 ! If the C type doesn't exist, don't generate a vocab
 SYMBOL: __does_not_exist__
 
-[ ] [
-    [ __does_not_exist__ specialized-array-vocab forget-vocab ] with-compilation-unit
-] unit-test
-
 [
     """
 IN: specialized-arrays.tests
@@ -151,4 +147,9 @@ SPECIALIZED-ARRAY: __does_not_exist__
     deferred?
 ] unit-test
 
-[ \ __does_not_exist__ forget ] with-compilation-unit
+[ ] [
+    [
+        \ __does_not_exist__ forget
+        __does_not_exist__ specialized-array-vocab forget-vocab
+    ] with-compilation-unit
+] unit-test

basis/ui/gadgets/editors/editors-tests.factor

@@ -1,8 +1,8 @@
-USING: accessors ui.gadgets.editors tools.test kernel io
+USING: accessors ui.gadgets.editors ui.gadgets.editors.private
-io.streams.plain definitions namespaces ui.gadgets
+tools.test kernel io io.streams.plain definitions namespaces
-ui.gadgets.grids prettyprint documents ui.gestures ui.gadgets.debug
+ui.gadgets ui.gadgets.grids prettyprint documents ui.gestures
-models documents.elements ui.gadgets.scrollers ui.gadgets.line-support
+ui.gadgets.debug models documents.elements ui.gadgets.scrollers
-sequences ;
+ui.gadgets.line-support sequences ;
 IN: ui.gadgets.editors.tests
 
 [ "foo bar" ] [
@@ -55,6 +55,9 @@ IN: ui.gadgets.editors.tests
 [ ] [ <editor> com-join-lines ] unit-test
 [ ] [ <editor> "A" over set-editor-string com-join-lines ] unit-test
 [ "A B" ] [ <editor> "A\nB" over set-editor-string [ com-join-lines ] [ editor-string ] bi ] unit-test
+[ "A B\nC\nD" ] [ <editor> "A\nB\nC\nD" over set-editor-string { 0 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test
+[ "A\nB C\nD" ] [ <editor> "A\nB\nC\nD" over set-editor-string { 1 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test
+[ "A\nB\nC D" ] [ <editor> "A\nB\nC\nD" over set-editor-string { 2 0 } over set-caret dup mark>caret [ com-join-lines ] [ editor-string ] bi ] unit-test
 
 [ 2 ] [ <editor> 20 >>min-rows 20 >>min-cols pref-viewport-dim length ] unit-test
 

basis/ui/gadgets/editors/editors.factor

@@ -17,6 +17,8 @@ caret-color
 caret mark
 focused? blink blink-alarm ;
 
+<PRIVATE
+
 : <loc> ( -- loc ) { 0 0 } <model> ;
 
 : init-editor-locs ( editor -- editor )
@@ -27,6 +29,8 @@ focused? blink blink-alarm ;
     COLOR: red >>caret-color
     monospace-font >>font ; inline
 
+PRIVATE>
+
 : new-editor ( class -- editor )
     new-line-gadget
         <document> >>model
@@ -36,6 +40,8 @@ focused? blink blink-alarm ;
 : <editor> ( -- editor )
     editor new-editor ;
 
+<PRIVATE
+
 : activate-editor-model ( editor model -- )
     [ add-connection ]
     [ nip activate-model ]
@@ -70,6 +76,8 @@ SYMBOL: blink-interval
         bi
     ] [ drop ] if ;
 
+PRIVATE>
+
 M: editor graft*
     [ dup caret>> activate-editor-model ]
     [ dup mark>> activate-editor-model ] bi ;
@@ -142,6 +150,8 @@ M: editor ungraft*
         ] keep scroll>rect
     ] [ drop ] if ;
 
+<PRIVATE
+
 : draw-caret? ( editor -- ? )
     { [ focused?>> ] [ blink>> ] } 1&& ;
 
@@ -189,6 +199,8 @@ TUPLE: selected-line start end first? last? ;
         ] 3bi
     ] if ;
 
+PRIVATE>
+
 M: editor draw-line ( line index editor -- )
     [ selected-lines get at ] dip over
     [ draw-selected-line ] [ nip draw-unselected-line ] if ;
@@ -206,6 +218,8 @@ M: editor baseline font>> font-metrics ascent>> ;
 
 M: editor cap-height font>> font-metrics cap-height>> ;
 
+<PRIVATE
+
 : contents-changed ( model editor -- )
     [ [ nip caret>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
     [ [ nip mark>> ] [ drop ] 2bi '[ _ validate-loc ] (change-model) ]
@@ -214,6 +228,8 @@ M: editor cap-height font>> font-metrics cap-height>> ;
 : caret/mark-changed ( editor -- )
     [ restart-blinking ] keep scroll>caret ;
 
+PRIVATE>
+
 M: editor model-changed
     {
         { [ 2dup model>> eq? ] [ contents-changed ] }
@@ -513,6 +529,8 @@ PRIVATE>
 : change-selection ( editor quot -- )
     '[ gadget-selection @ ] [ user-input* drop ] bi ; inline
 
+<PRIVATE
+
 : join-lines ( string -- string' )
     "\n" split
     [ rest-slice [ [ blank? ] trim-head-slice ] change-each ]
@@ -520,22 +538,39 @@ PRIVATE>
     [ " " join ]
     tri ;
 
-: this-line-and-next ( document line -- start end )
-    [ nip 0 swap 2array ]
-    [ 1 + [ nip ] [ swap doc-line length ] 2bi 2array ]
-    2bi ;
-
 : last-line? ( document line -- ? )
     [ last-line# ] dip = ;
 
+: prev-line-and-this ( document line -- start end )
+    swap
+    [ drop 1 - 0 2array ]
+    [ [ drop ] [ doc-line length ] 2bi 2array ]
+    2bi ;
+
+: join-with-prev ( document line -- )
+    [ prev-line-and-this ] [ drop ] 2bi
+    [ join-lines ] change-doc-range ;
+
+: this-line-and-next ( document line -- start end )
+    swap
+    [ drop 0 2array ]
+    [ [ 1 + ] dip [ drop ] [ doc-line length ] 2bi 2array ]
+    2bi ;
+
+: join-with-next ( document line -- )
+    [ this-line-and-next ] [ drop ] 2bi
+    [ join-lines ] change-doc-range ;
+
+PRIVATE>
+
 : com-join-lines ( editor -- )
     dup gadget-selection?
     [ [ join-lines ] change-selection ] [
-        [ model>> ] [ editor-caret first ] bi
+        [ model>> ] [ editor-caret first ] bi {
-        2dup last-line? [ 2drop ] [
+            { [ over last-line# 0 = ] [ 2drop ] }
-            [ this-line-and-next ] [ drop ] 2bi
+            { [ 2dup last-line? ] [ join-with-prev ] }
-            [ join-lines ] change-doc-range
+            [ join-with-next ]
-        ] if
+        } cond
     ] if ;
 
 multiline-editor "multiline" f {
@@ -566,6 +601,8 @@ TUPLE: source-editor < multiline-editor ;
 ! Fields wrap an editor
 TUPLE: field < border editor min-cols max-cols ;
 
+<PRIVATE
+
 : field-theme ( gadget -- gadget )
     { 2 2 } >>size
     { 1 0 } >>fill
@@ -576,6 +613,8 @@ TUPLE: field < border editor min-cols max-cols ;
         { 1 0 } >>fill
         field-theme ;
 
+PRIVATE>
+
 : new-field ( class -- gadget )
     [ <editor> ] dip new-border
         dup gadget-child >>editor

core/classes/builtin/builtin-docs.factor

@@ -9,7 +9,7 @@ $nl
     builtin-class
     builtin-class?
 }
-"See " { $link "type-index" } " for a list of built-in classes." ;
+"See " { $link "class-index" } " for a list of built-in classes." ;
 
 HELP: builtin-class
 { $class-description "The class of built-in classes." }

core/generic/single/single-tests.factor

@@ -4,7 +4,8 @@ accessors words byte-arrays bit-arrays parser namespaces make
 quotations stack-checker vectors growable hashtables sbufs
 prettyprint byte-vectors bit-vectors specialized-vectors
 definitions generic sets graphs assocs grouping see eval ;
-SPECIALIZED-VECTOR: double
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-VECTOR: c:double
 IN: generic.single.tests
 
 GENERIC: lo-tag-test ( obj -- obj' )

extra/cpu/8080/emulator/emulator.factor

@@ -24,7 +24,6 @@ USING:
     quotations
     sequences
     sequences.deep
-    syntax
     words
 ;
 IN: cpu.8080.emulator

extra/space-invaders/space-invaders.factor

@@ -22,15 +22,13 @@ USING:
     ui.gadgets
     ui.gestures
     ui.render
+    specialized-arrays
 ;
 QUALIFIED: threads
 QUALIFIED: system
+SPECIALIZED-ARRAY: uchar
 IN: space-invaders
 
-<< 
-    "uchar" require-c-array 
->>
-
 TUPLE: space-invaders < cpu port1 port2i port2o port3o port4lo port4hi port5o bitmap sounds looping? ;
 CONSTANT: game-width 224
 CONSTANT: game-height 256

extra/ui/gadgets/controls/controls.factor

@@ -1,7 +1,7 @@
 USING: accessors assocs arrays kernel models monads sequences
 models.combinators ui.gadgets ui.gadgets.borders ui.gadgets.buttons
-ui.gadgets.buttons.private ui.gadgets.editors words images.loader
+ui.gadgets.buttons.private ui.gadgets.editors ui.gadgets.editors.private
-ui.gadgets.scrollers ui.images vocabs.parser lexer
+words images.loader ui.gadgets.scrollers ui.images vocabs.parser lexer
 models.range ui.gadgets.sliders ;
 QUALIFIED-WITH: ui.gadgets.sliders slider
 QUALIFIED-WITH: ui.gadgets.tables tbl

vm/debug.cpp

@@ -296,7 +296,7 @@ void factor_vm::dump_code_heap()
 		const char *status;
 		if(scan->type() == FREE_BLOCK_TYPE)
 			status = "free";
-		else if(scan->marked_p())
+		else if(code->state->is_marked_p(scan))
 		{
 			reloc_size += object_size(((code_block *)scan)->relocation);
 			literal_size += object_size(((code_block *)scan)->literals);

vm/full_collector.cpp

@@ -134,6 +134,8 @@ void factor_vm::collect_full_impl(bool trace_contexts_p)
 {
 	full_collector collector(this);
 
+	code->state->clear_mark_bits();
+
 	collector.trace_roots();
         if(trace_contexts_p)
 	{
@@ -148,16 +150,6 @@ void factor_vm::collect_full_impl(bool trace_contexts_p)
 	nursery.here = nursery.start;
 }
 
-/* In both cases, compact code heap before updating code blocks so that
-XTs are correct after */
-
-void factor_vm::big_code_heap_update()
-{
-	big_code_heap_updater updater(this);
-	code->free_unmarked(updater);
-	code->clear_remembered_set();
-}
-
 void factor_vm::collect_growing_heap(cell requested_bytes,
 	bool trace_contexts_p,
 	bool compact_code_heap_p)
@@ -168,15 +160,18 @@ void factor_vm::collect_growing_heap(cell requested_bytes,
 	collect_full_impl(trace_contexts_p);
 	delete old;
 
-	if(compact_code_heap_p) compact_code_heap(trace_contexts_p);
+	if(compact_code_heap_p)
+	{
+		compact_code_heap(trace_contexts_p);
+		big_code_heap_updater updater(this);
+		iterate_code_heap(updater);
+	}
+	else
+	{
+		big_code_heap_updater updater(this);
+		code->free_unmarked(updater);
+	}
 
-	big_code_heap_update();
-}
-
-void factor_vm::small_code_heap_update()
-{
-	small_code_heap_updater updater(this);
-	code->free_unmarked(updater);
 	code->clear_remembered_set();
 }
 
@@ -190,10 +185,16 @@ void factor_vm::collect_full(bool trace_contexts_p, bool compact_code_heap_p)
 	if(compact_code_heap_p)
 	{
 		compact_code_heap(trace_contexts_p);
-		big_code_heap_update();
+		big_code_heap_updater updater(this);
+		iterate_code_heap(updater);
 	}
 	else
-		small_code_heap_update();
+	{
+		small_code_heap_updater updater(this);
+		code->free_unmarked(updater);
+	}
+
+	code->clear_remembered_set();
 }
 
 }

vm/gc.cpp

@@ -54,9 +54,6 @@ void factor_vm::gc(gc_op op,
 			current_gc->op = collect_full_op;
 			break;
 		case collect_full_op:
-			/* Since we start tracing again, any previously
-			marked code blocks must be re-marked and re-traced */
-			code->clear_mark_bits();
 			current_gc->op = collect_growing_heap_op;
 			break;
 		default:

vm/heap.cpp

@@ -16,9 +16,18 @@ heap::heap(bool secure_gc_, cell size, bool executable_p) : secure_gc(secure_gc_
 	if(size > (1L << (sizeof(cell) * 8 - 6))) fatal_error("Heap too large",size);
 	seg = new segment(align_page(size),executable_p);
 	if(!seg) fatal_error("Out of memory in heap allocator",size);
+	state = new mark_bits<heap_block,block_size_increment>(seg->start,size);
 	clear_free_list();
 }
 
+heap::~heap()
+{
+	delete seg;
+	seg = NULL;
+	delete state;
+	state = NULL;
+}
+
 void heap::add_to_free_list(free_heap_block *block)
 {
 	if(block->size() < free_list_count * block_size_increment)
@@ -34,52 +43,15 @@ void heap::add_to_free_list(free_heap_block *block)
 	}
 }
 
-/* Called after reading the code heap from the image file, and after code GC.
+/* Called after reading the code heap from the image file, and after code heap
-
+compaction. Makes a free list consisting of one free block, at the very end. */
-In the former case, we must add a large free block from compiling.base + size to
-compiling.limit. */
 void heap::build_free_list(cell size)
 {
-	heap_block *prev = NULL;
-
 	clear_free_list();
-
-	size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
-
-	heap_block *scan = first_block();
 	free_heap_block *end = (free_heap_block *)(seg->start + size);
-
+	end->set_type(FREE_BLOCK_TYPE);
-	/* Add all free blocks to the free list */
+	end->set_size(seg->end - (cell)end);
-	while(scan && scan < (heap_block *)end)
+	add_to_free_list(end);
-	{
-		if(scan->type() == FREE_BLOCK_TYPE)
-			add_to_free_list((free_heap_block *)scan);
-
-		prev = 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) <= seg->end)
-	{
-		end->set_marked_p(false);
-		end->set_type(FREE_BLOCK_TYPE);
-		end->set_size(seg->end - (cell)end);
-
-		/* add final free block */
-		add_to_free_list(end);
-	}
-	/* This branch is taken if the newly loaded image fits exactly, or
-	after code GC */
-	else
-	{
-		/* 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->set_size(seg->end - (cell)prev);
-	}
-
 }
 
 void heap::assert_free_block(free_heap_block *block)
@@ -154,7 +126,6 @@ heap_block *heap::heap_allot(cell size, cell type)
 	{
 		block = split_free_block(block,size);
 		block->set_type(type);
-		block->set_marked_p(false);
 		return block;
 	}
 	else
@@ -170,18 +141,7 @@ void heap::heap_free(heap_block *block)
 
 void heap::mark_block(heap_block *block)
 {
-	block->set_marked_p(true);
+	state->set_marked_p(block,true);
-}
-
-void heap::clear_mark_bits()
-{
-	heap_block *scan = first_block();
-
-	while(scan)
-	{
-		scan->set_marked_p(false);
-		scan = next_block(scan);
-	}
 }
 
 /* Compute total sum of sizes of free blocks, and size of largest free block */
@@ -210,20 +170,21 @@ void heap::heap_usage(cell *used, cell *total_free, cell *max_free)
 	}
 }
 
-/* The size of the heap, not including the last block if it's free */
+/* The size of the heap after compaction */
 cell heap::heap_size()
 {
 	heap_block *scan = first_block();
+	
+	while(scan)
+	{
+		if(scan->type() == FREE_BLOCK_TYPE) break;
+		else scan = next_block(scan);
+	}
 
-	while(next_block(scan) != NULL)
+	assert(scan->type() == FREE_BLOCK_TYPE);
-		scan = next_block(scan);
+	assert((cell)scan + scan->size() == seg->end);
 
-	/* this is the last block in the heap, and it is free */
+	return (cell)scan - (cell)first_block();
-	if(scan->type() == FREE_BLOCK_TYPE)
-		return (cell)scan - seg->start;
-	/* otherwise the last block is allocated */
-	else
-		return seg->size;
 }
 
 void heap::compact_heap()
@@ -238,7 +199,7 @@ void heap::compact_heap()
 	{
 		heap_block *next = next_block(scan);
  
-		if(scan->type() != FREE_BLOCK_TYPE && scan->marked_p())
+		if(state->is_marked_p(scan))
 		{
 			cell size = scan->size();
 			memmove(address,scan,size);

vm/heap.hpp

@@ -13,9 +13,11 @@ struct heap {
 	bool secure_gc;
 	segment *seg;
 	heap_free_list free;
+	mark_bits<heap_block,block_size_increment> *state;
 	unordered_map<heap_block *, char *> forwarding;
 
 	explicit heap(bool secure_gc_, cell size, bool executable_p);
+	~heap();
 
 	inline heap_block *next_block(heap_block *block)
 	{
@@ -46,7 +48,6 @@ struct heap {
 	heap_block *heap_allot(cell size, cell type);
 	void heap_free(heap_block *block);
 	void mark_block(heap_block *block);
-	void clear_mark_bits();
 	void heap_usage(cell *used, cell *total_free, cell *max_free);
 	cell heap_size();
 	void compact_heap();
@@ -71,11 +72,10 @@ struct heap {
 				else
 					prev = scan;
 			}
-			else if(scan->marked_p())
+			else if(state->is_marked_p(scan))
 			{
 				if(prev && prev->type() == FREE_BLOCK_TYPE)
 					add_to_free_list((free_heap_block *)prev);
-				scan->set_marked_p(false);
 				prev = scan;
 				iter(scan);
 			}

vm/image.cpp

@@ -67,86 +67,6 @@ void factor_vm::load_code_heap(FILE *file, image_header *h, vm_parameters *p)
 	code->build_free_list(h->code_size);
 }
 
-/* Save the current image to disk */
-bool factor_vm::save_image(const vm_char *filename)
-{
-	FILE* file;
-	image_header h;
-
-	file = OPEN_WRITE(filename);
-	if(file == NULL)
-	{
-		print_string("Cannot open image file: "); print_native_string(filename); nl();
-		print_string(strerror(errno)); nl();
-		return false;
-	}
-
-	h.magic = image_magic;
-	h.version = image_version;
-	h.data_relocation_base = data->tenured->start;
-	h.data_size = data->tenured->here - data->tenured->start;
-	h.code_relocation_base = code->seg->start;
-	h.code_size = code->heap_size();
-
-	h.true_object = true_object;
-	h.bignum_zero = bignum_zero;
-	h.bignum_pos_one = bignum_pos_one;
-	h.bignum_neg_one = bignum_neg_one;
-
-	for(cell i = 0; i < USER_ENV; i++)
-		h.userenv[i] = (save_env_p(i) ? userenv[i] : false_object);
-
-	bool ok = true;
-
-	if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
-	if(fwrite((void*)data->tenured->start,h.data_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)
-	{
-		print_string("save-image failed: "); print_string(strerror(errno)); nl();
-	}
-
-	return ok;
-}
-
-void factor_vm::primitive_save_image()
-{
-	/* do a full GC to push everything into tenured space */
-	primitive_compact_gc();
-
-	gc_root<byte_array> path(dpop(),this);
-	path.untag_check(this);
-	save_image((vm_char *)(path.untagged() + 1));
-}
-
-void factor_vm::primitive_save_image_and_exit()
-{
-	/* We unbox this before doing anything else. This is the only point
-	where we might throw an error, so we have to throw an error here since
-	later steps destroy the current image. */
-	gc_root<byte_array> path(dpop(),this);
-	path.untag_check(this);
-
-	/* strip out userenv data which is set on startup anyway */
-	for(cell i = 0; i < USER_ENV; i++)
-	{
-		if(!save_env_p(i)) userenv[i] = false_object;
-	}
-
-	gc(collect_full_op,
-		0, /* requested size */
-		false, /* discard objects only reachable from stacks */
-		true /* compact the code heap */);
-
-	/* Save the image */
-	if(save_image((vm_char *)(path.untagged() + 1)))
-		exit(0);
-	else
-		exit(1);
-}
-
 void factor_vm::data_fixup(cell *handle, cell data_relocation_base)
 {
 	if(immediate_p(*handle))
@@ -353,4 +273,82 @@ void factor_vm::load_image(vm_parameters *p)
 	userenv[IMAGE_ENV] = allot_alien(false_object,(cell)p->image_path);
 }
 
+/* Save the current image to disk */
+bool factor_vm::save_image(const vm_char *filename)
+{
+	FILE* file;
+	image_header h;
+
+	file = OPEN_WRITE(filename);
+	if(file == NULL)
+	{
+		print_string("Cannot open image file: "); print_native_string(filename); nl();
+		print_string(strerror(errno)); nl();
+		return false;
+	}
+
+	h.magic = image_magic;
+	h.version = image_version;
+	h.data_relocation_base = data->tenured->start;
+	h.data_size = data->tenured->here - data->tenured->start;
+	h.code_relocation_base = code->seg->start;
+	h.code_size = code->heap_size();
+
+	h.true_object = true_object;
+	h.bignum_zero = bignum_zero;
+	h.bignum_pos_one = bignum_pos_one;
+	h.bignum_neg_one = bignum_neg_one;
+
+	for(cell i = 0; i < USER_ENV; i++)
+		h.userenv[i] = (save_env_p(i) ? userenv[i] : false_object);
+
+	bool ok = true;
+
+	if(fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
+	if(fwrite((void*)data->tenured->start,h.data_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)
+	{
+		print_string("save-image failed: "); print_string(strerror(errno)); nl();
+	}
+
+	return ok;
+}
+
+void factor_vm::primitive_save_image()
+{
+	/* do a full GC to push everything into tenured space */
+	primitive_compact_gc();
+
+	gc_root<byte_array> path(dpop(),this);
+	path.untag_check(this);
+	save_image((vm_char *)(path.untagged() + 1));
+}
+
+void factor_vm::primitive_save_image_and_exit()
+{
+	/* We unbox this before doing anything else. This is the only point
+	where we might throw an error, so we have to throw an error here since
+	later steps destroy the current image. */
+	gc_root<byte_array> path(dpop(),this);
+	path.untag_check(this);
+
+	/* strip out userenv data which is set on startup anyway */
+	for(cell i = 0; i < USER_ENV; i++)
+		if(!save_env_p(i)) userenv[i] = false_object;
+
+	gc(collect_full_op,
+		0, /* requested size */
+		false, /* discard objects only reachable from stacks */
+		true /* compact the code heap */);
+
+	/* Save the image */
+	if(save_image((vm_char *)(path.untagged() + 1)))
+		exit(0);
+	else
+		exit(1);
+}
+
 }

vm/layouts.hpp

@@ -201,15 +201,6 @@ struct heap_block
 {
 	cell header;
 
-	bool marked_p() { return header & 1; }
-	void set_marked_p(bool marked)
-	{
-		if(marked)
-			header |= 1;
-		else
-			header &= ~1;
-	}
-
 	cell type() { return (header >> 1) & 0x1f; }
 	void set_type(cell type)
 	{

vm/mark_bits.hpp

@@ -0,0 +1,103 @@
+namespace factor
+{
+
+const int forwarding_granularity = 128;
+
+template<typename Block, int Granularity> struct mark_bits {
+	cell start;
+	cell size;
+	cell bits_size;
+	unsigned int *marked;
+	unsigned int *freed;
+	cell forwarding_size;
+	cell *forwarding;
+
+	void clear_mark_bits()
+	{
+		memset(marked,0,bits_size * sizeof(unsigned int));
+	}
+
+	void clear_free_bits()
+	{
+		memset(freed,0,bits_size * sizeof(unsigned int));
+	}
+
+	void clear_forwarding()
+	{
+		memset(forwarding,0,forwarding_size * sizeof(cell));
+	}
+
+	explicit mark_bits(cell start_, cell size_) :
+		start(start_),
+		size(size_),
+		bits_size(size / Granularity / 32),
+		marked(new unsigned int[bits_size]),
+		freed(new unsigned int[bits_size]),
+		forwarding_size(size / Granularity / forwarding_granularity),
+		forwarding(new cell[forwarding_size])
+	{
+		clear_mark_bits();
+		clear_free_bits();
+		clear_forwarding();
+	}
+
+	~mark_bits()
+	{
+		delete[] marked;
+		marked = NULL;
+		delete[] freed;
+		freed = NULL;
+		delete[] forwarding;
+		forwarding = NULL;
+	}
+
+	std::pair<cell,cell> bitmap_deref(Block *address)
+	{
+		cell word_number = (((cell)address - start) / Granularity);
+		cell word_index = (word_number >> 5);
+		cell word_shift = (word_number & 31);
+
+#ifdef FACTOR_DEBUG
+		assert(word_index < bits_size);
+#endif
+
+		return std::make_pair(word_index,word_shift);
+	}
+
+	bool bitmap_elt(unsigned int *bits, Block *address)
+	{
+		std::pair<cell,cell> pair = bitmap_deref(address);
+		return (bits[pair.first] & (1 << pair.second)) != 0;
+	}
+
+	void set_bitmap_elt(unsigned int *bits, Block *address, bool flag)
+	{
+		std::pair<cell,cell> pair = bitmap_deref(address);
+		if(flag)
+			bits[pair.first] |= (1 << pair.second);
+		else
+			bits[pair.first] &= ~(1 << pair.second);
+	}
+
+	bool is_marked_p(Block *address)
+	{
+		return bitmap_elt(marked,address);
+	}
+
+	void set_marked_p(Block *address, bool marked_p)
+	{
+		set_bitmap_elt(marked,address,marked_p);
+	}
+
+	bool is_free_p(Block *address)
+	{
+		return bitmap_elt(freed,address);
+	}
+
+	void set_free_p(Block *address, bool free_p)
+	{
+		set_bitmap_elt(freed,address,free_p);
+	}
+};
+
+}

vm/master.hpp

@@ -78,6 +78,7 @@ namespace factor
 #include "words.hpp"
 #include "float_bits.hpp"
 #include "io.hpp"
+#include "mark_bits.hpp"
 #include "heap.hpp"
 #include "image.hpp"
 #include "alien.hpp"

vm/vm.hpp

@@ -253,8 +253,6 @@ struct factor_vm
 	void collect_nursery();
 	void collect_aging();
 	void collect_to_tenured();
-	void big_code_heap_update();
-	void small_code_heap_update();
 	void collect_full_impl(bool trace_contexts_p);
 	void collect_growing_heap(cell requested_bytes, bool trace_contexts_p, bool compact_code_heap_p);
 	void collect_full(bool trace_contexts_p, bool compact_code_heap_p);