Add GC maps to ##box, ##box-long-long, ##alien-invoke, ##alien-indirect and ##call-gc; remove ##gc-map instruction

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.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/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/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/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 ;
 

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,10 +80,15 @@ 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/slot_visitor.hpp

@@ -296,6 +296,9 @@ struct call_frame_slot_visitor {
 		if(index == -1)
 			return;
 
+#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);
@@ -303,9 +306,14 @@ 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]);
 			}
 		}
+	}
 };
 
 template<typename Fixup>