From f01f7ad6eb2ffe47f758837d71df8a527778a712 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Aug 2009 03:47:07 -0500 Subject: [PATCH 1/4] compiler.tree.propagation: bitand custom inlining was wrong if the second input was a bignum --- .../tree/propagation/propagation-tests.factor | 2 ++ .../propagation/transforms/transforms.factor | 21 +++++++++++++++---- 2 files changed, 19 insertions(+), 4 deletions(-) diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index f20afc77f3..511f87dd09 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -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 diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor index d6c107b74b..683c182903 100644 --- a/basis/compiler/tree/propagation/transforms/transforms.factor +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -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 From 9ef8f6c81df398cbed05a8efbf6dd106d0d41fe7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Aug 2009 03:47:45 -0500 Subject: [PATCH 2/4] compiler.tree.modular-arithmetic: eliminate >bignum calls where possible, convert fixnum-shift to fixnum-shift-fast if shift count is positive, don't run if there are no modular values --- .../modular-arithmetic-tests.factor | 36 +++++++++- .../modular-arithmetic.factor | 70 ++++++++++++------- 2 files changed, 78 insertions(+), 28 deletions(-) diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 7b972c5160..42e7f421bf 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -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 \ No newline at end of file diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index d97295d0f1..5dbc639430 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -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 ] 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 ; From a3631f18789a478258514b7243d9e0bb28ccfda5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Aug 2009 03:48:03 -0500 Subject: [PATCH 3/4] bootstrap.compiler: add -debug-compiler switch which loads compiler but doesn't compile any words --- basis/bootstrap/compiler/compiler.factor | 114 ++++++++++++----------- 1 file changed, 59 insertions(+), 55 deletions(-) diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor index a539e45661..e9187cc3b1 100755 --- a/basis/bootstrap/compiler/compiler.factor +++ b/basis/bootstrap/compiler/compiler.factor @@ -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 \ No newline at end of file From 79cdc4533942f35f0fd16843d7b5e8efe6b1809a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 20 Aug 2009 03:55:19 -0500 Subject: [PATCH 4/4] math: move float methods to math.floats --- core/math/floats/floats.factor | 36 ++++++++++++++++++++++- core/math/math.factor | 53 +++++----------------------------- 2 files changed, 43 insertions(+), 46 deletions(-) diff --git a/core/math/floats/floats.factor b/core/math/floats/floats.factor index 160b220173..661bccd88c 100644 --- a/core/math/floats/floats.factor +++ b/core/math/floats/floats.factor @@ -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 diff --git a/core/math/math.factor b/core/math/math.factor index 1213e13a1f..e6c34c112c 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -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 : ( 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