steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

compiler.cfg.*: a bunch of new tests

db4
Björn Lindqvist 2015-05-07 13:23:28 +02:00 committed by John Benediktsson
parent a6e2834252
commit 8f02cad9c5
7 changed files with 193 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
basis/compiler/cfg/builder/alien/boxing/boxing-tests.factor Normal file
View File

@ -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

10
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -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 } } }

12
basis/compiler/cfg/dominance/dominance-tests.factor
View File

@ -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 )
{
{ 0 { } }
{ 1 { } }
{ 2 { } }
{ 3 { } }
{ 4 { } }
{ 5 { } }
{ 6 { } }
{ 7 { } }
{ 8 { } }
} [ over insns>block ] assoc-map dup
9 iota [ V{ } clone over insns>block ] { } map>assoc dup
{
{ 0 1 }
{ 1 2 } { 1 7 }

60
basis/compiler/cfg/gc-checks/gc-checks-tests.factor
View File

@ -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
compiler.cfg.comparisons compiler.cfg.utilities ;
memory classes make combinators.short-circuit
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>>
{

17
basis/compiler/cfg/intrinsics/fixnum/fixnum-tests.factor Normal file
View File

@ -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

77
basis/compiler/tree/propagation/call-effect/call-effect-tests.factor
View File

@ -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
math effects kernel compiler.tree.builder compiler.tree.optimizer
compiler.tree.debugger sequences eval fry tools.test ;
USING: accessors combinators combinators.private compiler.tree
compiler.tree.propagation.call-effect compiler.units math effects kernel
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
{ t } [
[ boa ] inline-cache new [ update-inline-cache ] keep
[ boa ] effect-counter inline-cache boa =
! cached-effect
{ t } [ [ + ] cached-effect ( a b -- c ) effect= ] unit-test
{ t } [ 5 [ + ] curry cached-effect ( a -- c ) effect= ] unit-test
{ 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
[ t ] [ 5 [ + ] curry cached-effect ( a -- c ) effect= ] unit-test
[ 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
! update-inline-cache
{ t } [
[ boa ] inline-cache new [ update-inline-cache ] keep
[ boa ] effect-counter inline-cache boa =
] unit-test
: optimized-quot ( quot -- quot' )
build-tree optimize-tree nodes>quot ;

20
core/memory/memory-tests.factor
View File

@ -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