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

basis/compiler/cfg/builder/alien/alien.factor

@@ -102,7 +102,7 @@ M: #alien-invoke emit-node
     [
         {
             [ caller-parameters ]
-            [ ##prepare-var-args alien-invoke-dlsym ##alien-invoke ]
+            [ ##prepare-var-args alien-invoke-dlsym <gc-map> ##alien-invoke ]
             [ emit-stack-frame ]
             [ box-return* ]
         } cleave
@@ -111,7 +111,7 @@ M: #alien-invoke emit-node
 M:: #alien-indirect emit-node ( node -- )
     node [
         D 0 ^^peek -1 ##inc-d ^^unbox-any-c-ptr :> src
-        [ caller-parameters src ##alien-indirect ]
+        [ caller-parameters src <gc-map> ##alien-indirect ]
         [ emit-stack-frame ]
         [ box-return* ]
         tri

basis/compiler/cfg/builder/alien/boxing/boxing.factor

@@ -105,13 +105,13 @@ M: struct-c-type flatten-parameter-type frob-struct flatten-c-type ;
 GENERIC: box ( vregs reps c-type -- dst )
 
 M: c-type box
-    [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* ^^box ;
+    [ first ] [ drop ] [ [ boxer>> ] [ rep>> ] bi ] tri* <gc-map> ^^box ;
 
 M: long-long-type box
-    [ first2 ] [ drop ] [ boxer>> ] tri* ^^box-long-long ;
+    [ first2 ] [ drop ] [ boxer>> ] tri* <gc-map> ^^box-long-long ;
 
 M: struct-c-type box
-    '[ _ heap-size ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
+    '[ _ heap-size <gc-map> ^^allot-byte-array dup ^^unbox-byte-array ] 2dip
     implode-struct ;
 
 GENERIC: box-parameter ( vregs reps c-type -- dst )

basis/compiler/cfg/finalization/finalization.factor

@@ -1,15 +1,17 @@
 ! Copyright (C) 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.cfg.gc-checks compiler.cfg.representations
+USING: kernel compiler.cfg.gc-checks
-compiler.cfg.save-contexts compiler.cfg.ssa.destruction
+compiler.cfg.representations compiler.cfg.save-contexts
-compiler.cfg.build-stack-frame compiler.cfg.linear-scan
+compiler.cfg.ssa.destruction compiler.cfg.build-stack-frame
-compiler.cfg.scheduling ;
+compiler.cfg.linear-scan compiler.cfg.scheduling
+compiler.cfg.stacks.uninitialized ;
 IN: compiler.cfg.finalization
 
 : finalize-cfg ( cfg -- cfg' )
     select-representations
     schedule-instructions
     insert-gc-checks
+    dup compute-uninitialized-sets
     insert-save-contexts
     destruct-ssa
     linear-scan

basis/compiler/cfg/gc-checks/gc-checks-tests.factor

@@ -42,13 +42,12 @@ V{
 
 [
     V{
-        T{ ##gc-map f V{ 0 } V{ 3 } { 0 1 2 } }
+        T{ ##call-gc f T{ gc-map } }
-        T{ ##call-gc }
         T{ ##branch }
     }
 ]
 [
-    V{ D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+    <gc-call> instructions>>
 ] unit-test
 
 30 \ vreg-counter set-global
@@ -82,7 +81,7 @@ V{
 
 [ ] [ cfg get needs-predecessors drop ] unit-test
 
-[ ] [ { D 1 R 2 } { 10 20 } V{ } 31337 3 get (insert-gc-check) ] unit-test
+[ ] [ V{ } 31337 3 get (insert-gc-check) ] unit-test
 
 [ t ] [ 1 get successors>> first gc-check? ] unit-test
 
@@ -146,8 +145,7 @@ H{
 
 [
     V{
-        T{ ##gc-map f V{ 0 1 2 } V{ } { 2 } }
+        T{ ##call-gc f T{ gc-map } }
-        T{ ##call-gc }
         T{ ##branch }
     }
 ] [ 2 get predecessors>> second instructions>> ] unit-test

basis/compiler/cfg/gc-checks/gc-checks.factor

@@ -9,10 +9,7 @@ compiler.cfg.registers
 compiler.cfg.utilities
 compiler.cfg.comparisons
 compiler.cfg.instructions
-compiler.cfg.predecessors
+compiler.cfg.predecessors ;
-compiler.cfg.liveness
-compiler.cfg.liveness.ssa
-compiler.cfg.stacks.uninitialized ;
 IN: compiler.cfg.gc-checks
 
 <PRIVATE
@@ -50,12 +47,9 @@ IN: compiler.cfg.gc-checks
         ] bi*
     ] V{ } make >>instructions ;
 
-: scrubbed ( uninitialized-locs -- scrub-d scrub-r )
+: <gc-call> ( -- bb )
-    [ ds-loc? ] partition [ [ n>> ] map ] bi@ ;
+    <basic-block>
-
+    [ <gc-map> ##call-gc ##branch ] V{ } make
-: <gc-call> ( uninitialized-locs gc-roots -- bb )
-    [ <basic-block> ] 2dip
-    [ [ scrubbed ] dip ##gc-map ##call-gc ##branch ] V{ } make
     >>instructions t >>unlikely? ;
 
 :: insert-guard ( body check bb -- )
@@ -69,7 +63,7 @@ IN: compiler.cfg.gc-checks
 
     check predecessors>> [ bb check update-successors ] each ;
 
-: (insert-gc-check) ( uninitialized-locs gc-roots phis size bb -- )
+: (insert-gc-check) ( phis size bb -- )
     [ [ <gc-call> ] 2dip <gc-check> ] dip insert-guard ;
 
 GENERIC: allocation-size* ( insn -- n )
@@ -85,35 +79,17 @@ M: ##box-displaced-alien allocation-size* drop 5 cells ;
     [ ##allocation? ] filter
     [ allocation-size* data-alignment get align ] map-sum ;
 
-: gc-live-in ( bb -- vregs )
-    [ live-in keys ] [ instructions>> [ ##phi? ] filter [ dst>> ] map ] bi
-    append ;
-
-: live-tagged ( bb -- vregs )
-    gc-live-in [ rep-of tagged-rep? ] filter ;
-
 : remove-phis ( bb -- phis )
     [ [ ##phi? ] partition ] change-instructions drop ;
 
 : insert-gc-check ( bb -- )
-    {
+    [ remove-phis ] [ allocation-size ] [ ] tri (insert-gc-check) ;
-        [ uninitialized-locs ]
-        [ live-tagged ]
-        [ remove-phis ]
-        [ allocation-size ]
-        [ ]
-    } cleave
-    (insert-gc-check) ;
 
 PRIVATE>
 
 : insert-gc-checks ( cfg -- cfg' )
     dup blocks-with-gc [
-        [
+        [ needs-predecessors ] dip
-            needs-predecessors
-            dup compute-ssa-live-sets
-            dup compute-uninitialized-sets
-        ] dip
         [ insert-gc-check ] each
         cfg-changed
     ] unless-empty ;

basis/compiler/cfg/instructions/instructions.factor

@@ -670,27 +670,28 @@ literal: size align offset ;
 INSN: ##box
 def: dst/tagged-rep
 use: src
-literal: boxer rep ;
+literal: boxer rep gc-map ;
 
 INSN: ##box-long-long
 def: dst/tagged-rep
 use: src1/int-rep src2/int-rep
-literal: boxer ;
+literal: boxer gc-map ;
 
 INSN: ##allot-byte-array
 def: dst/tagged-rep
-literal: size ;
+literal: size gc-map ;
 
 INSN: ##prepare-var-args ;
 
 INSN: ##alien-invoke
-literal: symbols dll ;
+literal: symbols dll gc-map ;
 
 INSN: ##cleanup
 literal: n ;
 
 INSN: ##alien-indirect
-use: src/int-rep ;
+use: src/int-rep
+literal: gc-map ;
 
 INSN: ##alien-assembly
 literal: quot ;
@@ -819,10 +820,7 @@ INSN: ##check-nursery-branch
 literal: size cc
 temp: temp1/int-rep temp2/int-rep ;
 
-INSN: ##call-gc ;
+INSN: ##call-gc literal: gc-map ;
-
-INSN: ##gc-map
-literal: scrub-d scrub-r gc-roots ;
 
 ! Spills and reloads, inserted by register allocator
 TUPLE: spill-slot { n integer } ;
@@ -860,6 +858,23 @@ UNION: conditional-branch-insn
 UNION: ##read ##slot ##slot-imm ##vm-field ##alien-global ;
 UNION: ##write ##set-slot ##set-slot-imm ##set-vm-field ;
 
+! Instructions that contain subroutine calls to functions which
+! allocate memory
+UNION: gc-map-insn
+##call-gc
+##alien-invoke
+##alien-indirect
+##box
+##box-long-long
+##allot-byte-array ;
+
+M: gc-map-insn clone call-next-method [ clone ] change-gc-map ;
+
+! Each one has a gc-map slot
+TUPLE: gc-map scrub-d scrub-r gc-roots ;
+
+: <gc-map> ( -- gc-map ) gc-map new ;
+
 ! Instructions that clobber registers. They receive inputs and
 ! produce outputs in spill slots.
 UNION: hairy-clobber-insn

basis/compiler/cfg/linear-scan/assignment/assignment.factor

@@ -142,8 +142,10 @@ RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 M: vreg-insn assign-registers-in-insn
     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 
-M: ##gc-map assign-registers-in-insn
+M: gc-map-insn assign-registers-in-insn
-    [ [ vreg>reg ] map ] change-gc-roots drop ;
+    [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
+    [ gc-map>> [ [ vreg>reg ] map ] change-gc-roots drop ]
+    bi ;
 
 M: insn assign-registers-in-insn drop ;
 

basis/compiler/cfg/liveness/liveness.factor

@@ -1,25 +1,40 @@
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors assocs sequences sets
 compiler.cfg.def-use compiler.cfg.dataflow-analysis
-compiler.cfg.instructions ;
+compiler.cfg.instructions compiler.cfg.registers
+cpu.architecture ;
 IN: compiler.cfg.liveness
 
 ! See http://en.wikipedia.org/wiki/Liveness_analysis
-! Do not run after SSA construction
+! Do not run after SSA construction; compiler.cfg.liveness.ssa
+! should be used instead. The transfer-liveness word is used
+! by SSA liveness too, so it handles ##phi instructions.
 
 BACKWARD-ANALYSIS: live
 
-GENERIC: insn-liveness ( live-set insn -- )
+GENERIC: visit-insn ( live-set insn -- live-set )
 
 : kill-defs ( live-set insn -- live-set )
-    defs-vreg [ over delete-at ] when* ;
+    defs-vreg [ over delete-at ] when* ; inline
 
 : gen-uses ( live-set insn -- live-set )
-    dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ;
+    uses-vregs [ over conjoin ] each ; inline
+
+M: vreg-insn visit-insn [ kill-defs ] [ gen-uses ] bi ;
+
+: fill-gc-map ( live-set insn -- live-set )
+    gc-map>> over keys [ rep-of tagged-rep? ] filter >>gc-roots drop ;
+
+M: gc-map-insn visit-insn
+    [ kill-defs ] [ fill-gc-map ] [ gen-uses ] tri ;
+
+M: ##phi visit-insn kill-defs ;
+
+M: insn visit-insn drop ;
 
 : transfer-liveness ( live-set instructions -- live-set' )
-    [ clone ] [ <reversed> ] bi* [ [ kill-defs ] [ gen-uses ] bi ] each ;
+    [ clone ] [ <reversed> ] bi* [ visit-insn ] each ;
 
 : local-live-in ( instructions -- live-set )
     [ H{ } ] dip transfer-liveness keys ;

basis/compiler/cfg/ssa/interference/interference-tests.factor

@@ -182,7 +182,7 @@ V{
 
 V{
     T{ ##save-context f 77 78 }
-    T{ ##call-gc f { } }
+    T{ ##call-gc f T{ gc-map } }
     T{ ##branch }
 } 2 test-bb
 

basis/compiler/cfg/stacks/uninitialized/uninitialized-tests.factor

@@ -29,8 +29,8 @@ V{
 
 [ ] [ test-uninitialized ] unit-test
 
-[ V{ D 0 D 1 D 2 } ] [ 1 get uninitialized-locs ] unit-test
+[ { B{ 0 0 0 } B{ } } ] [ 1 get uninitialized-in ] unit-test
-[ V{ R 0 } ] [ 2 get uninitialized-locs ] unit-test
+[ { B{ 1 1 1 } B{ 0 } } ] [ 2 get uninitialized-in ] unit-test
 
 ! When merging, if a location is uninitialized in one branch and
 ! initialized in another, we have to consider it uninitialized,
@@ -57,4 +57,4 @@ V{
 
 [ ] [ test-uninitialized ] unit-test
 
-[ V{ D 0 } ] [ 3 get uninitialized-locs ] unit-test
+[ { B{ 0 } B{ } } ] [ 3 get uninitialized-in ] unit-test

basis/compiler/cfg/stacks/uninitialized/uninitialized.factor

@@ -9,11 +9,17 @@ IN: compiler.cfg.stacks.uninitialized
 
 ! Consider the following sequence of instructions:
 ! ##inc-d 2
-! ##gc
+! ...
+! ##allot
 ! ##replace ... D 0
 ! ##replace ... D 1
-! The GC check runs before stack locations 0 and 1 have been initialized,
+! The GC check runs before stack locations 0 and 1 have been
-! and it needs to zero them out so that GC doesn't try to trace them.
+! initialized, and so the GC needs to scrub them so that they
+! don't get traced. This is achieved by computing uninitialized
+! locations with a dataflow analysis, and recording the
+! information in GC maps. The scrub_contexts() method on
+! vm/gc.cpp reads this information from GC maps and performs
+! the scrubbing.
 
 <PRIVATE
 
@@ -28,7 +34,6 @@ GENERIC: visit-insn ( insn -- )
     ] change ;
 
 M: ##inc-d visit-insn n>> ds-loc handle-inc ;
-
 M: ##inc-r visit-insn n>> rs-loc handle-inc ;
 
 ERROR: uninitialized-peek insn ;
@@ -46,6 +51,12 @@ M: ##peek visit-insn visit-peek ;
 M: ##replace visit-insn visit-replace ;
 M: ##replace-imm visit-insn visit-replace ;
 
+M: gc-map-insn visit-insn
+    gc-map>>
+    ds-loc get clone >>scrub-d
+    rs-loc get clone >>scrub-r
+    drop ;
+
 M: insn visit-insn drop ;
 
 : prepare ( pair -- )
@@ -59,9 +70,6 @@ M: insn visit-insn drop ;
 : (join-sets) ( seq1 seq2 -- seq )
     2dup [ length ] bi@ max '[ _ 1 pad-tail ] bi@ [ bitand ] 2map ;
 
-: (uninitialized-locs) ( seq quot -- seq' )
-    [ [ drop 0 = ] selector [ each-index ] dip ] dip map ; inline
-
 PRIVATE>
 
 FORWARD-ANALYSIS: uninitialized
@@ -71,11 +79,3 @@ M: uninitialized-analysis transfer-set ( pair bb analysis -- pair' )
 
 M: uninitialized-analysis join-sets ( sets analysis -- pair )
     2drop sift [ f ] [ [ ] [ [ (join-sets) ] 2map ] map-reduce ] if-empty ;
-
-: uninitialized-locs ( bb -- locs )
-    uninitialized-in dup [
-        first2
-        [ [ <ds-loc> ] (uninitialized-locs) ]
-        [ [ <rs-loc> ] (uninitialized-locs) ]
-        bi* append f like
-    ] when ;

basis/compiler/codegen/codegen.factor

@@ -258,7 +258,6 @@ CODEGEN: ##restore-context %restore-context
 CODEGEN: ##vm-field %vm-field
 CODEGEN: ##set-vm-field %set-vm-field
 CODEGEN: ##alien-global %alien-global
-CODEGEN: ##gc-map %gc-map
 CODEGEN: ##call-gc %call-gc
 CODEGEN: ##spill %spill
 CODEGEN: ##reload %reload

basis/compiler/codegen/fixup/fixup-tests.factor

@@ -1,6 +1,7 @@
 USING: namespaces byte-arrays make compiler.codegen.fixup
 bit-arrays accessors classes.struct tools.test kernel math
-sequences alien.c-types specialized-arrays boxes ;
+sequences alien.c-types specialized-arrays boxes
+compiler.cfg.instructions system cpu.architecture ;
 SPECIALIZED-ARRAY: uint
 IN: compiler.codegen.fixup.tests
 
@@ -10,19 +11,23 @@ STRUCT: gc-info
 { gc-root-count uint }
 { return-address-count uint } ;
 
+SINGLETON: fake-cpu
+
+fake-cpu \ cpu set
+
+M: fake-cpu gc-root-offsets ;
+
 [ ] [
     [
         init-fixup
 
         50 <byte-array> %
 
-        { { } { } { } } set-next-gc-map
+        T{ gc-map f B{ } B{ } V{ } } gc-map-here
-        gc-map-here
 
         50 <byte-array> %
 
-        { { 0 4 } { 1 } { 1 3 } } set-next-gc-map
+        T{ gc-map f B{ 0 1 1 1 0 } B{ 1 0 } V{ 1 3 } } gc-map-here
-        gc-map-here
 
         emit-gc-info
     ] B{ } make

basis/compiler/codegen/fixup/fixup.factor

@@ -4,8 +4,9 @@ USING: arrays bit-arrays byte-arrays byte-vectors generic assocs
 hashtables io.binary kernel kernel.private math namespaces make
 sequences words quotations strings alien.accessors alien.strings
 layouts system combinators math.bitwise math.order
-combinators.smart accessors growable fry compiler.constants
+combinators.short-circuit combinators.smart accessors growable
-memoize boxes ;
+fry memoize compiler.constants compiler.cfg.instructions
+cpu.architecture ;
 IN: compiler.codegen.fixup
 
 ! Utilities
@@ -149,30 +150,37 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
 ! uint <largest GC root spill slot>
 ! uint <number of return addresses>
 
-SYMBOLS: next-gc-map return-addresses gc-maps ;
+SYMBOLS: return-addresses gc-maps ;
 
-: gc-map? ( triple -- ? )
+: gc-map-needed? ( gc-map -- ? )
     ! If there are no stack locations to scrub and no GC roots,
     ! there's no point storing the GC map.
-    [ empty? not ] any? ;
+    dup [
+        {
+            [ scrub-d>> empty? ]
+            [ scrub-r>> empty? ]
+            [ gc-roots>> empty? ]
+        } 1&& not
+    ] when ;
 
-: gc-map-here ( -- )
+: gc-map-here ( gc-map -- )
-    next-gc-map get box> dup gc-map? [
+    dup gc-map-needed? [
         gc-maps get push
         compiled-offset return-addresses get push
     ] [ drop ] if ;
 
-: set-next-gc-map ( gc-map -- ) next-gc-map get >box ;
+: emit-scrub ( seqs -- n )
+    ! seqs is a sequence of sequences of 0/1
+    dup [ length ] [ max ] map-reduce
+    [ '[ [ 0 = ] ?{ } map-as _ f pad-tail % ] each ] keep ;
 
 : integers>bits ( seq n -- bit-array )
     <bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
 
-: emit-bitmap ( seqs -- n )
+: emit-gc-roots ( seqs -- n )
     ! seqs is a sequence of sequences of integers 0..n-1
-    [ 0 ] [
     dup [ [ 0 ] [ supremum 1 + ] if-empty ] [ max ] map-reduce
-        [ '[ _ integers>bits % ] each ] keep
+    [ '[ _ integers>bits % ] each ] keep ;
-    ] if-empty ;
 
 : emit-uint ( n -- )
     building get push-uint ;
@@ -182,9 +190,9 @@ SYMBOLS: next-gc-map return-addresses gc-maps ;
         return-addresses get empty? [ 0 emit-uint ] [
             gc-maps get
             [
-                [ [ first ] map emit-bitmap ]
+                [ [ scrub-d>> ] map emit-scrub ]
-                [ [ second ] map emit-bitmap ]
+                [ [ scrub-r>> ] map emit-scrub ]
-                [ [ third ] map emit-bitmap ] tri
+                [ [ gc-roots>> gc-root-offsets ] map emit-gc-roots ] tri
             ] ?{ } make underlying>> %
             return-addresses get [ emit-uint ] each
             [ emit-uint ] tri@
@@ -208,12 +216,10 @@ SYMBOLS: next-gc-map return-addresses gc-maps ;
     BV{ } clone relocation-table set
     V{ } clone binary-literal-table set
     V{ } clone return-addresses set
-    V{ } clone gc-maps set
+    V{ } clone gc-maps set ;
-    <box> next-gc-map set ;
 
 : check-fixup ( seq -- )
-    length data-alignment get mod 0 assert=
+    length data-alignment get mod 0 assert= ;
-    next-gc-map get occupied>> f assert= ;
 
 : with-fixup ( quot -- code )
     '[

basis/cpu/architecture/architecture.factor

@@ -225,6 +225,8 @@ M: object vm-stack-space 0 ;
 ! %store-memory work
 HOOK: complex-addressing? cpu ( -- ? )
 
+HOOK: gc-root-offsets cpu ( seq -- seq' )
+
 HOOK: %load-immediate cpu ( reg val -- )
 HOOK: %load-reference cpu ( reg obj -- )
 HOOK: %load-float cpu ( reg val -- )
@@ -488,8 +490,7 @@ HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
 
 ! GC checks
 HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
-HOOK: %gc-map cpu ( scrub-d scrub-r gc-roots -- )
+HOOK: %call-gc cpu ( gc-map -- )
-HOOK: %call-gc cpu ( -- )
 
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )
@@ -595,11 +596,11 @@ HOOK: %local-allot cpu ( dst size align offset -- )
 ! Call a function to convert a value into a tagged pointer,
 ! possibly allocating a bignum, float, or alien instance,
 ! which is then pushed on the data stack
-HOOK: %box cpu ( dst src func rep -- )
+HOOK: %box cpu ( dst src func rep gc-map -- )
 
-HOOK: %box-long-long cpu ( dst src1 src2 func -- )
+HOOK: %box-long-long cpu ( dst src1 src2 func gc-map -- )
 
-HOOK: %allot-byte-array cpu ( dst size -- )
+HOOK: %allot-byte-array cpu ( dst size gc-map -- )
 
 HOOK: %restore-context cpu ( temp1 temp2 -- )
 
@@ -609,13 +610,13 @@ HOOK: %prepare-var-args cpu ( -- )
 
 M: object %prepare-var-args ;
 
-HOOK: %alien-invoke cpu ( function library -- )
+HOOK: %alien-invoke cpu ( function library gc-map -- )
 
 HOOK: %cleanup cpu ( n -- )
 
 M: object %cleanup ( n -- ) drop ;
 
-HOOK: %alien-indirect cpu ( src -- )
+HOOK: %alien-indirect cpu ( src gc-map -- )
 
 HOOK: %load-reg-param cpu ( dst reg rep -- )
 

basis/cpu/x86/32/32.factor

@@ -134,7 +134,7 @@ M: x86.32 %store-reg-param ( src reg rep -- )
     EAX src tagged-rep %copy
     4 save-vm-ptr
     0 stack@ EAX MOV
-    func f %alien-invoke ;
+    func f f %alien-invoke ;
 
 M:: x86.32 %unbox ( dst src func rep -- )
     src func call-unbox-func
@@ -146,36 +146,37 @@ M:: x86.32 %unbox-long-long ( src out func -- )
     EAX out int-rep %copy
     4 stack@ EAX MOV
     8 save-vm-ptr
-    func f %alien-invoke ;
+    func f f %alien-invoke ;
 
-M:: x86.32 %box ( dst src func rep -- )
+M:: x86.32 %box ( dst src func rep gc-map -- )
     rep rep-size save-vm-ptr
     src rep %store-return
     0 stack@ rep %load-return
-    func f %alien-invoke
+    func f gc-map %alien-invoke
     dst EAX tagged-rep %copy ;
 
-M:: x86.32 %box-long-long ( dst src1 src2 func -- )
+M:: x86.32 %box-long-long ( dst src1 src2 func gc-map -- )
     8 save-vm-ptr
     EAX src1 int-rep %copy
     0 stack@ EAX int-rep %copy
     EAX src2 int-rep %copy
     4 stack@ EAX int-rep %copy
-    func f %alien-invoke
+    func f gc-map %alien-invoke
     dst EAX tagged-rep %copy ;
 
-M:: x86.32 %allot-byte-array ( dst size -- )
+M:: x86.32 %allot-byte-array ( dst size gc-map -- )
     4 save-vm-ptr
     0 stack@ size MOV
-    "allot_byte_array" f %alien-invoke
+    "allot_byte_array" f gc-map %alien-invoke
     dst EAX tagged-rep %copy ;
 
-M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ;
+M: x86.32 %alien-invoke
+    [ 0 CALL rc-relative rel-dlsym ] dip gc-map-here ;
 
 M: x86.32 %begin-callback ( -- )
     0 save-vm-ptr
     4 stack@ 0 MOV
-    "begin_callback" f %alien-invoke ;
+    "begin_callback" f f %alien-invoke ;
 
 M: x86.32 %alien-callback ( quot -- )
     [ EAX ] dip %load-reference
@@ -183,7 +184,7 @@ M: x86.32 %alien-callback ( quot -- )
 
 M: x86.32 %end-callback ( -- )
     0 save-vm-ptr
-    "end_callback" f %alien-invoke ;
+    "end_callback" f f %alien-invoke ;
 
 GENERIC: float-function-param ( n dst src -- )
 
@@ -198,13 +199,13 @@ M:: register float-function-param ( n dst src -- )
 
 M:: x86.32 %unary-float-function ( dst src func -- )
     0 dst src float-function-param
-    func "libm" load-library %alien-invoke
+    func "libm" load-library f %alien-invoke
     dst double-rep %load-return ;
 
 M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
     0 dst src1 float-function-param
     8 dst src2 float-function-param
-    func "libm" load-library %alien-invoke
+    func "libm" load-library f %alien-invoke
     dst double-rep %load-return ;
 
 : funny-large-struct-return? ( return abi -- ? )

basis/cpu/x86/32/bootstrap.factor

@@ -63,6 +63,9 @@ IN: bootstrap.x86
     ds-reg ctx-reg context-datastack-offset [+] MOV
     rs-reg ctx-reg context-retainstack-offset [+] MOV ;
 
+: jit-scrub-return ( n -- )
+    ESP swap [+] 0 MOV ;
+
 [
     ! ctx-reg is preserved across the call because it is non-volatile
     ! in the C ABI
@@ -130,6 +133,7 @@ IN: bootstrap.x86
 
     ! Unwind stack frames
     ESP EDX MOV
+    0 jit-scrub-return
 
     jit-jump-quot
 ] \ unwind-native-frames define-sub-primitive
@@ -252,9 +256,7 @@ IN: bootstrap.x86
 
 ! Contexts
 : jit-switch-context ( reg -- )
-    ! Dummy return address -- it never gets returned to but it
+    -4 jit-scrub-return
-    ! must point to inside the current code block
-    ESP -4 [+] HEX: ffffffff MOV rc-absolute-cell rt-this jit-rel
 
     ! Save ds, rs registers
     jit-load-vm

basis/cpu/x86/64/64.factor

@@ -90,30 +90,29 @@ M:: x86.64 %store-reg-param ( src reg rep -- )
 M:: x86.64 %unbox ( dst src func rep -- )
     param-reg-0 src tagged-rep %copy
     param-reg-1 %mov-vm-ptr
-    func f %alien-invoke
+    func f f %alien-invoke
     dst rep %load-return ;
 
-M:: x86.64 %box ( dst src func rep -- )
+M:: x86.64 %box ( dst src func rep gc-map -- )
     0 rep reg-class-of cdecl param-regs at nth src rep %copy
     rep int-rep? os windows? or param-reg-1 param-reg-0 ? %mov-vm-ptr
-    func f %alien-invoke
+    func f gc-map %alien-invoke
     dst int-rep %load-return ;
 
-M:: x86.64 %allot-byte-array ( dst size -- )
+M:: x86.64 %allot-byte-array ( dst size gc-map -- )
     param-reg-0 size MOV
     param-reg-1 %mov-vm-ptr
-    "allot_byte_array" f %alien-invoke
+    "allot_byte_array" f gc-map %alien-invoke
     dst int-rep %load-return ;
 
 M: x86.64 %alien-invoke
-    R11 0 MOV
+    [ R11 0 MOV rc-absolute-cell rel-dlsym R11 CALL ] dip
-    rc-absolute-cell rel-dlsym
+    gc-map-here ;
-    R11 CALL ;
 
 M: x86.64 %begin-callback ( -- )
     param-reg-0 %mov-vm-ptr
     param-reg-1 0 MOV
-    "begin_callback" f %alien-invoke ;
+    "begin_callback" f f %alien-invoke ;
 
 M: x86.64 %alien-callback ( quot -- )
     [ param-reg-0 ] dip %load-reference
@@ -121,14 +120,14 @@ M: x86.64 %alien-callback ( quot -- )
 
 M: x86.64 %end-callback ( -- )
     param-reg-0 %mov-vm-ptr
-    "end_callback" f %alien-invoke ;
+    "end_callback" f f %alien-invoke ;
 
 : float-function-param ( i src -- )
     [ float-regs cdecl param-regs at nth ] dip double-rep %copy ;
 
 M:: x86.64 %unary-float-function ( dst src func -- )
     0 src float-function-param
-    func "libm" load-library %alien-invoke
+    func "libm" load-library f %alien-invoke
     dst double-rep %load-return ;
 
 M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
@@ -136,7 +135,7 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
     ! src2 is always a spill slot
     0 src1 float-function-param
     1 src2 float-function-param
-    func "libm" load-library %alien-invoke
+    func "libm" load-library f %alien-invoke
     dst double-rep %load-return ;
 
 M: x86.64 long-long-on-stack? f ;

basis/cpu/x86/64/bootstrap.factor

@@ -61,6 +61,9 @@ IN: bootstrap.x86
     ds-reg ctx-reg context-datastack-offset [+] MOV
     rs-reg ctx-reg context-retainstack-offset [+] MOV ;
 
+: jit-scrub-return ( n -- )
+    RSP swap [+] 0 MOV ;
+
 [
     ! ctx-reg is preserved across the call because it is non-volatile
     ! in the C ABI
@@ -111,6 +114,7 @@ IN: bootstrap.x86
 
     ! Unwind stack frames
     RSP arg2 MOV
+    0 jit-scrub-return
 
     ! Load VM pointer into vm-reg, since we're entering from
     ! C code
@@ -228,10 +232,7 @@ IN: bootstrap.x86
 
 ! Contexts
 : jit-switch-context ( reg -- )
-    ! Dummy return address -- it never gets returned to but it
+    -8 jit-scrub-return
-    ! must point to inside the current code block
-    R11 0 [RIP+] LEA
-    RSP -8 [+] R11 MOV
 
     ! Save ds, rs registers
     jit-save-context

basis/cpu/x86/x86.factor

@@ -480,13 +480,10 @@ M:: x86 %check-nursery-branch ( label size cc temp1 temp2 -- )
         { cc/<= [ label JG ] }
     } case ;
 
-: gc-root-offsets ( seq -- seq' )
+M: x86 gc-root-offsets
     [ n>> spill-offset special-offset cell + cell /i ] map f like ;
 
-M: x86 %gc-map ( scrub-d scrub-r gc-roots -- )
+M: x86 %call-gc ( gc-map -- )
-    gc-root-offsets 3array set-next-gc-map ;
-
-M: x86 %call-gc
     \ minor-gc %call
     gc-map-here ;
 
@@ -612,8 +609,8 @@ M:: x86 %load-stack-param ( dst n rep -- )
 M:: x86 %local-allot ( dst size align offset -- )
     dst offset local-allot-offset special-offset stack@ LEA ;
 
-M: x86 %alien-indirect ( src -- )
+M: x86 %alien-indirect ( src gc-map -- )
-    ?spill-slot CALL ;
+    [ ?spill-slot CALL ] [ gc-map-here ] bi* ;
 
 M: x86 %loop-entry 16 alignment [ NOP ] times ;
 

basis/io/sockets/sockets-docs.factor

@@ -34,6 +34,10 @@ ARTICLE: "network-connection" "Connection-oriented networking"
     <client>
     with-client
 }
+"The local address of a client socket can be controlled with this word:"
+{ $subsections
+    with-local-address
+}
 "Connection-oriented network servers are implemented by first opening a server socket, then waiting for connections:"
 { $subsections
     <server>
@@ -215,3 +219,17 @@ HELP: send
 HELP: resolve-host
 { $values { "addrspec" "an address specifier" } { "seq" "a sequence of address specifiers" } }
 { $description "Resolves host names to IP addresses." } ;
+
+HELP: with-local-address
+{ $values { "addr" "an " { $link inet4 } " or " { $link inet6 } " address specifier" } { "quot" quotation } }
+{ $description "Client sockets opened within the scope of the quotation passed to this combinator will have their local address bound to the given address." }
+{ $examples
+  { "Binds the local address of a newly created client socket within the quotation to 127.0.0.1."
+    "This ensures that all traffic originates from the given address (the port is choosen by the TCP stack)." }
+  { $code "\"127.0.0.1\" 0 <inet4> [ ] with-local-address" }
+  $nl
+  { "Binds the local address of a newly created client socket within the quotation to the local address 192.168.0.1 and the local port 23000. "
+    "Be aware that you can only have one client socket with the same local address at a time or else an I/O error (\"address already in use\") will be thrown."
+  }
+  { $code "\"192.168.0.1\" 23000 <inet4> [ ] with-local-address" }
+} ;

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

@@ -0,0 +1,4 @@
+USING: math.vectors.simd math.vectors.simd.cords tools.test ;
+IN: math.vectors.simd.cords.tests
+
+[ float-4{ 1.0 2.0 3.0 4.0 } ] [ double-4{ 1.0 2.0 3.0 4.0 } >float-4 ] unit-test

basis/math/vectors/simd/cords/cords.factor

@@ -28,8 +28,8 @@ BOA-EFFECT [ N 2 * "n" <array> { "v" } <effect> ]
 WHERE
 
 : >A ( seq -- A )
-    [ N head >A/2 ]
+    [ N head-slice >A/2 ]
-    [ N tail >A/2 ] bi cord-append ;
+    [ N tail-slice >A/2 ] bi cord-append ;
 
 \ A-boa
 { N ndip A/2-boa cord-append } { A/2-boa } >quotation prefix >quotation

basis/prettyprint/backend/backend.factor

@@ -226,7 +226,9 @@ M: object pprint-object ( obj -- )
 M: object pprint* pprint-object ;
 M: vector pprint* pprint-object ;
 M: byte-vector pprint* pprint-object ;
-M: hashtable pprint* pprint-object ;
+M: hashtable pprint*
+    nesting-limit inc
+    [ pprint-object ] [ nesting-limit dec ] [ ] cleanup ;
 M: curry pprint* pprint-object ;
 M: compose pprint* pprint-object ;
 M: hash-set pprint* pprint-object ;

basis/sequences/cords/cords.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs sequences sorting binary-search fry math
-math.order arrays classes combinators kernel functors math.functions
+math.order arrays classes combinators kernel functors locals
-math.vectors ;
+math.functions math.vectors ;
 IN: sequences.cords
 
 MIXIN: cord
@@ -47,57 +47,62 @@ M: T cord-append
     [ [ head>> ] dip call ]
     [ [ tail>> ] dip call ] 2bi cord-append ; inline
 
-: cord-2map ( cord cord quot -- cord' )
+:: cord-2map ( cord-a cord-b quot fallback -- cord' )
-    [ [ [ head>> ] bi@ ] dip call ]
+    cord-a cord-b 2dup [ cord? ] both? [
-    [ [ [ tail>> ] bi@ ] dip call ] 3bi cord-append ; inline
+        [ [ head>> ] bi@ quot call ]
+        [ [ tail>> ] bi@ quot call ] 2bi cord-append
+    ] [ fallback call ] if ; inline
 
 : cord-both ( cord quot -- h t )
     [ [ head>> ] [ tail>> ] bi ] dip bi@ ; inline
 
-: cord-2both ( cord cord quot -- h t )
+:: cord-2both ( cord-a cord-b quot combine fallback -- result )
-    [ [ [ head>> ] bi@ ] dip call ]
+    cord-a cord-b 2dup [ cord? ] both? [
-    [ [ [ tail>> ] bi@ ] dip call ] 3bi ; inline
+        [ [ head>> ] bi@ quot call ]
+        [ [ tail>> ] bi@ quot call ] 2bi combine call
+    ] [ fallback call ] if ; inline
 
 <PRIVATE
 : split-shuffle ( shuf -- sh uf )
     dup length 2 /i cut* ; foldable
 PRIVATE>
 
-M: cord v+                [ v+                ] cord-2map ; inline
+M: cord v+                [ v+                ] [ call-next-method ] cord-2map ; inline
-M: cord v-                [ v-                ] cord-2map ; inline
+M: cord v-                [ v-                ] [ call-next-method ] cord-2map ; inline
 M: cord vneg              [ vneg              ] cord-map  ; inline
-M: cord v+-               [ v+-               ] cord-2map ; inline
+M: cord v+-               [ v+-               ] [ call-next-method ] cord-2map ; inline
-M: cord vs+               [ vs+               ] cord-2map ; inline
+M: cord vs+               [ vs+               ] [ call-next-method ] cord-2map ; inline
-M: cord vs-               [ vs-               ] cord-2map ; inline
+M: cord vs-               [ vs-               ] [ call-next-method ] cord-2map ; inline
-M: cord vs*               [ vs*               ] cord-2map ; inline
+M: cord vs*               [ vs*               ] [ call-next-method ] cord-2map ; inline
-M: cord v*                [ v*                ] cord-2map ; inline
+M: cord v*                [ v*                ] [ call-next-method ] cord-2map ; inline
-M: cord v/                [ v/                ] cord-2map ; inline
+M: cord v/                [ v/                ] [ call-next-method ] cord-2map ; inline
-M: cord vmin              [ vmin              ] cord-2map ; inline
+M: cord vmin              [ vmin              ] [ call-next-method ] cord-2map ; inline
-M: cord vmax              [ vmax              ] cord-2map ; inline
+M: cord vmax              [ vmax              ] [ call-next-method ] cord-2map ; inline
-M: cord v.                [ v.                ] cord-2both + ; inline
+M: cord v.
+    [ v.                ] [ + ] [ call-next-method ] cord-2both ; inline
 M: cord vsqrt             [ vsqrt             ] cord-map  ; inline
 M: cord sum               [ sum               ] cord-both + ; inline
 M: cord vabs              [ vabs              ] cord-map  ; inline
-M: cord vbitand           [ vbitand           ] cord-2map ; inline
+M: cord vbitand           [ vbitand           ] [ call-next-method ] cord-2map ; inline
-M: cord vbitandn          [ vbitandn          ] cord-2map ; inline
+M: cord vbitandn          [ vbitandn          ] [ call-next-method ] cord-2map ; inline
-M: cord vbitor            [ vbitor            ] cord-2map ; inline
+M: cord vbitor            [ vbitor            ] [ call-next-method ] cord-2map ; inline
-M: cord vbitxor           [ vbitxor           ] cord-2map ; inline
+M: cord vbitxor           [ vbitxor           ] [ call-next-method ] cord-2map ; inline
 M: cord vbitnot           [ vbitnot           ] cord-map  ; inline
-M: cord vand              [ vand              ] cord-2map ; inline
+M: cord vand              [ vand              ] [ call-next-method ] cord-2map ; inline
-M: cord vandn             [ vandn             ] cord-2map ; inline
+M: cord vandn             [ vandn             ] [ call-next-method ] cord-2map ; inline
-M: cord vor               [ vor               ] cord-2map ; inline
+M: cord vor               [ vor               ] [ call-next-method ] cord-2map ; inline
-M: cord vxor              [ vxor              ] cord-2map ; inline
+M: cord vxor              [ vxor              ] [ call-next-method ] cord-2map ; inline
 M: cord vnot              [ vnot              ] cord-map  ; inline
 M: cord vlshift           '[ _ vlshift        ] cord-map  ; inline
 M: cord vrshift           '[ _ vrshift        ] cord-map  ; inline
 M: cord (vmerge-head)     [ head>> ] bi@ (vmerge) cord-append ; inline
 M: cord (vmerge-tail)     [ tail>> ] bi@ (vmerge) cord-append ; inline
-M: cord v<=               [ v<=               ] cord-2map ; inline
+M: cord v<=               [ v<=               ] [ call-next-method ] cord-2map ; inline
-M: cord v<                [ v<                ] cord-2map ; inline
+M: cord v<                [ v<                ] [ call-next-method ] cord-2map ; inline
-M: cord v=                [ v=                ] cord-2map ; inline
+M: cord v=                [ v=                ] [ call-next-method ] cord-2map ; inline
-M: cord v>                [ v>                ] cord-2map ; inline
+M: cord v>                [ v>                ] [ call-next-method ] cord-2map ; inline
-M: cord v>=               [ v>=               ] cord-2map ; inline
+M: cord v>=               [ v>=               ] [ call-next-method ] cord-2map ; inline
-M: cord vunordered?       [ vunordered?       ] cord-2map ; inline
+M: cord vunordered?       [ vunordered?       ] [ call-next-method ] cord-2map ; inline
 M: cord vany?             [ vany?             ] cord-both or  ; inline
 M: cord vall?             [ vall?             ] cord-both and ; inline
 M: cord vnone?            [ vnone?            ] cord-both and ; inline

basis/tools/disassembler/udis/udis-tests.factor

@@ -2,8 +2,7 @@ IN: tools.disassembler.udis.tests
 USING: tools.disassembler.udis tools.test alien.c-types system combinators kernel ;
 
 {
-    { [ os linux? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] }
+    { [ cpu x86.32? ] [ [ 604 ] [ ud heap-size ] unit-test ] }
-    { [ os macosx? cpu x86.32? and ] [ [ 592 ] [ ud heap-size ] unit-test ] }
+    { [ cpu x86.64? ] [ [ 672 ] [ ud heap-size ] unit-test ] }
-    { [ os macosx? cpu x86.64? and ] [ [ 656 ] [ ud heap-size ] unit-test ] }
     [ ]
 } cond

basis/tools/disassembler/udis/udis.factor

@@ -67,7 +67,11 @@ STRUCT: ud
     { c3 uchar }
     { inp_cache uchar[256] }
     { inp_sess uchar[64] }
-    { itab_entry void* } ;
+    { have_modrm uchar }
+    { modrm uchar }
+    { user_opaque_data void* }
+    { itab_entry void* }
+    { le void* } ;
 
 FUNCTION: void ud_translate_intel ( ud* u ) ;
 FUNCTION: void ud_translate_att ( ud* u ) ;

basis/typed/prettyprint/prettyprint.factor

@@ -1,4 +1,5 @@
-USING: definitions kernel locals.definitions see see.private typed words ;
+USING: definitions kernel locals.definitions see see.private typed words
+summary make accessors classes ;
 IN: typed.prettyprint
 
 PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
@@ -9,3 +10,24 @@ M: typed-lambda-word definer drop \ TYPED:: \ ; ;
 M: typed-word definition "typed-def" word-prop ;
 M: typed-word declarations. "typed-word" word-prop declarations. ;
 
+M: input-mismatch-error summary
+    [
+        "Typed word “" %
+        dup word>> name>> %
+        "” expected input value of type " %
+        dup expected-type>> name>> %
+        " but got " %
+        dup value>> class name>> %
+        drop
+    ] "" make ;
+
+M: output-mismatch-error summary
+    [
+        "Typed word “" %
+        dup word>> name>> %
+        "” expected to output value of type " %
+        dup expected-type>> name>> %
+        " but gave " %
+        dup value>> class name>> %
+        drop
+    ] "" make ;

basis/typed/typed-tests.factor

@@ -1,6 +1,6 @@
 USING: accessors effects eval kernel layouts math namespaces
-quotations tools.test typed words words.symbol
+quotations tools.test typed words words.symbol combinators.short-circuit
-compiler.tree.debugger prettyprint definitions compiler.units ;
+compiler.tree.debugger prettyprint definitions compiler.units sequences ;
 IN: typed.tests
 
 TYPED: f+ ( a: float b: float -- c: float )
@@ -24,14 +24,17 @@ TYPED: dee ( x: tweedle-dee -- y )
 TYPED: dum ( x: tweedle-dum -- y )
     drop \ tweedle-dum ;
 
-[ \ tweedle-dum new dee ] [ input-mismatch-error? ] must-fail-with
+[ \ tweedle-dum new dee ]
-[ \ tweedle-dee new dum ] [ input-mismatch-error? ] must-fail-with
+[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dee = ] [ value>> tweedle-dum? ] } 1&& ] must-fail-with
 
+[ \ tweedle-dee new dum ]
+[ { [ input-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
 
 TYPED: dumdum ( x -- y: tweedle-dum )
     drop \ tweedle-dee new ;
 
-[ f dumdum ] [ output-mismatch-error? ] must-fail-with
+[ f dumdum ]
+[ { [ output-mismatch-error? ] [ expected-type>> tweedle-dum = ] [ value>> tweedle-dee? ] } 1&& ] must-fail-with
 
 TYPED:: f+locals ( a: float b: float -- c: float )
     a b + ;

basis/typed/typed.factor

@@ -7,7 +7,7 @@ locals.parser macros stack-checker.dependencies ;
 FROM: classes.tuple.private => tuple-layout ;
 IN: typed
 
-ERROR: type-mismatch-error word expected-types ;
+ERROR: type-mismatch-error value expected-type word expected-types ;
 ERROR: input-mismatch-error < type-mismatch-error ;
 ERROR: output-mismatch-error < type-mismatch-error ;
 
@@ -28,9 +28,6 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
 : typed-stack-effect? ( effect -- ? )
     [ object = ] all? not ;
 
-: input-mismatch-quot ( word types -- quot )
-    [ input-mismatch-error ] 2curry ;
-
 : depends-on-unboxing ( class -- )
     [ dup tuple-layout depends-on-tuple-layout ]
     [ depends-on-final ]
@@ -47,7 +44,7 @@ PREDICATE: typed-word < word "typed-word" word-prop >boolean ;
 
 :: unboxer ( error-quot word types type -- quot )
     type "coercer" word-prop [ ] or
-    [ dup type instance? [ word types error-quot call ] unless ]
+    type type word types error-quot '[ dup _ instance? [ _ _ _ @ ] unless ]
     type (unboxer)
     compose compose ;
 

core/vocabs/loader/loader-docs.factor

@@ -11,7 +11,7 @@ $nl
 $nl
 "The second way is to create a configuration file. You can list additional vocabulary roots in a file that Factor reads at startup:"
 { $subsections "factor-roots" }
-"Finally, you can add vocabulary roots dynamically using a word:"
+"Finally, you can add vocabulary roots by calling a word from your " { $snippet "factor-rc" } " file (see " { $link "factor-rc" } "):"
 { $subsections add-vocab-root } ;
 
 ARTICLE: "vocabs.roots" "Vocabulary roots"

extra/alien/handles/authors.txt

@@ -0,0 +1 @@
+Joe Groff

extra/alien/handles/handles-tests.factor

@@ -0,0 +1,45 @@
+! (c)2010 Joe Groff bsd license
+USING: accessors alien alien.c-types alien.handles alien.syntax
+destructors kernel math tools.test ;
+IN: alien.handles.tests
+
+TUPLE: thingy { x integer } ;
+C: <thingy> thingy
+
+CALLBACK: int thingy-callback ( uint thingy-handle ) ;
+CALLBACK: int thingy-ptr-callback ( void* thingy-handle ) ;
+
+: test-thingy-callback ( -- alien )
+    [ alien-handle> x>> 1 + ] thingy-callback ;
+
+: test-thingy-ptr-callback ( -- alien )
+    [ alien-handle-ptr> x>> 1 + ] thingy-ptr-callback ;
+
+: invoke-test-thingy-callback ( thingy -- n )
+    test-thingy-callback int { uint } cdecl alien-indirect ;
+: invoke-test-thingy-ptr-callback ( thingy -- n )
+    test-thingy-ptr-callback int { void* } cdecl alien-indirect ;
+
+[ t f ] [
+    [ 5 <thingy> <alien-handle> &release-alien-handle [ alien-handle? ] keep ] with-destructors
+    alien-handle?
+] unit-test
+
+[ t f ] [
+    [ 5 <thingy> <alien-handle-ptr> &release-alien-handle-ptr [ alien-handle-ptr? ] keep ] with-destructors
+    alien-handle-ptr?
+] unit-test
+
+[ 6 ] [
+    [
+        5 <thingy> <alien-handle> &release-alien-handle
+        invoke-test-thingy-callback
+    ] with-destructors
+] unit-test
+
+[ 6 ] [
+    [
+        5 <thingy> <alien-handle-ptr> &release-alien-handle-ptr
+        invoke-test-thingy-ptr-callback
+    ] with-destructors
+] unit-test

extra/alien/handles/handles.factor

@@ -0,0 +1,49 @@
+! (c)2010 Joe Groff bsd license
+USING: alien alien.destructors assocs kernel math math.bitwise
+namespaces ;
+IN: alien.handles
+
+<PRIVATE
+
+SYMBOLS: alien-handle-counter alien-handles ;
+
+alien-handle-counter [ 0 ] initialize
+alien-handles [ H{ } clone ] initialize
+
+: biggest-handle ( -- n )
+    -1 32 bits ; inline
+
+: (next-handle) ( -- n )
+    alien-handle-counter [ 1 + biggest-handle bitand dup ] change-global ; inline
+
+: next-handle ( -- n )
+    [ (next-handle) dup alien-handles get-global key? ] [ drop ] while ;
+
+PRIVATE>
+
+: <alien-handle> ( object -- int )
+    next-handle [ alien-handles get-global set-at ] keep ; inline
+: alien-handle> ( int -- object )
+    alien-handles get-global at ; inline
+
+: alien-handle? ( int -- ? )
+    alien-handles get-global key? >boolean ; inline
+
+: release-alien-handle ( int -- )
+    alien-handles get-global delete-at ; inline
+
+DESTRUCTOR: release-alien-handle
+
+: <alien-handle-ptr> ( object -- void* )
+    <alien-handle> <alien> ; inline
+: alien-handle-ptr> ( void* -- object )
+    alien-address alien-handle> ; inline
+
+: alien-handle-ptr? ( alien -- ? )
+    alien-address alien-handle? ; inline
+
+: release-alien-handle-ptr ( alien -- )
+    alien-address release-alien-handle ; inline
+
+DESTRUCTOR: release-alien-handle-ptr
+

extra/alien/handles/summary.txt

@@ -0,0 +1 @@
+Generate integer handle values to allow Factor object references to be passed through the FFI

extra/bson/constants/constants.factor

@@ -19,6 +19,16 @@ TUPLE: oid { a initial: 0 } { b initial: 0 } ;
 
 TUPLE: dbref ref id db ;
 
+TUPLE: mongo-timestamp incr seconds ;
+
+: <mongo-timestamp> ( incr seconds -- mongo-timestamp )
+    mongo-timestamp boa ;
+
+TUPLE: mongo-scoped-code code object ;
+
+: <mongo-scoped-code> ( code object -- mongo-scoped-code )
+    mongo-scoped-code boa ;
+
 CONSTRUCTOR: dbref ( ref id -- dbref ) ;
 
 : dbref>assoc ( dbref -- assoc )
@@ -48,29 +58,30 @@ CONSTANT: MDB_OID_FIELD "_id"
 CONSTANT: MDB_META_FIELD "_mfd"
 
 CONSTANT: T_EOO     0
-CONSTANT: T_Double  1  
+CONSTANT: T_Double  HEX: 1
-CONSTANT: T_Integer  16  
+CONSTANT: T_String  HEX: 2
-CONSTANT: T_Boolean  8  
+CONSTANT: T_Object  HEX: 3
-CONSTANT: T_String  2  
+CONSTANT: T_Array   HEX: 4
-CONSTANT: T_Object  3  
+CONSTANT: T_Binary  HEX: 5
-CONSTANT: T_Array  4  
+CONSTANT: T_Undefined  HEX: 6
-CONSTANT: T_Binary  5  
+CONSTANT: T_OID     HEX: 7
-CONSTANT: T_Undefined  6  
+CONSTANT: T_Boolean HEX: 8
-CONSTANT: T_OID  7  
+CONSTANT: T_Date    HEX: 9
-CONSTANT: T_Date  9  
+CONSTANT: T_NULL    HEX: A
-CONSTANT: T_NULL  10  
+CONSTANT: T_Regexp  HEX: B
-CONSTANT: T_Regexp  11  
+CONSTANT: T_DBRef   HEX: C
-CONSTANT: T_DBRef  12  
+CONSTANT: T_Code    HEX: D
-CONSTANT: T_Code  13  
+CONSTANT: T_Symbol  HEX: E
-CONSTANT: T_ScopedCode  17  
+CONSTANT: T_ScopedCode HEX: F
-CONSTANT: T_Symbol  14  
+CONSTANT: T_Integer HEX: 10
-CONSTANT: T_JSTypeMax  16  
+CONSTANT: T_Timestamp HEX: 11
-CONSTANT: T_MaxKey  127  
+CONSTANT: T_Integer64 HEX: 12
-
+CONSTANT: T_MinKey  HEX: FF
-CONSTANT: T_Binary_Function 1   
+CONSTANT: T_MaxKey  HEX: 7F
-CONSTANT: T_Binary_Bytes 2
-CONSTANT: T_Binary_UUID 3
-CONSTANT: T_Binary_MD5 5
-CONSTANT: T_Binary_Custom 128
 
+CONSTANT: T_Binary_Function     HEX: 1
+CONSTANT: T_Binary_Bytes        HEX: 2
+CONSTANT: T_Binary_UUID         HEX: 3
+CONSTANT: T_Binary_MD5          HEX: 5
+CONSTANT: T_Binary_Custom       HEX: 80
 

extra/bson/reader/reader.factor

@@ -10,65 +10,46 @@ FROM: typed => TYPED: ;
 
 IN: bson.reader
 
+SYMBOL: state
+
+DEFER: stream>assoc
+
 <PRIVATE
 
-TUPLE: element { type integer } name ;
+DEFER: read-elements
 
-TUPLE: state
+: read-int32 ( -- int32 )
-    { size initial: -1 }
-    { exemplar assoc }
-    result
-    { scope vector }
-    { elements vector } ;
-
-TYPED: (prepare-elements) ( -- elements-vector: vector )
-    V{ } clone [ T_Object "" element boa swap push ] [ ] bi ; inline
-
-: <state> ( exemplar -- state )
-    [ state new ] dip
-    {
-        [ clone >>exemplar ]
-        [ clone >>result ]
-        [ V{ } clone [ push ] keep >>scope ]
-    } cleave
-    (prepare-elements) >>elements ;
-
-TYPED: get-state ( -- state: state )
-    state get ; inline
-
-TYPED: read-int32 ( -- int32: integer )
     4 read signed-le> ; inline
 
-TYPED: read-longlong ( -- longlong: integer )
+: read-longlong ( -- longlong )
     8 read signed-le> ; inline
 
-TYPED: read-double ( -- double: float )
+: read-double ( -- double )
     8 read le> bits>double ; inline
 
-TYPED: read-byte-raw ( -- byte-raw: byte-array )
+: read-byte-raw ( -- byte-raw )
     1 read ; inline
 
-TYPED: read-byte ( -- byte: integer )
+: read-byte ( -- byte )
     read-byte-raw first ; inline
 
-TYPED: read-cstring ( -- string: string )
+: read-cstring ( -- string )
     "\0" read-until drop >string ; inline
 
-TYPED: read-sized-string ( length: integer -- string: string )
+: read-sized-string ( length -- string )
     read 1 head-slice* >string ; inline
 
-TYPED: push-element ( type: integer name: string state: state -- )
+: read-timestamp ( -- timestamp )
-    [ element boa ] dip elements>> push ; inline
+    8 read [ 4 head signed-le> ] [ 4 tail signed-le> ] bi <mongo-timestamp> ;
 
-TYPED: pop-element ( state: state -- element: element )
+: object-result ( quot -- object )
-    elements>> pop ; inline
+    [
+        state get clone
+        [ clear-assoc ] [ ] [ ] tri state
+    ] dip with-variable ; inline
 
-TYPED: peek-scope ( state: state -- ht )
+: bson-object-data-read ( -- )
-    scope>> last ; inline
+    read-int32 drop read-elements ; inline recursive
-
-: bson-object-data-read ( -- object )
-    read-int32 drop get-state 
-    [ exemplar>> clone dup ] [ scope>> ] bi push ; inline
 
 : bson-binary-read ( -- binary )
    read-int32 read-byte 
@@ -86,68 +67,35 @@ TYPED: bson-regexp-read ( -- mdbregexp: mdbregexp )
 TYPED: bson-oid-read ( -- oid: oid )
     read-longlong read-int32 oid boa ; inline
 
+: check-object ( assoc -- object )
+    dup dbref-assoc? [ assoc>dbref ] when ; inline
+
 TYPED: element-data-read ( type: integer -- object )
     {
         { T_OID         [ bson-oid-read ] }
         { T_String      [ read-int32 read-sized-string ] }
         { T_Integer     [ read-int32 ] }
+        { T_Integer64   [ read-longlong ] }
         { T_Binary      [ bson-binary-read ] }
-        { T_Object [ bson-object-data-read ] }
+        { T_Object      [ [ bson-object-data-read ] object-result check-object ] }
-        { T_Array [ bson-object-data-read ] }
+        { T_Array       [ [ bson-object-data-read ] object-result values ] }
         { T_Double      [ read-double ] }
         { T_Boolean     [ read-byte 1 = ] }
         { T_Date        [ read-longlong millis>timestamp ] }
         { T_Regexp      [ bson-regexp-read ] }
+        { T_Timestamp   [ read-timestamp ] }
+        { T_Code        [ read-int32 read-sized-string ] }
+        { T_ScopedCode  [ read-int32 drop read-cstring H{ } clone stream>assoc <mongo-scoped-code> ] }
         { T_NULL        [ f ] }
-    } case ; inline
+    } case ; inline recursive
 
-TYPED: bson-array? ( type: integer -- ?: boolean )
+TYPED: (read-object) ( type: integer name: string -- )
-    T_Array = ; inline
+    [ element-data-read ] dip state get set-at ; inline recursive
-
-TYPED: bson-object? ( type: integer -- ?: boolean )
-    T_Object = ; inline
-
-: check-object ( assoc -- object )
-    dup dbref-assoc? [ assoc>dbref ] when ; inline
-
-TYPED: fix-result ( assoc type: integer -- result )
-    {
-        { T_Array [ values ] }
-        { T_Object [ check-object ] }
-    } case ; inline
-
-TYPED: end-element ( type: integer -- )
-    { [ bson-object? ] [ bson-array? ] } 1||
-    [ get-state pop-element drop ] unless ; inline
-
-TYPED: (>state<) ( -- state: state scope: vector element: element )
-    get-state [  ] [ scope>> ] [ pop-element ] tri ; inline
-
-TYPED: (prepare-result) ( scope: vector element: element -- result )
-    [ pop ] [ type>> ] bi* fix-result ; inline
-
-: bson-eoo-element-read ( -- cont?: boolean )
-    (>state<)
-    [ (prepare-result) ] [  ] [ drop empty? ] 2tri
-    [ 2drop >>result drop f ]
-    [ swap [ name>> ] [ last ] bi* set-at drop t ] if ; inline
-
-TYPED: (prepare-object) ( type: integer -- object )
-    [ element-data-read ] [ end-element ] bi ; inline
-
-:: (read-object) ( type name state -- )
-    state peek-scope :> scope
-    type (prepare-object) name scope set-at ; inline
-
-TYPED: bson-not-eoo-element-read ( type: integer -- cont?: boolean )
-    read-cstring get-state
-    [ push-element ]
-    [ (read-object) t ] 3bi ; inline
 
 TYPED: (element-read) ( type: integer -- cont?: boolean )
     dup T_EOO > 
-    [ bson-not-eoo-element-read ]
+    [ read-cstring (read-object) t ]
-    [ drop bson-eoo-element-read ] if ; inline
+    [ drop f ] if ; inline recursive
 
 : read-elements ( -- )
     read-byte (element-read)
@@ -156,6 +104,6 @@ TYPED: (element-read) ( type: integer -- cont?: boolean )
 PRIVATE>
 
 : stream>assoc ( exemplar -- assoc )
-    <state> read-int32 >>size
+    clone [
-    [ state [ read-elements ] with-variable ]
+        state [ bson-object-data-read ] with-variable
-    [ result>> ] bi ;
+    ] keep ;

extra/opengl/glu/glu.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005 Alex Chapman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.libraries alien.syntax kernel
-sequences words system combinators opengl.gl ;
+sequences words system combinators opengl.gl alien.destructors ;
 IN: opengl.glu
 
 <<
@@ -267,5 +267,21 @@ FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdo
 ! FUNCTION: GLboolean gluCheckExtension ( GLubyte* extName, GLubyte* extString ) ;
 ! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ;
 
+DESTRUCTOR: gluDeleteNurbsRenderer
+DESTRUCTOR: gluDeleteQuadric
+DESTRUCTOR: gluDeleteTess
+
+CALLBACK: void GLUtessBeginCallback ( GLenum type ) ;
+CALLBACK: void GLUtessBeginDataCallback ( GLenum type, void* data ) ;
+CALLBACK: void GLUtessEdgeFlagCallback ( GLboolean flag ) ;
+CALLBACK: void GLUtessEdgeFlagDataCallback ( GLboolean flag, void* data ) ;
+CALLBACK: void GLUtessVertexCallback ( void* vertex_data ) ;
+CALLBACK: void GLUtessVertexDataCallback ( void* vertex_data, void* data ) ;
+CALLBACK: void GLUtessEndCallback ( ) ;
+CALLBACK: void GLUtessEndDataCallback ( void* data ) ;
+CALLBACK: void GLUtessCombineDataCallback ( GLdouble* coords, void** vertex_data, GLfloat* weight, void** out_data, void* data ) ;
+CALLBACK: void GLUtessErrorCallback ( GLenum errno ) ;
+CALLBACK: void GLUtessErrorDataCallback ( GLenum errno, void* data ) ;
+
 : gl-look-at ( eye focus up -- )
     [ first3 ] tri@ gluLookAt ;

extra/pop3/pop3-tests.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Elie Chaftari.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: concurrency.promises namespaces kernel pop3 pop3.server
-sequences tools.test accessors ;
+sequences tools.test accessors calendar ;
 IN: pop3.tests
 
 FROM: pop3 => count delete ;
@@ -12,7 +12,7 @@ FROM: pop3 => count delete ;
 [ ] [
         <pop3-account>
             "127.0.0.1" >>host
-            "p1" get ?promise >>port
+            "p1" get 5 seconds ?promise-timeout >>port
         connect
 ] unit-test
 [ ] [ "username@host.com" >user ] unit-test
@@ -59,7 +59,7 @@ FROM: pop3 => count delete ;
 [ ] [
         <pop3-account>
             "127.0.0.1" >>host
-            "p2" get ?promise >>port
+            "p2" get 5 seconds ?promise-timeout >>port
             "username@host.com" >>user
             "password" >>pwd
         connect

misc/fuel/fuel-font-lock.el

@@ -59,6 +59,7 @@
   (ratio constant  "ratios")
   (declaration keyword "declaration words")
   (ebnf-form constant "EBNF: ... ;EBNF form")
+  (error-form warning "ERROR: ... ; form")
   (parsing-word keyword  "parsing words")
   (postpone-body comment "postponed form")
   (setter-word function-name "setter words (>>foo)")
@@ -101,6 +102,9 @@
     (,fuel-syntax--brace-words-regex 1 'factor-font-lock-parsing-word)
     (,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
                                         (2 'factor-font-lock-word))
+    (,fuel-syntax--alien-function-alias-regex (1 'factor-font-lock-word)
+                                              (2 'factor-font-lock-type-name)
+                                              (3 'factor-font-lock-word))
     (,fuel-syntax--alien-callback-regex (1 'factor-font-lock-type-name)
                                         (2 'factor-font-lock-word))
     (,fuel-syntax--vocab-ref-regexp  2 'factor-font-lock-vocabulary-name)
@@ -111,6 +115,11 @@
     (,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
                                  (2 'factor-font-lock-type-name)
                                  (3 'factor-font-lock-invalid-syntax nil t))
+    (,fuel-syntax--c-global-regex (1 'factor-font-lock-type-name)
+                                  (2 'factor-font-lock-word)
+                                  (3 'factor-font-lock-invalid-syntax nil t))
+    (,fuel-syntax--c-type-regex (1 'factor-font-lock-type-name)
+                                (2 'factor-font-lock-invalid-syntax nil t))
     (,fuel-syntax--rename-regex (1 'factor-font-lock-word)
                                 (2 'factor-font-lock-vocabulary-name)
                                 (3 'factor-font-lock-word)
@@ -124,6 +133,7 @@
     (,fuel-syntax--float-regex . 'factor-font-lock-number)
     (,fuel-syntax--ratio-regex . 'factor-font-lock-ratio)
     (,fuel-syntax--type-definition-regex 2 'factor-font-lock-type-name)
+    (,fuel-syntax--error-regex 2 'factor-font-lock-error-form)
     (,fuel-syntax--method-definition-regex (1 'factor-font-lock-type-name)
                                            (2 'factor-font-lock-word))
     (,fuel-syntax--before-definition-regex (1 'factor-font-lock-type-name)

misc/fuel/fuel-syntax.el

@@ -47,10 +47,10 @@
   '(":" "::" ";" "&:" "<<" "<PRIVATE" ">>"
     "ABOUT:" "AFTER:" "ALIAS:" "ALIEN:" "ARTICLE:"
     "B" "BEFORE:" "BIN:"
-    "C:" "CALLBACK:" "ENUM:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"
+    "C:" "CALLBACK:" "C-GLOBAL:" "C-TYPE:" "CHAR:" "COM-INTERFACE:" "CONSTANT:" "CONSULT:" "call-next-method"
-    "DEFER:"
+    "DEFER:" "DESTRUCTOR:"
-    "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
+    "EBNF:" ";EBNF" "ENUM:" "ERROR:" "EXCLUDE:"
-    "f" "FORGET:" "FROM:" "FUNCTION:"
+    "f" "FORGET:" "FROM:" "FUNCTION:" "FUNCTION-ALIAS:"
     "GAME:" "GENERIC#" "GENERIC:"
     "GLSL-SHADER:" "GLSL-PROGRAM:"
     "HELP:" "HEX:" "HOOK:"
@@ -135,6 +135,9 @@
   (fuel-syntax--second-word-regex
    '("C-STRUCT:" "C-UNION:" "COM-INTERFACE:" "MIXIN:" "TUPLE:" "SINGLETON:" "SPECIALIZED-ARRAY:" "STRUCT:" "UNION:" "UNION-STRUCT:")))
 
+(defconst fuel-syntax--error-regex
+  (fuel-syntax--second-word-regex '("ERROR:")))
+
 (defconst fuel-syntax--tuple-decl-regex
   "^TUPLE: +\\([^ \n]+\\) +< +\\([^ \n]+\\)\\_>")
 
@@ -158,15 +161,19 @@
 (defconst fuel-syntax--sub-vocab-regex "^<\\([^ \n]+\\) *$")
 
 (defconst fuel-syntax--alien-function-regex
-  "\\_<FUNCTION: \\(\\w+\\) \\(\\w+\\)")
+  "\\_<FUNCTION: +\\(\\w+\\)[\n ]+\\(\\w+\\)")
+
+(defconst fuel-syntax--alien-function-alias-regex
+  "\\_<FUNCTION-ALIAS: +\\(\\w+\\)[\n ]+\\(\\w+\\)[\n ]+\\(\\w+\\)")
 
 (defconst fuel-syntax--alien-callback-regex
-  "\\_<CALLBACK: \\(\\w+\\) \\(\\w+\\)")
+  "\\_<CALLBACK: +\\(\\w+\\) +\\(\\w+\\)")
 
 (defconst fuel-syntax--indent-def-starts '("" ":"
                                            "AFTER" "BEFORE"
-                                           "ENUM" "COM-INTERFACE" "CONSULT"
+                                           "COM-INTERFACE" "CONSULT"
-                                           "FROM" "FUNCTION:"
+                                           "ENUM" "ERROR"
+                                           "FROM" "FUNCTION:" "FUNCTION-ALIAS:"
                                            "INTERSECTION:"
                                            "M" "M:" "MACRO" "MACRO:"
                                            "MEMO" "MEMO:" "METHOD"
@@ -197,8 +204,8 @@
 (defconst fuel-syntax--single-liner-regex
   (regexp-opt '("ABOUT:"
                 "ALIAS:"
-                "CONSTANT:" "C:" "C-TYPE:"
+                "CONSTANT:" "C:" "C-GLOBAL:" "C-TYPE:"
-                "DEFER:"
+                "DEFER:" "DESTRUCTOR:"
                 "FORGET:"
                 "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:"
                 "HEX:" "HOOK:"
@@ -242,6 +249,12 @@
 (defconst fuel-syntax--typedef-regex
   "\\_<TYPEDEF: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
 
+(defconst fuel-syntax--c-global-regex
+  "\\_<C-GLOBAL: +\\(\\w+\\) +\\(\\w+\\)\\( .*\\)?$")
+
+(defconst fuel-syntax--c-type-regex
+  "\\_<C-TYPE: +\\(\\w+\\)\\( .*\\)?$")
+
 (defconst fuel-syntax--rename-regex
   "\\_<RENAME: +\\(\\w+\\) +\\(\\w+\\) +=> +\\(\\w+\\)\\( .*\\)?$")
 

vm/callstack.cpp

@@ -108,7 +108,25 @@ stack_frame *factor_vm::frame_successor(stack_frame *frame)
 	return (stack_frame *)((cell)frame - frame->size);
 }
 
-/* Allocates memory */
+cell factor_vm::frame_offset(stack_frame *frame)
+{
+	char *entry_point = (char *)frame_code(frame)->entry_point();
+	char *return_address = (char *)FRAME_RETURN_ADDRESS(frame,this);
+	if(return_address)
+		return return_address - entry_point;
+	else
+		return (cell)-1;
+}
+
+void factor_vm::set_frame_offset(stack_frame *frame, cell offset)
+{
+	char *entry_point = (char *)frame_code(frame)->entry_point();
+	if(offset == (cell)-1)
+		FRAME_RETURN_ADDRESS(frame,this) = NULL;
+	else
+		FRAME_RETURN_ADDRESS(frame,this) = entry_point + offset;
+}
+
 cell factor_vm::frame_scan(stack_frame *frame)
 {
 	switch(frame_type(frame))
@@ -120,13 +138,7 @@ cell factor_vm::frame_scan(stack_frame *frame)
 				obj = obj.as<word>()->def;
 
 			if(obj.type_p(QUOTATION_TYPE))
-			{
+				return tag_fixnum(quot_code_offset_to_scan(obj.value(),frame_offset(frame)));
-				char *return_addr = (char *)FRAME_RETURN_ADDRESS(frame,this);
-				char *quot_entry_point = (char *)frame_code(frame)->entry_point();
-
-				return tag_fixnum(quot_code_offset_to_scan(
-					obj.value(),(cell)(return_addr - quot_entry_point)));
-			}    
 			else
 				return false_object;
 		}
@@ -138,11 +150,6 @@ cell factor_vm::frame_scan(stack_frame *frame)
 	}
 }
 
-cell factor_vm::frame_offset(stack_frame *frame)
-{
-	return (cell)FRAME_RETURN_ADDRESS(frame,this) - (cell)frame_code(frame)->entry_point();
-}
-
 struct stack_frame_accumulator {
 	factor_vm *parent;
 	growable_array frames;
@@ -209,9 +216,9 @@ void factor_vm::primitive_set_innermost_stack_frame_quot()
 	jit_compile_quot(quot.value(),true);
 
 	stack_frame *inner = innermost_stack_frame(callstack.untagged());
-	cell offset = (char *)FRAME_RETURN_ADDRESS(inner,this) - (char *)inner->entry_point;
+	cell offset = frame_offset(inner);
 	inner->entry_point = quot->entry_point;
-	FRAME_RETURN_ADDRESS(inner,this) = (char *)quot->entry_point + offset;
+	set_frame_offset(inner,offset);
 }
 
 void factor_vm::primitive_callstack_bounds()

vm/code_block_visitor.hpp

@@ -42,13 +42,10 @@ struct call_frame_code_block_visitor {
 
 	void operator()(stack_frame *frame)
 	{
-		code_block *old_block = parent->frame_code(frame);
+		cell offset = parent->frame_offset(frame);
-		cell offset = (char *)FRAME_RETURN_ADDRESS(frame,parent) - (char *)old_block;
+		code_block *compiled = fixup.fixup_code(parent->frame_code(frame));
-
+		frame->entry_point = compiled->entry_point();
-		const code_block *new_block = fixup.fixup_code(old_block);
+		parent->set_frame_offset(frame,offset);
-		frame->entry_point = new_block->entry_point();
-
-		FRAME_RETURN_ADDRESS(frame,parent) = (char *)new_block + offset;
 	}
 };
 

vm/collector.hpp

@@ -43,6 +43,8 @@ template<typename TargetGeneration, typename Policy> struct gc_workhorse : no_fi
 
 	object *fixup_data(object *obj)
 	{
+		parent->check_data_pointer(obj);
+
 		if(!policy.should_copy_p(obj))
 		{
 			policy.visited_object(obj);

vm/contexts.cpp

@@ -65,9 +65,14 @@ void context::scrub_stacks(gc_info *info, cell index)
 		for(cell loc = 0; loc < info->scrub_d_count; loc++)
 		{
 			if(bitmap_p(bitmap,base + loc))
+			{
+#ifdef DEBUG_GC_MAPS
+				std::cout << "scrubbing datastack location " << loc << std::endl;
+#endif
 				((cell *)datastack)[-loc] = 0;
 			}
 		}
+	}
 
 	{
 		cell base = info->scrub_r_base(index);
@@ -75,9 +80,14 @@ void context::scrub_stacks(gc_info *info, cell index)
 		for(cell loc = 0; loc < info->scrub_r_count; loc++)
 		{
 			if(bitmap_p(bitmap,base + loc))
+			{
+#ifdef DEBUG_GC_MAPS
+				std::cout << "scrubbing retainstack location " << loc << std::endl;
+#endif
 				((cell *)retainstack)[-loc] = 0;
 			}
 		}
+	}
 }
 
 context::~context()

vm/free_list_allocator.hpp

@@ -164,7 +164,7 @@ template<typename Block, typename Iterator> struct heap_compactor {
 	{
 		if(this->state->marked_p(block))
 		{
-			*finger = block;
+			*finger = (Block *)((char *)block + size);
 			memmove((Block *)address,block,size);
 			iter(block,(Block *)address,size);
 			address += size;

vm/gc.cpp

@@ -207,13 +207,15 @@ struct call_frame_scrubber {
 
 	void operator()(stack_frame *frame)
 	{
-		const code_block *compiled = parent->frame_code(frame);
+		cell return_address = parent->frame_offset(frame);
+		if(return_address == (cell)-1)
+			return;
+
+		code_block *compiled = parent->frame_code(frame);
 		gc_info *info = compiled->block_gc_info();
 
-		cell return_address = parent->frame_offset(frame);
 		assert(return_address < compiled->size());
 		int index = info->return_address_index(return_address);
-
 		if(index != -1)
 			ctx->scrub_stacks(info,index);
 	}

vm/slot_visitor.hpp

@@ -284,14 +284,21 @@ struct call_frame_slot_visitor {
 	*/
 	void operator()(stack_frame *frame)
 	{
-		const code_block *compiled = visitor->fixup.translate_code(parent->frame_code(frame));
-		gc_info *info = compiled->block_gc_info();
 		cell return_address = parent->frame_offset(frame);
+		if(return_address == (cell)-1)
+			return;
+
+		code_block *compiled = visitor->fixup.translate_code(parent->frame_code(frame));
+		gc_info *info = compiled->block_gc_info();
+
 		assert(return_address < compiled->size());
 		int index = info->return_address_index(return_address);
+		if(index == -1)
+			return;
 
-		if(index != -1)
+#ifdef DEBUG_GC_MAPS
-		{
+		std::cout << "call frame code block " << compiled << " with offset " << return_address << std::endl;
+#endif
 		u8 *bitmap = info->gc_info_bitmap();
 		cell base = info->spill_slot_base(index);
 		cell *stack_pointer = (cell *)(parent->frame_successor(frame) + 1);
@@ -299,6 +306,10 @@ struct call_frame_slot_visitor {
 		for(cell spill_slot = 0; spill_slot < info->gc_root_count; spill_slot++)
 		{
 			if(bitmap_p(bitmap,base + spill_slot))
+			{
+#ifdef DEBUG_GC_MAPS
+				std::cout << "visiting spill slot " << spill_slot << std::endl;
+#endif
 				visitor->visit_handle(&stack_pointer[spill_slot]);
 			}
 		}

vm/vm.hpp

@@ -597,6 +597,7 @@ struct factor_vm
 	stack_frame *frame_successor(stack_frame *frame);
 	cell frame_scan(stack_frame *frame);
 	cell frame_offset(stack_frame *frame);
+	void set_frame_offset(stack_frame *frame, cell offset);
 	void primitive_callstack_to_array();
 	stack_frame *innermost_stack_frame(callstack *stack);
 	void primitive_innermost_stack_frame_executing();