Merge git://github.com/littledan/Factor into littledan

basis/compiler/tree/propagation/propagation-tests.factor

@@ -8,7 +8,7 @@ layouts compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker slots.private words
 hashtables classes assocs locals specialized-arrays system
 sorting math.libm math.floats.private math.integers.private
-math.intervals quotations effects alien alien.data ;
+math.intervals quotations effects alien alien.data sets ;
 FROM: math => float ;
 SPECIALIZED-ARRAY: double
 SPECIALIZED-ARRAY: void*
@@ -952,3 +952,13 @@ M: tuple-with-read-only-slot clone
 
 ! Reduction
 [ 1 ] [ [ 4 <reversed> [ nth-unsafe ] [ ] unless ] final-info length ] unit-test
+
+! Optimization on bit?
+[ t ] [ [ 3 bit? ] { bit? fixnum-bit? } inlined? ] unit-test
+[ f ] [ [ 500 bit? ] { bit? fixnum-bit? } inlined? ] unit-test
+
+[ t ] [ [ { 1 } intersect ] { intersect } inlined? ] unit-test
+[ f ] [ [ { 1 } swap intersect ] { intersect } inlined? ] unit-test ! We could do this
+
+[ t ] [ [ { 1 } diff ] { diff } inlined? ] unit-test
+[ f ] [ [ { 1 } swap diff ] { diff } inlined? ] unit-test ! We could do this

basis/compiler/tree/propagation/transforms/transforms.factor

@@ -284,6 +284,15 @@ CONSTANT: lookup-table-at-max 256
 
 \ intersect [ intersect-quot ] 1 define-partial-eval
 
+: fixnum-bits ( -- n )
+    cell-bits tag-bits get - ;
+
+: bit-quot ( #call -- quot/f )
+    in-d>> second value-info interval>> 0 fixnum-bits [a,b] interval-subset?
+    [ [ >fixnum ] dip fixnum-bit? ] f ? ;
+
+\ bit? [ bit-quot ] "custom-inlining" set-word-prop
+
 ! Speeds up sum-file, sort and reverse-complement benchmarks by
 ! compiling decoder-readln better
 \ push [

core/math/integers/integers.factor

@@ -58,7 +58,10 @@ M: fixnum shift >fixnum fixnum-shift ; inline
 
 M: fixnum bitnot fixnum-bitnot ; inline
 
-M: fixnum bit? neg shift 1 bitand 0 > ; inline
+: fixnum-bit? ( n m -- b )
+    neg shift 1 bitand 0 > ; inline
+
+M: fixnum bit? fixnum-bit? ; inline
 
 : fixnum-log2 ( x -- n )
     0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ;

extra/benchmark/nsieve-bits/nsieve-bits.factor

@@ -1,5 +1,5 @@
 USING: math math.parser sequences sequences.private kernel
-bit-arrays make io ;
+bit-arrays make io math.ranges multiline fry locals ;
 IN: benchmark.nsieve-bits
 
 : clear-flags ( step i seq -- )
@@ -13,23 +13,24 @@ IN: benchmark.nsieve-bits
     2dup length < [
         2dup nth-unsafe [
             over dup 2 * pick clear-flags
-            rot 1 + -rot ! increment count
+            [ 1 + ] 2dip ! increment count
         ] when [ 1 + ] dip (nsieve-bits)
     ] [
         2drop
     ] if ; inline recursive
 
 : nsieve-bits ( m -- count )
-    0 2 rot 1 + <bit-array> dup set-bits (nsieve-bits) ;
+    [ 0 2 ] dip 1 + <bit-array> dup set-bits (nsieve-bits) ;
 
 : nsieve-bits. ( m -- )
     [ "Primes up to " % dup # " " % nsieve-bits # ] "" make
-    print ;
+    print ; inline
 
 : nsieve-bits-main ( n -- )
-    dup 2^ 10000 * nsieve-bits.
+    [ 2^ 10000 * nsieve-bits. ] 
-    dup 1 - 2^ 10000 * nsieve-bits.
+    [ 1 - 2^ 10000 * nsieve-bits. ]
-    2 - 2^ 10000 * nsieve-bits. ;
+    [ 2 - 2^ 10000 * nsieve-bits. ]
+    tri ;
 
 : nsieve-bits-main* ( -- ) 11 nsieve-bits-main ;
 

extra/benchmark/nsieve/nsieve.factor

@@ -13,22 +13,23 @@ IN: benchmark.nsieve
     2dup length < [
         2dup nth-unsafe [
             over dup 2 * pick clear-flags
-            rot 1 + -rot ! increment count
+            [ 1 + ] 2dip ! increment count
         ] when [ 1 + ] dip (nsieve)
     ] [
         2drop
     ] if ; inline recursive
 
 : nsieve ( m -- count )
-    0 2 rot 1 + t <array> (nsieve) ;
+    [ 0 2 ] dip 1 + t <array> (nsieve) ;
 
 : nsieve. ( m -- )
     [ "Primes up to " % dup # " " % nsieve # ] "" make print ;
 
 : nsieve-main ( n -- )
-    dup 2^ 10000 * nsieve.
+    [ 2^ 10000 * nsieve. ]
-    dup 1 - 2^ 10000 * nsieve.
+    [ 1 - 2^ 10000 * nsieve. ]
-    2 - 2^ 10000 * nsieve. ;
+    [ 2 - 2^ 10000 * nsieve. ]
+    tri ;
 
 : nsieve-main* ( -- ) 9 nsieve-main ;