--- /dev/null
+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
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 ;
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 } } }
[ 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 }
-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 }
[ 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>>
{
--- /dev/null
+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
! 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
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 ;
-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 ;
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
projects / factor.git / commitdiff