Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
93c93a392b
|
|
@ -35,83 +35,87 @@ gc
|
|||
: compile-unoptimized ( words -- )
|
||||
[ optimized? not ] filter compile ;
|
||||
|
||||
nl
|
||||
"Compiling..." write flush
|
||||
"debug-compiler" get [
|
||||
|
||||
nl
|
||||
"Compiling..." write flush
|
||||
|
||||
! Compile a set of words ahead of the full compile.
|
||||
! This set of words was determined semi-empirically
|
||||
! using the profiler. It improves bootstrap time
|
||||
! significantly, because frequenly called words
|
||||
! which are also quick to compile are replaced by
|
||||
! compiled definitions as soon as possible.
|
||||
{
|
||||
not ?
|
||||
! Compile a set of words ahead of the full compile.
|
||||
! This set of words was determined semi-empirically
|
||||
! using the profiler. It improves bootstrap time
|
||||
! significantly, because frequenly called words
|
||||
! which are also quick to compile are replaced by
|
||||
! compiled definitions as soon as possible.
|
||||
{
|
||||
not ?
|
||||
|
||||
2over roll -roll
|
||||
2over roll -roll
|
||||
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? tombstone?
|
||||
curry? compose? callable?
|
||||
quotation?
|
||||
array? hashtable? vector?
|
||||
tuple? sbuf? tombstone?
|
||||
curry? compose? callable?
|
||||
quotation?
|
||||
|
||||
curry compose uncurry
|
||||
curry compose uncurry
|
||||
|
||||
array-nth set-array-nth length>>
|
||||
array-nth set-array-nth length>>
|
||||
|
||||
wrap probe
|
||||
wrap probe
|
||||
|
||||
namestack*
|
||||
namestack*
|
||||
|
||||
layout-of
|
||||
} compile-unoptimized
|
||||
layout-of
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
bitand bitor bitxor bitnot
|
||||
} compile-unoptimized
|
||||
{
|
||||
bitand bitor bitxor bitnot
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
+ 2/ < <= > >= shift
|
||||
} compile-unoptimized
|
||||
{
|
||||
+ 2/ < <= > >= shift
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
new-sequence nth push pop last flip
|
||||
} compile-unoptimized
|
||||
{
|
||||
new-sequence nth push pop last flip
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
hashcode* = equal? assoc-stack (assoc-stack) get set
|
||||
} compile-unoptimized
|
||||
{
|
||||
hashcode* = equal? assoc-stack (assoc-stack) get set
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
memq? split harvest sift cut cut-slice start index clone
|
||||
set-at reverse push-all class number>string string>number
|
||||
like clone-like
|
||||
} compile-unoptimized
|
||||
{
|
||||
memq? split harvest sift cut cut-slice start index clone
|
||||
set-at reverse push-all class number>string string>number
|
||||
like clone-like
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
lines prefix suffix unclip new-assoc update
|
||||
word-prop set-word-prop 1array 2array 3array ?nth
|
||||
} compile-unoptimized
|
||||
{
|
||||
lines prefix suffix unclip new-assoc update
|
||||
word-prop set-word-prop 1array 2array 3array ?nth
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
{
|
||||
malloc calloc free memcpy
|
||||
} compile-unoptimized
|
||||
{
|
||||
malloc calloc free memcpy
|
||||
} compile-unoptimized
|
||||
|
||||
"." write flush
|
||||
"." write flush
|
||||
|
||||
vocabs [ words compile-unoptimized "." write flush ] each
|
||||
vocabs [ words compile-unoptimized "." write flush ] each
|
||||
|
||||
" done" print flush
|
||||
" done" print flush
|
||||
|
||||
] unless
|
||||
|
|
@ -4,7 +4,7 @@ USING: kernel kernel.private tools.test math math.partial-dispatch
|
|||
prettyprint math.private accessors slots.private sequences
|
||||
sequences.private strings sbufs compiler.tree.builder
|
||||
compiler.tree.normalization compiler.tree.debugger alien.accessors
|
||||
layouts combinators byte-arrays ;
|
||||
layouts combinators byte-arrays arrays ;
|
||||
IN: compiler.tree.modular-arithmetic.tests
|
||||
|
||||
: test-modular-arithmetic ( quot -- quot' )
|
||||
|
|
@ -134,7 +134,7 @@ TUPLE: declared-fixnum { x fixnum } ;
|
|||
] { mod fixnum-mod rem } inlined?
|
||||
] unit-test
|
||||
|
||||
[ [ >fixnum 255 fixnum-bitand ] ]
|
||||
[ [ >fixnum 255 >R R> fixnum-bitand ] ]
|
||||
[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
@ -201,6 +201,21 @@ cell {
|
|||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ >integer [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >integer } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ >bignum [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ >bignum [ >fixnum ] [ >fixnum ] bi ]
|
||||
{ >bignum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ f ] [
|
||||
[ [ { fixnum } declare 2 fixnum+ ] dip [ >fixnum 2 - ] [ ] if ]
|
||||
{ fixnum+ } inlined?
|
||||
|
|
@ -257,4 +272,21 @@ cell {
|
|||
[ f ] [
|
||||
[ [ >fixnum ] 2dip set-alien-unsigned-1 ]
|
||||
{ >fixnum } inlined?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
[ { fixnum } declare 123 >bignum bitand >fixnum ]
|
||||
{ >bignum fixnum>bignum bignum-bitand } inlined?
|
||||
] unit-test
|
||||
|
||||
! Shifts
|
||||
[ t ] [
|
||||
[
|
||||
[ 0 ] 2dip { array } declare [
|
||||
hashcode* >fixnum swap [
|
||||
[ -2 shift ] [ 5 shift ] bi
|
||||
+ +
|
||||
] keep bitxor >fixnum
|
||||
] with each
|
||||
] { + bignum+ fixnum-shift bitxor bignum-bitxor } inlined?
|
||||
] unit-test
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math math.private math.partial-dispatch namespaces sequences
|
||||
sets accessors assocs words kernel memoize fry combinators
|
||||
combinators.short-circuit layouts alien.accessors
|
||||
USING: math math.intervals math.private math.partial-dispatch
|
||||
namespaces sequences sets accessors assocs words kernel memoize fry
|
||||
combinators combinators.short-circuit layouts alien.accessors
|
||||
compiler.tree
|
||||
compiler.tree.combinators
|
||||
compiler.tree.propagation.info
|
||||
|
|
@ -30,7 +30,7 @@ IN: compiler.tree.modular-arithmetic
|
|||
] each-integer-derived-op
|
||||
] each
|
||||
|
||||
{ bitand bitor bitxor bitnot >integer }
|
||||
{ bitand bitor bitxor bitnot >integer >bignum fixnum>bignum }
|
||||
[ t "modular-arithmetic" set-word-prop ] each
|
||||
|
||||
! Words that only use the low-order bits of their input. If the input
|
||||
|
|
@ -71,16 +71,28 @@ M: #push compute-modular-candidates*
|
|||
[ out-d>> first ] [ literal>> ] bi
|
||||
real? [ [ modular-value ] [ fixnum-value ] bi ] [ drop ] if ;
|
||||
|
||||
: small-shift? ( interval -- ? )
|
||||
0 cell-bits tag-bits get - 1 - [a,b] interval-subset? ;
|
||||
|
||||
: modular-word? ( #call -- ? )
|
||||
dup word>> { shift fixnum-shift bignum-shift } memq?
|
||||
[ node-input-infos second interval>> small-shift? ]
|
||||
[ word>> "modular-arithmetic" word-prop ]
|
||||
if ;
|
||||
|
||||
: output-candidate ( #call -- )
|
||||
out-d>> first [ modular-value ] [ fixnum-value ] bi ;
|
||||
|
||||
: low-order-word? ( #call -- ? )
|
||||
word>> "low-order" word-prop ;
|
||||
|
||||
: input-candidiate ( #call -- )
|
||||
in-d>> first modular-value ;
|
||||
|
||||
M: #call compute-modular-candidates*
|
||||
{
|
||||
{
|
||||
[ 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 ]
|
||||
}
|
||||
{ [ dup modular-word? ] [ output-candidate ] }
|
||||
{ [ dup low-order-word? ] [ input-candidiate ] }
|
||||
[ drop ]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -94,15 +106,13 @@ M: node compute-modular-candidates*
|
|||
|
||||
GENERIC: only-reads-low-order? ( node -- ? )
|
||||
|
||||
: output-modular? ( #call -- ? )
|
||||
out-d>> first modular-values get key? ;
|
||||
|
||||
M: #call only-reads-low-order?
|
||||
{
|
||||
[ word>> "low-order" word-prop ]
|
||||
[
|
||||
{
|
||||
[ word>> "modular-arithmetic" word-prop ]
|
||||
[ out-d>> first modular-values get key? ]
|
||||
} 1&&
|
||||
]
|
||||
[ low-order-word? ]
|
||||
[ { [ modular-word? ] [ output-modular? ] } 1&& ]
|
||||
} 1|| ;
|
||||
|
||||
M: node only-reads-low-order? drop f ;
|
||||
|
|
@ -167,17 +177,25 @@ MEMO: fixnum-coercion ( flags -- nodes )
|
|||
[ drop fixnum <class-info> ] change-at
|
||||
] when ;
|
||||
|
||||
: like->fixnum? ( #call -- ? )
|
||||
word>> { >fixnum bignum>fixnum float>fixnum } memq? ;
|
||||
|
||||
: like->integer? ( #call -- ? )
|
||||
word>> { >integer >bignum fixnum>bignum } memq? ;
|
||||
|
||||
M: #call optimize-modular-arithmetic*
|
||||
dup word>> {
|
||||
{ [ dup { >fixnum bignum>fixnum float>fixnum } memq? ] [ drop optimize->fixnum ] }
|
||||
{ [ dup \ >integer eq? ] [ drop optimize->integer ] }
|
||||
{ [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
|
||||
{ [ dup "low-order" word-prop ] [ drop optimize-low-order-op ] }
|
||||
[ drop ]
|
||||
{
|
||||
{ [ dup like->fixnum? ] [ optimize->fixnum ] }
|
||||
{ [ dup like->integer? ] [ optimize->integer ] }
|
||||
{ [ dup modular-word? ] [ optimize-modular-op ] }
|
||||
{ [ dup low-order-word? ] [ optimize-low-order-op ] }
|
||||
[ ]
|
||||
} cond ;
|
||||
|
||||
M: node optimize-modular-arithmetic* ;
|
||||
|
||||
: optimize-modular-arithmetic ( nodes -- nodes' )
|
||||
dup compute-modular-candidates compute-modular-values
|
||||
[ optimize-modular-arithmetic* ] map-nodes ;
|
||||
modular-values get assoc-empty? [
|
||||
[ optimize-modular-arithmetic* ] map-nodes
|
||||
] unless ;
|
||||
|
|
|
|||
|
|
@ -82,6 +82,8 @@ IN: compiler.tree.propagation.tests
|
|||
|
||||
[ bignum ] [ [ { bignum bignum } declare bitxor ] final-math-class ] unit-test
|
||||
|
||||
[ bignum ] [ [ { integer } declare 123 >bignum bitand ] final-math-class ] unit-test
|
||||
|
||||
[ float ] [ [ { float float } declare mod ] final-math-class ] unit-test
|
||||
|
||||
[ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test
|
||||
|
|
|
|||
|
|
@ -38,6 +38,12 @@ IN: compiler.tree.propagation.transforms
|
|||
in-d>> rem-custom-inlining
|
||||
] "custom-inlining" set-word-prop
|
||||
|
||||
: positive-fixnum? ( obj -- ? )
|
||||
{ [ fixnum? ] [ 0 >= ] } 1&& ;
|
||||
|
||||
: simplify-bitand? ( value -- ? )
|
||||
value-info literal>> positive-fixnum? ;
|
||||
|
||||
{
|
||||
bitand-integer-integer
|
||||
bitand-integer-fixnum
|
||||
|
|
@ -45,10 +51,17 @@ IN: compiler.tree.propagation.transforms
|
|||
bitand
|
||||
} [
|
||||
[
|
||||
in-d>> second value-info >literal< [
|
||||
0 most-positive-fixnum between?
|
||||
[ [ >fixnum ] bi@ fixnum-bitand ] f ?
|
||||
] when
|
||||
{
|
||||
{
|
||||
[ dup in-d>> first simplify-bitand? ]
|
||||
[ drop [ >fixnum fixnum-bitand ] ]
|
||||
}
|
||||
{
|
||||
[ dup in-d>> second simplify-bitand? ]
|
||||
[ drop [ [ >fixnum ] dip fixnum-bitand ] ]
|
||||
}
|
||||
[ drop f ]
|
||||
} cond
|
||||
] "custom-inlining" set-word-prop
|
||||
] each
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2004, 2006 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.private ;
|
||||
IN: math.floats.private
|
||||
|
|
@ -28,3 +28,37 @@ M: float /i float/f >integer ; inline
|
|||
M: float mod float-mod ; inline
|
||||
|
||||
M: real abs dup 0 < [ neg ] when ; inline
|
||||
|
||||
M: float fp-special?
|
||||
double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
|
||||
|
||||
M: float fp-nan-payload
|
||||
double>bits 52 2^ 1 - bitand ; inline
|
||||
|
||||
M: float fp-nan?
|
||||
dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-qnan?
|
||||
dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? not ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-snan?
|
||||
dup fp-nan? [ fp-nan-payload 51 2^ bitand zero? ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-infinity?
|
||||
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
|
||||
|
||||
M: float next-float ( m -- n )
|
||||
double>bits
|
||||
dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
|
||||
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
|
||||
1 + bits>double ! positive
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
M: float prev-float ( m -- n )
|
||||
double>bits
|
||||
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
|
||||
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
|
||||
1 - bits>double ! positive non-zero
|
||||
] if
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -97,55 +97,18 @@ GENERIC: fp-snan? ( x -- ? )
|
|||
GENERIC: fp-infinity? ( x -- ? )
|
||||
GENERIC: fp-nan-payload ( x -- bits )
|
||||
|
||||
M: object fp-special?
|
||||
drop f ; inline
|
||||
M: object fp-nan?
|
||||
drop f ; inline
|
||||
M: object fp-qnan?
|
||||
drop f ; inline
|
||||
M: object fp-snan?
|
||||
drop f ; inline
|
||||
M: object fp-infinity?
|
||||
drop f ; inline
|
||||
M: object fp-nan-payload
|
||||
drop f ; inline
|
||||
|
||||
M: float fp-special?
|
||||
double>bits -52 shift HEX: 7ff [ bitand ] keep = ; inline
|
||||
|
||||
M: float fp-nan-payload
|
||||
double>bits HEX: fffffffffffff bitand ; inline
|
||||
|
||||
M: float fp-nan?
|
||||
dup fp-special? [ fp-nan-payload zero? not ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-qnan?
|
||||
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? not ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-snan?
|
||||
dup fp-nan? [ fp-nan-payload HEX: 8000000000000 bitand zero? ] [ drop f ] if ; inline
|
||||
|
||||
M: float fp-infinity?
|
||||
dup fp-special? [ fp-nan-payload zero? ] [ drop f ] if ; inline
|
||||
M: object fp-special? drop f ; inline
|
||||
M: object fp-nan? drop f ; inline
|
||||
M: object fp-qnan? drop f ; inline
|
||||
M: object fp-snan? drop f ; inline
|
||||
M: object fp-infinity? drop f ; inline
|
||||
M: object fp-nan-payload drop f ; inline
|
||||
|
||||
: <fp-nan> ( payload -- nan )
|
||||
HEX: 7ff0000000000000 bitor bits>double ; inline
|
||||
|
||||
: next-float ( m -- n )
|
||||
double>bits
|
||||
dup -0.0 double>bits > [ 1 - bits>double ] [ ! negative non-zero
|
||||
dup -0.0 double>bits = [ drop 0.0 ] [ ! negative zero
|
||||
1 + bits>double ! positive
|
||||
] if
|
||||
] if ; inline
|
||||
|
||||
: prev-float ( m -- n )
|
||||
double>bits
|
||||
dup -0.0 double>bits >= [ 1 + bits>double ] [ ! negative
|
||||
dup 0.0 double>bits = [ drop -0.0 ] [ ! positive zero
|
||||
1 - bits>double ! positive non-zero
|
||||
] if
|
||||
] if ; inline
|
||||
GENERIC: next-float ( m -- n )
|
||||
GENERIC: prev-float ( m -- n )
|
||||
|
||||
: next-power-of-2 ( m -- n )
|
||||
dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
|
||||
|
|
|
|||
Loading…
Reference in New Issue