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

basis/compiler/tests/optimizer.factor

@@ -389,4 +389,10 @@ DEFER: loop-bbb
 
 [ f ] [ \ broken-declaration optimized? ] unit-test
 
-[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
+[ ] [ [ \ broken-declaration forget ] with-compilation-unit ] unit-test
+
+! Modular arithmetic bug
+: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
+
+[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
+[ -10 ] [ -10 modular-arithmetic-bug ] unit-test

basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor

@@ -98,13 +98,18 @@ TUPLE: declared-fixnum { x fixnum } ;
     ] { mod fixnum-mod } inlined?
 ] unit-test
 
-
 [ f ] [
     [
         256 mod
     ] { mod fixnum-mod } inlined?
 ] unit-test
 
+[ f ] [
+    [
+        >fixnum 256 mod
+    ] { mod fixnum-mod } inlined?
+] unit-test
+
 [ f ] [
     [
         dup 0 >= [ 256 mod ] when
@@ -128,3 +133,6 @@ TUPLE: declared-fixnum { x fixnum } ;
         { integer } declare [ 256 rem ] map
     ] { mod fixnum-mod rem } inlined?
 ] unit-test
+
+[ [ >fixnum 255 fixnum-bitand ] ]
+[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test

basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math math.partial-dispatch namespaces sequences sets
 accessors assocs words kernel memoize fry combinators
+combinators.short-circuit
 compiler.tree
 compiler.tree.combinators
 compiler.tree.def-use
@@ -69,6 +70,12 @@ GENERIC: optimize-modular-arithmetic* ( node -- nodes )
 : optimize->fixnum ( #call -- nodes )
     dup redundant->fixnum? [ drop f ] when ;
 
+: optimize->integer ( #call -- nodes )
+    dup out-d>> first actually-used-by dup length 1 = [
+        first node>> { [ #call? ] [ word>> \ >fixnum eq? ] } 1&&
+        [ drop { } ] when
+    ] [ drop ] if ;
+
 MEMO: fixnum-coercion ( flags -- nodes )
     [ [ ] [ >fixnum ] ? ] map '[ _ spread ] splice-quot ;
 
@@ -87,6 +94,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
 M: #call optimize-modular-arithmetic*
     dup word>> {
         { [ dup \ >fixnum eq? ] [ drop optimize->fixnum ] }
+        { [ dup \ >integer eq? ] [ drop optimize->integer ] }
         { [ dup "modular-arithmetic" word-prop ] [ drop optimize-modular-op ] }
         [ drop ]
     } cond ;

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -148,10 +148,6 @@ most-negative-fixnum most-positive-fixnum [a,b]
 comparison-ops
 [ dup '[ _ define-comparison-constraints ] each-derived-op ] each
 
-! generic-comparison-ops [
-!     dup specific-comparison define-comparison-constraints
-! ] each
-
 ! Remove redundant comparisons
 : fold-comparison ( info1 info2 word -- info )
     [ [ interval>> ] bi@ ] dip interval-comparison {
@@ -217,6 +213,8 @@ generic-comparison-ops [
     { >float float }
     { fixnum>float float }
     { bignum>float float }
+
+    { >integer integer }
 } [
     '[
         _
@@ -228,19 +226,26 @@ generic-comparison-ops [
     ] "outputs" set-word-prop
 ] assoc-each
 
+: rem-custom-inlining ( #call -- quot/f )
+    second value-info literal>> dup integer?
+    [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ;
+
 {
     mod-integer-integer
     mod-integer-fixnum
     mod-fixnum-integer
     fixnum-mod
-    rem
 } [
     [
-        in-d>> second value-info >literal<
-        [ dup integer? [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ] when
+        in-d>> dup first value-info interval>> [0,inf] interval-subset?
+        [ rem-custom-inlining ] [ drop f ] if
     ] "custom-inlining" set-word-prop
 ] each
 
+\ rem [
+    in-d>> rem-custom-inlining
+] "custom-inlining" set-word-prop
+
 {
     bitand-integer-integer
     bitand-integer-fixnum

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

@@ -690,4 +690,7 @@ TUPLE: littledan-2 { from read-only } { to read-only } ;
 ! Mutable tuples with circularity should not cause problems
 TUPLE: circle me ;
 
-[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
+[ ] [ circle new dup >>me 1quotation final-info drop ] unit-test
+
+! Joe found an oversight
+[ V{ integer } ] [ [ >integer ] final-classes ] unit-test

basis/math/intervals/intervals.factor

@@ -48,6 +48,8 @@ TUPLE: interval { from read-only } { to read-only } ;
 
 : (a,inf] ( a -- interval ) 1/0. (a,b] ; inline
 
+: [0,inf] ( -- interval ) 0 [a,inf] ; foldable
+
 : [-inf,inf] ( -- interval ) full-interval ; inline
 
 : compare-endpoints ( p1 p2 quot -- ? )
@@ -262,7 +264,7 @@ TUPLE: interval { from read-only } { to read-only } ;
 : interval-abs ( i1 -- i2 )
     {
         { [ dup empty-interval eq? ] [ ] }
-        { [ dup full-interval eq? ] [ drop 0 [a,inf] ] }
+        { [ dup full-interval eq? ] [ drop [0,inf] ] }
         { [ 0 over interval-contains? ] [ (interval-abs) { 0 t } suffix points>interval ] }
         [ (interval-abs) points>interval ]
     } cond ;
@@ -376,7 +378,7 @@ SYMBOL: incomparable
 : interval-log2 ( i1 -- i2 )
     {
         { empty-interval [ empty-interval ] }
-        { full-interval [ 0 [a,inf] ] }
+        { full-interval [ [0,inf] ] }
         [
             to>> first 1 max dup most-positive-fixnum >
             [ drop full-interval interval-log2 ]

vm/code_gc.cpp

@@ -303,7 +303,7 @@ cell heap_size(heap *heap)
 }
 
 /* Compute where each block is going to go, after compaction */
-	cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+cell compute_heap_forwarding(heap *heap, unordered_map<heap_block *,char *> &forwarding)
 {
 	heap_block *scan = first_block(heap);
 	char *address = (char *)first_block(heap);
@@ -324,7 +324,7 @@ cell heap_size(heap *heap)
 	return (cell)address - heap->seg->start;
 }
 
-	void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
+void compact_heap(heap *heap, unordered_map<heap_block *,char *> &forwarding)
 {
 	heap_block *scan = first_block(heap);
 

vm/cpu-x86.32.S

@@ -1,9 +1,5 @@
 #include "asm.h"
 
-/* Note that primitive word definitions are compiled with
-__attribute__((regparm 2), so the pointer to the word object is passed in EAX,
-and the callstack top is passed in EDX */
-
 #define ARG0 %eax
 #define ARG1 %edx
 #define STACK_REG %esp
@@ -59,9 +55,9 @@ DEF(bool,check_sse2,(void)):
 	mov %edx,%eax
 	ret
 
-DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
+DEF(void,primitive_inline_cache_miss,(void)):
 	mov (%esp),%ebx
-DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)):
+DEF(void,primitive_inline_cache_miss_tail,(void)):
 	sub $8,%esp
 	push %ebx
 	call MANGLE(inline_cache_miss)

vm/cpu-x86.64.S

@@ -72,9 +72,9 @@ DEF(void,set_callstack,(F_STACK_FRAME *to, F_STACK_FRAME *from, CELL length, voi
 	call *ARG3                         /* call memcpy */
 	ret                                /* return _with new stack_ */
 
-DEF(F_FASTCALL void,primitive_inline_cache_miss,(void)):
+DEF(void,primitive_inline_cache_miss,(void)):
 	mov (%rsp),%rbx
-DEF(F_FASTCALL void,primitive_inline_cache_miss_tail,(void)):
+DEF(void,primitive_inline_cache_miss_tail,(void)):
 	sub $STACK_PADDING,%rsp
 	mov %rbx,ARG0
 	call MANGLE(inline_cache_miss)