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

marginally faster generic arithmetic

cvs
Slava Pestov 2004-12-19 01:24:46 +00:00
parent 3bdca9dede
commit c82e2b032d
11 changed files with 129 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
library/compiler/generator-x86.factor
View File

@ -31,6 +31,7 @@ USE: inference
USE: kernel
USE: namespaces
USE: words
USE: lists
: DS ( -- address ) "ds" dlsym-self ;
@ -56,6 +57,19 @@ USE: words
ECX DS R>[I]
] "generator" set-word-property
#replace-immediate [
DS ECX [I]>R
address ECX I>[R]
ECX DS R>[I]
] "generator" set-word-property
#replace-indirect [
DS ECX [I]>R
intern-literal EAX [I]>R
EAX ECX R>[R]
ECX DS R>[I]
] "generator" set-word-property
#call [
dup postpone-word
CALL compiled-offset defer-xt
@ -122,3 +136,17 @@ USE: words
#cleanup [
dup 0 = [ drop ] [ ESP R+I ] ifte
] "generator" set-word-property
[
[ #drop drop ]
[ #dup dup ]
[ #swap swap ]
[ #over over ]
[ #pick pick ]
[ #>r >r ]
[ #r> r> ]
] [
uncons
[ car CALL compiled-offset defer-xt drop ] cons
"generator" set-word-property
] each

16
library/compiler/linearizer.factor
View File

@ -44,6 +44,8 @@ USE: errors
SYMBOL: #push-immediate
SYMBOL: #push-indirect
SYMBOL: #replace-immediate
SYMBOL: #replace-indirect
SYMBOL: #jump-t ( branch if top of stack is true )
SYMBOL: #jump ( tail-call )
SYMBOL: #jump-label ( tail-call )
@ -166,17 +168,3 @@ SYMBOL: #target ( part of jump table )
] "linearizer" set-word-property
#values [ drop ] "linearizer" set-word-property
[
[ #drop drop ]
[ #dup dup ]
[ #swap swap ]
[ #over over ]
[ #pick pick ]
[ #>r >r ]
[ #r> r> ]
] [
uncons
[ car #call swons , drop ] cons
"linearizer" set-word-property
] each

39
library/compiler/simplifier.factor
View File

@ -71,11 +71,7 @@ USE: words
] ifte ;
: simplify-node ( node rest -- rest ? )
over car "simplify" word-property [
call
] [
swap , f
] ifte* ;
over car "simplify" [ swap , f ] singleton ;
: find-label ( label linear -- rest )
[ cdr over = ] some? cdr nip ;
@ -87,11 +83,7 @@ USE: words
purge-labels [ (simplify) ] make-list ;
: follow ( linear -- linear )
dup car car "follow" word-property dup [
call
] [
drop
] ifte ;
dup car car "follow" [ ] singleton ;
#label [
cdr follow
@ -104,17 +96,34 @@ USE: words
: follows? ( op linear -- ? )
follow dup [ car car = ] [ 2drop f ] ifte ;
GENERIC: call-simplifier ( node rest -- rest ? )
M: cons call-simplifier ( node rest -- ? )
GENERIC: simplify-call ( node rest -- rest ? )
M: cons simplify-call ( node rest -- rest ? )
swap , f ;
PREDICATE: cons return-follows #return swap follows? ;
M: return-follows call-simplifier ( node rest -- rest ? )
M: return-follows simplify-call ( node rest -- rest ? )
>r
unswons [
[ #call | #jump ]
[ #call-label | #jump-label ]
] assoc swons , r> t ;
#call [ call-simplifier ] "simplify" set-word-property
#call-label [ call-simplifier ] "simplify" set-word-property
#call [ simplify-call ] "simplify" set-word-property
#call-label [ simplify-call ] "simplify" set-word-property
GENERIC: simplify-drop ( node rest -- rest ? )
M: cons simplify-drop ( node rest -- rest ? )
swap , f ;
PREDICATE: cons push-next ( list -- ? )
dup [
car car [ #push-immediate #push-indirect ] contains?
] when ;
M: push-next simplify-drop ( node rest -- rest ? )
nip uncons >r unswons [
[ #push-immediate | #replace-immediate ]
[ #push-indirect | #replace-indirect ]
] assoc swons , r> t ;
#drop [ simplify-drop ] "simplify" set-word-property

2
library/kernel.factor
View File

@ -70,7 +70,7 @@ USE: vectors
>r dup type r> dispatch ; inline
: 2generic ( n n vtable -- )
>r 2dup arithmetic-type r> dispatch ; inline
>r arithmetic-type r> dispatch ; inline
: hashcode ( obj -- hash )
#! If two objects are =, they must have equal hashcodes.

2
library/primitives.factor
View File

@ -73,7 +73,7 @@ USE: words
[ sbuf-clone " sbuf -- sbuf " [ 1 | 1 ] ]
[ sbuf= " sbuf sbuf -- ? " [ 2 | 1 ] ]
[ sbuf-hashcode " sbuf -- n " [ 1 | 1 ] ]
[ arithmetic-type " n n -- type " [ 2 | 1 ] ]
[ arithmetic-type " n n -- type " [ 2 | 3 ] ]
[ number? " obj -- ? " [ 1 | 1 ] ]
[ >fixnum " n -- fixnum " [ 1 | 1 ] ]
[ >bignum " n -- bignum " [ 1 | 1 ] ]

18
library/test/compiler/simplifier.factor
View File

@ -3,6 +3,7 @@ USE: compiler
USE: test
USE: inference
USE: lists
USE: kernel
[ [ ] ] [ [ ] simplify ] unit-test
[ [ [ #return ] ] ] [ [ [ #return ] ] simplify ] unit-test
@ -38,3 +39,20 @@ unit-test
[ #return ]
] simplify car
] unit-test
[
t
] [
[
[ #push-immediate | 1 ]
] push-next? >boolean
] unit-test
[
[
[ #replace-immediate | 1 ]
[ #return ]
]
] [
[ drop 1 ] dataflow linearize simplify
] unit-test

59
native/arithmetic.c
View File

@ -1,80 +1,95 @@
#include "factor.h"
CELL arithmetic_type(CELL obj1, CELL obj2)
void primitive_arithmetic_type(void)
{
CELL obj1 = dpeek();
CELL obj2 = get(ds - CELLS);
CELL type1 = type_of(obj1);
CELL type2 = type_of(obj2);
CELL type;
switch(type1)
switch(type2)
{
case FIXNUM_TYPE:
type = type2;
switch(type1)
{
case BIGNUM_TYPE:
put(ds - CELLS,tag_object(to_bignum(obj2)));
break;
case FLOAT_TYPE:
put(ds - CELLS,tag_object(make_float(to_float((obj2)))));
break;
}
type = type1;
break;
case BIGNUM_TYPE:
switch(type2)
switch(type1)
{
case FIXNUM_TYPE:
drepl(tag_object(to_bignum(obj1)));
type = type2;
break;
case FLOAT_TYPE:
put(ds - CELLS,tag_object(make_float(to_float((obj2)))));
type = type1;
break;
default:
type = type2;
type = type1;
break;
}
break;
case RATIO_TYPE:
switch(type2)
switch(type1)
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
type = type2;
break;
case FLOAT_TYPE:
put(ds - CELLS,tag_object(make_float(to_float((obj2)))));
type = type1;
break;
default:
type = type2;
type = type1;
break;
}
break;
case FLOAT_TYPE:
switch(type2)
switch(type1)
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
case RATIO_TYPE:
type = type1;
drepl(tag_object(make_float(to_float(obj1))));
type = type2;
break;
default:
type = type2;
type = type1;
break;
}
break;
case COMPLEX_TYPE:
switch(type2)
switch(type1)
{
case FIXNUM_TYPE:
case BIGNUM_TYPE:
case RATIO_TYPE:
case FLOAT_TYPE:
type = type1;
type = type2;
break;
default:
type = type2;
type = type1;
break;
}
break;
default:
type = type1;
type = type2;
break;
}
return type;
}
void primitive_arithmetic_type(void)
{
CELL obj2 = dpop();
CELL obj1 = dpop();
dpush(tag_fixnum(arithmetic_type(obj1,obj2)));
dpush(tag_fixnum(type));
}
bool realp(CELL tagged)

1
native/arithmetic.h
View File

@ -1,6 +1,5 @@
#include "factor.h"
CELL arithmetic_type(CELL obj1, CELL obj2);
void primitive_arithmetic_type(void);
bool realp(CELL tagged);

4
native/bignum.c
View File

@ -81,8 +81,8 @@ void primitive_bignum_eq(void)
#define GC_AND_POP_BIGNUMS(x,y) \
F_ARRAY *x, *y; \
maybe_garbage_collection(); \
y = to_bignum(dpop()); \
x = to_bignum(dpop());
y = untag_bignum_fast(dpop()); \
x = untag_bignum_fast(dpop());
void primitive_bignum_add(void)
{

7
native/bignum.h
View File

@ -2,10 +2,15 @@ CELL bignum_zero;
CELL bignum_pos_one;
CELL bignum_neg_one;
INLINE F_ARRAY* untag_bignum_fast(CELL tagged)
{
return (F_ARRAY*)UNTAG(tagged);
}
INLINE F_ARRAY* untag_bignum(CELL tagged)
{
type_check(BIGNUM_TYPE,tagged);
return (F_ARRAY*)UNTAG(tagged);
return untag_bignum_fast(tagged);
}
F_FIXNUM to_integer(CELL x);

14
native/float.c
View File

@ -74,8 +74,8 @@ void primitive_float_to_bits(void)
#define GC_AND_POP_FLOATS(x,y) \
double x, y; \
maybe_garbage_collection(); \
y = to_float(dpop()); \
x = to_float(dpop());
y = untag_float_fast(dpop()); \
x = untag_float_fast(dpop());
void primitive_float_eq(void)
{
@ -151,7 +151,10 @@ void primitive_fatan(void)
void primitive_fatan2(void)
{
GC_AND_POP_FLOATS(x,y);
double x, y;
maybe_garbage_collection();
y = to_float(dpop());
x = to_float(dpop());
dpush(tag_object(make_float(atan2(x,y))));
}
@ -181,7 +184,10 @@ void primitive_flog(void)
void primitive_fpow(void)
{
GC_AND_POP_FLOATS(x,y);
double x, y;
maybe_garbage_collection();
y = to_float(dpop());
x = to_float(dpop());
dpush(tag_object(make_float(pow(x,y))));
}