From c82e2b032d9919ae72b5336ca5ec8d6e9d97ebf1 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 19 Dec 2004 01:24:46 +0000 Subject: [PATCH] marginally faster generic arithmetic --- library/compiler/generator-x86.factor | 28 ++++++++++++ library/compiler/linearizer.factor | 16 +------ library/compiler/simplifier.factor | 39 +++++++++------- library/kernel.factor | 2 +- library/primitives.factor | 2 +- library/test/compiler/simplifier.factor | 18 ++++++++ native/arithmetic.c | 59 ++++++++++++++++--------- native/arithmetic.h | 1 - native/bignum.c | 4 +- native/bignum.h | 7 ++- native/float.c | 14 ++++-- 11 files changed, 129 insertions(+), 61 deletions(-) diff --git a/library/compiler/generator-x86.factor b/library/compiler/generator-x86.factor index 577a48e340..dde3906967 100644 --- a/library/compiler/generator-x86.factor +++ b/library/compiler/generator-x86.factor @@ -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 diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor index 41451106eb..cdeecd9c08 100644 --- a/library/compiler/linearizer.factor +++ b/library/compiler/linearizer.factor @@ -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 diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor index 93bf71c7d6..a531e64445 100644 --- a/library/compiler/simplifier.factor +++ b/library/compiler/simplifier.factor @@ -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 diff --git a/library/kernel.factor b/library/kernel.factor index 99aeaf52c4..8a0fe0020e 100644 --- a/library/kernel.factor +++ b/library/kernel.factor @@ -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. diff --git a/library/primitives.factor b/library/primitives.factor index ebd94178a6..a483824306 100644 --- a/library/primitives.factor +++ b/library/primitives.factor @@ -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 ] ] diff --git a/library/test/compiler/simplifier.factor b/library/test/compiler/simplifier.factor index 222e94f10b..a1ed0ce704 100644 --- a/library/test/compiler/simplifier.factor +++ b/library/test/compiler/simplifier.factor @@ -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 diff --git a/native/arithmetic.c b/native/arithmetic.c index da1243c889..b1cf55f819 100644 --- a/native/arithmetic.c +++ b/native/arithmetic.c @@ -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) diff --git a/native/arithmetic.h b/native/arithmetic.h index 840810d54a..8aa16028fb 100644 --- a/native/arithmetic.h +++ b/native/arithmetic.h @@ -1,6 +1,5 @@ #include "factor.h" -CELL arithmetic_type(CELL obj1, CELL obj2); void primitive_arithmetic_type(void); bool realp(CELL tagged); diff --git a/native/bignum.c b/native/bignum.c index 2176b112f4..f40988497e 100644 --- a/native/bignum.c +++ b/native/bignum.c @@ -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) { diff --git a/native/bignum.h b/native/bignum.h index 4bbc7f21e9..b884fec7cc 100644 --- a/native/bignum.h +++ b/native/bignum.h @@ -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); diff --git a/native/float.c b/native/float.c index f1e6fe17c4..4d90e82681 100644 --- a/native/float.c +++ b/native/float.c @@ -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)))); }