Merge git://github.com/mncharity/factor into mncharity
commit
9a9be2405b
|
@ -11,6 +11,8 @@ compiler.tree.normalization
|
||||||
compiler.tree.cleanup
|
compiler.tree.cleanup
|
||||||
compiler.tree.propagation
|
compiler.tree.propagation
|
||||||
compiler.tree.propagation.info
|
compiler.tree.propagation.info
|
||||||
|
compiler.tree.escape-analysis
|
||||||
|
compiler.tree.tuple-unboxing
|
||||||
compiler.tree.def-use
|
compiler.tree.def-use
|
||||||
compiler.tree.builder
|
compiler.tree.builder
|
||||||
compiler.tree.optimizer
|
compiler.tree.optimizer
|
||||||
|
@ -209,6 +211,8 @@ SYMBOL: node-count
|
||||||
normalize
|
normalize
|
||||||
propagate
|
propagate
|
||||||
cleanup
|
cleanup
|
||||||
|
escape-analysis
|
||||||
|
unbox-tuples
|
||||||
apply-identities
|
apply-identities
|
||||||
compute-def-use
|
compute-def-use
|
||||||
remove-dead-code
|
remove-dead-code
|
||||||
|
|
|
@ -21,7 +21,7 @@ TUPLE: definition value node uses ;
|
||||||
ERROR: no-def-error value ;
|
ERROR: no-def-error value ;
|
||||||
|
|
||||||
: def-of ( value -- definition )
|
: def-of ( value -- definition )
|
||||||
dup def-use get at* [ nip ] [ no-def-error ] if ;
|
def-use get ?at [ no-def-error ] unless ;
|
||||||
|
|
||||||
ERROR: multiple-defs-error ;
|
ERROR: multiple-defs-error ;
|
||||||
|
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: kernel tools.test compiler.tree compiler.tree.builder
|
USING: kernel tools.test compiler.tree compiler.tree.builder
|
||||||
compiler.tree.def-use compiler.tree.def-use.simplified accessors
|
compiler.tree.recursive compiler.tree.def-use
|
||||||
sequences sorting classes ;
|
compiler.tree.def-use.simplified accessors sequences sorting classes ;
|
||||||
IN: compiler.tree.def-use.simplified
|
IN: compiler.tree.def-use.simplified
|
||||||
|
|
||||||
[ { #call #return } ] [
|
[ { #call #return } ] [
|
||||||
|
@ -8,3 +8,17 @@ IN: compiler.tree.def-use.simplified
|
||||||
first out-d>> first actually-used-by
|
first out-d>> first actually-used-by
|
||||||
[ node>> class ] map natural-sort
|
[ node>> class ] map natural-sort
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
: word-1 ( a -- b ) dup [ word-1 ] when ; inline recursive
|
||||||
|
|
||||||
|
[ { #introduce } ] [
|
||||||
|
[ word-1 ] build-tree analyze-recursive compute-def-use
|
||||||
|
last in-d>> first actually-defined-by
|
||||||
|
[ node>> class ] map natural-sort
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ { #if #return } ] [
|
||||||
|
[ word-1 ] build-tree analyze-recursive compute-def-use
|
||||||
|
first out-d>> first actually-used-by
|
||||||
|
[ node>> class ] map natural-sort
|
||||||
|
] unit-test
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2008 Slava Pestov.
|
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: sequences kernel fry vectors
|
USING: sequences kernel fry vectors accessors namespaces assocs sets
|
||||||
compiler.tree compiler.tree.def-use ;
|
stack-checker.branches compiler.tree compiler.tree.def-use ;
|
||||||
IN: compiler.tree.def-use.simplified
|
IN: compiler.tree.def-use.simplified
|
||||||
|
|
||||||
! Simplified def-use follows chains of copies.
|
! Simplified def-use follows chains of copies.
|
||||||
|
@ -9,32 +9,85 @@ IN: compiler.tree.def-use.simplified
|
||||||
! A 'real' usage is a usage of a value that is not a #renaming.
|
! A 'real' usage is a usage of a value that is not a #renaming.
|
||||||
TUPLE: real-usage value node ;
|
TUPLE: real-usage value node ;
|
||||||
|
|
||||||
! Def
|
<PRIVATE
|
||||||
GENERIC: actually-defined-by* ( value node -- real-usage )
|
|
||||||
|
|
||||||
: actually-defined-by ( value -- real-usage )
|
SYMBOLS: visited accum ;
|
||||||
dup defined-by actually-defined-by* ;
|
|
||||||
|
: if-not-visited ( value quot -- )
|
||||||
|
over visited get key?
|
||||||
|
[ 2drop ] [ over visited get conjoin call ] if ; inline
|
||||||
|
|
||||||
|
: with-simplified-def-use ( quot -- real-usages )
|
||||||
|
[
|
||||||
|
H{ } clone visited set
|
||||||
|
H{ } clone accum set
|
||||||
|
call
|
||||||
|
accum get keys
|
||||||
|
] with-scope ; inline
|
||||||
|
|
||||||
|
PRIVATE>
|
||||||
|
|
||||||
|
! Def
|
||||||
|
GENERIC: actually-defined-by* ( value node -- )
|
||||||
|
|
||||||
|
: (actually-defined-by) ( value -- )
|
||||||
|
[ dup defined-by actually-defined-by* ] if-not-visited ;
|
||||||
|
|
||||||
M: #renaming actually-defined-by*
|
M: #renaming actually-defined-by*
|
||||||
inputs/outputs swap [ index ] dip nth actually-defined-by ;
|
inputs/outputs swap [ index ] dip nth (actually-defined-by) ;
|
||||||
|
|
||||||
M: #return-recursive actually-defined-by* real-usage boa ;
|
M: #call-recursive actually-defined-by*
|
||||||
|
[ out-d>> index ] [ label>> return>> in-d>> nth ] bi
|
||||||
|
(actually-defined-by) ;
|
||||||
|
|
||||||
M: node actually-defined-by* real-usage boa ;
|
M: #enter-recursive actually-defined-by*
|
||||||
|
[ out-d>> index ] keep
|
||||||
|
[ in-d>> nth (actually-defined-by) ]
|
||||||
|
[ label>> calls>> [ node>> in-d>> nth (actually-defined-by) ] with each ] 2bi ;
|
||||||
|
|
||||||
|
M: #phi actually-defined-by*
|
||||||
|
[ out-d>> index ] [ phi-in-d>> ] bi
|
||||||
|
[
|
||||||
|
nth dup +bottom+ eq?
|
||||||
|
[ drop ] [ (actually-defined-by) ] if
|
||||||
|
] with each ;
|
||||||
|
|
||||||
|
M: node actually-defined-by*
|
||||||
|
real-usage boa accum get conjoin ;
|
||||||
|
|
||||||
|
: actually-defined-by ( value -- real-usages )
|
||||||
|
[ (actually-defined-by) ] with-simplified-def-use ;
|
||||||
|
|
||||||
! Use
|
! Use
|
||||||
GENERIC# actually-used-by* 1 ( value node accum -- )
|
GENERIC: actually-used-by* ( value node -- )
|
||||||
|
|
||||||
: (actually-used-by) ( value accum -- )
|
: (actually-used-by) ( value -- )
|
||||||
[ [ used-by ] keep ] dip '[ _ swap _ actually-used-by* ] each ;
|
[ dup used-by [ actually-used-by* ] with each ] if-not-visited ;
|
||||||
|
|
||||||
M: #renaming actually-used-by*
|
M: #renaming actually-used-by*
|
||||||
[ inputs/outputs [ indices ] dip nths ] dip
|
inputs/outputs [ indices ] dip nths
|
||||||
'[ _ (actually-used-by) ] each ;
|
[ (actually-used-by) ] each ;
|
||||||
|
|
||||||
M: #return-recursive actually-used-by* [ real-usage boa ] dip push ;
|
M: #return-recursive actually-used-by*
|
||||||
|
[ in-d>> index ] keep
|
||||||
|
[ out-d>> nth (actually-used-by) ]
|
||||||
|
[ label>> calls>> [ node>> out-d>> nth (actually-used-by) ] with each ] 2bi ;
|
||||||
|
|
||||||
M: node actually-used-by* [ real-usage boa ] dip push ;
|
M: #call-recursive actually-used-by*
|
||||||
|
[ in-d>> index ] [ label>> enter-out>> nth ] bi
|
||||||
|
(actually-used-by) ;
|
||||||
|
|
||||||
|
M: #enter-recursive actually-used-by*
|
||||||
|
[ in-d>> index ] [ out-d>> nth ] bi (actually-used-by) ;
|
||||||
|
|
||||||
|
M: #phi actually-used-by*
|
||||||
|
[ phi-in-d>> [ index ] with map-find drop ] [ out-d>> nth ] bi
|
||||||
|
(actually-used-by) ;
|
||||||
|
|
||||||
|
M: #recursive actually-used-by* 2drop ;
|
||||||
|
|
||||||
|
M: node actually-used-by*
|
||||||
|
real-usage boa accum get conjoin ;
|
||||||
|
|
||||||
: actually-used-by ( value -- real-usages )
|
: actually-used-by ( value -- real-usages )
|
||||||
10 <vector> [ (actually-used-by) ] keep ;
|
[ (actually-used-by) ] with-simplified-def-use ;
|
||||||
|
|
|
@ -1,11 +1,10 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel kernel.private tools.test math math.partial-dispatch
|
USING: kernel kernel.private tools.test math math.partial-dispatch
|
||||||
math.private accessors slots.private sequences sequences.private strings sbufs
|
prettyprint math.private accessors slots.private sequences
|
||||||
compiler.tree.builder
|
sequences.private strings sbufs compiler.tree.builder
|
||||||
compiler.tree.normalization
|
compiler.tree.normalization compiler.tree.debugger alien.accessors
|
||||||
compiler.tree.debugger
|
layouts combinators byte-arrays ;
|
||||||
alien.accessors layouts combinators byte-arrays ;
|
|
||||||
IN: compiler.tree.modular-arithmetic.tests
|
IN: compiler.tree.modular-arithmetic.tests
|
||||||
|
|
||||||
: test-modular-arithmetic ( quot -- quot' )
|
: test-modular-arithmetic ( quot -- quot' )
|
||||||
|
@ -93,8 +92,6 @@ TUPLE: declared-fixnum { x fixnum } ;
|
||||||
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
|
[ { string sbuf } declare ] \ push-all def>> append \ >fixnum inlined?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
[ t ] [
|
[ t ] [
|
||||||
[
|
[
|
||||||
{ integer } declare [ 256 mod ] map
|
{ integer } declare [ 256 mod ] map
|
||||||
|
@ -140,6 +137,11 @@ TUPLE: declared-fixnum { x fixnum } ;
|
||||||
[ [ >fixnum 255 fixnum-bitand ] ]
|
[ [ >fixnum 255 fixnum-bitand ] ]
|
||||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ { fixnum fixnum } declare + [ 1 + >fixnum ] [ 2 + >fixnum ] bi ]
|
||||||
|
{ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ]
|
[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ]
|
||||||
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test
|
[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test
|
||||||
|
|
||||||
|
@ -176,3 +178,83 @@ cell {
|
||||||
[ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
|
[ 0 10 <byte-array> 10 [ 1 pick 0 + >fixnum pick set-nth-unsafe [ 1 + >fixnum ] dip ] times ]
|
||||||
{ >fixnum } inlined?
|
{ >fixnum } inlined?
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [ [ + >fixnum ] { >fixnum } inlined? ] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ >integer [ >fixnum ] [ >fixnum ] bi ]
|
||||||
|
{ >integer } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
[ >integer [ >fixnum ] [ >fixnum ] bi ]
|
||||||
|
{ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ]
|
||||||
|
{ >integer } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
[ >integer [ 2 + >fixnum ] [ 3 + >fixnum ] bi ]
|
||||||
|
{ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
[ [ { fixnum } declare 2 fixnum+ ] dip [ >fixnum 2 - ] [ ] if ]
|
||||||
|
{ fixnum+ } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ { fixnum boolean } declare [ 1 + ] [ "HI" throw ] if >fixnum ]
|
||||||
|
{ fixnum+ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ { fixnum boolean } declare [ 1 + ] [ drop 5 ] if >fixnum ]
|
||||||
|
{ fixnum+ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ { fixnum boolean } declare [ 1 + ] [ 2 + ] if >fixnum ]
|
||||||
|
{ fixnum+ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ [ [ 1 ] [ 4 ] if ] ] [
|
||||||
|
[ [ 1.5 ] [ 4 ] if >fixnum ] test-modular-arithmetic
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ [ [ 1 ] [ 2 ] if ] ] [
|
||||||
|
[ [ 1.5 ] [ 2.3 ] if >fixnum ] test-modular-arithmetic
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
[ { fixnum fixnum boolean } declare [ [ 3 * ] [ 1 + ] dip ] [ [ 4 - ] [ 2 + ] dip ] if >fixnum ]
|
||||||
|
{ fixnum+ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ 0 1000 [ 1 + dup >fixnum . ] times drop ]
|
||||||
|
{ fixnum+ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ { fixnum } declare 3 + [ 1000 ] dip [ >fixnum . ] curry times ]
|
||||||
|
{ fixnum+ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ t ] [
|
||||||
|
[ 0 1000 [ 1 + ] times >fixnum ]
|
||||||
|
{ fixnum+ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
[ f >fixnum ]
|
||||||
|
{ >fixnum } inlined?
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ f ] [
|
||||||
|
[ [ >fixnum ] 2dip set-alien-unsigned-1 ]
|
||||||
|
{ >fixnum } inlined?
|
||||||
|
] unit-test
|
|
@ -1,10 +1,11 @@
|
||||||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: math math.partial-dispatch namespaces sequences sets
|
USING: math math.private math.partial-dispatch namespaces sequences
|
||||||
accessors assocs words kernel memoize fry combinators
|
sets accessors assocs words kernel memoize fry combinators
|
||||||
combinators.short-circuit layouts alien.accessors
|
combinators.short-circuit layouts alien.accessors
|
||||||
compiler.tree
|
compiler.tree
|
||||||
compiler.tree.combinators
|
compiler.tree.combinators
|
||||||
|
compiler.tree.propagation.info
|
||||||
compiler.tree.def-use
|
compiler.tree.def-use
|
||||||
compiler.tree.def-use.simplified
|
compiler.tree.def-use.simplified
|
||||||
compiler.tree.late-optimizations ;
|
compiler.tree.late-optimizations ;
|
||||||
|
@ -19,17 +20,24 @@ IN: compiler.tree.modular-arithmetic
|
||||||
! ==>
|
! ==>
|
||||||
! [ >fixnum ] bi@ fixnum+fast
|
! [ >fixnum ] bi@ fixnum+fast
|
||||||
|
|
||||||
|
! Words where the low-order bits of the output only depends on the
|
||||||
|
! low-order bits of the input. If the output is only used for its
|
||||||
|
! low-order bits, then the word can be converted into a form that is
|
||||||
|
! cheaper to compute.
|
||||||
{ + - * bitand bitor bitxor } [
|
{ + - * bitand bitor bitxor } [
|
||||||
[
|
[
|
||||||
t "modular-arithmetic" set-word-prop
|
t "modular-arithmetic" set-word-prop
|
||||||
] each-integer-derived-op
|
] each-integer-derived-op
|
||||||
] each
|
] each
|
||||||
|
|
||||||
{ bitand bitor bitxor bitnot }
|
{ bitand bitor bitxor bitnot >integer }
|
||||||
[ t "modular-arithmetic" set-word-prop ] each
|
[ t "modular-arithmetic" set-word-prop ] each
|
||||||
|
|
||||||
|
! Words that only use the low-order bits of their input. If the input
|
||||||
|
! is a modular arithmetic word, then the input can be converted into
|
||||||
|
! a form that is cheaper to compute.
|
||||||
{
|
{
|
||||||
>fixnum
|
>fixnum bignum>fixnum float>fixnum
|
||||||
set-alien-unsigned-1 set-alien-signed-1
|
set-alien-unsigned-1 set-alien-signed-1
|
||||||
set-alien-unsigned-2 set-alien-signed-2
|
set-alien-unsigned-2 set-alien-signed-2
|
||||||
}
|
}
|
||||||
|
@ -38,80 +46,138 @@ cell 8 = [
|
||||||
] when
|
] when
|
||||||
[ t "low-order" set-word-prop ] each
|
[ t "low-order" set-word-prop ] each
|
||||||
|
|
||||||
SYMBOL: modularize-values
|
! Values which only have their low-order bits used. This set starts out
|
||||||
|
! big and is gradually refined.
|
||||||
|
SYMBOL: modular-values
|
||||||
|
|
||||||
: modular-value? ( value -- ? )
|
: modular-value? ( value -- ? )
|
||||||
modularize-values get key? ;
|
modular-values get key? ;
|
||||||
|
|
||||||
: modularize-value ( value -- ) modularize-values get conjoin ;
|
: modular-value ( value -- )
|
||||||
|
modular-values get conjoin ;
|
||||||
|
|
||||||
GENERIC: maybe-modularize* ( value node -- )
|
! Values which are known to be fixnums.
|
||||||
|
SYMBOL: fixnum-values
|
||||||
|
|
||||||
: maybe-modularize ( value -- )
|
: fixnum-value? ( value -- ? )
|
||||||
actually-defined-by [ value>> ] [ node>> ] bi
|
fixnum-values get key? ;
|
||||||
over actually-used-by length 1 = [
|
|
||||||
maybe-modularize*
|
|
||||||
] [ 2drop ] if ;
|
|
||||||
|
|
||||||
M: #call maybe-modularize*
|
: fixnum-value ( value -- )
|
||||||
dup word>> "modular-arithmetic" word-prop [
|
fixnum-values get conjoin ;
|
||||||
[ modularize-value ]
|
|
||||||
[ in-d>> [ maybe-modularize ] each ] bi*
|
|
||||||
] [ 2drop ] if ;
|
|
||||||
|
|
||||||
M: node maybe-modularize* 2drop ;
|
GENERIC: compute-modular-candidates* ( node -- )
|
||||||
|
|
||||||
GENERIC: compute-modularized-values* ( node -- )
|
M: #push compute-modular-candidates*
|
||||||
|
[ out-d>> first ] [ literal>> ] bi
|
||||||
|
real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ;
|
||||||
|
|
||||||
M: #call compute-modularized-values*
|
M: #call compute-modular-candidates*
|
||||||
dup word>> "low-order" word-prop
|
{
|
||||||
[ in-d>> first maybe-modularize ] [ drop ] if ;
|
{
|
||||||
|
[ dup word>> "modular-arithmetic" word-prop ]
|
||||||
|
[ out-d>> first [ modular-value ] [ fixnum-value ] bi ]
|
||||||
|
}
|
||||||
|
{
|
||||||
|
[ dup word>> "low-order" word-prop ]
|
||||||
|
[ in-d>> first modular-value ]
|
||||||
|
}
|
||||||
|
[ drop ]
|
||||||
|
} cond ;
|
||||||
|
|
||||||
M: node compute-modularized-values* drop ;
|
M: node compute-modular-candidates*
|
||||||
|
drop ;
|
||||||
|
|
||||||
: compute-modularized-values ( nodes -- )
|
: compute-modular-candidates ( nodes -- )
|
||||||
[ compute-modularized-values* ] each-node ;
|
H{ } clone modular-values set
|
||||||
|
H{ } clone fixnum-values set
|
||||||
|
[ compute-modular-candidates* ] each-node ;
|
||||||
|
|
||||||
|
GENERIC: only-reads-low-order? ( node -- ? )
|
||||||
|
|
||||||
|
M: #call only-reads-low-order?
|
||||||
|
{
|
||||||
|
[ word>> "low-order" word-prop ]
|
||||||
|
[
|
||||||
|
{
|
||||||
|
[ word>> "modular-arithmetic" word-prop ]
|
||||||
|
[ out-d>> first modular-values get key? ]
|
||||||
|
} 1&&
|
||||||
|
]
|
||||||
|
} 1|| ;
|
||||||
|
|
||||||
|
M: node only-reads-low-order? drop f ;
|
||||||
|
|
||||||
|
SYMBOL: changed?
|
||||||
|
|
||||||
|
: only-used-as-low-order? ( value -- ? )
|
||||||
|
actually-used-by [ node>> only-reads-low-order? ] all? ;
|
||||||
|
|
||||||
|
: (compute-modular-values) ( -- )
|
||||||
|
modular-values get keys [
|
||||||
|
dup only-used-as-low-order?
|
||||||
|
[ drop ] [ modular-values get delete-at changed? on ] if
|
||||||
|
] each ;
|
||||||
|
|
||||||
|
: compute-modular-values ( -- )
|
||||||
|
[ changed? off (compute-modular-values) changed? get ] loop ;
|
||||||
|
|
||||||
GENERIC: optimize-modular-arithmetic* ( node -- nodes )
|
GENERIC: optimize-modular-arithmetic* ( node -- nodes )
|
||||||
|
|
||||||
|
M: #push optimize-modular-arithmetic*
|
||||||
|
dup [ out-d>> first modular-value? ] [ literal>> real? ] bi and
|
||||||
|
[ [ >fixnum ] change-literal ] when ;
|
||||||
|
|
||||||
: redundant->fixnum? ( #call -- ? )
|
: redundant->fixnum? ( #call -- ? )
|
||||||
in-d>> first actually-defined-by value>> modular-value? ;
|
in-d>> first actually-defined-by
|
||||||
|
[ value>> { [ modular-value? ] [ fixnum-value? ] } 1&& ] all? ;
|
||||||
|
|
||||||
: optimize->fixnum ( #call -- nodes )
|
: optimize->fixnum ( #call -- nodes )
|
||||||
dup redundant->fixnum? [ drop f ] when ;
|
dup redundant->fixnum? [ drop f ] when ;
|
||||||
|
|
||||||
|
: should-be->fixnum? ( #call -- ? )
|
||||||
|
out-d>> first modular-value? ;
|
||||||
|
|
||||||
: optimize->integer ( #call -- nodes )
|
: optimize->integer ( #call -- nodes )
|
||||||
dup out-d>> first actually-used-by dup length 1 = [
|
dup should-be->fixnum? [ \ >fixnum >>word ] when ;
|
||||||
first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
|
|
||||||
[ drop { } ] when
|
|
||||||
] [ drop ] if ;
|
|
||||||
|
|
||||||
MEMO: fixnum-coercion ( flags -- nodes )
|
MEMO: fixnum-coercion ( flags -- nodes )
|
||||||
|
! flags indicate which input parameters are already known to be fixnums,
|
||||||
|
! and don't need a coercion as a result.
|
||||||
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
|
[ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
|
||||||
|
|
||||||
|
: modular-value-info ( #call -- alist )
|
||||||
|
[ in-d>> ] [ out-d>> ] bi append
|
||||||
|
fixnum <class-info> '[ _ ] { } map>assoc ;
|
||||||
|
|
||||||
: optimize-modular-op ( #call -- nodes )
|
: optimize-modular-op ( #call -- nodes )
|
||||||
dup out-d>> first modular-value? [
|
dup out-d>> first modular-value? [
|
||||||
[ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
|
[ in-d>> ] [ word>> integer-op-input-classes ] [ ] tri
|
||||||
[
|
[
|
||||||
[
|
[
|
||||||
[ actually-defined-by value>> modular-value? ]
|
[ actually-defined-by [ value>> modular-value? ] all? ]
|
||||||
[ fixnum eq? ]
|
[ fixnum eq? ]
|
||||||
bi* or
|
bi* or
|
||||||
] 2map fixnum-coercion
|
] 2map fixnum-coercion
|
||||||
] [ [ modular-variant ] change-word ] bi* suffix
|
] [ [ modular-variant ] change-word ] bi* suffix
|
||||||
] when ;
|
] when ;
|
||||||
|
|
||||||
|
: optimize-low-order-op ( #call -- nodes )
|
||||||
|
dup in-d>> first fixnum-value? [
|
||||||
|
[ ] [ in-d>> first ] [ info>> ] tri
|
||||||
|
[ drop fixnum <class-info> ] change-at
|
||||||
|
] when ;
|
||||||
|
|
||||||
M: #call optimize-modular-arithmetic*
|
M: #call optimize-modular-arithmetic*
|
||||||
dup word>> {
|
dup word>> {
|
||||||
{ [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
|
{ [ dup { >fixnum bignum>fixnum float>fixnum } memq? ] [ drop optimize->fixnum ] }
|
||||||
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
|
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
|
||||||
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
|
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
|
||||||
|
{ [ dup "low-order" word-prop ] [ drop optimize-low-order-op ] }
|
||||||
[ drop ]
|
[ drop ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
M: node optimize-modular-arithmetic* ;
|
M: node optimize-modular-arithmetic* ;
|
||||||
|
|
||||||
: optimize-modular-arithmetic ( nodes -- nodes' )
|
: optimize-modular-arithmetic ( nodes -- nodes' )
|
||||||
H{ } clone modularize-values set
|
dup compute-modular-candidates compute-modular-values
|
||||||
dup compute-modularized-values
|
|
||||||
[ optimize-modular-arithmetic* ] map-nodes ;
|
[ optimize-modular-arithmetic* ] map-nodes ;
|
||||||
|
|
|
@ -18,6 +18,16 @@ HELP: /*
|
||||||
""
|
""
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
|
HELP: HEREDOC:
|
||||||
|
{ $syntax "HEREDOC: marker\n...text...marker" }
|
||||||
|
{ $values { "marker" "a word (token)" } { "text" "arbitrary text" } { "" "a string" } }
|
||||||
|
{ $description "A multiline string syntax with a user-specified terminating delimiter. HEREDOC: reads the next word, and uses it as the 'close quote'. All input from the beginning of the HEREDOC:'s next line, until the first appearance of the word's name, becomes a string. The terminating word does not need to be at the beginning of a line.\n\nThe HEREDOC: line should not have anything after the delimiting word. The delimiting word should be an alphanumeric token. It should not be, as in some other languages, a \"quoted string\"." }
|
||||||
|
{ $examples
|
||||||
|
{ $example "USING: heredoc ;" "HEREDOC: END\nx\nEND" "! \"x\\n\"" }
|
||||||
|
{ $example "HEREDOC: END\nxEND" "! \"x\"" }
|
||||||
|
{ $example "2 5 HEREDOC: zap\nfoo\nbarzap subseq" "! \"o\\nb\"" }
|
||||||
|
} ;
|
||||||
|
|
||||||
{ POSTPONE: <" POSTPONE: STRING: } related-words
|
{ POSTPONE: <" POSTPONE: STRING: } related-words
|
||||||
|
|
||||||
HELP: parse-multiline-string
|
HELP: parse-multiline-string
|
||||||
|
@ -29,6 +39,7 @@ ARTICLE: "multiline" "Multiline"
|
||||||
"Multiline strings:"
|
"Multiline strings:"
|
||||||
{ $subsection POSTPONE: STRING: }
|
{ $subsection POSTPONE: STRING: }
|
||||||
{ $subsection POSTPONE: <" }
|
{ $subsection POSTPONE: <" }
|
||||||
|
{ $subsection POSTPONE: HEREDOC: }
|
||||||
"Multiline comments:"
|
"Multiline comments:"
|
||||||
{ $subsection POSTPONE: /* }
|
{ $subsection POSTPONE: /* }
|
||||||
"Writing new multiline parsing words:"
|
"Writing new multiline parsing words:"
|
||||||
|
|
|
@ -19,3 +19,43 @@ world"> ] unit-test
|
||||||
|
|
||||||
[ "\nhi" ] [ <"
|
[ "\nhi" ] [ <"
|
||||||
hi"> ] unit-test
|
hi"> ] unit-test
|
||||||
|
|
||||||
|
|
||||||
|
! HEREDOC:
|
||||||
|
|
||||||
|
[ "foo\nbar\n" ] [ HEREDOC: END
|
||||||
|
foo
|
||||||
|
bar
|
||||||
|
END ] unit-test
|
||||||
|
|
||||||
|
[ "foo\nbar" ] [ HEREDOC: END
|
||||||
|
foo
|
||||||
|
barEND ] unit-test
|
||||||
|
|
||||||
|
[ "" ] [ HEREDOC: END
|
||||||
|
END ] unit-test
|
||||||
|
|
||||||
|
[ " " ] [ HEREDOC: END
|
||||||
|
END ] unit-test
|
||||||
|
|
||||||
|
[ "\n" ] [ HEREDOC: END
|
||||||
|
|
||||||
|
END ] unit-test
|
||||||
|
|
||||||
|
[ "x" ] [ HEREDOC: END
|
||||||
|
xEND ] unit-test
|
||||||
|
|
||||||
|
[ "xyz " ] [ HEREDOC: END
|
||||||
|
xyz END ] unit-test
|
||||||
|
|
||||||
|
[ "} ! * # \" «\n" ] [ HEREDOC: END
|
||||||
|
} ! * # " «
|
||||||
|
END ] unit-test
|
||||||
|
|
||||||
|
[ 21 "foo\nbar" " HEREDOC: FOO\n FOO\n" 22 ] [ 21 HEREDOC: X
|
||||||
|
foo
|
||||||
|
barX HEREDOC: END ! mumble
|
||||||
|
HEREDOC: FOO
|
||||||
|
FOO
|
||||||
|
END 22 ] unit-test
|
||||||
|
|
||||||
|
|
|
@ -27,7 +27,7 @@ SYNTAX: STRING:
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
|
||||||
:: (parse-multiline-string) ( i end -- j )
|
:: (scan-multiline-string) ( i end -- j )
|
||||||
lexer get line-text>> :> text
|
lexer get line-text>> :> text
|
||||||
text [
|
text [
|
||||||
end text i start* [| j |
|
end text i start* [| j |
|
||||||
|
@ -35,18 +35,21 @@ SYNTAX: STRING:
|
||||||
] [
|
] [
|
||||||
text i short tail % CHAR: \n ,
|
text i short tail % CHAR: \n ,
|
||||||
lexer get next-line
|
lexer get next-line
|
||||||
0 end (parse-multiline-string)
|
0 end (scan-multiline-string)
|
||||||
] if*
|
] if*
|
||||||
] [ end unexpected-eof ] if ;
|
] [ end unexpected-eof ] if ;
|
||||||
|
|
||||||
|
:: (parse-multiline-string) ( end-text skip-n-chars -- str )
|
||||||
|
[
|
||||||
|
lexer get
|
||||||
|
[ skip-n-chars + end-text (scan-multiline-string) ]
|
||||||
|
change-column drop
|
||||||
|
] "" make ;
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
: parse-multiline-string ( end-text -- str )
|
: parse-multiline-string ( end-text -- str )
|
||||||
[
|
1 (parse-multiline-string) ;
|
||||||
lexer get
|
|
||||||
[ 1 + swap (parse-multiline-string) ]
|
|
||||||
change-column drop
|
|
||||||
] "" make ;
|
|
||||||
|
|
||||||
SYNTAX: <"
|
SYNTAX: <"
|
||||||
"\">" parse-multiline-string parsed ;
|
"\">" parse-multiline-string parsed ;
|
||||||
|
@ -61,3 +64,9 @@ SYNTAX: {"
|
||||||
"\"}" parse-multiline-string parsed ;
|
"\"}" parse-multiline-string parsed ;
|
||||||
|
|
||||||
SYNTAX: /* "*/" parse-multiline-string drop ;
|
SYNTAX: /* "*/" parse-multiline-string drop ;
|
||||||
|
|
||||||
|
SYNTAX: HEREDOC:
|
||||||
|
scan
|
||||||
|
lexer get next-line
|
||||||
|
0 (parse-multiline-string)
|
||||||
|
parsed ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: tools.test byte-arrays sequences kernel ;
|
USING: tools.test byte-arrays sequences kernel math ;
|
||||||
IN: byte-arrays.tests
|
IN: byte-arrays.tests
|
||||||
|
|
||||||
[ 6 B{ 1 2 3 } ] [
|
[ 6 B{ 1 2 3 } ] [
|
||||||
|
@ -11,3 +11,7 @@ IN: byte-arrays.tests
|
||||||
[ -10 B{ } resize-byte-array ] must-fail
|
[ -10 B{ } resize-byte-array ] must-fail
|
||||||
|
|
||||||
[ B{ 123 } ] [ 123 1byte-array ] unit-test
|
[ B{ 123 } ] [ 123 1byte-array ] unit-test
|
||||||
|
|
||||||
|
[ B{ 123 } ] [ 123 0 B{ 0 } [ set-nth ] keep ] unit-test
|
||||||
|
|
||||||
|
[ B{ 123 } ] [ 123 >bignum 0 B{ 0 } [ set-nth ] keep ] unit-test
|
|
@ -1,5 +1,5 @@
|
||||||
USING: tools.test io.streams.byte-array io.encodings.binary
|
USING: tools.test io.streams.byte-array io.encodings.binary
|
||||||
io.encodings.utf8 io kernel arrays strings namespaces ;
|
io.encodings.utf8 io kernel arrays strings namespaces math ;
|
||||||
|
|
||||||
[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test
|
[ B{ } ] [ B{ } binary [ contents ] with-byte-reader ] unit-test
|
||||||
[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
|
[ B{ 1 2 3 } ] [ binary [ B{ 1 2 3 } write ] with-byte-writer ] unit-test
|
||||||
|
@ -28,3 +28,8 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
|
||||||
read1
|
read1
|
||||||
] with-byte-reader
|
] with-byte-reader
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
! Overly aggressive compiler optimizations
|
||||||
|
[ B{ 123 } ] [
|
||||||
|
binary [ 123 >bignum write1 ] with-byte-writer
|
||||||
|
] unit-test
|
|
@ -36,8 +36,7 @@ C-STRUCT: yuv_buffer
|
||||||
255 min 0 max ; inline
|
255 min 0 max ; inline
|
||||||
|
|
||||||
: stride ( line yuv -- uvy yy )
|
: stride ( line yuv -- uvy yy )
|
||||||
[ yuv_buffer-uv_stride swap 2/ * >fixnum ]
|
[ yuv_buffer-uv_stride swap 2/ * ] [ yuv_buffer-y_stride * ] 2bi ; inline
|
||||||
[ yuv_buffer-y_stride * >fixnum ] 2bi ; inline
|
|
||||||
|
|
||||||
: compute-y ( yuv uvy yy x -- y )
|
: compute-y ( yuv uvy yy x -- y )
|
||||||
+ >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
|
+ >fixnum nip swap yuv_buffer-y swap alien-unsigned-1 16 - ; inline
|
||||||
|
@ -74,16 +73,16 @@ C-STRUCT: yuv_buffer
|
||||||
drop ; inline
|
drop ; inline
|
||||||
|
|
||||||
: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
|
: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
|
||||||
compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
|
compute-yuv compute-rgb store-rgb 3 + ; inline
|
||||||
|
|
||||||
: yuv>rgb-row ( index rgb yuv y -- index )
|
: yuv>rgb-row ( index rgb yuv y -- index )
|
||||||
over stride
|
over stride
|
||||||
pick yuv_buffer-y_width >fixnum
|
pick yuv_buffer-y_width
|
||||||
[ yuv>rgb-pixel ] with with with with each ; inline
|
[ yuv>rgb-pixel ] with with with with each ; inline
|
||||||
|
|
||||||
: yuv>rgb ( rgb yuv -- )
|
: yuv>rgb ( rgb yuv -- )
|
||||||
[ 0 ] 2dip
|
[ 0 ] 2dip
|
||||||
dup yuv_buffer-y_height >fixnum
|
dup yuv_buffer-y_height
|
||||||
[ yuv>rgb-row ] with with each
|
[ yuv>rgb-row ] with with each
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
|
|
|
@ -2,8 +2,9 @@ IN: multi-methods.tests
|
||||||
USING: multi-methods tools.test math sequences namespaces system
|
USING: multi-methods tools.test math sequences namespaces system
|
||||||
kernel strings definitions prettyprint debugger arrays
|
kernel strings definitions prettyprint debugger arrays
|
||||||
hashtables continuations classes assocs accessors see ;
|
hashtables continuations classes assocs accessors see ;
|
||||||
|
RENAME: GENERIC: multi-methods => multi-methods:GENERIC:
|
||||||
|
|
||||||
GENERIC: first-test ( -- )
|
multi-methods:GENERIC: first-test ( -- )
|
||||||
|
|
||||||
[ t ] [ \ first-test generic? ] unit-test
|
[ t ] [ \ first-test generic? ] unit-test
|
||||||
|
|
||||||
|
@ -13,14 +14,14 @@ SINGLETON: paper INSTANCE: paper thing
|
||||||
SINGLETON: scissors INSTANCE: scissors thing
|
SINGLETON: scissors INSTANCE: scissors thing
|
||||||
SINGLETON: rock INSTANCE: rock thing
|
SINGLETON: rock INSTANCE: rock thing
|
||||||
|
|
||||||
GENERIC: beats? ( obj1 obj2 -- ? )
|
multi-methods:GENERIC: beats? ( obj1 obj2 -- ? )
|
||||||
|
|
||||||
METHOD: beats? { paper scissors } t ;
|
METHOD: beats? { paper scissors } 2drop t ;
|
||||||
METHOD: beats? { scissors rock } t ;
|
METHOD: beats? { scissors rock } 2drop t ;
|
||||||
METHOD: beats? { rock paper } t ;
|
METHOD: beats? { rock paper } 2drop t ;
|
||||||
METHOD: beats? { thing thing } f ;
|
METHOD: beats? { thing thing } 2drop f ;
|
||||||
|
|
||||||
: play ( obj1 obj2 -- ? ) beats? 2nip ;
|
: play ( obj1 obj2 -- ? ) beats? ;
|
||||||
|
|
||||||
[ { } 3 play ] must-fail
|
[ { } 3 play ] must-fail
|
||||||
[ t ] [ error get no-method? ] unit-test
|
[ t ] [ error get no-method? ] unit-test
|
||||||
|
@ -34,7 +35,7 @@ METHOD: beats? { thing thing } f ;
|
||||||
|
|
||||||
SYMBOL: some-var
|
SYMBOL: some-var
|
||||||
|
|
||||||
GENERIC: hook-test ( -- obj )
|
multi-methods:GENERIC: hook-test ( obj -- obj )
|
||||||
|
|
||||||
METHOD: hook-test { array { some-var array } } reverse ;
|
METHOD: hook-test { array { some-var array } } reverse ;
|
||||||
METHOD: hook-test { { some-var array } } class ;
|
METHOD: hook-test { { some-var array } } class ;
|
||||||
|
@ -57,7 +58,7 @@ TUPLE: busted-1 ;
|
||||||
TUPLE: busted-2 ; INSTANCE: busted-2 busted
|
TUPLE: busted-2 ; INSTANCE: busted-2 busted
|
||||||
TUPLE: busted-3 ;
|
TUPLE: busted-3 ;
|
||||||
|
|
||||||
GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
|
multi-methods:GENERIC: busted-sort ( obj1 obj2 -- obj1 obj2 )
|
||||||
|
|
||||||
METHOD: busted-sort { busted-1 busted-2 } ;
|
METHOD: busted-sort { busted-1 busted-2 } ;
|
||||||
METHOD: busted-sort { busted-2 busted-3 } ;
|
METHOD: busted-sort { busted-2 busted-3 } ;
|
Loading…
Reference in New Issue