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
Slava Pestov
parent
9f4ac667dc
commit
fc4894fbdf
|
|
@ -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-<array>? ( 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-<byte-array>?
|
||||
[ nip emit-allot-byte-array drop ] [ drop emit-primitive ] if ;
|
||||
|
||||
: emit-<byte-array> ( node -- )
|
||||
dup node-input-infos first literal>> dup expand-<byte-array>? [
|
||||
nip
|
||||
[ 0 ^^load-literal ] dip
|
||||
[ emit-allot-byte-array ] keep
|
||||
bytes>cells store-initial-element
|
||||
] [ drop emit-primitive ] if ;
|
||||
:: emit-<byte-array> ( node -- )
|
||||
node node-input-infos first literal>> dup expand-<byte-array>? [
|
||||
:> len
|
||||
0 ^^load-literal :> elt
|
||||
len emit-allot-byte-array :> reg
|
||||
len reg elt byte-array store-initial-element
|
||||
] [ drop node emit-primitive ] if ;
|
||||
|
|
|
|||
|
|
@ -52,8 +52,6 @@ IN: compiler.cfg.intrinsics
|
|||
arrays:<array>
|
||||
byte-arrays:<byte-array>
|
||||
byte-arrays:(byte-array)
|
||||
math.private:<complex>
|
||||
math.private:<ratio>
|
||||
kernel:<wrapper>
|
||||
alien.accessors:alien-unsigned-1
|
||||
alien.accessors:set-alien-unsigned-1
|
||||
|
|
@ -140,8 +138,6 @@ IN: compiler.cfg.intrinsics
|
|||
{ \ arrays:<array> [ emit-<array> iterate-next ] }
|
||||
{ \ byte-arrays:<byte-array> [ emit-<byte-array> iterate-next ] }
|
||||
{ \ byte-arrays:(byte-array) [ emit-(byte-array) iterate-next ] }
|
||||
{ \ math.private:<complex> [ emit-simple-allot iterate-next ] }
|
||||
{ \ math.private:<ratio> [ emit-simple-allot iterate-next ] }
|
||||
{ \ kernel:<wrapper> [ 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 ] }
|
||||
|
|
|
|||
|
|
@ -342,12 +342,12 @@ cell 8 = [
|
|||
] unit-test
|
||||
|
||||
[ 1 2 ] [
|
||||
1 2 [ <complex> ] compile-call
|
||||
1 2 [ complex boa ] compile-call
|
||||
dup real-part swap imaginary-part
|
||||
] unit-test
|
||||
|
||||
[ 1 2 ] [
|
||||
1 2 [ <ratio> ] compile-call dup numerator swap denominator
|
||||
1 2 [ ratio boa ] compile-call dup numerator swap denominator
|
||||
] unit-test
|
||||
|
||||
[ \ + ] [ \ + [ <wrapper> ] compile-call ] unit-test
|
||||
|
|
|
|||
|
|
@ -12,7 +12,6 @@ M: #push run-escape-analysis*
|
|||
|
||||
M: #call run-escape-analysis*
|
||||
{
|
||||
{ [ dup word>> \ <complex> eq? ] [ t ] }
|
||||
{ [ dup immutable-tuple-boa? ] [ t ] }
|
||||
[ f ]
|
||||
} cond nip ;
|
||||
|
|
|
|||
|
|
@ -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>> \ <complex> eq? ] bi or
|
||||
dup immutable-tuple-boa?
|
||||
[ (count-unboxed-allocations) ] [ drop ] if ;
|
||||
|
||||
M: #push count-unboxed-allocations*
|
||||
|
|
@ -291,7 +291,7 @@ C: <ro-box> ro-box
|
|||
|
||||
[ 0 ] [ [ bad-tuple-fib-3 i>> ] count-unboxed-allocations ] unit-test
|
||||
|
||||
[ 1 ] [ [ <complex> >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
|
||||
|
||||
|
|
|
|||
|
|
@ -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>> {
|
||||
{ \ <tuple-boa> [ record-tuple-allocation ] }
|
||||
{ \ <complex> [ record-complex-allocation ] }
|
||||
{ \ slot [ record-slot-call ] }
|
||||
[ drop record-unknown-allocation ]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -357,7 +357,7 @@ TUPLE: immutable-prop-test-tuple { x sequence read-only } ;
|
|||
] unit-test
|
||||
|
||||
[ V{ complex } ] [
|
||||
[ <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 ] [ <complex> ] if
|
||||
[ "Oops" throw ] [ complex boa ] if
|
||||
] final-classes
|
||||
] unit-test
|
||||
|
||||
|
|
@ -590,7 +590,7 @@ MIXIN: empty-mixin
|
|||
|
||||
[ V{ float } ] [
|
||||
[
|
||||
[ { float float } declare <complex> ]
|
||||
[ { float float } declare complex boa ]
|
||||
[ 2drop C{ 0.0 0.0 } ]
|
||||
if real-part
|
||||
] final-classes
|
||||
|
|
|
|||
|
|
@ -109,7 +109,7 @@ M: #declare propagate-before
|
|||
|
||||
: output-value-infos ( #call word -- infos )
|
||||
{
|
||||
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
|
||||
{ [ dup \ <tuple-boa> eq? ] [ drop propagate-<tuple-boa> ] }
|
||||
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
|
||||
{ [ dup predicate? ] [ propagate-predicate ] }
|
||||
{ [ dup "outputs" word-prop ] [ call-outputs-quot ] }
|
||||
|
|
|
|||
|
|
@ -29,9 +29,6 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
[ constructor-output-class <class-info> ]
|
||||
bi* value-info-intersect 1array ;
|
||||
|
||||
: tuple-constructor? ( word -- ? )
|
||||
{ <tuple-boa> <complex> } memq? ;
|
||||
|
||||
: fold-<tuple-boa> ( values class -- info )
|
||||
[ [ literal>> ] map ] dip prefix >tuple
|
||||
<literal-info> ;
|
||||
|
|
@ -44,18 +41,9 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
<tuple-info>
|
||||
] if ;
|
||||
|
||||
: propagate-<tuple-boa> ( #call -- info )
|
||||
: propagate-<tuple-boa> ( #call -- infos )
|
||||
in-d>> unclip-last
|
||||
value-info literal>> first (propagate-tuple-constructor) ;
|
||||
|
||||
: propagate-<complex> ( #call -- info )
|
||||
in-d>> [ value-info ] map complex <tuple-info> ;
|
||||
|
||||
: propagate-tuple-constructor ( #call word -- infos )
|
||||
{
|
||||
{ \ <tuple-boa> [ propagate-<tuple-boa> ] }
|
||||
{ \ <complex> [ propagate-<complex> ] }
|
||||
} case 1array ;
|
||||
value-info literal>> first (propagate-tuple-constructor) 1array ;
|
||||
|
||||
: read-only-slot? ( n class -- ? )
|
||||
all-slots [ offset>> = ] with find nip
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
[ <complex> <complex> dup 1 slot drop 2 slot drop ]
|
||||
[ 1 cons boa over [ "A" throw ] when car>> ]
|
||||
[ [ <=> ] sort ]
|
||||
[ [ <=> ] with search ]
|
||||
|
|
|
|||
|
|
@ -36,9 +36,6 @@ M: #push unbox-tuples* ( #push -- nodes )
|
|||
: unbox-<tuple-boa> ( #call -- nodes )
|
||||
dup unbox-output? [ in-d>> 1 tail* #drop ] when ;
|
||||
|
||||
: unbox-<complex> ( #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>> {
|
||||
{ \ <tuple-boa> [ unbox-<tuple-boa> ] }
|
||||
{ \ <complex> [ unbox-<complex> ] }
|
||||
{ \ slot [ unbox-slot-access ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -25,7 +25,3 @@ HELP: complex
|
|||
{ $class-description "The class of complex numbers with non-zero imaginary part." } ;
|
||||
|
||||
ABOUT: "complex-numbers"
|
||||
|
||||
HELP: <complex> ( 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." } ;
|
||||
|
|
|
|||
|
|
@ -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/ ;
|
||||
|
|
|
|||
|
|
@ -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" } "." } ;
|
||||
|
|
|
|||
|
|
@ -7,19 +7,8 @@ IN: math.functions
|
|||
: >fraction ( a/b -- a b )
|
||||
[ numerator ] [ denominator ] bi ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (rect>) ( x y -- z )
|
||||
dup 0 = [ drop ] [ <complex> ] 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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: <ratio> ( 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." } ;
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ IN: math.ratios
|
|||
<PRIVATE
|
||||
|
||||
: fraction> ( a b -- a/b )
|
||||
dup 1 number= [ drop ] [ <ratio> ] 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
|
||||
|
|
|
|||
|
|
@ -286,9 +286,6 @@ M: object infer-call*
|
|||
\ bignum>float { bignum } { float } define-primitive
|
||||
\ bignum>float make-foldable
|
||||
|
||||
\ <ratio> { integer integer } { ratio } define-primitive
|
||||
\ <ratio> 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
|
||||
|
||||
\ <complex> { real real } { complex } define-primitive
|
||||
\ <complex> make-foldable
|
||||
|
||||
\ both-fixnums? { object object } { object } define-primitive
|
||||
|
||||
\ fixnum+ { fixnum fixnum } { integer } define-primitive
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )) }
|
||||
{ "<ratio>" "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 )) }
|
||||
{ "<complex>" "math.private" (( x y -- z )) }
|
||||
{ "fixnum+" "math.private" (( x y -- z )) }
|
||||
{ "fixnum-" "math.private" (( x y -- z )) }
|
||||
{ "fixnum*" "math.private" (( x y -- z )) }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ;
|
||||
|
||||
: math-precedence ( class -- pair )
|
||||
{
|
||||
{ [ dup null class<= ] [ drop { -1 -1 } ] }
|
||||
{ [ dup math-class? ] [ class-types last/first ] }
|
||||
[ drop { 100 100 } ]
|
||||
} cond ;
|
||||
|
||||
: math-class<=> ( 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 ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: applicable-method ( generic class -- quot )
|
||||
over method
|
||||
[ 1quotation ]
|
||||
[ default-math-method ] ?if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: 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
|
||||
<PRIVATE
|
||||
|
||||
: math-vtable ( picker quot -- quot )
|
||||
[
|
||||
[ , \ tag , ]
|
||||
[ num-tags get swap [ bootstrap-type>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? ;
|
||||
|
|
|
|||
|
|
@ -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 -- ? )
|
||||
|
|
|
|||
47
vm/arrays.c
47
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);
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
36
vm/layouts.h
36
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;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
22
vm/math.c
22
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));
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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,
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
2
vm/run.c
2
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;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
13
vm/run.h
13
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);
|
||||
|
|
|
|||
70
vm/strings.c
70
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)
|
||||
|
|
|
|||
|
|
@ -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;
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue