compiler.cfg.*: a bunch of new tests

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

@@ -0,0 +1,30 @@
+USING: alien.c-types compiler.cfg.builder.alien.boxing
+compiler.cfg.instructions compiler.test cpu.architecture kernel make system
+tools.test ;
+IN: compiler.cfg.builder.alien.boxing.tests
+
+{
+    { 1 }
+    { { int-rep f f } }
+    V{ T{ ##unbox-any-c-ptr { dst 1 } { src 77 } } }
+} [
+    [ 77 c-string base-type unbox-parameter ] V{ } make
+] cfg-unit-test
+
+! unboxing is only needed on 32bit archs
+cpu x86.32?
+{
+    { 1 }
+    { { int-rep f f } }
+    V{
+        T{ ##unbox
+           { dst 1 }
+           { src 77 }
+           { unboxer "to_fixnum" }
+           { rep int-rep }
+        }
+    }
+}
+{ { 77 } { { int-rep f f } } V{ } } ? [
+    [ 77 int base-type unbox-parameter ] V{ } make
+] cfg-unit-test

basis/compiler/cfg/builder/builder-tests.factor

@@ -4,7 +4,7 @@ compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.optimizer
 compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.representations
 compiler.cfg.rpo compiler.cfg.stacks compiler.cfg.stacks.local
 compiler.cfg.utilities compiler.test compiler.tree compiler.tree.builder
-compiler.tree.optimizer fry hashtables kernel kernel.private locals make math
+compiler.tree.optimizer fry hashtables io kernel kernel.private locals make math
 math.partial-dispatch math.private namespaces prettyprint sbufs sequences
 sequences.private slots.private strings strings.private tools.test vectors
 words ;
@@ -243,6 +243,14 @@ IN: compiler.cfg.builder.tests
     T{ #shuffle { in-d { 37 81 92 } } } make-input-map
 ] unit-test
 
+! emit-call
+{
+    V{ T{ ##call { word print } } T{ ##branch } }
+} [
+    [ \ print 4 emit-call ] V{ } make drop
+    basic-block get successors>> first instructions>>
+] cfg-unit-test
+
 ! emit-node
 {
     { T{ ##load-integer { dst 78 } { val 0 } } }

basis/compiler/cfg/dominance/dominance-tests.factor

@@ -75,17 +75,7 @@ V{ } 5 test-bb
 [ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
 
 : non-det-test ( -- cfg )
-    {
+    9 iota [ V{ } clone over insns>block ] { } map>assoc dup
-        { 0 { } }
-        { 1 { } }
-        { 2 { } }
-        { 3 { } }
-        { 4 { } }
-        { 5 { } }
-        { 6 { } }
-        { 7 { } }
-        { 8 { } }
-    } [ over insns>block ] assoc-map dup
     {
         { 0 1 }
         { 1 2 } { 1 7 }

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

@@ -1,12 +1,64 @@
-USING: arrays compiler.cfg.gc-checks
+USING: arrays byte-arrays compiler.cfg.gc-checks
 compiler.cfg.gc-checks.private compiler.cfg.debugger
 compiler.cfg.registers compiler.cfg.instructions compiler.cfg
 compiler.cfg.predecessors compiler.cfg.rpo cpu.architecture
 tools.test kernel vectors namespaces accessors sequences alien
-memory classes make combinators.short-circuit byte-arrays
+memory classes make combinators.short-circuit
-compiler.cfg.comparisons compiler.cfg.utilities ;
+compiler.cfg.comparisons compiler.test compiler.cfg.utilities ;
 IN: compiler.cfg.gc-checks.tests
 
+! insert-gc-check?
+{ t } [
+    V{
+        T{ ##inc } T{ ##allot }
+    } 0 insns>block insert-gc-check?
+] unit-test
+
+! allocation-size
+{ t } [
+    V{ T{ ##box-alien f 0 1 } } allocation-size 123 <alien> size =
+] unit-test
+
+! add-gc-checks
+{
+    {
+        V{
+            T{ ##inc }
+            T{ ##peek }
+            T{ ##alien-invoke }
+            T{ ##check-nursery-branch
+               { size 64 }
+               { cc cc<= }
+               { temp1 1 }
+               { temp2 2 }
+            }
+        }
+        V{
+            T{ ##allot
+               { dst 1 }
+               { size 64 }
+               { class-of byte-array }
+            }
+            T{ ##add }
+            T{ ##branch }
+        }
+    }
+} [
+    {
+        V{ T{ ##inc } T{ ##peek } T{ ##alien-invoke } }
+        V{
+            T{ ##allot
+               { dst 1 }
+               { size 64 }
+               { class-of byte-array }
+            }
+            T{ ##add }
+            T{ ##branch }
+        }
+    } [ add-gc-checks ] keep
+] cfg-unit-test
+
+! gc-check-offsets
 [ { } ] [
     V{
         T{ ##inc }
@@ -101,8 +153,6 @@ V{
 
 [ t ] [ cfg get blocks-with-gc 1 get 1array sequence= ] unit-test
 
-[ ] [ 1 get instructions>> allocation-size 123 <alien> size assert= ] unit-test
-
 : gc-check? ( bb -- ? )
     instructions>>
     {

basis/compiler/cfg/intrinsics/fixnum/fixnum-tests.factor

@@ -0,0 +1,17 @@
+USING: compiler.cfg.comparisons compiler.cfg.instructions
+compiler.cfg.intrinsics.fixnum compiler.test make tools.test ;
+IN: compiler.cfg.intrinsics.fixnum.tests
+
+{
+    V{
+        T{ ##compare-integer
+           { dst 4 }
+           { src1 1 }
+           { src2 2 }
+           { cc cc> }
+           { temp 3 }
+        }
+    }
+} [
+    [ cc> emit-fixnum-comparison ] V{ } make
+] cfg-unit-test

basis/compiler/tree/propagation/call-effect/call-effect-tests.factor

@@ -1,14 +1,26 @@
 ! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators compiler.tree.propagation.call-effect compiler.units
+USING: accessors combinators combinators.private compiler.tree
-math effects kernel compiler.tree.builder compiler.tree.optimizer
+compiler.tree.propagation.call-effect compiler.units math effects kernel
-compiler.tree.debugger sequences eval fry tools.test ;
+compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences
+eval fry kernel.private tools.test ;
 IN: compiler.tree.propagation.call-effect.tests
 
-! update-inline-cache
+! cached-effect
-{ t } [
+{ t } [ [ + ] cached-effect ( a b -- c ) effect= ] unit-test
-    [ boa ] inline-cache new [ update-inline-cache ] keep
+{ t } [ 5 [ + ] curry cached-effect ( a -- c ) effect= ] unit-test
-    [ boa ] effect-counter inline-cache boa =
+{ t } [ 5 [ ] curry cached-effect ( -- c ) effect= ] unit-test
+{ t } [ [ dup ] [ drop ] compose cached-effect ( a -- b ) effect= ] unit-test
+{ t } [ [ drop ] [ dup ] compose cached-effect ( a b -- c d ) effect= ] unit-test
+{ t } [ [ 2drop ] [ dup ] compose cached-effect ( a b c -- d e ) effect= ] unit-test
+{ t } [ [ 1 2 3 ] [ 2drop ] compose cached-effect ( -- a ) effect= ] unit-test
+{ t } [ [ 1 2 ] [ 3drop ] compose cached-effect ( a -- ) effect= ] unit-test
+
+! call-effect>quot
+{
+    [ drop ( a -- b ) T{ inline-cache } call-effect-ic ]
+} [
+    ( a -- b ) call-effect>quot
 ] unit-test
 
 ! call-effect-slow>quot
@@ -16,25 +28,60 @@ IN: compiler.tree.propagation.call-effect.tests
     100 [ sq ] ( a -- b ) call-effect-slow>quot call
 ] unit-test
 
+{
+    [
+        [
+            ( -- a b c )
+            2dup
+            [
+                [ [ datastack ] dip dip ] dip dup terminated?>>
+                [ 2drop f ] [
+                    dup in>> length swap out>> length
+                    check-datastack
+                ] if
+            ]
+            2dip
+            rot
+            [ 2drop ]
+            [ wrong-values ]
+            if
+        ]
+        ( obj -- a b c )
+        call-effect-unsafe
+    ]
+} [
+    ( -- a b c ) call-effect-slow>quot
+] unit-test
+
 ! call-effect-unsafe?
 { f t } [
     [ ] ( m -- ) call-effect-unsafe?
     [ ] ( x -- x ) call-effect-unsafe?
 ] unit-test
 
+! call-inlining
+{
+    [ drop f T{ inline-cache } call-effect-ic ]
+} [
+    T{ #call
+       { word call-effect }
+       { in-d V{ 165186755 165186756 165186754 } }
+       { out-d { 165186757 } }
+    } call-inlining
+] unit-test
+
+! execute-effect-unsafe?
 [ t ] [ \ + ( a b -- c ) execute-effect-unsafe? ] unit-test
 [ t ] [ \ + ( a b c -- d e ) execute-effect-unsafe? ] unit-test
 [ f ] [ \ + ( a b c -- d ) execute-effect-unsafe? ] unit-test
 [ f ] [ \ call ( x -- ) execute-effect-unsafe? ] unit-test
 
-[ t ] [ [ + ] cached-effect ( a b -- c ) effect= ] unit-test
+! update-inline-cache
-[ t ] [ 5 [ + ] curry cached-effect ( a -- c ) effect= ] unit-test
+{ t } [
-[ t ] [ 5 [ ] curry cached-effect ( -- c ) effect= ] unit-test
+    [ boa ] inline-cache new [ update-inline-cache ] keep
-[ t ] [ [ dup ] [ drop ] compose cached-effect ( a -- b ) effect= ] unit-test
+    [ boa ] effect-counter inline-cache boa =
-[ t ] [ [ drop ] [ dup ] compose cached-effect ( a b -- c d ) effect= ] unit-test
+] unit-test
-[ t ] [ [ 2drop ] [ dup ] compose cached-effect ( a b c -- d e ) effect= ] unit-test
+
-[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect ( -- a ) effect= ] unit-test
-[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect ( a -- ) effect= ] unit-test
 
 : optimized-quot ( quot -- quot' )
     build-tree optimize-tree nodes>quot ;

core/memory/memory-tests.factor

@@ -1,4 +1,4 @@
-USING: accessors kernel kernel.private math memory prettyprint
+USING: accessors effects kernel kernel.private math memory prettyprint
 io sequences tools.test words namespaces layouts classes
 classes.builtin arrays quotations system ;
 FROM: tools.memory => data-room code-room ;
@@ -73,3 +73,21 @@ SYMBOL: foo
     data-room tenured>> size>>
     assert=
 ] unit-test
+
+! Perform one gc cycle. Then increase the stack height by 100 and
+! force a gc cycle again.
+SYMBOL: foo-var
+
+: perform ( -- )
+    { 1 2 3 } { 4 5 6 } <effect> drop ;
+
+: deep-stack-minor-gc ( n -- )
+    dup [
+        dup 0 > [ 1 - deep-stack-minor-gc ] [
+            drop 100000 [ perform ] times
+        ] if
+    ] dip foo-var set ;
+
+{ } [
+    minor-gc 100 deep-stack-minor-gc
+] unit-test