From fc4894fbdfa5fddd0a42a3c7ce82ba169eae3887 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 30 Apr 2009 00:27:35 -0500 Subject: [PATCH] Replace ratio and complex built-in types with tuples defined in the library. This frees up two lo-tags, so move array and quotation over to these tags and update compiler for new tags --- .../cfg/intrinsics/allot/allot.factor | 28 ++--- .../compiler/cfg/intrinsics/intrinsics.factor | 4 - basis/compiler/tests/intrinsics.factor | 4 +- .../tree/escape-analysis/check/check.factor | 1 - .../escape-analysis-tests.factor | 4 +- .../tree/escape-analysis/simple/simple.factor | 4 - .../tree/propagation/propagation-tests.factor | 6 +- .../tree/propagation/simple/simple.factor | 2 +- .../tree/propagation/slots/slots.factor | 16 +-- .../tuple-unboxing-tests.factor | 1 - .../tree/tuple-unboxing/tuple-unboxing.factor | 4 - basis/math/complex/complex-docs.factor | 4 - basis/math/complex/complex.factor | 6 +- basis/math/functions/functions-docs.factor | 5 - basis/math/functions/functions.factor | 13 +- basis/math/ratios/ratios-docs.factor | 3 - basis/math/ratios/ratios.factor | 2 +- .../known-words/known-words.factor | 6 - core/bootstrap/layouts/layouts.factor | 24 ++-- core/bootstrap/primitives.factor | 32 ----- core/generic/math/math-docs.factor | 2 +- core/generic/math/math.factor | 111 +++++++++++------- core/math/math.factor | 11 +- vm/arrays.c | 47 +++++--- vm/arrays.h | 9 +- vm/byte_arrays.c | 28 +++-- vm/callstack.c | 4 +- vm/cpu-x86.32.S | 2 +- vm/cpu-x86.64.S | 2 +- vm/data_heap.c | 22 ++-- vm/dispatch.c | 6 +- vm/factor.c | 2 +- vm/inline_cache.c | 2 +- vm/layouts.h | 36 ++---- vm/local_roots.h | 2 +- vm/math.c | 22 ---- vm/math.h | 4 - vm/primitives.c | 2 - vm/quotations.c | 2 +- vm/quotations.h | 5 + vm/run.c | 2 +- vm/run.h | 13 +- vm/strings.c | 70 +++++++---- vm/tuples.c | 2 +- 44 files changed, 265 insertions(+), 312 deletions(-) diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 3a4c702bc5..938dbbccbf 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -27,11 +27,11 @@ IN: compiler.cfg.intrinsics.allot [ tuple ##set-slots ] [ ds-push drop ] 2bi ] [ drop emit-primitive ] if ; -: store-length ( len reg -- ) - [ ^^load-literal ] dip 1 object tag-number ##set-slot-imm ; +: store-length ( len reg class -- ) + [ [ ^^load-literal ] dip 1 ] dip tag-number ##set-slot-imm ; -: store-initial-element ( elt reg len -- ) - [ 2 + object tag-number ##set-slot-imm ] with with each ; +:: store-initial-element ( len reg elt class -- ) + len [ [ elt reg ] dip 2 + class tag-number ##set-slot-imm ] each ; : expand-? ( obj -- ? ) dup integer? [ 0 8 between? ] [ drop f ] if ; @@ -42,8 +42,8 @@ IN: compiler.cfg.intrinsics.allot [let | elt [ ds-pop ] reg [ len ^^allot-array ] | ds-drop - len reg store-length - elt reg len store-initial-element + len reg array store-length + len reg elt array store-initial-element reg ds-push ] ] [ node emit-primitive ] if @@ -57,16 +57,16 @@ IN: compiler.cfg.intrinsics.allot : emit-allot-byte-array ( len -- dst ) ds-drop dup ^^allot-byte-array - [ store-length ] [ ds-push ] [ ] tri ; + [ byte-array store-length ] [ ds-push ] [ ] tri ; : emit-(byte-array) ( node -- ) dup node-input-infos first literal>> dup expand-? [ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ; -: emit- ( node -- ) - dup node-input-infos first literal>> dup expand-? [ - nip - [ 0 ^^load-literal ] dip - [ emit-allot-byte-array ] keep - bytes>cells store-initial-element - ] [ drop emit-primitive ] if ; +:: emit- ( node -- ) + node node-input-infos first literal>> dup expand-? [ + :> len + 0 ^^load-literal :> elt + len emit-allot-byte-array :> reg + len reg elt byte-array store-initial-element + ] [ drop node emit-primitive ] if ; diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 3d0a7bec9c..ec819f9440 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics arrays: byte-arrays: byte-arrays:(byte-array) - math.private: - math.private: kernel: alien.accessors:alien-unsigned-1 alien.accessors:set-alien-unsigned-1 @@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics { \ arrays: [ emit- iterate-next ] } { \ byte-arrays: [ emit- iterate-next ] } { \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] } - { \ math.private: [ emit-simple-allot iterate-next ] } - { \ math.private: [ emit-simple-allot iterate-next ] } { \ kernel: [ emit-simple-allot iterate-next ] } { \ alien.accessors:alien-unsigned-1 [ 1 emit-alien-unsigned-getter iterate-next ] } { \ alien.accessors:set-alien-unsigned-1 [ 1 emit-alien-integer-setter iterate-next ] } diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index a6e827ea33..5ca0f3f109 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -342,12 +342,12 @@ cell 8 = [ ] unit-test [ 1 2 ] [ - 1 2 [ ] compile-call + 1 2 [ complex boa ] compile-call dup real-part swap imaginary-part ] unit-test [ 1 2 ] [ - 1 2 [ ] compile-call dup numerator swap denominator + 1 2 [ ratio boa ] compile-call dup numerator swap denominator ] unit-test [ \ + ] [ \ + [ ] compile-call ] unit-test diff --git a/basis/compiler/tree/escape-analysis/check/check.factor b/basis/compiler/tree/escape-analysis/check/check.factor index 333b3fa636..ed253ad89b 100644 --- a/basis/compiler/tree/escape-analysis/check/check.factor +++ b/basis/compiler/tree/escape-analysis/check/check.factor @@ -12,7 +12,6 @@ M: #push run-escape-analysis* M: #call run-escape-analysis* { - { [ dup word>> \ eq? ] [ t ] } { [ dup immutable-tuple-boa? ] [ t ] } [ f ] } cond nip ; diff --git a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor index bcb8b2f80a..5f89372ebe 100644 --- a/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor +++ b/basis/compiler/tree/escape-analysis/escape-analysis-tests.factor @@ -17,7 +17,7 @@ GENERIC: count-unboxed-allocations* ( m node -- n ) out-d>> first escaping-allocation? [ 1+ ] unless ; M: #call count-unboxed-allocations* - dup [ immutable-tuple-boa? ] [ word>> \ eq? ] bi or + dup immutable-tuple-boa? [ (count-unboxed-allocations) ] [ drop ] if ; M: #push count-unboxed-allocations* @@ -291,7 +291,7 @@ C: ro-box [ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test -[ 1 ] [ [ >rect ] count-unboxed-allocations ] unit-test +[ 1 ] [ [ complex boa >rect ] count-unboxed-allocations ] unit-test [ 0 ] [ [ 1 cons boa 2 cons boa ] count-unboxed-allocations ] unit-test diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor index fe1e60dbc2..729d6a0490 100644 --- a/basis/compiler/tree/escape-analysis/simple/simple.factor +++ b/basis/compiler/tree/escape-analysis/simple/simple.factor @@ -47,9 +47,6 @@ M: #push escape-analysis* [ record-unknown-allocation ] if ; -: record-complex-allocation ( #call -- ) - [ in-d>> ] [ out-d>> first ] bi record-allocation ; - : slot-offset ( #call -- n/f ) dup in-d>> [ first node-value-info class>> ] @@ -71,7 +68,6 @@ M: #push escape-analysis* M: #call escape-analysis* dup word>> { { \ [ record-tuple-allocation ] } - { \ [ record-complex-allocation ] } { \ slot [ record-slot-call ] } [ drop record-unknown-allocation ] } case ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index f6308ac40a..ed8d2983b5 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -357,7 +357,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ; ] unit-test [ V{ complex } ] [ - [ ] final-classes + [ complex boa ] final-classes ] unit-test [ V{ complex } ] [ @@ -375,7 +375,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ; [ V{ complex } ] [ [ { float float object } declare - [ "Oops" throw ] [ ] if + [ "Oops" throw ] [ complex boa ] if ] final-classes ] unit-test @@ -590,7 +590,7 @@ MIXIN: empty-mixin [ V{ float } ] [ [ - [ { float float } declare ] + [ { float float } declare complex boa ] [ 2drop C{ 0.0 0.0 } ] if real-part ] final-classes diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor index 9937c6b9c4..5837d59ef9 100644 --- a/basis/compiler/tree/propagation/simple/simple.factor +++ b/basis/compiler/tree/propagation/simple/simple.factor @@ -109,7 +109,7 @@ M: #declare propagate-before : output-value-infos ( #call word -- infos ) { - { [ dup tuple-constructor? ] [ propagate-tuple-constructor ] } + { [ dup \ eq? ] [ drop propagate- ] } { [ dup sequence-constructor? ] [ propagate-sequence-constructor ] } { [ dup predicate? ] [ propagate-predicate ] } { [ dup "outputs" word-prop ] [ call-outputs-quot ] } diff --git a/basis/compiler/tree/propagation/slots/slots.factor b/basis/compiler/tree/propagation/slots/slots.factor index 8192b1c520..1e221c89f1 100644 --- a/basis/compiler/tree/propagation/slots/slots.factor +++ b/basis/compiler/tree/propagation/slots/slots.factor @@ -29,9 +29,6 @@ UNION: fixed-length-sequence array byte-array string ; [ constructor-output-class ] bi* value-info-intersect 1array ; -: tuple-constructor? ( word -- ? ) - { } memq? ; - : fold- ( values class -- info ) [ [ literal>> ] map ] dip prefix >tuple ; @@ -44,18 +41,9 @@ UNION: fixed-length-sequence array byte-array string ; ] if ; -: propagate- ( #call -- info ) +: propagate- ( #call -- infos ) in-d>> unclip-last - value-info literal>> first (propagate-tuple-constructor) ; - -: propagate- ( #call -- info ) - in-d>> [ value-info ] map complex ; - -: propagate-tuple-constructor ( #call word -- infos ) - { - { \ [ propagate- ] } - { \ [ propagate- ] } - } case 1array ; + value-info literal>> first (propagate-tuple-constructor) 1array ; : read-only-slot? ( n class -- ? ) all-slots [ offset>> = ] with find nip diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor index 8654a6f983..70670648b1 100644 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor @@ -32,7 +32,6 @@ TUPLE: empty-tuple ; [ dup [ drop f ] [ "A" throw ] if ] [ [ ] [ ] curry curry dup 2 slot swap 3 slot dup 2 slot swap 3 slot drop ] [ [ ] [ ] curry curry call ] - [ dup 1 slot drop 2 slot drop ] [ 1 cons boa over [ "A" throw ] when car>> ] [ [ <=> ] sort ] [ [ <=> ] with search ] diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor index 1e00efa835..107ea59902 100755 --- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor +++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor @@ -36,9 +36,6 @@ M: #push unbox-tuples* ( #push -- nodes ) : unbox- ( #call -- nodes ) dup unbox-output? [ in-d>> 1 tail* #drop ] when ; -: unbox- ( #call -- nodes ) - dup unbox-output? [ drop { } ] when ; - : (flatten-values) ( values accum -- ) dup '[ dup unboxed-allocation @@ -70,7 +67,6 @@ M: #push unbox-tuples* ( #push -- nodes ) M: #call unbox-tuples* dup word>> { { \ [ unbox- ] } - { \ [ unbox- ] } { \ slot [ unbox-slot-access ] } [ drop ] } case ; diff --git a/basis/math/complex/complex-docs.factor b/basis/math/complex/complex-docs.factor index 6b6f5c95bd..a51b86ff0b 100644 --- a/basis/math/complex/complex-docs.factor +++ b/basis/math/complex/complex-docs.factor @@ -25,7 +25,3 @@ HELP: complex { $class-description "The class of complex numbers with non-zero imaginary part." } ; ABOUT: "complex-numbers" - -HELP: ( x y -- z ) -{ $values { "x" "a real number" } { "y" "a real number" } { "z" "a complex number" } } -{ $description "Low-level complex number constructor. User code should call " { $link rect> } " instead." } ; diff --git a/basis/math/complex/complex.factor b/basis/math/complex/complex.factor index c41faaf558..832a9e64ba 100644 --- a/basis/math/complex/complex.factor +++ b/basis/math/complex/complex.factor @@ -15,14 +15,14 @@ M: complex hashcode* nip >rect [ hashcode ] bi@ bitxor ; : complex= ( x y quot -- ? ) componentwise and ; inline M: complex equal? over complex? [ [ = ] complex= ] [ 2drop f ] if ; M: complex number= [ number= ] complex= ; -: complex-op ( x y quot -- z ) componentwise (rect>) ; inline +: complex-op ( x y quot -- z ) componentwise rect> ; inline M: complex + [ + ] complex-op ; M: complex - [ - ] complex-op ; : *re ( x y -- xr*yr xi*yi ) [ >rect ] bi@ [ * ] bi-curry@ bi* ; inline : *im ( x y -- xi*yr xr*yi ) swap [ >rect ] bi@ swap [ * ] bi-curry@ bi* ; inline -M: complex * [ *re - ] [ *im + ] 2bi (rect>) ; +M: complex * [ *re - ] [ *im + ] 2bi rect> ; : (complex/) ( x y -- r i m ) [ [ *re + ] [ *im - ] 2bi ] keep absq ; inline -: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ (rect>) ; inline +: complex/ ( x y quot -- z ) [ (complex/) ] dip curry bi@ rect> ; inline M: complex / [ / ] complex/ ; M: complex /f [ /f ] complex/ ; M: complex /i [ /i ] complex/ ; diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor index f7d0d5a941..48da8aa6ec 100644 --- a/basis/math/functions/functions-docs.factor +++ b/basis/math/functions/functions-docs.factor @@ -100,11 +100,6 @@ ARTICLE: "math-functions" "Mathematical functions" ABOUT: "math-functions" -HELP: (rect>) -{ $values { "x" real } { "y" real } { "z" number } } -{ $description "Creates a complex number from real and imaginary components." } -{ $warning "This word does not check that the arguments are real numbers, which can have undefined consequences. Use the " { $link rect> } " word instead." } ; - HELP: rect> { $values { "x" real } { "y" real } { "z" number } } { $description "Creates a complex number from real and imaginary components. If " { $snippet "z" } " is an integer zero, this will simply output " { $snippet "x" } "." } ; diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index a6beb87345..c21053317e 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -7,19 +7,8 @@ IN: math.functions : >fraction ( a/b -- a b ) [ numerator ] [ denominator ] bi ; inline -) ( x y -- z ) - dup 0 = [ drop ] [ ] if ; inline - -PRIVATE> - : rect> ( x y -- z ) - 2dup [ real? ] both? [ - (rect>) - ] [ - "Complex number must have real components" throw - ] if ; inline + dup 0 = [ drop ] [ complex boa ] if ; inline GENERIC: sqrt ( x -- y ) foldable diff --git a/basis/math/ratios/ratios-docs.factor b/basis/math/ratios/ratios-docs.factor index 7b6393dabe..2e51fa1870 100644 --- a/basis/math/ratios/ratios-docs.factor +++ b/basis/math/ratios/ratios-docs.factor @@ -47,6 +47,3 @@ HELP: 2>fraction { $values { "a/b" rational } { "c/d" rational } { "a" integer } { "c" integer } { "b" "a positive integer" } { "d" "a positive integer" } } { $description "Extracts the numerator and denominator of two rational numbers at once." } ; -HELP: ( a b -- a/b ) -{ $values { "a" integer } { "b" integer } { "a/b" "a ratio" } } -{ $description "Primitive ratio constructor. User code should call " { $link / } " to create ratios instead." } ; diff --git a/basis/math/ratios/ratios.factor b/basis/math/ratios/ratios.factor index 54e4bee1a8..d4f457180e 100644 --- a/basis/math/ratios/ratios.factor +++ b/basis/math/ratios/ratios.factor @@ -9,7 +9,7 @@ IN: math.ratios ( a b -- a/b ) - dup 1 number= [ drop ] [ ] if ; inline + dup 1 number= [ drop ] [ ratio boa ] if ; inline : scale ( a/b c/d -- a*d b*c ) 2>fraction [ * swap ] dip * swap ; inline diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 0bbaa32c25..72eead1826 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -286,9 +286,6 @@ M: object infer-call* \ bignum>float { bignum } { float } define-primitive \ bignum>float make-foldable -\ { integer integer } { ratio } define-primitive -\ make-foldable - \ string>float { string } { float } define-primitive \ string>float make-foldable @@ -307,9 +304,6 @@ M: object infer-call* \ bits>double { integer } { float } define-primitive \ bits>double make-foldable -\ { real real } { complex } define-primitive -\ make-foldable - \ both-fixnums? { object object } { object } define-primitive \ fixnum+ { fixnum fixnum } { integer } define-primitive diff --git a/core/bootstrap/layouts/layouts.factor b/core/bootstrap/layouts/layouts.factor index 264756ab9b..0243ad040e 100644 --- a/core/bootstrap/layouts/layouts.factor +++ b/core/bootstrap/layouts/layouts.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces math words kernel alien byte-arrays hashtables vectors strings sbufs arrays @@ -9,14 +9,14 @@ BIN: 111 tag-mask set 8 num-tags set 3 tag-bits set -17 num-types set +15 num-types set H{ { fixnum BIN: 000 } { bignum BIN: 001 } - { ratio BIN: 010 } + { array BIN: 010 } { float BIN: 011 } - { complex BIN: 100 } + { quotation BIN: 100 } { POSTPONE: f BIN: 101 } { object BIN: 110 } { hi-tag BIN: 110 } @@ -24,13 +24,11 @@ H{ } tag-numbers set tag-numbers get H{ - { array 8 } - { wrapper 9 } - { byte-array 10 } - { callstack 11 } - { string 12 } - { word 13 } - { quotation 14 } - { dll 15 } - { alien 16 } + { wrapper 8 } + { byte-array 9 } + { callstack 10 } + { string 11 } + { word 12 } + { dll 13 } + { alien 14 } } assoc-union type-numbers set diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a3b4a91aeb..2d2963c1d8 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -126,9 +126,7 @@ bootstrapping? on "fixnum" "math" create register-builtin "bignum" "math" create register-builtin "tuple" "kernel" create register-builtin -"ratio" "math" create register-builtin "float" "math" create register-builtin -"complex" "math" create register-builtin "f" "syntax" lookup register-builtin "array" "arrays" create register-builtin "wrapper" "kernel" create register-builtin @@ -147,24 +145,6 @@ bootstrapping? on "f?" "syntax" vocab-words delete-at ! Some unions -"integer" "math" create -"fixnum" "math" lookup -"bignum" "math" lookup -2array -define-union-class - -"rational" "math" create -"integer" "math" lookup -"ratio" "math" lookup -2array -define-union-class - -"real" "math" create -"rational" "math" lookup -"float" "math" lookup -2array -define-union-class - "c-ptr" "alien" create [ "alien" "alien" lookup , "f" "syntax" lookup , @@ -211,19 +191,9 @@ bi "bignum" "math" create { } define-builtin "bignum" "math" create ">bignum" "math" create 1quotation "coercer" set-word-prop -"ratio" "math" create { - { "numerator" { "integer" "math" } read-only } - { "denominator" { "integer" "math" } read-only } -} define-builtin - "float" "math" create { } define-builtin "float" "math" create ">float" "math" create 1quotation "coercer" set-word-prop -"complex" "math" create { - { "real" { "real" "math" } read-only } - { "imaginary" { "real" "math" } read-only } -} define-builtin - "array" "arrays" create { { "length" { "array-capacity" "sequences.private" } read-only } } define-builtin @@ -395,14 +365,12 @@ tuple { "float>bignum" "math.private" (( x -- y )) } { "fixnum>float" "math.private" (( x -- y )) } { "bignum>float" "math.private" (( x -- y )) } - { "" "math.private" (( a b -- a/b )) } { "string>float" "math.private" (( str -- n/f )) } { "float>string" "math.private" (( n -- str )) } { "float>bits" "math" (( x -- n )) } { "double>bits" "math" (( x -- n )) } { "bits>float" "math" (( n -- x )) } { "bits>double" "math" (( n -- x )) } - { "" "math.private" (( x y -- z )) } { "fixnum+" "math.private" (( x y -- z )) } { "fixnum-" "math.private" (( x y -- z )) } { "fixnum*" "math.private" (( x y -- z )) } diff --git a/core/generic/math/math-docs.factor b/core/generic/math/math-docs.factor index 60fa745339..7d7d6e725b 100644 --- a/core/generic/math/math-docs.factor +++ b/core/generic/math/math-docs.factor @@ -1,5 +1,5 @@ USING: kernel generic help.markup help.syntax math classes -sequences quotations ; +sequences quotations generic.math.private ; IN: generic.math HELP: math-upgrade diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 8d4610dabe..f7e79e68bd 100644 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays generic hashtables kernel kernel.private math -namespaces make sequences words quotations layouts combinators +namespaces sequences words quotations layouts combinators sequences.private classes classes.builtin classes.algebra -definitions math.order math.private ; +definitions math.order math.private assocs ; IN: generic.math PREDICATE: math-class < class @@ -13,24 +13,30 @@ PREDICATE: math-class < class number bootstrap-word class<= ] if ; + ( class1 class2 -- class ) - [ math-precedence ] compare +gt+ eq? ; +: bootstrap-words ( classes -- classes' ) + [ bootstrap-word ] map ; -: math-class-max ( class1 class2 -- class ) - [ math-class<=> ] most ; +: math-precedence ( class -- pair ) + [ + { null fixnum bignum ratio float complex object } bootstrap-words + swap [ class<= ] curry find drop + ] [ + { null fixnum integer rational real number object } bootstrap-words + swap [ swap class<= ] curry find drop + ] bi 2array ; : (math-upgrade) ( max class -- quot ) dupd = [ drop [ ] ] [ "coercer" word-prop [ ] or ] if ; +PRIVATE> + +: math-class-max ( class1 class2 -- class ) + [ [ math-precedence ] bi@ after? ] most ; + : math-upgrade ( class1 class2 -- quot ) [ math-class-max ] 2keep [ @@ -44,33 +50,57 @@ ERROR: no-math-method left right generic ; : default-math-method ( generic -- quot ) [ no-math-method ] curry [ ] like ; + + : object-method ( generic -- quot ) object bootstrap-word applicable-method ; : math-method ( word class1 class2 -- quot ) 2dup and [ - [ - 2dup 2array , \ declare , - 2dup math-upgrade % - math-class-max over order min-class applicable-method % - ] [ ] make + [ 2array [ declare ] curry nip ] + [ math-upgrade nip ] + [ math-class-max over order min-class applicable-method ] + 3tri 3append ] [ 2drop object-method ] if ; -SYMBOL: picker +class ] prepose map , ] bi* - \ dispatch , - ] [ ] make ; inline +SYMBOL: generic-word + +: make-math-method-table ( classes quot: ( class -- quot ) -- alist ) + [ bootstrap-words ] dip + [ [ drop ] [ call ] 2bi ] curry { } map>assoc ; inline + +: math-alist>quot ( alist -- quot ) + [ generic-word get object-method ] dip alist>quot ; + +: tag-dispatch-entry ( tag picker -- quot ) + [ "type" word-prop 1quotation [ tag ] [ eq? ] surround ] dip prepend ; + +: tag-dispatch ( picker alist -- alist' ) + swap [ [ tag-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ; + +: tuple-dispatch-entry ( class picker -- quot ) + [ 1quotation [ { tuple } declare class ] [ eq? ] surround ] dip prepend ; + +: tuple-dispatch ( picker alist -- alist' ) + swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ; + +: math-dispatch-step ( picker quot: ( class -- quot ) -- quot ) + [ [ { bignum float fixnum } ] dip make-math-method-table ] + [ [ { ratio complex } ] dip make-math-method-table tuple-dispatch ] 2bi + tuple swap 2array prefix tag-dispatch ; inline + +PRIVATE> SINGLETON: math-combination @@ -78,20 +108,21 @@ M: math-combination make-default-method drop default-math-method ; M: math-combination perform-combination - drop - dup - [ - [ 2dup both-fixnums? ] % - dup fixnum bootstrap-word dup math-method , - \ over [ - dup math-class? [ - \ dup [ [ 2dup ] dip math-method ] math-vtable - ] [ - over object-method - ] if nip - ] math-vtable nip , - \ if , - ] [ ] make define ; + drop dup generic-word [ + dup + [ fixnum bootstrap-word dup math-method ] + [ + [ over ] [ + dup math-class? [ + [ dup ] [ math-method ] with with math-dispatch-step + ] [ + drop object-method + ] if + ] with math-dispatch-step + ] bi + [ if ] 2curry [ 2dup both-fixnums? ] prepend + define + ] with-variable ; PREDICATE: math-generic < generic ( word -- ? ) "combination" word-prop math-combination? ; diff --git a/core/math/math.factor b/core/math/math.factor index 42786ffc9d..993d8d0e76 100755 --- a/core/math/math.factor +++ b/core/math/math.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2003, 2008 Slava Pestov. +! Copyright (C) 2003, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math.private ; IN: math @@ -63,23 +63,22 @@ PRIVATE> : neg ( x -- -x ) 0 swap - ; inline : recip ( x -- y ) 1 swap / ; inline : sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline - : ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline - : rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable - : 2^ ( n -- 2^n ) 1 swap shift ; inline - : even? ( n -- ? ) 1 bitand zero? ; - : odd? ( n -- ? ) 1 bitand 1 number= ; UNION: integer fixnum bignum ; +TUPLE: ratio { numerator integer read-only } { denominator integer read-only } ; + UNION: rational integer ratio ; UNION: real rational float ; +TUPLE: complex { real real read-only } { imaginary real read-only } ; + UNION: number real complex ; GENERIC: fp-nan? ( x -- ? ) diff --git a/vm/arrays.c b/vm/arrays.c index 3f0de35262..4d5dc67818 100644 --- a/vm/arrays.c +++ b/vm/arrays.c @@ -34,7 +34,7 @@ void primitive_array(void) { CELL initial = dpop(); CELL size = unbox_array_size(); - dpush(tag_object(allot_array(ARRAY_TYPE,size,initial))); + dpush(tag_array(allot_array(ARRAY_TYPE,size,initial))); } CELL allot_array_1(CELL obj) @@ -43,7 +43,7 @@ CELL allot_array_1(CELL obj) F_ARRAY *a = allot_array_internal(ARRAY_TYPE,1); UNREGISTER_ROOT(obj); set_array_nth(a,0,obj); - return tag_object(a); + return tag_array(a); } CELL allot_array_2(CELL v1, CELL v2) @@ -55,7 +55,7 @@ CELL allot_array_2(CELL v1, CELL v2) UNREGISTER_ROOT(v1); set_array_nth(a,0,v1); set_array_nth(a,1,v2); - return tag_object(a); + return tag_array(a); } CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) @@ -73,35 +73,48 @@ CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4) set_array_nth(a,1,v2); set_array_nth(a,2,v3); set_array_nth(a,3,v4); - return tag_object(a); + return tag_array(a); } -F_ARRAY *reallot_array(F_ARRAY* array, CELL capacity) +static bool reallot_array_in_place_p(F_ARRAY *array, CELL capacity) +{ + return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); +} + +F_ARRAY *reallot_array(F_ARRAY *array, CELL capacity) { #ifdef FACTOR_DEBUG CELL header = untag_header(array->header); assert(header == ARRAY_TYPE || header == BIGNUM_TYPE); #endif - CELL to_copy = array_capacity(array); - if(capacity < to_copy) + if(reallot_array_in_place_p(array,capacity)) + { + array->capacity = tag_fixnum(capacity); + return array; + } + else + { + CELL to_copy = array_capacity(array); + if(capacity < to_copy) to_copy = capacity; - REGISTER_UNTAGGED(array); - F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); - UNREGISTER_UNTAGGED(array); + REGISTER_UNTAGGED(array); + F_ARRAY* new_array = allot_array_internal(untag_header(array->header),capacity); + UNREGISTER_UNTAGGED(array); + + memcpy(new_array + 1,array + 1,to_copy * CELLS); + memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); - memcpy(new_array + 1,array + 1,to_copy * CELLS); - memset((char *)AREF(new_array,to_copy),'\0',(capacity - to_copy) * CELLS); - - return new_array; + return new_array; + } } void primitive_resize_array(void) { F_ARRAY* array = untag_array(dpop()); CELL capacity = unbox_array_size(); - dpush(tag_object(reallot_array(array,capacity))); + dpush(tag_array(reallot_array(array,capacity))); } void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt) @@ -112,7 +125,7 @@ void growable_array_add(F_GROWABLE_ARRAY *array, CELL elt) if(array->count == array_capacity(underlying)) { underlying = reallot_array(underlying,array->count * 2); - array->array = tag_object(underlying); + array->array = tag_array(underlying); } UNREGISTER_ROOT(elt); @@ -131,7 +144,7 @@ void growable_array_append(F_GROWABLE_ARRAY *array, F_ARRAY *elts) if(new_size >= array_capacity(underlying)) { underlying = reallot_array(underlying,new_size * 2); - array->array = tag_object(underlying); + array->array = tag_array(underlying); } UNREGISTER_UNTAGGED(elts); diff --git a/vm/arrays.h b/vm/arrays.h index 4d773922b4..3b2a065aba 100644 --- a/vm/arrays.h +++ b/vm/arrays.h @@ -1,5 +1,10 @@ DEFINE_UNTAG(F_ARRAY,ARRAY_TYPE,array) +INLINE CELL tag_array(F_ARRAY *array) +{ + return RETAG(array,ARRAY_TYPE); +} + /* Inline functions */ INLINE CELL array_size(CELL size) { @@ -61,7 +66,7 @@ INLINE F_GROWABLE_ARRAY make_growable_array(void) { F_GROWABLE_ARRAY result; result.count = 0; - result.array = tag_object(allot_array(ARRAY_TYPE,100,F)); + result.array = tag_array(allot_array(ARRAY_TYPE,100,F)); return result; } @@ -80,7 +85,7 @@ void growable_array_append(F_GROWABLE_ARRAY *result, F_ARRAY *elts); INLINE void growable_array_trim(F_GROWABLE_ARRAY *array) { - array->array = tag_object(reallot_array(untag_object(array->array),array->count)); + array->array = tag_array(reallot_array(untag_object(array->array),array->count)); } #define GROWABLE_ARRAY_TRIM(result) growable_array_trim(&result##_g) diff --git a/vm/byte_arrays.c b/vm/byte_arrays.c index 42fd5ba274..480b4d7a9f 100644 --- a/vm/byte_arrays.c +++ b/vm/byte_arrays.c @@ -30,23 +30,35 @@ void primitive_uninitialized_byte_array(void) dpush(tag_object(allot_byte_array_internal(size))); } +static bool reallot_byte_array_in_place_p(F_BYTE_ARRAY *array, CELL capacity) +{ + return in_zone(&nursery,(CELL)array) && capacity <= array_capacity(array); +} + F_BYTE_ARRAY *reallot_byte_array(F_BYTE_ARRAY *array, CELL capacity) { #ifdef FACTOR_DEBUG assert(untag_header(array->header) == BYTE_ARRAY_TYPE); #endif - - CELL to_copy = array_capacity(array); - if(capacity < to_copy) + if(reallot_byte_array_in_place_p(array,capacity)) + { + array->capacity = tag_fixnum(capacity); + return array; + } + else + { + CELL to_copy = array_capacity(array); + if(capacity < to_copy) to_copy = capacity; - REGISTER_UNTAGGED(array); - F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); - UNREGISTER_UNTAGGED(array); + REGISTER_UNTAGGED(array); + F_BYTE_ARRAY *new_array = allot_byte_array_internal(capacity); + UNREGISTER_UNTAGGED(array); - memcpy(new_array + 1,array + 1,to_copy); + memcpy(new_array + 1,array + 1,to_copy); - return new_array; + return new_array; + } } void primitive_resize_byte_array(void) diff --git a/vm/callstack.c b/vm/callstack.c index b7e6b946bb..26f8589c29 100755 --- a/vm/callstack.c +++ b/vm/callstack.c @@ -170,7 +170,7 @@ void primitive_callstack_to_array(void) frame_index = 0; iterate_callstack_object(stack,stack_frame_to_array); - dpush(tag_object(array)); + dpush(tag_array(array)); } F_STACK_FRAME *innermost_stack_frame(F_CALLSTACK *callstack) @@ -214,7 +214,7 @@ void primitive_set_innermost_stack_frame_quot(void) REGISTER_UNTAGGED(callstack); REGISTER_UNTAGGED(quot); - jit_compile(tag_object(quot),true); + jit_compile(tag_quotation(quot),true); UNREGISTER_UNTAGGED(quot); UNREGISTER_UNTAGGED(callstack); diff --git a/vm/cpu-x86.32.S b/vm/cpu-x86.32.S index cfac257ff3..3c0db36935 100755 --- a/vm/cpu-x86.32.S +++ b/vm/cpu-x86.32.S @@ -29,7 +29,7 @@ and the callstack top is passed in EDX */ pop %ebp ; \ pop %ebx -#define QUOT_XT_OFFSET 14 +#define QUOT_XT_OFFSET 16 #define WORD_XT_OFFSET 30 /* We pass a function pointer to memcpy to work around a Mac OS X diff --git a/vm/cpu-x86.64.S b/vm/cpu-x86.64.S index 984f7d1842..26cb753d59 100644 --- a/vm/cpu-x86.64.S +++ b/vm/cpu-x86.64.S @@ -61,7 +61,7 @@ #endif -#define QUOT_XT_OFFSET 34 +#define QUOT_XT_OFFSET 36 #define WORD_XT_OFFSET 66 /* We pass a function pointer to memcpy to work around a Mac OS X diff --git a/vm/data_heap.c b/vm/data_heap.c index 44232ab6b0..cab9114089 100644 --- a/vm/data_heap.c +++ b/vm/data_heap.c @@ -216,12 +216,8 @@ CELL unaligned_object_size(CELL pointer) return sizeof(F_QUOTATION); case WORD_TYPE: return sizeof(F_WORD); - case RATIO_TYPE: - return sizeof(F_RATIO); case FLOAT_TYPE: return sizeof(F_FLOAT); - case COMPLEX_TYPE: - return sizeof(F_COMPLEX); case DLL_TYPE: return sizeof(F_DLL); case ALIEN_TYPE: @@ -276,10 +272,6 @@ CELL binary_payload_start(CELL pointer) tuple = untag_object(pointer); layout = untag_object(tuple->layout); return tuple_size(layout); - case RATIO_TYPE: - return sizeof(F_RATIO); - case COMPLEX_TYPE: - return sizeof(F_COMPLEX); case WRAPPER_TYPE: return sizeof(F_WRAPPER); default: @@ -291,20 +283,22 @@ CELL binary_payload_start(CELL pointer) /* Push memory usage statistics in data heap */ void primitive_data_room(void) { - F_ARRAY *a = allot_array(ARRAY_TYPE,data_heap->gen_count * 2,F); - int gen; - dpush(tag_fixnum((data_heap->cards_end - data_heap->cards) >> 10)); dpush(tag_fixnum((data_heap->decks_end - data_heap->decks) >> 10)); + GROWABLE_ARRAY(a); + + int gen; for(gen = 0; gen < data_heap->gen_count; gen++) { F_ZONE *z = (gen == NURSERY ? &nursery : &data_heap->generations[gen]); - set_array_nth(a,gen * 2,tag_fixnum((z->end - z->here) >> 10)); - set_array_nth(a,gen * 2 + 1,tag_fixnum((z->size) >> 10)); + GROWABLE_ARRAY_ADD(a,tag_fixnum((z->end - z->here) >> 10)); + GROWABLE_ARRAY_ADD(a,tag_fixnum((z->size) >> 10)); } - dpush(tag_object(a)); + GROWABLE_ARRAY_TRIM(a); + GROWABLE_ARRAY_DONE(a); + dpush(a); } /* Disables GC and activates next-object ( -- obj ) primitive */ diff --git a/vm/dispatch.c b/vm/dispatch.c index 492b29ac17..507725458e 100644 --- a/vm/dispatch.c +++ b/vm/dispatch.c @@ -74,7 +74,11 @@ static CELL lookup_tuple_method(CELL object, CELL methods) static CELL lookup_hi_tag_method(CELL object, CELL methods) { F_ARRAY *hi_tag_methods = untag_object(methods); - return array_nth(hi_tag_methods,hi_tag(object) - HEADER_TYPE); + CELL tag = hi_tag(object) - HEADER_TYPE; +#ifdef FACTOR_DEBUG + assert(tag < TYPE_COUNT - HEADER_TYPE); +#endif + return array_nth(hi_tag_methods,tag); } static CELL method_cache_hashcode(CELL key, F_ARRAY *array) diff --git a/vm/factor.c b/vm/factor.c index 56a72d5c1e..0a652f7aab 100755 --- a/vm/factor.c +++ b/vm/factor.c @@ -167,7 +167,7 @@ void pass_args_to_factor(int argc, F_CHAR **argv) set_array_nth(args,i,arg); } - userenv[ARGS_ENV] = tag_object(args); + userenv[ARGS_ENV] = tag_array(args); } void start_factor(F_PARAMETERS *p) diff --git a/vm/inline_cache.c b/vm/inline_cache.c index 38503f5731..4d10074ae6 100644 --- a/vm/inline_cache.c +++ b/vm/inline_cache.c @@ -144,7 +144,7 @@ static CELL add_inline_cache_entry(CELL cache_entries, CELL class, CELL method) cache_entries_array = reallot_array(cache_entries_array,pic_size + 2); set_array_nth(cache_entries_array,pic_size,class); set_array_nth(cache_entries_array,pic_size + 1,method); - return tag_object(cache_entries_array); + return tag_array(cache_entries_array); } } diff --git a/vm/layouts.h b/vm/layouts.h index 27bbe5b137..fd30f1bfa2 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -32,9 +32,9 @@ typedef signed long long s64; /*** Tags ***/ #define FIXNUM_TYPE 0 #define BIGNUM_TYPE 1 -#define RATIO_TYPE 2 +#define ARRAY_TYPE 2 #define FLOAT_TYPE 3 -#define COMPLEX_TYPE 4 +#define QUOTATION_TYPE 4 #define F_TYPE 5 #define OBJECT_TYPE 6 #define TUPLE_TYPE 7 @@ -50,17 +50,15 @@ typedef signed long long s64; #define GC_COLLECTED 5 /* See gc.c */ /*** Header types ***/ -#define ARRAY_TYPE 8 -#define WRAPPER_TYPE 9 -#define BYTE_ARRAY_TYPE 10 -#define CALLSTACK_TYPE 11 -#define STRING_TYPE 12 -#define WORD_TYPE 13 -#define QUOTATION_TYPE 14 -#define DLL_TYPE 15 -#define ALIEN_TYPE 16 +#define WRAPPER_TYPE 8 +#define BYTE_ARRAY_TYPE 9 +#define CALLSTACK_TYPE 10 +#define STRING_TYPE 11 +#define WORD_TYPE 12 +#define DLL_TYPE 13 +#define ALIEN_TYPE 14 -#define TYPE_COUNT 17 +#define TYPE_COUNT 15 INLINE bool immediate_p(CELL obj) { @@ -175,13 +173,6 @@ typedef struct { CELL object; } F_WRAPPER; -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - CELL header; - CELL numerator; - CELL denominator; -} F_RATIO; - /* Assembly code makes assumptions about the layout of this struct */ typedef struct { /* We use a union here to force the float value to be aligned on an @@ -210,13 +201,6 @@ typedef struct { F_CODE_BLOCK *code; } F_QUOTATION; -/* Assembly code makes assumptions about the layout of this struct */ -typedef struct { - CELL header; - CELL real; - CELL imaginary; -} F_COMPLEX; - /* Assembly code makes assumptions about the layout of this struct */ typedef struct { CELL header; diff --git a/vm/local_roots.h b/vm/local_roots.h index 59f1bfc4e6..bbedf46394 100644 --- a/vm/local_roots.h +++ b/vm/local_roots.h @@ -38,7 +38,7 @@ CELL extra_roots; DEFPUSHPOP(root_,extra_roots) -#define REGISTER_UNTAGGED(obj) root_push(obj ? tag_object(obj) : 0) +#define REGISTER_UNTAGGED(obj) root_push(obj ? RETAG(obj,OBJECT_TYPE) : 0) #define UNREGISTER_UNTAGGED(obj) obj = untag_object(root_pop()) /* We ignore strings which point outside the data heap, but we might be given diff --git a/vm/math.c b/vm/math.c index 7bff0de387..25180abdd6 100644 --- a/vm/math.c +++ b/vm/math.c @@ -375,18 +375,6 @@ CELL unbox_array_size(void) return 0; /* can't happen */ } -/* Ratios */ - -/* Does not reduce to lowest terms, so should only be used by math -library implementation, to avoid breaking invariants. */ -void primitive_from_fraction(void) -{ - F_RATIO* ratio = allot_object(RATIO_TYPE,sizeof(F_RATIO)); - ratio->denominator = dpop(); - ratio->numerator = dpop(); - dpush(RETAG(ratio,RATIO_TYPE)); -} - /* Floats */ void primitive_fixnum_to_float(void) { @@ -525,13 +513,3 @@ void box_double(double flo) { dpush(allot_float(flo)); } - -/* Complex numbers */ - -void primitive_from_rect(void) -{ - F_COMPLEX* z = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); - z->imaginary = dpop(); - z->real = dpop(); - dpush(RETAG(z,COMPLEX_TYPE)); -} diff --git a/vm/math.h b/vm/math.h index f94f12b76d..4a18888549 100644 --- a/vm/math.h +++ b/vm/math.h @@ -85,8 +85,6 @@ DLLEXPORT u64 to_unsigned_8(CELL obj); CELL unbox_array_size(void); -void primitive_from_fraction(void); - INLINE double untag_float_fast(CELL tagged) { return ((F_FLOAT*)UNTAG(tagged))->n; @@ -151,5 +149,3 @@ void primitive_float_bits(void); void primitive_bits_float(void); void primitive_double_bits(void); void primitive_bits_double(void); - -void primitive_from_rect(void); diff --git a/vm/primitives.c b/vm/primitives.c index 3e9a829a2e..61bc01a22e 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -7,14 +7,12 @@ void *primitives[] = { primitive_float_to_bignum, primitive_fixnum_to_float, primitive_bignum_to_float, - primitive_from_fraction, primitive_str_to_float, primitive_float_to_str, primitive_float_bits, primitive_double_bits, primitive_bits_float, primitive_bits_double, - primitive_from_rect, primitive_fixnum_add, primitive_fixnum_subtract, primitive_fixnum_multiply, diff --git a/vm/quotations.c b/vm/quotations.c index 4b5eb0dd2c..255289b407 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -439,7 +439,7 @@ void primitive_array_to_quotation(void) quot->compiledp = F; quot->cached_effect = F; quot->cache_counter = F; - drepl(tag_object(quot)); + drepl(tag_quotation(quot)); } void primitive_quotation_xt(void) diff --git a/vm/quotations.h b/vm/quotations.h index 6fcd894b05..16ef9df422 100755 --- a/vm/quotations.h +++ b/vm/quotations.h @@ -1,5 +1,10 @@ DEFINE_UNTAG(F_QUOTATION,QUOTATION_TYPE,quotation) +INLINE CELL tag_quotation(F_QUOTATION *quotation) +{ + return RETAG(quotation,QUOTATION_TYPE); +} + void set_quot_xt(F_QUOTATION *quot, F_CODE_BLOCK *code); void jit_compile(CELL quot, bool relocate); F_FASTCALL CELL lazy_jit_compile_impl(CELL quot, F_STACK_FRAME *stack); diff --git a/vm/run.c b/vm/run.c index 7dc2474113..f5e45c2d5a 100755 --- a/vm/run.c +++ b/vm/run.c @@ -120,7 +120,7 @@ bool stack_to_array(CELL bottom, CELL top) { F_ARRAY *a = allot_array_internal(ARRAY_TYPE,depth / CELLS); memcpy(a + 1,(void*)bottom,depth); - dpush(tag_object(a)); + dpush(tag_array(a)); return true; } } diff --git a/vm/run.h b/vm/run.h index c500484d25..b8f27de5ae 100755 --- a/vm/run.h +++ b/vm/run.h @@ -153,16 +153,19 @@ INLINE CELL untag_header(CELL cell) return cell >> TAG_BITS; } -INLINE CELL tag_object(void* cell) -{ - return RETAG(cell,OBJECT_TYPE); -} - INLINE CELL hi_tag(CELL tagged) { return untag_header(get(UNTAG(tagged))); } +INLINE CELL tag_object(void *cell) +{ +#ifdef FACTOR_DEBUG + assert(hi_tag((CELL)cell) >= HEADER_TYPE); +#endif + return RETAG(cell,OBJECT_TYPE); +} + INLINE CELL type_of(CELL tagged) { CELL tag = TAG(tagged); diff --git a/vm/strings.c b/vm/strings.c index 03414077b9..f08a2e8866 100644 --- a/vm/strings.c +++ b/vm/strings.c @@ -107,40 +107,60 @@ void primitive_string(void) dpush(tag_object(allot_string(length,initial))); } +static bool reallot_string_in_place_p(F_STRING *string, CELL capacity) +{ + return in_zone(&nursery,(CELL)string) && capacity <= string_capacity(string); +} + F_STRING* reallot_string(F_STRING* string, CELL capacity) { - CELL to_copy = string_capacity(string); - if(capacity < to_copy) - to_copy = capacity; - - REGISTER_UNTAGGED(string); - F_STRING *new_string = allot_string_internal(capacity); - UNREGISTER_UNTAGGED(string); - - memcpy(new_string + 1,string + 1,to_copy); - - if(string->aux != F) + if(reallot_string_in_place_p(string,capacity)) { + string->length = tag_fixnum(capacity); + + if(string->aux != F) + { + F_BYTE_ARRAY *aux = untag_object(string->aux); + aux->capacity = tag_fixnum(capacity * 2); + } + + return string; + } + else + { + CELL to_copy = string_capacity(string); + if(capacity < to_copy) + to_copy = capacity; + + REGISTER_UNTAGGED(string); + F_STRING *new_string = allot_string_internal(capacity); + UNREGISTER_UNTAGGED(string); + + memcpy(new_string + 1,string + 1,to_copy); + + if(string->aux != F) + { + REGISTER_UNTAGGED(string); + REGISTER_UNTAGGED(new_string); + F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); + UNREGISTER_UNTAGGED(new_string); + UNREGISTER_UNTAGGED(string); + + write_barrier((CELL)new_string); + new_string->aux = tag_object(new_aux); + + F_BYTE_ARRAY *aux = untag_object(string->aux); + memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); + } + REGISTER_UNTAGGED(string); REGISTER_UNTAGGED(new_string); - F_BYTE_ARRAY *new_aux = allot_byte_array(capacity * sizeof(u16)); + fill_string(new_string,to_copy,capacity,'\0'); UNREGISTER_UNTAGGED(new_string); UNREGISTER_UNTAGGED(string); - write_barrier((CELL)new_string); - new_string->aux = tag_object(new_aux); - - F_BYTE_ARRAY *aux = untag_object(string->aux); - memcpy(new_aux + 1,aux + 1,to_copy * sizeof(u16)); + return new_string; } - - REGISTER_UNTAGGED(string); - REGISTER_UNTAGGED(new_string); - fill_string(new_string,to_copy,capacity,'\0'); - UNREGISTER_UNTAGGED(new_string); - UNREGISTER_UNTAGGED(string); - - return new_string; } void primitive_resize_string(void) diff --git a/vm/tuples.c b/vm/tuples.c index 0ad7557179..c93bdf4669 100644 --- a/vm/tuples.c +++ b/vm/tuples.c @@ -6,7 +6,7 @@ F_TUPLE *allot_tuple(F_TUPLE_LAYOUT *layout) REGISTER_UNTAGGED(layout); F_TUPLE *tuple = allot_object(TUPLE_TYPE,tuple_size(layout)); UNREGISTER_UNTAGGED(layout); - tuple->layout = tag_object(layout); + tuple->layout = tag_array((F_ARRAY *)layout); return tuple; }