diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index f57682cc89..a4eb4c3d3a 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -4,7 +4,6 @@ - what if retain stack is full - ie, inside retain stack overflow handler, don't cons? - os-windows.c error_message &co -- to_float, to_fixnum, to_bignum: don't cons - inline float allocation needs a gc check - alien invoke, callback need a gc check - relocation should not cons at all diff --git a/library/bootstrap/primitives.factor b/library/bootstrap/primitives.factor index ee6c0a0578..2bd6913c3f 100644 --- a/library/bootstrap/primitives.factor +++ b/library/bootstrap/primitives.factor @@ -43,9 +43,12 @@ call { "dispatch" "kernel-internals" } { "rehash-string" "strings" } { "string>sbuf" "strings" } - { ">fixnum" "math" } - { ">bignum" "math" } - { ">float" "math" } + { "bignum>fixnum" "math-internals" } + { "float>fixnum" "math-internals" } + { "fixnum>bignum" "math-internals" } + { "float>bignum" "math-internals" } + { "fixnum>float" "math-internals" } + { "bignum>float" "math-internals" } { "(fraction>)" "math-internals" } { "string>float" "math-internals" } { "float>string" "math-internals" } @@ -240,11 +243,11 @@ num-types f builtins set "fixnum?" "math" create t "inline" set-word-prop "fixnum" "math" create 0 "fixnum?" "math" create { } define-builtin -"fixnum" "math" create ">fixnum" "math" lookup unit "coercer" set-word-prop +"fixnum" "math" create ">fixnum" "math" create unit "coercer" set-word-prop "bignum?" "math" create t "inline" set-word-prop "bignum" "math" create 1 "bignum?" "math" create { } define-builtin -"bignum" "math" create ">bignum" "math" lookup unit "coercer" set-word-prop +"bignum" "math" create ">bignum" "math" create unit "coercer" set-word-prop "word?" "words" create t "inline" set-word-prop "word" "words" create 2 "word?" "words" create @@ -297,7 +300,7 @@ num-types f builtins set "float?" "math" create t "inline" set-word-prop "float" "math" create 5 "float?" "math" create { } define-builtin -"float" "math" create ">float" "math" lookup unit "coercer" set-word-prop +"float" "math" create ">float" "math" create unit "coercer" set-word-prop "complex?" "math" create t "inline" set-word-prop "complex" "math" create 6 "complex?" "math" create diff --git a/library/compiler/alien/aliens.facts b/library/compiler/alien/aliens.facts index a6f6eb630d..a9ca242f05 100644 --- a/library/compiler/alien/aliens.facts +++ b/library/compiler/alien/aliens.facts @@ -1,5 +1,5 @@ IN: alien -USING: help ; +USING: arrays help ; HELP: alien { $class-description "The class of alien pointers. See " { $link "syntax-aliens" } " for syntax and " { $link "c-objects" } " for general information." } ; @@ -24,7 +24,7 @@ $terpri HELP: alien-address ( c-ptr -- addr ) { $values { "c-ptr" "an alien or " { $link f } } { "addr" "a non-negative integer" } } { $description "Outputs the address of an alien." } -{ $note "Taking the address of a " { $link byte-array } " is explicitly prohibited since byte arrays can be moved by the garbage collector between the time the address is taken, and when it is accessed. If you need to pass pointers to C functions which will persist across alien calls, you must allocate unmanaged memory instead. See " { $link "malloc" } "." } ; +{ $notes "Taking the address of a " { $link byte-array } " is explicitly prohibited since byte arrays can be moved by the garbage collector between the time the address is taken, and when it is accessed. If you need to pass pointers to C functions which will persist across alien calls, you must allocate unmanaged memory instead. See " { $link "malloc" } "." } ; HELP: { $values { "address" "a non-negative integer" } { "alien" "a new alien address" } } diff --git a/library/compiler/inference/known-words.factor b/library/compiler/inference/known-words.factor index c06733a862..388817b2b2 100644 --- a/library/compiler/inference/known-words.factor +++ b/library/compiler/inference/known-words.factor @@ -71,14 +71,23 @@ t over set-effect-terminated? \ string>sbuf { string } { sbuf } "infer-effect" set-word-prop -\ >fixnum { real } { fixnum } "infer-effect" set-word-prop -\ >fixnum t "foldable" set-word-prop +\ bignum>fixnum { bignum } { fixnum } "infer-effect" set-word-prop +\ bignum>fixnum t "foldable" set-word-prop -\ >bignum { real } { bignum } "infer-effect" set-word-prop -\ >bignum t "foldable" set-word-prop +\ float>fixnum { float } { fixnum } "infer-effect" set-word-prop +\ bignum>fixnum t "foldable" set-word-prop -\ >float { real } { float } "infer-effect" set-word-prop -\ >float t "foldable" set-word-prop +\ fixnum>bignum { fixnum } { bignum } "infer-effect" set-word-prop +\ fixnum>bignum t "foldable" set-word-prop + +\ float>bignum { float } { bignum } "infer-effect" set-word-prop +\ float>bignum t "foldable" set-word-prop + +\ fixnum>float { fixnum } { float } "infer-effect" set-word-prop +\ fixnum>float t "foldable" set-word-prop + +\ bignum>float { bignum } { float } "infer-effect" set-word-prop +\ bignum>float t "foldable" set-word-prop \ (fraction>) { integer integer } { rational } "infer-effect" set-word-prop \ (fraction>) t "foldable" set-word-prop diff --git a/library/math/constants.factor b/library/math/constants.factor index 4a7e71df1e..8b002d5ea4 100644 --- a/library/math/constants.factor +++ b/library/math/constants.factor @@ -26,3 +26,7 @@ IN: math : most-positive-fixnum ( -- n ) first-bignum 1- ; : most-negative-fixnum ( -- n ) first-bignum neg ; + +M: float >integer + dup most-negative-fixnum most-positive-fixnum between? + [ >fixnum ] [ >bignum ] if ; diff --git a/library/math/float.factor b/library/math/float.factor index b1ac639cb8..4069587d17 100644 --- a/library/math/float.factor +++ b/library/math/float.factor @@ -23,6 +23,10 @@ M: real <=> - ; M: float zero? dup 0.0 float= swap -0.0 float= or ; +M: float >fixnum float>fixnum ; +M: float >bignum float>bignum ; +M: float >float ; + M: float < float< ; M: float <= float<= ; M: float > float> ; diff --git a/library/math/integer.factor b/library/math/integer.factor index 78646cd3f0..3b943c6a29 100644 --- a/library/math/integer.factor +++ b/library/math/integer.factor @@ -52,6 +52,12 @@ M: integer / 2dup gcd nip tuck /i >r /i r> fraction> ] if ; +M: integer >integer ; + +M: fixnum >fixnum ; +M: fixnum >bignum fixnum>bignum ; +M: fixnum >float fixnum>float ; + M: fixnum number= eq? ; M: fixnum < fixnum< ; @@ -75,6 +81,10 @@ M: fixnum shift >fixnum fixnum-shift ; M: fixnum bitnot fixnum-bitnot ; +M: bignum >fixnum bignum>fixnum ; +M: bignum >bignum ; +M: bignum >float bignum>float ; + M: bignum number= bignum= ; M: bignum < bignum< ; M: bignum <= bignum<= ; diff --git a/library/math/math.factor b/library/math/math.factor index 8854fc8f7b..9c83f05310 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -3,6 +3,11 @@ IN: math USING: errors generic kernel math-internals ; +GENERIC: >integer ( x -- y ) foldable +GENERIC: >fixnum ( x -- y ) foldable +GENERIC: >bignum ( x -- y ) foldable +GENERIC: >float ( x -- y ) foldable + G: number= ( x y -- ? ) math-combination ; foldable M: object number= 2drop f ; diff --git a/library/math/ratio.factor b/library/math/ratio.factor index 31cdec796a..ed2d6f1078 100644 --- a/library/math/ratio.factor +++ b/library/math/ratio.factor @@ -1,5 +1,5 @@ -! Copyright (C) 2004, 2005 Slava Pestov. -! See http://factor.sf.net/license.txt for BSD license. +! Copyright (C) 2004, 2006 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. IN: math USING: generic kernel kernel-internals math math-internals ; @@ -25,6 +25,12 @@ M: ratio number= : ratio+d ( a/b c/d -- b*d ) denominator swap denominator * ; inline +M: ratio >integer >fraction /i ; +M: ratio >float >fraction /f ; + +M: ratio >fixnum >integer >fixnum ; +M: ratio >bignum >integer >bignum ; + M: ratio < scale < ; M: ratio <= scale <= ; M: ratio > scale > ; diff --git a/vm/factor.h b/vm/factor.h index 3e4c167511..2277827499 100644 --- a/vm/factor.h +++ b/vm/factor.h @@ -21,8 +21,8 @@ #include "bignumint.h" #include "bignum.h" #include "data_gc.h" -#include "math.h" #include "types.h" +#include "math.h" #include "io.h" #include "code_gc.h" #include "compiler.h" diff --git a/vm/math.c b/vm/math.c index fed74ae92a..3bcd8d41f9 100644 --- a/vm/math.c +++ b/vm/math.c @@ -4,41 +4,46 @@ F_FIXNUM to_fixnum(CELL tagged) { - F_RATIO* r; - F_ARRAY* x; - F_ARRAY* y; - F_FLOAT* f; - switch(TAG(tagged)) { case FIXNUM_TYPE: return untag_fixnum_fast(tagged); case BIGNUM_TYPE: - return (F_FIXNUM)s48_bignum_to_fixnum((F_ARRAY*)UNTAG(tagged)); - case RATIO_TYPE: - r = (F_RATIO*)UNTAG(tagged); - x = to_bignum(r->numerator); - y = to_bignum(r->denominator); - return to_fixnum(tag_bignum(s48_bignum_quotient(x,y))); - case FLOAT_TYPE: - f = (F_FLOAT*)UNTAG(tagged); - return (F_FIXNUM)f->n; + return bignum_to_fixnum(tagged); default: type_error(FIXNUM_TYPE,tagged); return -1; /* can't happen */ } } -void primitive_to_fixnum(void) +CELL to_cell(CELL x) { - drepl(tag_fixnum(to_fixnum(dpeek()))); + switch(type_of(x)) + { + case FIXNUM_TYPE: + return untag_fixnum_fast(x); + case BIGNUM_TYPE: + return s48_bignum_to_fixnum(untag_bignum_fast(x)); + default: + type_error(BIGNUM_TYPE,x); + return 0; + } +} + +void primitive_bignum_to_fixnum(void) +{ + drepl(tag_fixnum(bignum_to_fixnum(dpeek()))); +} + +void primitive_float_to_fixnum(void) +{ + drepl(tag_fixnum(float_to_fixnum(dpeek()))); } #define POP_FIXNUMS(x,y) \ - F_FIXNUM x, y; \ - y = untag_fixnum_fast(dpop()); \ - x = untag_fixnum_fast(dpop()); - + F_FIXNUM y = untag_fixnum_fast(dpop()); \ + F_FIXNUM x = untag_fixnum_fast(dpop()); + /* The fixnum arithmetic operations defined in C are relatively slow. The Factor compiler has optimized assembly intrinsics for all these operations. */ @@ -222,51 +227,14 @@ INT_DEFUNBOX(unbox_unsigned_1, unsigned char) INT_DEFUNBOX(unbox_unsigned_2, unsigned short) /* Bignums */ - -CELL to_cell(CELL x) +void primitive_fixnum_to_bignum(void) { - switch(type_of(x)) - { - case FIXNUM_TYPE: - return untag_fixnum_fast(x); - case BIGNUM_TYPE: - return s48_bignum_to_fixnum(untag_bignum_fast(x)); - default: - type_error(BIGNUM_TYPE,x); - return 0; - } + drepl(tag_bignum(fixnum_to_bignum(dpeek()))); } -F_ARRAY* to_bignum(CELL tagged) +void primitive_float_to_bignum(void) { - F_RATIO* r; - F_ARRAY* x; - F_ARRAY* y; - F_FLOAT* f; - - switch(type_of(tagged)) - { - case FIXNUM_TYPE: - return s48_fixnum_to_bignum(untag_fixnum_fast(tagged)); - case BIGNUM_TYPE: - return (F_ARRAY*)UNTAG(tagged); - case RATIO_TYPE: - r = (F_RATIO*)UNTAG(tagged); - x = to_bignum(r->numerator); - y = to_bignum(r->denominator); - return s48_bignum_quotient(x,y); - case FLOAT_TYPE: - f = (F_FLOAT*)UNTAG(tagged); - return s48_double_to_bignum(f->n); - default: - type_error(BIGNUM_TYPE,tagged); - return NULL; /* can't happen */ - } -} - -void primitive_to_bignum(void) -{ - drepl(tag_bignum(to_bignum(dpeek()))); + drepl(tag_bignum(fixnum_to_bignum(dpeek()))); } #define POP_BIGNUMS(x,y) \ @@ -427,7 +395,7 @@ F_FIXNUM unbox_unsigned_cell(void) void box_signed_4(s32 n) { - dpush(tag_bignum(s48_long_to_bignum(n))); + dpush(allot_integer(n)); } s32 unbox_signed_4(void) @@ -437,7 +405,7 @@ s32 unbox_signed_4(void) void box_unsigned_4(u32 n) { - dpush(tag_bignum(s48_ulong_to_bignum(n))); + dpush(allot_cell(n)); } u32 unbox_unsigned_4(void) @@ -447,22 +415,50 @@ u32 unbox_unsigned_4(void) void box_signed_8(s64 n) { - dpush(tag_bignum(s48_long_long_to_bignum(n))); + if(n < FIXNUM_MIN || n > FIXNUM_MAX) + dpush(tag_bignum(s48_long_long_to_bignum(n))); + else + dpush(tag_fixnum(n)); } s64 unbox_signed_8(void) { - return s48_bignum_to_long_long(to_bignum(dpop())); + CELL obj = dpop(); + + switch(type_of(obj)) + { + case FIXNUM_TYPE: + return untag_fixnum_fast(obj); + case BIGNUM_TYPE: + return s48_bignum_to_long_long(untag_array_fast(obj)); + default: + type_error(BIGNUM_TYPE,obj); + return -1; + } } void box_unsigned_8(u64 n) { - dpush(tag_bignum(s48_ulong_long_to_bignum(n))); + if(n > FIXNUM_MAX) + dpush(tag_bignum(s48_ulong_long_to_bignum(n))); + else + dpush(tag_fixnum(n)); } u64 unbox_unsigned_8(void) { - return s48_bignum_to_ulong_long(to_bignum(dpop())); + CELL obj = dpop(); + + switch(type_of(obj)) + { + case FIXNUM_TYPE: + return untag_fixnum_fast(obj); + case BIGNUM_TYPE: + return s48_bignum_to_ulong_long(untag_array_fast(obj)); + default: + type_error(BIGNUM_TYPE,obj); + return -1; + } } /* Ratios */ @@ -478,35 +474,14 @@ void primitive_from_fraction(void) } /* Floats */ - -double to_float(CELL tagged) +void primitive_fixnum_to_float(void) { - F_RATIO* r; - double x; - double y; - - switch(TAG(tagged)) - { - case FIXNUM_TYPE: - return (double)untag_fixnum_fast(tagged); - case BIGNUM_TYPE: - return s48_bignum_to_double((F_ARRAY*)UNTAG(tagged)); - case RATIO_TYPE: - r = (F_RATIO*)UNTAG(tagged); - x = to_float(r->numerator); - y = to_float(r->denominator); - return x / y; - case FLOAT_TYPE: - return ((F_FLOAT*)UNTAG(tagged))->n; - default: - type_error(FLOAT_TYPE,tagged); - return 0.0; /* can't happen */ - } + drepl(allot_float(fixnum_to_float(dpeek()))); } -void primitive_to_float(void) +void primitive_bignum_to_float(void) { - drepl(allot_float(to_float(dpeek()))); + drepl(allot_float(bignum_to_float(dpeek()))); } void primitive_str_to_float(void) @@ -634,7 +609,7 @@ void name (type flo) \ #define FLO_DEFUNBOX(name,type) \ type name(void) \ { \ - return to_float(dpop()); \ + return untag_float(dpop()); \ } FLO_DEFBOX(box_float,float) diff --git a/vm/math.h b/vm/math.h index 16321c3b7d..8f3886337a 100644 --- a/vm/math.h +++ b/vm/math.h @@ -11,8 +11,16 @@ INLINE CELL tag_fixnum(F_FIXNUM untagged) return RETAG(untagged << TAG_BITS,FIXNUM_TYPE); } +INLINE F_FIXNUM bignum_to_fixnum(CELL tagged) +{ + return (F_FIXNUM)s48_bignum_to_fixnum(untag_array_fast(tagged)); +} + F_FIXNUM to_fixnum(CELL tagged); -void primitive_to_fixnum(void); +CELL to_cell(CELL tagged); + +void primitive_bignum_to_fixnum(void); +void primitive_float_to_fixnum(void); void primitive_fixnum_add(void); void primitive_fixnum_subtract(void); @@ -55,9 +63,13 @@ INLINE CELL tag_bignum(F_ARRAY* bignum) return RETAG(bignum,BIGNUM_TYPE); } -CELL to_cell(CELL x); -F_ARRAY* to_bignum(CELL tagged); -void primitive_to_bignum(void); +INLINE F_ARRAY *fixnum_to_bignum(CELL tagged) +{ + return s48_fixnum_to_bignum(untag_fixnum_fast(tagged)); +} + +void primitive_fixnum_to_bignum(void); +void primitive_float_to_bignum(void); void primitive_bignum_eq(void); void primitive_bignum_add(void); void primitive_bignum_subtract(void); @@ -129,6 +141,12 @@ INLINE double untag_float_fast(CELL tagged) return ((F_FLOAT*)UNTAG(tagged))->n; } +INLINE double untag_float(CELL tagged) +{ + type_check(FLOAT_TYPE,tagged); + return untag_float_fast(tagged); +} + INLINE CELL allot_float(double n) { F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT)); @@ -136,8 +154,28 @@ INLINE CELL allot_float(double n) return RETAG(flo,FLOAT_TYPE); } -double to_float(CELL tagged); -void primitive_to_float(void); +INLINE F_FIXNUM float_to_fixnum(CELL tagged) +{ + return (F_FIXNUM)untag_float_fast(tagged); +} + +INLINE F_ARRAY *float_to_bignum(CELL tagged) +{ + return s48_double_to_bignum(untag_float_fast(tagged)); +} + +INLINE double fixnum_to_float(CELL tagged) +{ + return (double)untag_fixnum_fast(tagged); +} + +INLINE double bignum_to_float(CELL tagged) +{ + return s48_bignum_to_double(untag_array_fast(tagged)); +} + +void primitive_fixnum_to_float(void); +void primitive_bignum_to_float(void); void primitive_str_to_float(void); void primitive_float_to_str(void); void primitive_float_to_bits(void); diff --git a/vm/primitives.c b/vm/primitives.c index d645e532ed..7562a88e2b 100644 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -10,9 +10,12 @@ void* primitives[] = { primitive_dispatch, primitive_rehash_string, primitive_string_to_sbuf, - primitive_to_fixnum, - primitive_to_bignum, - primitive_to_float, + primitive_bignum_to_fixnum, + primitive_float_to_fixnum, + primitive_fixnum_to_bignum, + primitive_float_to_bignum, + primitive_fixnum_to_float, + primitive_bignum_to_float, primitive_from_fraction, primitive_str_to_float, primitive_float_to_str, diff --git a/vm/stack.h b/vm/stack.h index 34f7c50ec0..f4a32e354f 100644 --- a/vm/stack.h +++ b/vm/stack.h @@ -21,11 +21,6 @@ INLINE CELL dpeek(void) return get(ds); } -INLINE CELL dpeek2(void) -{ - return get(ds - CELLS); -} - INLINE CELL cpop(void) { CELL value = get(cs); diff --git a/vm/types.h b/vm/types.h index 08b9084e7d..6cf001055f 100644 --- a/vm/types.h +++ b/vm/types.h @@ -47,7 +47,7 @@ void primitive_become(void); INLINE CELL array_capacity(F_ARRAY* array) { - return untag_fixnum_fast(array->capacity); + return array->capacity >> TAG_BITS; } INLINE F_VECTOR* untag_vector(CELL tagged) @@ -75,7 +75,7 @@ INLINE F_STRING* untag_string(CELL tagged) INLINE CELL string_capacity(F_STRING* str) { - return untag_fixnum_fast(str->length); + return str->length >> TAG_BITS; } INLINE CELL string_size(CELL size)