steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

faster generic arithmetic, messing around with inference

cvs
Slava Pestov 2005-01-16 22:58:28 +00:00
parent 8247cc5ff4
commit b5801f45dd
31 changed files with 230 additions and 253 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
library/bootstrap/boot-stage2.factor
View File

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

3
library/bootstrap/boot.factor
View File

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

13
library/bootstrap/image.factor
View File

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

4
library/compiler/x86/assembler.factor
View File

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

19
library/compiler/x86/fixnum.factor
View File

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

7
library/generic/builtin.factor
View File

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

12
library/generic/generic.factor
View File

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

39
library/generic/null.factor Normal file
View File

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

22
library/inference/branches.factor
View File

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

8
library/inference/inference.factor
View File

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

2
library/inference/stack.factor
View File

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

48
library/inference/words.factor
View File

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

9
library/kernel.factor
View File

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

8
library/math/math.factor
View File

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

102
library/test/compiler/generic.factor
View File

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

2
library/test/generic.factor
View File

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

10
library/test/inference.factor
View File

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

3
library/test/math/complex.factor
View File

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

18
native/arithmetic.c
View File

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

32
native/bignum.c
View File

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

9
native/bignum.h
View File

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

8
native/fixnum.c
View File

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

36
native/float.c
View File

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

5
native/float.h
View File

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

2
native/gc.c
View File

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

2
native/memory.c
View File

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

4
native/misc.c
View File

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

6
native/types.c
View File

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

45
native/types.h
View File

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

2
native/unix/file.c
View File

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

2
native/win32/file.c
View File

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