diff --git a/library/bootstrap/boot-stage2.factor b/library/bootstrap/boot-stage2.factor index eb605a9ec8..dba461a37a 100644 --- a/library/bootstrap/boot-stage2.factor +++ b/library/bootstrap/boot-stage2.factor @@ -42,6 +42,7 @@ USE: namespaces [ "/library/generic/generic.factor" "/library/generic/object.factor" + "/library/generic/null.factor" "/library/generic/builtin.factor" "/library/generic/predicate.factor" "/library/generic/union.factor" diff --git a/library/bootstrap/boot.factor b/library/bootstrap/boot.factor index 380948ced2..c16f80af3e 100644 --- a/library/bootstrap/boot.factor +++ b/library/bootstrap/boot.factor @@ -72,16 +72,15 @@ USE: hashtables "traits" [ "generic" ] search "delegate" [ "generic" ] search - "object" [ "generic" ] search vocabularies get [ "generic" off ] bind - reveal reveal reveal "/library/generic/generic.factor" parse-resource append, "/library/generic/object.factor" parse-resource append, + "/library/generic/null.factor" parse-resource append, "/library/generic/builtin.factor" parse-resource append, "/library/generic/predicate.factor" parse-resource append, "/library/generic/union.factor" parse-resource append, diff --git a/library/bootstrap/image.factor b/library/bootstrap/image.factor index ff4f01be7c..820c63283e 100644 --- a/library/bootstrap/image.factor +++ b/library/bootstrap/image.factor @@ -82,22 +82,15 @@ SYMBOL: boot-quot : tag ( cell -- tag ) tag-mask bitand ; : fixnum-tag BIN: 000 ; inline +: bignum-tag BIN: 001 ; inline : cons-tag BIN: 010 ; inline : object-tag BIN: 011 ; inline -: ratio-tag BIN: 100 ; inline -: complex-tag BIN: 101 ; inline : f-type 6 ; inline : t-type 7 ; inline : array-type 8 ; inline -: bignum-type 9 ; inline -: float-type 10 ; inline : vector-type 11 ; inline : string-type 12 ; inline -: sbuf-type 13 ; inline -: port-type 14 ; inline -: dll-type 15 ; inline -: alien-type 16 ; inline : word-type 17 ; inline : immediate ( x tag -- tagged ) swap tag-bits shift bitor ; @@ -155,8 +148,8 @@ M: fixnum ' ( n -- tagged ) fixnum-tag immediate ; M: bignum ' ( bignum -- tagged ) #! This can only emit 0, -1 and 1. - object-tag here-as >r - bignum-type >header emit + bignum-tag here-as >r + bignum-tag >header emit [ [[ 0 [ 1 0 ] ]] [[ -1 [ 2 1 1 ] ]] diff --git a/library/compiler/x86/assembler.factor b/library/compiler/x86/assembler.factor index 01e8f8d91c..16bc572e21 100644 --- a/library/compiler/x86/assembler.factor +++ b/library/compiler/x86/assembler.factor @@ -251,6 +251,10 @@ GENERIC: SUB ( dst src -- ) M: integer SUB HEX: 81 BIN: 101 immediate-8/32 ; M: operand SUB HEX: 29 2-operand ; +GENERIC: AND ( dst src -- ) +M: integer AND HEX: 81 BIN: 100 immediate-8/32 ; +M: operand AND HEX: 21 2-operand ; + : IMUL ( dst src -- ) HEX: 0f compile-byte HEX: af 2-operand ; diff --git a/library/compiler/x86/fixnum.factor b/library/compiler/x86/fixnum.factor index b8e341897b..08ae3d23b5 100644 --- a/library/compiler/x86/fixnum.factor +++ b/library/compiler/x86/fixnum.factor @@ -145,3 +145,22 @@ USE: math-internals ] "generator" set-word-property \ fixnum/mod [ \ fixnum/mod self ] "infer" set-word-property + +\ arithmetic-type [ + drop + ECX DS> + EAX [ ECX -4 ] MOV + EAX BIN: 111 AND + EDX [ ECX ] MOV + EDX BIN: 111 AND + EAX EDX CMP + 0 JE fixup >r + \ arithmetic-type compile-call + 0 JMP fixup + compiled-offset r> patch + EAX 3 SHL + PUSH-DS + compiled-offset swap patch +] "generator" set-word-property + +\ arithmetic-type [ \ arithmetic-type self ] "infer" set-word-property diff --git a/library/generic/builtin.factor b/library/generic/builtin.factor index 987f40996b..9d53bb2f14 100644 --- a/library/generic/builtin.factor +++ b/library/generic/builtin.factor @@ -54,10 +54,13 @@ builtin 50 "priority" set-word-property builtin [ 2drop t ] "class<" set-word-property : builtin-predicate ( type# symbol -- ) - over f type = [ + #! We call search here because we have to know if the symbol + #! is t or f, and cannot compare type numbers or symbol + #! identity during bootstrapping. + dup "f" [ "syntax" ] search = [ nip [ not ] "predicate" set-word-property ] [ - over t type = [ + dup "t" [ "syntax" ] search = [ nip [ ] "predicate" set-word-property ] [ dup predicate-word diff --git a/library/generic/generic.factor b/library/generic/generic.factor index fa3062bf72..abfe9ee63e 100644 --- a/library/generic/generic.factor +++ b/library/generic/generic.factor @@ -190,16 +190,8 @@ SYMBOL: object : class-and ( class class -- class ) #! Return a class that is a subclass of both, or raise an #! error if this is impossible. - over builtin-supertypes - over builtin-supertypes - intersection [ - nip lookup-union - ] [ - [ - word-name , " and " , word-name , - " do not intersect" , - ] make-string throw - ] ?ifte ; + swap builtin-supertypes swap builtin-supertypes + intersection lookup-union ; : define-promise ( class -- ) #! A promise is a word that has no effect during diff --git a/library/generic/null.factor b/library/generic/null.factor new file mode 100644 index 0000000000..d6c9f6c5d9 --- /dev/null +++ b/library/generic/null.factor @@ -0,0 +1,39 @@ +! :folding=indent:collapseFolds=1: + +! $Id$ +! +! Copyright (C) 2005 Slava Pestov. +! +! Redistribution and use in source and binary forms, with or without +! modification, are permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, +! this list of conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, +! this list of conditions and the following disclaimer in the documentation +! and/or other materials provided with the distribution. +! +! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, +! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, +! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; +! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR +! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +IN: generic +USE: kernel +USE: words + +! Null metaclass with no instances. +SYMBOL: null +null [ drop [ ] ] "builtin-supertypes" set-word-property +null [ 2drop 2drop ] "add-method" set-word-property +null [ drop f ] "predicate" set-word-property +null 100 "priority" set-word-property +null [ 2drop t ] "class<" set-word-property +null null define-class diff --git a/library/inference/branches.factor b/library/inference/branches.factor index d245b89c62..c54e1c07a8 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -154,19 +154,14 @@ SYMBOL: cloned ] extend ; : (infer-branches) ( branchlist -- list ) - #! The branchlist is a list of pairs: - #! [[ value typeprop ]] + #! The branchlist is a list of pairs: [[ value typeprop ]] #! value is either a literal or computed instance; typeprop #! is a pair [[ value class ]] indicating a type propagation #! for the given branch. [ [ - inferring-base-case get 0 > [ - [ - infer-branch , - ] [ - [ drop ] when - ] catch + branches-can-fail? [ + [ infer-branch , ] [ [ drop ] when ] catch ] [ infer-branch , ] ifte @@ -184,7 +179,7 @@ SYMBOL: cloned #! parameter is a vector. (infer-branches) dup unify-effects unify-dataflow ; -: (with-block) ( label quot -- ) +: (with-block) ( label quot -- node ) #! Call a quotation in a new namespace, and transfer #! inference state from the outer scope. swap >r [ @@ -192,8 +187,8 @@ SYMBOL: cloned call d-in get meta-d get meta-r get get-dataflow ] with-scope - r> swap #label dataflow, [ node-label set ] bind - meta-r set meta-d set d-in set ; + r> swap #label dataflow, [ node-label set ] extend >r + meta-r set meta-d set d-in set r> ; : boolean-value? ( value -- ? ) #! Return if the value's boolean valuation is known. @@ -208,7 +203,8 @@ SYMBOL: cloned value-class \ f = not ; : static-branch? ( value -- ? ) - boolean-value? branches-can-fail? not and ; + drop f ; +! boolean-value? branches-can-fail? not and ; : static-ifte ( true false -- ) #! If the branch taken is statically known, just infer @@ -217,7 +213,7 @@ SYMBOL: cloned gensym [ dup value-recursion recursive-state set literal-value infer-quot - ] (with-block) ; + ] (with-block) drop ; : dynamic-ifte ( true false -- ) #! If branch taken is computed, infer along both paths and diff --git a/library/inference/inference.factor b/library/inference/inference.factor index 3d47425787..076832d913 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -39,13 +39,13 @@ USE: hashtables USE: generic USE: prettyprint -: max-recursion 1 ; +: max-recursion 0 ; ! This variable takes a value from 0 up to max-recursion. SYMBOL: inferring-base-case : branches-can-fail? ( -- ? ) - inferring-base-case get max-recursion >= ; + inferring-base-case get max-recursion > ; ! Word properties that affect inference: ! - infer-effect -- must be set. controls number of inputs @@ -149,6 +149,10 @@ M: literal set-value-class ( class value -- ) #! After inference is finished, collect information. uncons >r (present-effect) r> (present-effect) 2list ; +: simple-effect ( [[ d-in meta-d ]] -- [[ in# out# ]] ) + #! After inference is finished, collect information. + uncons vector-length >r vector-length r> cons ; + : effect ( -- [[ d-in meta-d ]] ) d-in get meta-d get cons ; diff --git a/library/inference/stack.factor b/library/inference/stack.factor index 3179ddaf27..80fac97c55 100644 --- a/library/inference/stack.factor +++ b/library/inference/stack.factor @@ -48,7 +48,7 @@ USE: words #! Partially evaluate a word. f over dup "infer-effect" word-property - [ drop host-word ] with-dataflow ; + [ host-word ] with-dataflow ; \ drop [ \ drop partial-eval ] "infer" set-word-property \ dup [ \ dup partial-eval ] "infer" set-word-property diff --git a/library/inference/words.factor b/library/inference/words.factor index c06fc8d100..6af8a9336f 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -40,15 +40,15 @@ USE: hashtables USE: parser USE: prettyprint -: with-dataflow ( param op [ intypes outtypes ] quot -- ) +: with-dataflow ( param op [[ in# out# ]] quot -- ) #! Take input parameters, execute quotation, take output #! parameters, add node. The quotation is called with the #! stack effect. >r dup car ensure-d >r dataflow, r> r> rot - [ pick car swap dataflow-inputs ] keep - pick 2slip cdr car swap - dataflow-outputs ; inline + [ pick car swap [ length 0 node-inputs ] bind ] keep + pick >r >r nip call r> r> cdr car swap + [ length 0 node-outputs ] bind ; inline : consume-d ( typelist -- ) [ pop-d 2drop ] each ; @@ -57,6 +57,7 @@ USE: prettyprint [ push-d ] each ; : (consume/produce) ( param op effect ) + dup >r -rot r> [ unswons consume-d car produce-d ] with-dataflow ; : consume/produce ( word [ in-types out-types ] -- ) @@ -78,7 +79,7 @@ USE: prettyprint : no-effect ( word -- ) "Unknown stack effect: " swap word-name cat2 throw ; -: with-block ( word label quot -- ) +: with-block ( word label quot -- node ) #! Execute a quotation with the word on the stack, and add #! its dataflow contribution to a new block node in the IR. over [ @@ -91,7 +92,7 @@ USE: prettyprint : recursive? ( word -- ? ) dup word-parameter tree-contains? ; -: inline-compound ( word -- effect ) +: inline-compound ( word -- effect node ) #! Infer the stack effect of a compound word in the current #! inferencer instance. If the word in question is recursive #! we infer its stack effect inside a new block. @@ -102,7 +103,7 @@ USE: prettyprint #! instance. [ recursive-state get init-inference - dup dup inline-compound present-effect + dup dup inline-compound drop present-effect [ "infer-effect" set-word-property ] keep ] with-scope consume/produce ; @@ -111,7 +112,7 @@ GENERIC: (apply-word) M: compound (apply-word) ( word -- ) #! Infer a compound word's stack effect. dup "inline" word-property [ - inline-compound drop + inline-compound 2drop ] [ infer-compound ] ifte ; @@ -139,13 +140,6 @@ M: symbol (apply-word) ( word -- ) ] when ] when ; -: decompose ( x y -- [[ d-in meta-d ]] ) - #! Return a stack effect such that x*effect = y. - uncons >r swap uncons >r - over vector-length over vector-length - - swap vector-head nip - r> vector-append r> cons ; - : with-recursion ( quot -- ) [ inferring-base-case inc @@ -155,15 +149,14 @@ M: symbol (apply-word) ( word -- ) rethrow ] catch ; -: base-case ( word -- [[ d-in meta-d ]] ) +: base-case ( word label -- ) [ - [ - copy-inference - inline-compound - ] with-scope effect swap decompose - present-effect - >r [ #call-label ] [ #call ] ?ifte r> - (consume/produce) + over inline-compound [ + drop + [ #call-label ] [ #call ] ?ifte + node-op set + node-param set + ] bind ] with-recursion ; : no-base-case ( word -- ) @@ -177,11 +170,9 @@ M: symbol (apply-word) ( word -- ) drop no-base-case ] [ inferring-base-case get max-recursion = [ - over base-case + base-case ] [ - [ - drop inline-compound drop - ] with-recursion + [ drop inline-compound 2drop ] with-recursion ] ifte ] ifte ; @@ -204,12 +195,13 @@ M: symbol (apply-word) ( word -- ) drop pop-d dup value-recursion recursive-state set literal-value infer-quot - ] with-block ; + ] with-block drop ; \ call [ infer-call ] "infer" set-word-property ! These hacks will go away soon \ * [ [ number number ] [ number ] ] "infer-effect" set-word-property +\ - [ [ number number ] [ number ] ] "infer-effect" set-word-property \ undefined-method t "terminator" set-word-property \ not-a-number t "terminator" set-word-property diff --git a/library/kernel.factor b/library/kernel.factor index 57702518f2..fe37533502 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -71,9 +71,16 @@ M: object = eq? ; : xor ( a b -- a^b ) dup not swap ? ; inline IN: syntax -BUILTIN: f 6 + +! The canonical t is a heap-allocated dummy object. It is always +! the first in the image. BUILTIN: t 7 +! In the runtime, the canonical f is represented as a null +! pointer with tag 3. So +! f address . ==> 3 +BUILTIN: f 9 + IN: kernel UNION: boolean f t ; COMPLEMENT: general-t f diff --git a/library/math/math.factor b/library/math/math.factor index 9b713d4d5d..6e733352b2 100644 --- a/library/math/math.factor +++ b/library/math/math.factor @@ -2,7 +2,7 @@ ! $Id$ ! -! Copyright (C) 2003, 2004 Slava Pestov. +! Copyright (C) 2003, 2005 Slava Pestov. ! ! Redistribution and use in source and binary forms, with or without ! modification, are permitted provided that the following conditions are met: @@ -58,16 +58,16 @@ GENERIC: bitnot ( n -- n ) ! Math types BUILTIN: fixnum 0 -BUILTIN: bignum 9 +BUILTIN: bignum 1 UNION: integer fixnum bignum ; BUILTIN: ratio 4 UNION: rational integer ratio ; -BUILTIN: float 10 +BUILTIN: float 5 UNION: real rational float ; -BUILTIN: complex 5 +BUILTIN: complex 6 UNION: number real complex ; M: real hashcode ( n -- n ) >fixnum ; diff --git a/library/test/compiler/generic.factor b/library/test/compiler/generic.factor index 320d3a1016..0e7e36d106 100644 --- a/library/test/compiler/generic.factor +++ b/library/test/compiler/generic.factor @@ -6,107 +6,31 @@ USE: math USE: kernel USE: words -: single-combination-test - { - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ nip ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - } single-combination ; compiled +GENERIC: single-combination-test + +M: object single-combination-test drop ; +M: f single-combination-test nip ; + +\ single-combination-test compile [ 2 3 ] [ 2 3 t single-combination-test ] unit-test [ 2 3 ] [ 2 3 4 single-combination-test ] unit-test [ 2 f ] [ 2 3 f single-combination-test ] unit-test -: single-combination-literal-test - 4 { - [ drop ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - [ nip ] - } single-combination ; compiled - -[ ] [ single-combination-literal-test ] unit-test - -: single-combination-test-alt - { - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ nip ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - [ drop ] - } single-combination ; compiled - -[ 5 ] [ 2 3 4 single-combination-test-alt + ] unit-test -[ 7/2 ] [ 2 3 3/2 single-combination-test-alt + ] unit-test - DEFER: single-combination-test-2 : single-combination-test-4 - not single-combination-test-2 ; + dup [ single-combination-test-2 ] when ; : single-combination-test-3 drop 3 ; -: single-combination-test-2 - { - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-4 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - [ single-combination-test-3 ] - } single-combination ; +GENERIC: single-combination-test-2 +M: object single-combination-test-2 single-combination-test-3 ; +M: f single-combination-test-2 single-combination-test-4 ; + +\ single-combination-test-2 compile [ 3 ] [ t single-combination-test-2 ] unit-test [ 3 ] [ 3 single-combination-test-2 ] unit-test -[ 3 ] [ f single-combination-test-2 ] unit-test +[ f ] [ f single-combination-test-2 ] unit-test diff --git a/library/test/generic.factor b/library/test/generic.factor index 8dafd24d5e..08b1f95e23 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -133,7 +133,7 @@ M: very-funny gooey sq ; [ fixnum ] [ fixnum fixnum class-and ] unit-test [ fixnum ] [ fixnum integer class-and ] unit-test [ fixnum ] [ integer fixnum class-and ] unit-test -[ vector fixnum class-and ] unit-test-fails +[ null ] [ vector fixnum class-and ] unit-test [ integer ] [ fixnum bignum class-or ] unit-test [ integer ] [ fixnum integer class-or ] unit-test [ rational ] [ ratio integer class-or ] unit-test diff --git a/library/test/inference.factor b/library/test/inference.factor index a042efab5c..eb06775ab9 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -223,8 +223,8 @@ SYMBOL: sym-test ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test -[ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test -[ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test -[ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test - -[ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test +! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test +! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test +! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test +! +! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test diff --git a/library/test/math/complex.factor b/library/test/math/complex.factor index 4e084394d5..1c509a5b43 100644 --- a/library/test/math/complex.factor +++ b/library/test/math/complex.factor @@ -3,6 +3,9 @@ USE: kernel USE: math USE: test +[ 1 #{ 0 1 }# rect> ] unit-test-fails +[ #{ 0 1 }# 1 rect> ] unit-test-fails + [ f ] [ #{ 5 12.5 }# 5 ] [ = ] test-word [ t ] [ #{ 1.0 2.0 }# #{ 1 2 }# ] [ = ] test-word [ f ] [ #{ 1.0 2.3 }# #{ 1 2 }# ] [ = ] test-word diff --git a/native/arithmetic.c b/native/arithmetic.c index 24caa1e9fc..6d6b1f50b4 100644 --- a/native/arithmetic.c +++ b/native/arithmetic.c @@ -5,8 +5,8 @@ void primitive_arithmetic_type(void) CELL obj1 = dpeek(); CELL obj2 = get(ds - CELLS); - CELL type1 = type_of(obj1); - CELL type2 = type_of(obj2); + CELL type1 = TAG(obj1); + CELL type2 = TAG(obj2); CELL type; @@ -16,10 +16,10 @@ void primitive_arithmetic_type(void) switch(type1) { case BIGNUM_TYPE: - put(ds - CELLS,tag_object(to_bignum(obj2))); + put(ds - CELLS,tag_bignum(to_bignum(obj2))); break; case FLOAT_TYPE: - put(ds - CELLS,tag_object(make_float(to_float((obj2))))); + put(ds - CELLS,tag_float(to_float((obj2)))); break; } type = type1; @@ -28,11 +28,11 @@ void primitive_arithmetic_type(void) switch(type1) { case FIXNUM_TYPE: - drepl(tag_object(to_bignum(obj1))); + drepl(tag_bignum(to_bignum(obj1))); type = type2; break; case FLOAT_TYPE: - put(ds - CELLS,tag_object(make_float(to_float((obj2))))); + put(ds - CELLS,tag_float(to_float((obj2)))); type = type1; break; default: @@ -48,7 +48,7 @@ void primitive_arithmetic_type(void) type = type2; break; case FLOAT_TYPE: - put(ds - CELLS,tag_object(make_float(to_float((obj2))))); + put(ds - CELLS,tag_float(to_float((obj2)))); type = type1; break; default: @@ -62,7 +62,7 @@ void primitive_arithmetic_type(void) case FIXNUM_TYPE: case BIGNUM_TYPE: case RATIO_TYPE: - drepl(tag_object(make_float(to_float(obj1)))); + drepl(tag_float(to_float(obj1))); type = type2; break; default: @@ -88,6 +88,6 @@ void primitive_arithmetic_type(void) type = type2; break; } - + dpush(tag_fixnum(type)); } diff --git a/native/bignum.c b/native/bignum.c index c80ab81ec9..2347778a94 100644 --- a/native/bignum.c +++ b/native/bignum.c @@ -53,7 +53,7 @@ CELL to_cell(CELL x) bignum = to_bignum(x); if(BIGNUM_NEGATIVE_P(bignum)) { - range_error(F,0,tag_object(bignum),FIXNUM_MAX); + range_error(F,0,tag_bignum(bignum),FIXNUM_MAX); return -1; } else @@ -100,7 +100,7 @@ F_ARRAY* to_bignum(CELL tagged) void primitive_to_bignum(void) { maybe_garbage_collection(); - drepl(tag_object(to_bignum(dpeek()))); + drepl(tag_bignum(to_bignum(dpeek()))); } void primitive_bignum_eq(void) @@ -119,33 +119,33 @@ void primitive_bignum_eq(void) void primitive_bignum_add(void) { GC_AND_POP_BIGNUMS(x,y); - dpush(tag_object(s48_bignum_add(x,y))); + dpush(tag_bignum(s48_bignum_add(x,y))); } void primitive_bignum_subtract(void) { GC_AND_POP_BIGNUMS(x,y); - dpush(tag_object(s48_bignum_subtract(x,y))); + dpush(tag_bignum(s48_bignum_subtract(x,y))); } void primitive_bignum_multiply(void) { GC_AND_POP_BIGNUMS(x,y); - dpush(tag_object(s48_bignum_multiply(x,y))); + dpush(tag_bignum(s48_bignum_multiply(x,y))); } void primitive_bignum_divint(void) { GC_AND_POP_BIGNUMS(x,y); - dpush(tag_object(s48_bignum_quotient(x,y))); + dpush(tag_bignum(s48_bignum_quotient(x,y))); } void primitive_bignum_divfloat(void) { GC_AND_POP_BIGNUMS(x,y); - dpush(tag_object(make_float( + dpush(tag_float( s48_bignum_to_double(x) / - s48_bignum_to_double(y)))); + s48_bignum_to_double(y))); } void primitive_bignum_divmod(void) @@ -153,32 +153,32 @@ void primitive_bignum_divmod(void) F_ARRAY *q, *r; GC_AND_POP_BIGNUMS(x,y); s48_bignum_divide(x,y,&q,&r); - dpush(tag_object(q)); - dpush(tag_object(r)); + dpush(tag_bignum(q)); + dpush(tag_bignum(r)); } void primitive_bignum_mod(void) { GC_AND_POP_BIGNUMS(x,y); - dpush(tag_object(s48_bignum_remainder(x,y))); + dpush(tag_bignum(s48_bignum_remainder(x,y))); } void primitive_bignum_and(void) { GC_AND_POP_BIGNUMS(x,y); - dpush(tag_object(s48_bignum_bitwise_and(x,y))); + dpush(tag_bignum(s48_bignum_bitwise_and(x,y))); } void primitive_bignum_or(void) { GC_AND_POP_BIGNUMS(x,y); - dpush(tag_object(s48_bignum_bitwise_ior(x,y))); + dpush(tag_bignum(s48_bignum_bitwise_ior(x,y))); } void primitive_bignum_xor(void) { GC_AND_POP_BIGNUMS(x,y); - dpush(tag_object(s48_bignum_bitwise_xor(x,y))); + dpush(tag_bignum(s48_bignum_bitwise_xor(x,y))); } void primitive_bignum_shift(void) @@ -188,7 +188,7 @@ void primitive_bignum_shift(void) maybe_garbage_collection(); y = to_fixnum(dpop()); x = to_bignum(dpop()); - dpush(tag_object(s48_bignum_arithmetic_shift(x,y))); + dpush(tag_bignum(s48_bignum_arithmetic_shift(x,y))); } void primitive_bignum_less(void) @@ -248,7 +248,7 @@ void primitive_bignum_greatereq(void) void primitive_bignum_not(void) { maybe_garbage_collection(); - drepl(tag_object(s48_bignum_bitwise_not( + drepl(tag_bignum(s48_bignum_bitwise_not( untag_bignum(dpeek())))); } diff --git a/native/bignum.h b/native/bignum.h index 4b865ee17a..c5ac7b514a 100644 --- a/native/bignum.h +++ b/native/bignum.h @@ -13,6 +13,11 @@ INLINE F_ARRAY* untag_bignum(CELL tagged) return untag_bignum_fast(tagged); } +INLINE CELL tag_bignum(F_ARRAY* bignum) +{ + return RETAG(bignum,BIGNUM_TYPE); +} + F_FIXNUM to_integer(CELL x); CELL to_cell(CELL x); @@ -46,7 +51,7 @@ CELL three_test(void* x, unsigned char r, unsigned char g, unsigned char b); INLINE CELL tag_integer(F_FIXNUM x) { if(x < FIXNUM_MIN || x > FIXNUM_MAX) - return tag_object(s48_long_to_bignum(x)); + return tag_bignum(s48_long_to_bignum(x)); else return tag_fixnum(x); } @@ -54,7 +59,7 @@ INLINE CELL tag_integer(F_FIXNUM x) INLINE CELL tag_cell(CELL x) { if(x > FIXNUM_MAX) - return tag_object(s48_ulong_to_bignum(x)); + return tag_bignum(s48_ulong_to_bignum(x)); else return tag_fixnum(x); } diff --git a/native/fixnum.c b/native/fixnum.c index d14109497e..9f9d5fb272 100644 --- a/native/fixnum.c +++ b/native/fixnum.c @@ -17,7 +17,7 @@ F_FIXNUM to_fixnum(CELL tagged) r = (F_RATIO*)UNTAG(tagged); x = to_bignum(r->numerator); y = to_bignum(r->denominator); - return to_fixnum(tag_object(s48_bignum_quotient(x,y))); + return to_fixnum(tag_bignum(s48_bignum_quotient(x,y))); case FLOAT_TYPE: f = (F_FLOAT*)UNTAG(tagged); return (F_FIXNUM)f->n; @@ -72,7 +72,7 @@ void primitive_fixnum_multiply(void) box_integer(prod); else { - dpush(tag_object( + dpush(tag_bignum( s48_bignum_multiply( s48_long_to_bignum(x), s48_long_to_bignum(y)))); @@ -91,7 +91,7 @@ void primitive_fixnum_divfloat(void) { F_FIXNUM y = untag_fixnum_fast(dpop()); F_FIXNUM x = untag_fixnum_fast(dpop()); - dpush(tag_object(make_float((double)x / (double)y))); + dpush(tag_float((double)x / (double)y)); } void primitive_fixnum_divmod(void) @@ -166,7 +166,7 @@ void primitive_fixnum_shift(void) } } - dpush(tag_object(s48_bignum_arithmetic_shift( + dpush(tag_bignum(s48_bignum_arithmetic_shift( s48_long_to_bignum(x),y))); } diff --git a/native/float.c b/native/float.c index b6b8b00e16..3a5f249870 100644 --- a/native/float.c +++ b/native/float.c @@ -28,7 +28,7 @@ double to_float(CELL tagged) void primitive_to_float(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(to_float(dpeek())))); + drepl(tag_float(to_float(dpeek()))); } void primitive_str_to_float(void) @@ -45,7 +45,7 @@ void primitive_str_to_float(void) f = strtod(c_str,&end); if(end != c_str + str->capacity) general_error(ERROR_FLOAT_FORMAT,tag_object(str)); - drepl(tag_object(make_float(f))); + drepl(tag_float(f)); } void primitive_float_to_str(void) @@ -74,25 +74,25 @@ void primitive_float_eq(void) void primitive_float_add(void) { GC_AND_POP_FLOATS(x,y); - dpush(tag_object(make_float(x + y))); + dpush(tag_float(x + y)); } void primitive_float_subtract(void) { GC_AND_POP_FLOATS(x,y); - dpush(tag_object(make_float(x - y))); + dpush(tag_float(x - y)); } void primitive_float_multiply(void) { GC_AND_POP_FLOATS(x,y); - dpush(tag_object(make_float(x * y))); + dpush(tag_float(x * y)); } void primitive_float_divfloat(void) { GC_AND_POP_FLOATS(x,y); - dpush(tag_object(make_float(x / y))); + dpush(tag_float(x / y)); } void primitive_float_less(void) @@ -122,19 +122,19 @@ void primitive_float_greatereq(void) void primitive_facos(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(acos(to_float(dpeek()))))); + drepl(tag_float(acos(to_float(dpeek())))); } void primitive_fasin(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(asin(to_float(dpeek()))))); + drepl(tag_float(asin(to_float(dpeek())))); } void primitive_fatan(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(atan(to_float(dpeek()))))); + drepl(tag_float(atan(to_float(dpeek())))); } void primitive_fatan2(void) @@ -143,31 +143,31 @@ void primitive_fatan2(void) maybe_garbage_collection(); y = to_float(dpop()); x = to_float(dpop()); - dpush(tag_object(make_float(atan2(x,y)))); + dpush(tag_float(atan2(x,y))); } void primitive_fcos(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(cos(to_float(dpeek()))))); + drepl(tag_float(cos(to_float(dpeek())))); } void primitive_fexp(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(exp(to_float(dpeek()))))); + drepl(tag_float(exp(to_float(dpeek())))); } void primitive_fcosh(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(cosh(to_float(dpeek()))))); + drepl(tag_float(cosh(to_float(dpeek())))); } void primitive_flog(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(log(to_float(dpeek()))))); + drepl(tag_float(log(to_float(dpeek())))); } void primitive_fpow(void) @@ -176,23 +176,23 @@ void primitive_fpow(void) maybe_garbage_collection(); y = to_float(dpop()); x = to_float(dpop()); - dpush(tag_object(make_float(pow(x,y)))); + dpush(tag_float(pow(x,y))); } void primitive_fsin(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(sin(to_float(dpeek()))))); + drepl(tag_float(sin(to_float(dpeek())))); } void primitive_fsinh(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(sinh(to_float(dpeek()))))); + drepl(tag_float(sinh(to_float(dpeek())))); } void primitive_fsqrt(void) { maybe_garbage_collection(); - drepl(tag_object(make_float(sqrt(to_float(dpeek()))))); + drepl(tag_float(sqrt(to_float(dpeek())))); } diff --git a/native/float.h b/native/float.h index c643be6380..139fe3ca8e 100644 --- a/native/float.h +++ b/native/float.h @@ -21,6 +21,11 @@ INLINE double untag_float(CELL tagged) return untag_float_fast(tagged); } +INLINE CELL tag_float(double flo) +{ + return RETAG(make_float(flo),FLOAT_TYPE); +} + double to_float(CELL tagged); void primitive_to_float(void); void primitive_str_to_float(void); diff --git a/native/gc.c b/native/gc.c index 72fc513f64..784677928c 100644 --- a/native/gc.c +++ b/native/gc.c @@ -148,5 +148,5 @@ void maybe_garbage_collection(void) void primitive_gc_time(void) { maybe_garbage_collection(); - dpush(tag_object(s48_long_long_to_bignum(gc_time))); + dpush(tag_bignum(s48_long_long_to_bignum(gc_time))); } diff --git a/native/memory.c b/native/memory.c index e99eb09ac2..8173732863 100644 --- a/native/memory.c +++ b/native/memory.c @@ -116,7 +116,7 @@ void primitive_allot_profiling(void) void primitive_address(void) { - dpush(tag_object(s48_ulong_to_bignum(dpop()))); + dpush(tag_bignum(s48_ulong_to_bignum(dpop()))); } void primitive_heap_stats(void) diff --git a/native/misc.c b/native/misc.c index cc64f52ba7..1ff79aa035 100644 --- a/native/misc.c +++ b/native/misc.c @@ -44,7 +44,7 @@ int64_t current_millis(void) void primitive_millis(void) { maybe_garbage_collection(); - dpush(tag_object(s48_long_long_to_bignum(current_millis()))); + dpush(tag_bignum(s48_long_long_to_bignum(current_millis()))); } void primitive_init_random(void) @@ -55,7 +55,7 @@ void primitive_init_random(void) void primitive_random_int(void) { maybe_garbage_collection(); - dpush(tag_object(s48_long_to_bignum(rand()))); + dpush(tag_bignum(s48_long_to_bignum(rand()))); } #ifdef WIN32 diff --git a/native/types.c b/native/types.c index 16063e4051..4f31e6e39d 100644 --- a/native/types.c +++ b/native/types.c @@ -20,12 +20,18 @@ CELL object_size(CELL pointer) case FIXNUM_TYPE: size = 0; break; + case BIGNUM_TYPE: + size = ASIZE(UNTAG(pointer)); + break; case CONS_TYPE: size = sizeof(F_CONS); break; case RATIO_TYPE: size = sizeof(F_RATIO); break; + case FLOAT_TYPE: + size = sizeof(F_FLOAT); + break; case COMPLEX_TYPE: size = sizeof(F_COMPLEX); break; diff --git a/native/types.h b/native/types.h index fdc37d4bbf..5660a1ea5e 100644 --- a/native/types.h +++ b/native/types.h @@ -6,26 +6,27 @@ /*** Tags ***/ #define FIXNUM_TYPE 0 +#define BIGNUM_TYPE 1 #define CONS_TYPE 2 #define OBJECT_TYPE 3 #define RATIO_TYPE 4 -#define COMPLEX_TYPE 5 -#define HEADER_TYPE 6 +#define FLOAT_TYPE 5 +#define COMPLEX_TYPE 6 +#define HEADER_TYPE 7 #define GC_COLLECTED 7 /* See gc.c */ /*** Header types ***/ -/* Canonical F object */ -#define F_TYPE 6 -#define F RETAG(0,OBJECT_TYPE) - /* Canonical T object */ #define T_TYPE 7 CELL T; #define ARRAY_TYPE 8 -#define BIGNUM_TYPE 9 -#define FLOAT_TYPE 10 + +/* Canonical F object */ +#define F_TYPE 9 +#define F RETAG(0,OBJECT_TYPE) + #define VECTOR_TYPE 11 #define STRING_TYPE 12 #define SBUF_TYPE 13 @@ -48,18 +49,9 @@ INLINE CELL tag_header(CELL cell) return RETAG(cell << TAG_BITS,OBJECT_TYPE); } -#define HEADER_DEBUG - INLINE CELL untag_header(CELL cell) { - CELL type = cell >> TAG_BITS; -#ifdef HEADER_DEBUG - if(!headerp(cell)) - critical_error("header type check",cell); - if(type <= HEADER_TYPE) - critical_error("header invariant check",cell); -#endif - return type; + return cell >> TAG_BITS; } INLINE CELL tag_object(void* cell) @@ -69,7 +61,10 @@ INLINE CELL tag_object(void* cell) INLINE CELL object_type(CELL tagged) { - return untag_header(get(UNTAG(tagged))); + if(tagged == F) + return F_TYPE; + else + return untag_header(get(UNTAG(tagged))); } INLINE void type_check(CELL type, CELL tagged) @@ -79,11 +74,6 @@ INLINE void type_check(CELL type, CELL tagged) if(TAG(tagged) == type) return; } - else if(tagged == F) - { - if(type == F_TYPE) - return; - } else if(TAG(tagged) == OBJECT_TYPE && object_type(tagged) == type) { @@ -102,12 +92,7 @@ INLINE CELL type_of(CELL tagged) { CELL tag = TAG(tagged); if(tag == OBJECT_TYPE) - { - if(tagged == F) - return F_TYPE; - else - return untag_header(get(UNTAG(tagged))); - } + return object_type(tagged); else return tag; } diff --git a/native/unix/file.c b/native/unix/file.c index 52183e24c1..1d49a14612 100644 --- a/native/unix/file.c +++ b/native/unix/file.c @@ -43,7 +43,7 @@ void primitive_stat(void) { CELL dirp = tag_boolean(S_ISDIR(sb.st_mode)); CELL mode = tag_fixnum(sb.st_mode & ~S_IFMT); - CELL size = tag_object(s48_long_long_to_bignum(sb.st_size)); + CELL size = tag_bignum(s48_long_long_to_bignum(sb.st_size)); CELL mtime = tag_integer(sb.st_mtime); dpush(cons( dirp, diff --git a/native/win32/file.c b/native/win32/file.c index 748a24e633..c1afb420db 100644 --- a/native/win32/file.c +++ b/native/win32/file.c @@ -60,7 +60,7 @@ void primitive_stat(void) else { CELL dirp = tag_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY); - CELL size = tag_object(s48_long_long_to_bignum( + CELL size = tag_bignum(s48_long_long_to_bignum( (int64_t)st.nFileSizeLow | (int64_t)st.nFileSizeHigh << 32)); CELL mtime = tag_integer((int) ((*(int64_t*)&st.ftLastWriteTime - EPOCH_OFFSET) / 10000000));