GC maps for more compact inline GC checks

GNUmakefile

@@ -46,6 +46,7 @@ ifdef CONFIG
 		vm/free_list.o \
 		vm/full_collector.o \
 		vm/gc.o \
+		vm/gc_info.o \
 		vm/image.o \
 		vm/inline_cache.o \
 		vm/instruction_operands.o \

Nmakefile

@@ -48,6 +48,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm\free_list.obj \
 	vm\full_collector.obj \
 	vm\gc.obj \
+	vm/gc_info.obj \
 	vm\image.obj \
 	vm\inline_cache.obj \
 	vm\instruction_operands.obj \

basis/bootstrap/stage2.factor

@@ -58,7 +58,6 @@ SYMBOL: bootstrap-time
     original-error set-global
     error set-global ; inline
 
-
 [
     ! We time bootstrap
     nano-count

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

@@ -29,14 +29,6 @@ V{
 
 2 \ vreg-counter set-global
 
-[
-    V{
-        T{ ##load-tagged f 3 0 }
-        T{ ##replace f 3 D 0 }
-        T{ ##replace f 3 R 3 }
-    }
-] [ [ { D 0 R 3 } wipe-locs ] V{ } make ] unit-test
-
 : gc-check? ( bb -- ? )
     instructions>>
     {
@@ -50,15 +42,13 @@ V{
 
 [
     V{
-        T{ ##load-tagged f 5 0 }
-        T{ ##replace f 5 D 0 }
-        T{ ##replace f 5 R 3 }
-        T{ ##call-gc f { 0 1 2 } }
+        T{ ##gc-map f V{ 0 } V{ 3 } { 0 1 2 } }
+        T{ ##call-gc }
         T{ ##branch }
     }
 ]
 [
-    { D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
+    V{ D 0 R 3 } { 0 1 2 } <gc-call> instructions>>
 ] unit-test
 
 30 \ vreg-counter set-global
@@ -156,11 +146,8 @@ H{
 
 [
     V{
-        T{ ##load-tagged f 31 0 }
-        T{ ##replace f 31 D 0 }
-        T{ ##replace f 31 D 1 }
-        T{ ##replace f 31 D 2 }
-        T{ ##call-gc f { 2 } }
+        T{ ##gc-map f V{ 0 1 2 } V{ } { 2 } }
+        T{ ##call-gc }
         T{ ##branch }
     }
 ] [ 2 get predecessors>> second instructions>> ] unit-test

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

@@ -50,16 +50,12 @@ IN: compiler.cfg.gc-checks
         ] bi*
     ] V{ } make >>instructions ;
 
-: wipe-locs ( uninitialized-locs -- )
-    '[
-        int-rep next-vreg-rep
-        [ 0 ##load-tagged ]
-        [ '[ [ _ ] dip ##replace ] each ] bi
-    ] unless-empty ;
+: scrubbed ( uninitialized-locs -- scrub-d scrub-r )
+    [ ds-loc? ] partition [ [ n>> ] map ] bi@ ;
 
 : <gc-call> ( uninitialized-locs gc-roots -- bb )
     [ <basic-block> ] 2dip
-    [ [ wipe-locs ] [ ##call-gc ] bi* ##branch ] V{ } make
+    [ [ scrubbed ] dip ##gc-map ##call-gc ##branch ] V{ } make
     >>instructions t >>unlikely? ;
 
 :: insert-guard ( body check bb -- )

basis/compiler/cfg/instructions/instructions.factor

@@ -819,8 +819,10 @@ INSN: ##check-nursery-branch
 literal: size cc
 temp: temp1/int-rep temp2/int-rep ;
 
-INSN: ##call-gc
-literal: gc-roots ;
+INSN: ##call-gc ;
+
+INSN: ##gc-map
+literal: scrub-d scrub-r gc-roots ;
 
 ! Spills and reloads, inserted by register allocator
 TUPLE: spill-slot { n integer } ;

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

@@ -142,8 +142,7 @@ 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: ##call-gc assign-registers-in-insn
-    dup call-next-method
+M: ##gc-map assign-registers-in-insn
     [ [ vreg>reg ] map ] change-gc-roots drop ;
 
 M: insn assign-registers-in-insn drop ;

basis/compiler/cfg/save-contexts/save-contexts.factor

@@ -10,7 +10,6 @@ IN: compiler.cfg.save-contexts
 : needs-save-context? ( insns -- ? )
     [
         {
-            [ ##call-gc? ]
             [ ##unary-float-function? ]
             [ ##binary-float-function? ]
             [ ##alien-invoke? ]

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

@@ -77,5 +77,5 @@ M: uninitialized-analysis join-sets ( sets analysis -- pair )
         first2
         [ [ <ds-loc> ] (uninitialized-locs) ]
         [ [ <rs-loc> ] (uninitialized-locs) ]
-        bi* append
+        bi* append f like
     ] when ;

basis/compiler/codegen/codegen.factor

@@ -258,6 +258,7 @@ 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

@@ -0,0 +1,67 @@
+USING: namespaces byte-arrays make compiler.codegen.fixup
+bit-arrays accessors classes.struct tools.test kernel math
+sequences alien.c-types specialized-arrays boxes ;
+SPECIALIZED-ARRAY: uint
+IN: compiler.codegen.fixup.tests
+
+STRUCT: gc-info
+{ scrub-d-count uint }
+{ scrub-r-count uint }
+{ gc-root-count uint }
+{ return-address-count uint } ;
+
+[ ] [
+    [
+        init-fixup
+
+        50 <byte-array> %
+
+        { { } { } { } } set-next-gc-map
+        gc-map-here
+
+        50 <byte-array> %
+
+        { { 0 4 } { 1 } { 1 3 } } set-next-gc-map
+        gc-map-here
+
+        emit-gc-info
+    ] B{ } make
+    "result" set
+] unit-test
+
+[ 0 ] [ "result" get length 16 mod ] unit-test
+
+[ ] [
+    [
+        100 <byte-array> %
+
+        ! The below data is 22 bytes -- 6 bytes padding needed to
+        ! align
+        6 <byte-array> %
+
+        ! Bitmap - 2 bytes
+        ?{
+            ! scrub-d
+            t f f f t
+            ! scrub-r
+            f t
+            ! gc-roots
+            f t f t
+        } underlying>> %
+
+        ! Return addresses - 4 bytes
+        uint-array{ 100 } underlying>> %
+
+        ! GC info footer - 16 bytes
+        S{ gc-info
+            { scrub-d-count 5 }
+            { scrub-r-count 2 }
+            { gc-root-count 4 }
+            { return-address-count 1 }
+        } (underlying)>> %
+    ] B{ } make
+    "expect" set
+] unit-test
+
+[ ] [ "result" get length "expect" get length assert= ] unit-test
+[ ] [ "result" get "expect" get assert= ] unit-test

basis/compiler/codegen/fixup/fixup.factor

@@ -1,10 +1,11 @@
 ! Copyright (C) 2007, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: 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 memoize ;
+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
+memoize boxes ;
 IN: compiler.codegen.fixup
 
 ! Utilities
@@ -95,7 +96,7 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
 : rel-decks-offset ( class -- )
     rt-decks-offset rel-fixup ;
 
-! And the rest
+! Labels
 : compute-target ( label-fixup -- offset )
     label>> offset>> [ "Unresolved label" throw ] unless* ;
 
@@ -112,13 +113,7 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
     [ [ compute-relative-label ] map concat ]
     bi* ;
 
-: init-fixup ( -- )
-    V{ } clone parameter-table set
-    V{ } clone literal-table set
-    V{ } clone label-table set
-    BV{ } clone relocation-table set
-    V{ } clone binary-literal-table set ;
-
+! Binary literals
 : alignment ( align -- n )
     [ compiled-offset dup ] dip align swap - ;
 
@@ -136,16 +131,102 @@ MEMO: cached-string>symbol ( symbol -- obj ) string>symbol ;
 : emit-binary-literals ( -- )
     binary-literal-table get [ emit-data ] assoc-each ;
 
+! GC info
+
+! Every code block either ends with
+!
+! uint 0
+!
+! or
+!
+! bitmap, byte aligned, three subsequences:
+! - <scrubbed data stack locations>
+! - <scrubbed retain stack locations>
+! - <GC root spill slots>
+! uint[] <return addresses>
+! uint <largest scrubbed data stack location>
+! uint <largest scrubbed retain stack location>
+! uint <largest GC root spill slot>
+! uint <number of return addresses>
+
+SYMBOLS: next-gc-map return-addresses gc-maps ;
+
+: gc-map? ( triple -- ? )
+    ! If there are no stack locations to scrub and no GC roots,
+    ! there's no point storing the GC map.
+    [ empty? not ] any? ;
+
+: gc-map-here ( -- )
+    next-gc-map get box> dup gc-map? [
+        gc-maps get push
+        compiled-offset return-addresses get push
+    ] [ drop ] if ;
+
+: set-next-gc-map ( gc-map -- ) next-gc-map get >box ;
+
+: integers>bits ( seq n -- bit-array )
+    <bit-array> [ '[ [ t ] dip _ set-nth ] each ] keep ;
+
+: emit-bitmap ( 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
+    ] if-empty ;
+
+: emit-uint ( n -- )
+    building get push-uint ;
+
+: gc-info ( -- byte-array )
+    [
+        return-addresses get empty? [ 0 emit-uint ] [
+            gc-maps get
+            [
+                [ [ first ] map emit-bitmap ]
+                [ [ second ] map emit-bitmap ]
+                [ [ third ] map emit-bitmap ] tri
+            ] ?{ } make underlying>> %
+            return-addresses get [ emit-uint ] each
+            [ emit-uint ] tri@
+            return-addresses get length emit-uint
+        ] if
+    ] B{ } make ;
+
+: emit-gc-info ( -- )
+    ! We want to place the GC info so that the end is aligned
+    ! on a 16-byte boundary.
+    gc-info [
+        length compiled-offset +
+        [ data-alignment get align ] keep -
+        (align-code)
+    ] [ % ] bi ;
+
+: init-fixup ( -- )
+    V{ } clone parameter-table set
+    V{ } clone literal-table set
+    V{ } clone label-table set
+    BV{ } clone relocation-table set
+    V{ } clone binary-literal-table set
+    V{ } clone return-addresses set
+    V{ } clone gc-maps set
+    <box> next-gc-map set ;
+
+: check-fixup ( seq -- )
+    length data-alignment get mod 0 assert=
+    next-gc-map get occupied>> f assert= ;
+
 : with-fixup ( quot -- code )
     '[
+        init-fixup
         [
-            init-fixup
             @
             emit-binary-literals
+            emit-gc-info
             label-table [ compute-labels ] change
             parameter-table get >array
             literal-table get >array
             relocation-table get >byte-array
             label-table get
         ] B{ } make
+        dup check-fixup
     ] output>array ; inline

basis/cpu/architecture/architecture.factor

@@ -488,7 +488,8 @@ HOOK: %write-barrier-imm cpu ( src slot tag temp1 temp2 -- )
 
 ! GC checks
 HOOK: %check-nursery-branch cpu ( label size cc temp1 temp2 -- )
-HOOK: %call-gc cpu ( gc-roots -- )
+HOOK: %gc-map cpu ( scrub-d scrub-r gc-roots -- )
+HOOK: %call-gc cpu ( -- )
 
 HOOK: %prologue cpu ( n -- )
 HOOK: %epilogue cpu ( n -- )

basis/cpu/x86/32/32.factor

@@ -239,11 +239,6 @@ M:: x86.32 stack-cleanup ( stack-size return abi -- n )
 M: x86.32 %cleanup ( n -- )
     [ ESP swap SUB ] unless-zero ;
 
-M:: x86.32 %call-gc ( gc-roots -- )
-    4 save-vm-ptr
-    0 stack@ gc-roots gc-root-offsets %load-reference
-    "inline_gc" f %alien-invoke ;
-
 M: x86.32 dummy-stack-params? f ;
 
 M: x86.32 dummy-int-params? f ;

basis/cpu/x86/64/64.factor

@@ -154,11 +154,6 @@ M:: x86.64 %binary-float-function ( dst src1 src2 func -- )
     func "libm" load-library %alien-invoke
     dst double-rep %load-return ;
 
-M:: x86.64 %call-gc ( gc-roots -- )
-    param-reg-0 gc-roots gc-root-offsets %load-reference
-    param-reg-1 %mov-vm-ptr
-    "inline_gc" f %alien-invoke ;
-
 M: x86.64 long-long-on-stack? f ;
 
 M: x86.64 float-on-stack? f ;