Inline allocators now GC check!

library/compiler/generator/architecture.factor

@@ -55,7 +55,7 @@ DEFER: %jump-label ( label -- )
 DEFER: %jump-t ( label vreg -- )
 
 ! Jump table of addresses (one cell each) is right after this
-DEFER: %dispatch ( vreg -- )
+DEFER: %dispatch ( -- )
 
 ! Jump table entry
 DEFER: %target ( label -- )

library/compiler/generator/generator.factor

@@ -153,24 +153,19 @@ M: #call-label generate-node
 
 ! #dispatch
 : dispatch-head ( node -- label/node )
-    #! Output the jump table insn and return a list of
-    #! label/branch pairs.
-    [ end-basic-block %dispatch ] H{
-        { +input+ { { f "n" } } }
-        { +scratch+ { { f "scratch" } } }
-    } with-template
+    #! Return a list of label/branch pairs.
     node-children [ <label> dup %target 2array ] map ;
 
 : dispatch-body ( label/node -- )
     <label> swap [
-        first2 resolve-label generate-nodes
+        first2 resolve-label generate-branch
         dup %jump-label
-    ] each resolve-label ;
+    ] each resolve-label init-templates ;
 
 M: #dispatch generate-node
     #! The parameter is a list of nodes, each one is a branch to
     #! take in case the top of stack has that type.
-    dispatch-head dispatch-body iterate-next ;
+    %dispatch dispatch-head dispatch-body iterate-next ;
 
 ! #push
 UNION: immediate fixnum POSTPONE: f ;

library/compiler/generator/templates.factor

@@ -4,6 +4,9 @@ IN: compiler
 USING: arrays generic hashtables inference io kernel math
 namespaces prettyprint sequences vectors words ;
 
+! Set this to t so that end-basic-block compiles a GC check
+SYMBOL: maybe-gc
+
 ! Register allocation
 
 ! Hash mapping reg-classes to mutable vectors
@@ -131,7 +134,12 @@ SYMBOL: phantom-r
 : finalize-contents ( -- )
     phantoms 2dup flush-locs [ vregs>stack ] 2apply ;
 
-: end-basic-block ( -- ) finalize-contents finalize-heights ;
+: end-basic-block ( -- )
+    finalize-contents finalize-heights
+    maybe-gc get [
+        maybe-gc off
+        "simple_gc" f %alien-invoke
+    ] when ;
 
 : used-vregs ( -- seq ) phantoms append [ vreg? ] subset ;
 
@@ -146,6 +154,7 @@ SYMBOL: phantom-r
     drop ;
 
 : init-templates ( -- )
+    maybe-gc off
     <phantom-datastack> phantom-d set
     <phantom-callstack> phantom-r set
     compute-free-vregs ;

library/compiler/ppc/allot.factor

@@ -9,6 +9,7 @@ USING: kernel assembler kernel-internals namespaces math ;
 : %allot ( header size -- )
     #! Store a pointer to 'size' bytes allocated from the
     #! nursery in r11.
+    maybe-gc on
     8 align ! align the size
     12 load-zone-ptr ! nusery -> r12
     11 12 cell LWZ ! nursery.here -> r11

library/compiler/ppc/architecture.factor

@@ -77,12 +77,17 @@ M: object load-literal
 : %dispatch ( -- )
     #! The value 20 is a magic number. It is the length of the
     #! instruction sequence that follows
-    "n" operand dup 1 SRAWI
-    0 "scratch" operand LOAD32 rel-absolute-2/2 rel-here
-    "n" operand dup "scratch" operand ADD
-    "n" operand dup 20 LWZ
-    "n" operand MTLR
-    BLR ;
+    [
+        "n" operand dup 1 SRAWI
+        0 "scratch" operand LOAD32 rel-absolute-2/2 rel-here
+        "n" operand dup "scratch" operand ADD
+        "n" operand dup 20 LWZ
+        "n" operand MTLR
+        BLR
+    ] H{
+        { +input+ { { f "n" } } }
+        { +scratch+ { { f "scratch" } } }
+    } with-template ;
 
 : %target ( label -- ) 0 , rel-absolute-cell rel-label ;
 

library/compiler/x86/allot.factor

@@ -21,6 +21,7 @@ USING: kernel assembler kernel-internals namespaces math ;
     allot-tmp-reg [] swap tag-header MOV ;
 
 : %allot ( header size quot -- )
+    maybe-gc on
     swap >r >r
     allot-tmp-reg PUSH
     load-allot-ptr

library/compiler/x86/architecture.factor

@@ -114,21 +114,26 @@ M: object load-literal
     #! Compile a piece of code that jumps to an offset in a
     #! jump table indexed by the fixnum at the top of the stack.
     #! The jump table must immediately follow this macro.
-    ! Untag and multiply to get a jump table offset
-    "end" define-label
-    "n" operand fixnum>slot@
-    ! Add to jump table base. We use a temporary register since
-    ! on AMD64 we have to load a 64-bit immediate. On x86, this
-    ! is redundant.
-    "scratch" operand HEX: ffffffff MOV
-    "end" get rel-absolute-cell rel-label
-    "n" operand "scratch" operand ADD
-    ! Jump to jump table entry
-    "n" operand [] JMP
-    ! Align for better performance
-    compile-aligned
-    ! Fix up jump table pointer
-    "end" resolve-label ;
+    [
+        ! Untag and multiply to get a jump table offset
+        "end" define-label
+        "n" operand fixnum>slot@
+        ! Add to jump table base. We use a temporary register
+        ! since on AMD64 we have to load a 64-bit immediate. On
+        ! x86, this is redundant.
+        "scratch" operand HEX: ffffffff MOV
+        "end" get rel-absolute-cell rel-label
+        "n" operand "scratch" operand ADD
+        ! Jump to jump table entry
+        "n" operand [] JMP
+        ! Align for better performance
+        compile-aligned
+        ! Fix up jump table pointer
+        "end" resolve-label
+    ] H{
+        { +input+ { { f "n" } } }
+        { +scratch+ { { f "scratch" } } }
+    } with-template ;
 
 : %target ( label -- ) 0 cell, rel-absolute-cell rel-label ;
 

library/test/kernel.factor

@@ -7,12 +7,12 @@ sequences test errors math-internals ;
 
 ! some primitives are missing GC checks
 [ ] [ 1000000 [ drop H{ } clone >n n> drop ] each ] unit-test
-! [ ] [ 1.0 10000000 [ drop 1.0 * ] each ] unit-test
+[ ] [ 1.0 10000000 [ 1.0 * ] times drop ] unit-test
 [ ] [ 268435455 >fixnum 10000000 [ dup dup + drop ] times drop ] unit-test
 [ ] [ 268435455 >fixnum 10000000 [ dup dup fixnum+ drop ] times drop ] unit-test
 [ ] [ 10000000 [ drop 1/3 >fixnum drop ] each ] unit-test
 [ ] [ 10000000 [ drop 1/3 >bignum drop ] each ] unit-test
-! [ ] [ 10000000 [ drop 1/3 >float drop ] each ] unit-test
+[ ] [ 10000000 [ drop 1/3 >float drop ] each ] unit-test
 
 ! Don't leak extra roots if error is thrown
 [ ] [ 10000 [ [ -1 f <array> ] catch drop ] times ] unit-test