Merge git://factorcode.org/git/factor

core/bit-arrays/bit-arrays.factor

@@ -6,16 +6,14 @@ IN: bit-arrays
 
 <PRIVATE
 
-: n>cell -5 shift 4 * ; inline
+: n>byte -3 shift ; inline
 
-: cell/bit ( n alien -- byte bit )
-    over n>cell alien-unsigned-4 swap 31 bitand ; inline
+: byte/bit ( n alien -- byte bit )
+    over n>byte alien-unsigned-1 swap 7 bitand ; inline
 
 : set-bit ( ? byte bit -- byte )
     2^ rot [ bitor ] [ bitnot bitand ] if ; inline
 
-: bits>bytes 7 + -3 shift ; inline
-
 : bits>cells 31 + -5 shift ; inline
 
 : (set-bits) ( bit-array n -- )
@@ -27,11 +25,13 @@ PRIVATE>
 
 M: bit-array length array-capacity ;
 
-M: bit-array nth-unsafe cell/bit bit? ;
+M: bit-array nth-unsafe
+    >r >fixnum r> byte/bit bit? ;
 
 M: bit-array set-nth-unsafe
-    [ cell/bit set-bit ] 2keep
-    swap n>cell set-alien-unsigned-4 ;
+    >r >fixnum r>
+    [ byte/bit set-bit ] 2keep
+    swap n>byte set-alien-unsigned-1 ;
 
 : clear-bits ( bit-array -- ) 0 (set-bits) ;
 

core/bootstrap/primitives.factor

@@ -441,6 +441,7 @@ builtins get num-tags get tail f union-class define-class
     { "fixnum-bitxor" "math.private" }
     { "fixnum-bitnot" "math.private" }
     { "fixnum-shift" "math.private" }
+    { "fixnum-shift-fast" "math.private" }
     { "fixnum<" "math.private" }
     { "fixnum<=" "math.private" }
     { "fixnum>" "math.private" }

core/compiler/test/intrinsics.factor

@@ -441,3 +441,15 @@ cell 8 = [
         ] keep 2 fixnum+fast
     ] compile-call
 ] unit-test
+
+[ 1 ] [
+    8 -3 [ fixnum-shift-fast ] compile-call
+] unit-test
+
+[ 2 ] [
+    16 -3 [ fixnum-shift-fast ] compile-call
+] unit-test
+
+[ 8 ] [
+    1 3 [ fixnum-shift-fast ] compile-call
+] unit-test

core/cpu/ppc/assembler/assembler.factor

@@ -126,6 +126,10 @@ words math.bitfields io.binary ;
 : (XOR) 316 x-form 31 insn ;
 : XOR 0 (XOR) ;  : XOR. 1 (XOR) ;
 
+: (NEG) 0 -rot 104 xo-form 31 insn ;
+: NEG 0 0 (NEG) ;  : NEG. 0 1 (NEG) ;
+: NEGO 1 0 (NEG) ; : NEGO. 1 1 (NEG) ;
+
 : CMPI d-form 11 insn ;
 : CMPLI d-form 10 insn ;
 

core/cpu/ppc/intrinsics/intrinsics.factor

@@ -166,15 +166,42 @@ IN: cpu.ppc.intrinsics
     }
 } define-intrinsics
 
-\ fixnum-shift [
-    "out" operand "x" operand "y" get neg SRAWI
-    ! Mask off low bits
-    "out" operand dup %untag
-] H{
-    { +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
-    { +scratch+ { { f "out" } } }
-    { +output+ { "out" } }
-} define-intrinsic
+: %untag-fixnums ( seq -- )
+    [ dup %untag-fixnum ] unique-operands ;
+
+\ fixnum-shift-fast {
+    {
+        [
+            "out" operand "x" operand "y" get neg SRAWI
+            ! Mask off low bits
+            "out" operand dup %untag
+        ] H{
+            { +input+ { { f "x" } { [ ] "y" } } }
+            { +scratch+ { { f "out" } } }
+            { +output+ { "out" } }
+        }
+    }
+    {
+        [
+            { "positive" "end" } [ define-label ] each
+            { "x" "y" } %untag-fixnums
+            0 "y" operand 0 CMPI
+            "positive" get BGE
+            "y" operand dup NEG
+            "out" operand "x" operand "y" operand SRAW
+            "end" get B
+            "positive" resolve-label
+            "out" operand "x" operand "y" operand SLW
+            "end" resolve-label
+            ! Mask off low bits
+            "out" operand dup %tag-fixnum
+        ] H{
+            { +input+ { { f "x" } { f "y" } } }
+            { +scratch+ { { f "out" } } }
+            { +output+ { "out" } }
+        }
+    }
+} define-intrinsics
 
 : generate-fixnum-mod
     #! PowerPC doesn't have a MOD instruction; so we compute
@@ -222,9 +249,6 @@ IN: cpu.ppc.intrinsics
     first2 define-fixnum-jump
 ] each
 
-: %untag-fixnums ( seq -- )
-    [ dup %untag-fixnum ] unique-operands ;
-
 : overflow-check ( insn1 insn2 -- )
     [
         >r 0 0 LI

core/cpu/x86/32/bootstrap.factor

@@ -12,5 +12,6 @@ IN: bootstrap.x86
 : stack-reg ESP ;
 : ds-reg ESI ;
 : fixnum>slot@ arg0 1 SAR ;
+: rex-length 0 ;
 
 "resource:core/cpu/x86/bootstrap.factor" run-file

core/cpu/x86/64/bootstrap.factor

@@ -12,5 +12,6 @@ IN: bootstrap.x86
 : stack-reg RSP ;
 : ds-reg R14 ;
 : fixnum>slot@ ;
+: rex-length 1 ;
 
 "resource:core/cpu/x86/bootstrap.factor" run-file

core/cpu/x86/assembler/assembler.factor

@@ -81,7 +81,7 @@ SYMBOL: XMM15 \ XMM15 15 128 define-register
 : n, >le % ; inline
 : 4, 4 n, ; inline
 : 2, 2 n, ; inline
-: cell, cell n, ; inline
+: cell, bootstrap-cell n, ; inline
 
 #! Extended AMD64 registers (R8-R15) return true.
 GENERIC: extended? ( op -- ? )

core/cpu/x86/bootstrap.factor

@@ -23,25 +23,27 @@ big-endian off
     temp-reg compiled-header-size ADD
     ! Jump to XT
     temp-reg JMP
-] rc-absolute-cell rt-literal 1 jit-profiling jit-define
+] rc-absolute-cell rt-literal 1 rex-length + jit-profiling jit-define
 
 [
+    temp-reg 0 MOV                             ! load XT
     stack-frame-size PUSH                      ! save stack frame size
-    0 PUSH                                     ! push XT
+    temp-reg PUSH                              ! push XT
     arg1 PUSH                                  ! alignment
-] rc-absolute-cell rt-label 6 jit-prolog jit-define
+] rc-absolute-cell rt-label 1 rex-length + jit-prolog jit-define
 
 [
     arg0 0 MOV                                 ! load literal
     arg0 dup [] MOV
     ds-reg bootstrap-cell ADD                  ! increment datastack pointer
     ds-reg [] arg0 MOV                         ! store literal on datastack
-] rc-absolute-cell rt-literal 1 jit-push-literal jit-define
+] rc-absolute-cell rt-literal 1 rex-length + jit-push-literal jit-define
 
 [
+    arg0 0 MOV                                 ! load XT
     arg1 stack-reg MOV                         ! pass callstack pointer as arg 2
-    (JMP) drop                                 ! go
-] rc-relative rt-primitive 3 jit-primitive jit-define
+    arg0 JMP                                   ! go
+] rc-absolute-cell rt-primitive 1 rex-length + jit-primitive jit-define
 
 [
     (JMP) drop
@@ -59,7 +61,7 @@ big-endian off
     arg0 arg1 [] CMOVNE                        ! load true branch if not equal
     arg0 arg1 bootstrap-cell [+] CMOVE         ! load false branch if equal
     arg0 quot-xt@ [+] JMP                      ! jump to quotation-xt
-] rc-absolute-cell rt-literal 1 jit-if-jump jit-define
+] rc-absolute-cell rt-literal 1 rex-length + jit-if-jump jit-define
 
 [
     arg1 0 MOV                                 ! load dispatch table
@@ -70,7 +72,7 @@ big-endian off
     arg0 arg1 ADD                              ! compute quotation location
     arg0 arg0 array-start [+] MOV              ! load quotation
     arg0 quot-xt@ [+] JMP                      ! execute branch
-] rc-absolute-cell rt-literal 1 jit-dispatch jit-define
+] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define
 
 [
     stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame

core/cpu/x86/intrinsics/intrinsics.factor

@@ -240,14 +240,30 @@ IN: cpu.x86.intrinsics
     }
 } define-intrinsics
 
-\ fixnum-shift [
-    "x" operand "y" get neg SAR
-    ! Mask off low bits
-    "x" operand %untag
-] H{
-    { +input+ { { f "x" } { [ -31 0 between? ] "y" } } }
-    { +output+ { "x" } }
-} define-intrinsic
+\ fixnum-shift-fast {
+    {
+        [
+            "y" operand NEG
+            "y" operand %untag-fixnum
+            "x" operand "y" operand SAR
+            ! Mask off low bits
+            "x" operand %untag
+        ] H{
+            { +input+ { { f "x" } { f "y" } } }
+            { +output+ { "x" } }
+            { +clobber+ { "y" } }
+        }
+    } {
+        [
+            "x" operand "y" get neg SAR
+            ! Mask off low bits
+            "x" operand %untag
+        ] H{
+            { +input+ { { f "x" } { [ ] "y" } } }
+            { +output+ { "x" } }
+        }
+    }
+} define-intrinsics
 
 : %untag-fixnums ( seq -- )
     [ %untag-fixnum ] unique-operands ;

core/inference/class/class-tests.factor

@@ -235,3 +235,28 @@ M: fixnum annotate-entry-test-1 drop ;
 [ t ] [
     [ 3 + = ] \ equal? inlined?
 ] unit-test
+
+[ t ] [
+    [ { fixnum fixnum } declare 7 bitand neg shift ]
+    \ shift inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum fixnum } declare 7 bitand neg shift ]
+    \ fixnum-shift inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum fixnum } declare 1 swap 7 bitand shift ]
+    \ fixnum-shift inlined?
+] unit-test
+
+[ t ] [
+    [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
+    \ shift inlined?
+] unit-test
+
+[ f ] [
+    [ { fixnum fixnum } declare 1 swap 31 bitand shift ]
+    \ fixnum-shift inlined?
+] unit-test

core/inference/known-words/known-words.factor

@@ -254,6 +254,9 @@ t over set-effect-terminated?
 \ fixnum-shift { fixnum fixnum } { integer } <effect> "inferred-effect" set-word-prop
 \ fixnum-shift make-foldable
 
+\ fixnum-shift-fast { fixnum fixnum } { fixnum } <effect> "inferred-effect" set-word-prop
+\ fixnum-shift-fast make-foldable
+
 \ bignum= { bignum bignum } { object } <effect> "inferred-effect" set-word-prop
 \ bignum= make-foldable
 

core/math/integers/integers-docs.factor

@@ -120,6 +120,11 @@ HELP: fixnum-shift ( x y -- z )
 { $description "Primitive version of " { $link shift } ". The result may overflow to a bignum." }
 { $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ;
 
+HELP: fixnum-shift-shift ( x y -- z )
+{ $values { "x" fixnum } { "y" fixnum } { "z" fixnum } }
+{ $description "Primitive version of " { $link shift } ". Unlike " { $link fixnum-shift } ", does not perform an overflow check, so the result may be incorrect." }
+{ $warning "This word does not perform type checking, and passing objects of the wrong type can crash the runtime. User code should call the generic word " { $link shift } " instead." } ;
+
 HELP: fixnum+fast ( x y -- z )
 { $values { "x" fixnum } { "y" fixnum } { "z" fixnum } }
 { $description "Primitive version of " { $link + } ". Unlike " { $link fixnum+ } ", does not perform an overflow check, so the result may be incorrect." }

core/math/integers/integers.factor

@@ -32,7 +32,7 @@ M: fixnum shift >fixnum fixnum-shift ;
 
 M: fixnum bitnot fixnum-bitnot ;
 
-M: fixnum bit? 2^ bitand 0 > ;
+M: fixnum bit? neg shift 1 bitand 0 > ;
 
 : (fixnum-log2) ( accum n -- accum )
     dup 1 number= [ drop ] [ >r 1+ r> 2/ (fixnum-log2) ] if ;

core/optimizer/math/math.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2007 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 IN: optimizer.math
 USING: alien arrays generic hashtables kernel assocs math
@@ -7,7 +7,7 @@ inference.class inference.dataflow vectors strings sbufs io
 namespaces assocs quotations math.intervals sequences.private
 combinators splitting layouts math.parser classes
 generic.math optimizer.pattern-match optimizer.backend
-optimizer.def-use generic.standard ;
+optimizer.def-use generic.standard system ;
 
 { + bignum+ float+ fixnum+fast } {
     { { number 0 } [ drop ] }
@@ -82,7 +82,7 @@ optimizer.def-use generic.standard ;
     { { @ @ } [ 2drop 0 ] }
 } define-identities
 
-{ shift fixnum-shift bignum-shift } {
+{ shift fixnum-shift fixnum-shift-fast bignum-shift } {
     { { 0 number } [ drop ] }
     { { number 0 } [ drop ] }
 } define-identities
@@ -196,7 +196,7 @@ optimizer.def-use generic.standard ;
     ] 2curry "output-classes" set-word-prop
 ] each
 
-{ fixnum-shift shift } [
+{ fixnum-shift fixnum-shift-fast shift } [
     [
         dup
         node-in-d second value-interval*
@@ -439,3 +439,28 @@ most-negative-fixnum most-positive-fixnum [a,b]
         [ splice-quot ] curry ,
     ] { } make 1array define-optimizers
 ] assoc-each
+
+: fixnum-shift-fast-pos? ( node -- ? )
+    #! Shifting 1 to the left won't overflow if the shift
+    #! count is small enough
+    dup dup node-in-d first node-literal 1 = [
+        dup node-in-d second node-interval
+        0 cell-bits tag-bits get - 2 - [a,b] interval-subset?
+    ] [ drop f ] if ;
+
+: fixnum-shift-fast-neg? ( node -- ? )
+    #! Shifting any number to the right won't overflow if the
+    #! shift count is small enough
+    dup node-in-d second node-interval
+    cell-bits 1- neg 0 [a,b] interval-subset? ;
+
+: fixnum-shift-fast? ( node -- ? )
+    dup fixnum-shift-fast-pos?
+    [ drop t ] [ fixnum-shift-fast-neg? ] if ;
+
+\ fixnum-shift {
+    {
+        [ dup fixnum-shift-fast? ]
+        [ [ fixnum-shift-fast ] splice-quot ]
+    }
+} define-optimizers

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

@@ -6,11 +6,11 @@ bit-arrays namespaces io ;
     2dup length >= [
         3drop
     ] [
-        f pick pick set-nth-unsafe >r over + r> clear-flags
+        f 2over set-nth-unsafe >r over + r> clear-flags
     ] if ; inline
 
 : (nsieve-bits) ( count i seq -- count )
-    2dup length <= [
+    2dup length < [
         2dup nth-unsafe [
             over dup 2 * pick clear-flags
             rot 1+ -rot ! increment count

extra/benchmark/nsieve/nsieve.factor

@@ -10,7 +10,7 @@ arrays namespaces io ;
     ] if ; inline
 
 : (nsieve) ( count i seq -- count )
-    2dup length <= [
+    2dup length < [
         2dup nth-unsafe [
             over dup 2 * pick clear-flags
             rot 1+ -rot ! increment count

vm/math.c

@@ -166,6 +166,12 @@ DEFINE_PRIMITIVE(fixnum_shift)
 		fixnum_to_bignum(x),y)));
 }
 
+DEFINE_PRIMITIVE(fixnum_shift_fast)
+{
+	POP_FIXNUMS(x,y)
+	dpush(tag_fixnum(y < 0 ? (x >> -y) : (x << y)));
+}
+
 DEFINE_PRIMITIVE(fixnum_less)
 {
 	POP_FIXNUMS(x,y)

vm/math.h

@@ -22,6 +22,7 @@ DECLARE_PRIMITIVE(fixnum_and);
 DECLARE_PRIMITIVE(fixnum_or);
 DECLARE_PRIMITIVE(fixnum_xor);
 DECLARE_PRIMITIVE(fixnum_shift);
+DECLARE_PRIMITIVE(fixnum_shift_fast);
 DECLARE_PRIMITIVE(fixnum_less);
 DECLARE_PRIMITIVE(fixnum_lesseq);
 DECLARE_PRIMITIVE(fixnum_greater);

vm/primitives.c

@@ -33,6 +33,7 @@ void *primitives[] = {
 	primitive_fixnum_xor,
 	primitive_fixnum_not,
 	primitive_fixnum_shift,
+	primitive_fixnum_shift_fast,
 	primitive_fixnum_less,
 	primitive_fixnum_lesseq,
 	primitive_fixnum_greater,