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

db4
Doug Coleman 2009-05-07 13:09:45 -05:00
commit 605068df93
9 changed files with 50 additions and 22 deletions

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -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 ]

View File

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

View File

@ -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)

View File

@ -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)