Merge branch 'master' of git://factorcode.org/git/factor

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

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

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

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

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
 

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

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