marginally faster generic arithmetic

diff --git a/library/compiler/generator-x86.factor b/library/compiler/generator-x86.factor
index 577a48e3408433d341b865e1195e45148c5d5d12..dde390696788237dd0dcfd9704d12eb61d70a44a 100644 (file)
--- 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 41451106eb1963fcee1bc44a74e10d771ba97e60..cdeecd9c08636fe2b6b44f91ea651a972c28fea8 100644 (file)
--- 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 93bf71c7d63f542f039188a5d5e047ce21149877..a531e644450ee53f7c1b0d5314a067ff3f09bc92 100644 (file)
--- 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 99aeaf52c4134cddb248100018268157597f926c..8a0fe0020e45e17bfe402ec8467a304649f1b5d0 100644 (file)
--- 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 ebd94178a61af5238b3929e1ebe5b4daf2d324bb..a4838243068246bf66ef6f77141eba2f7e59b193 100644 (file)
--- 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 222e94f10b9eb11699743da472b9c530682b31c4..a1ed0ce7047d0e82d5ab205577f04dbf7970dd26 100644 (file)
--- 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 da1243c8896b1c30484e088f7eb1009706aded5e..b1cf55f819757b1fd5e4638d0bb1295e7d69390d 100644 (file)
--- 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 840810d54ae2eb6deee5f3407a7e3d7dbdaecd5c..8aa16028fb008ef633510f7ec7cd96ecf7f17898 100644 (file)
--- 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 2176b112f43d42c0ebb0df99a0c1d427a2127433..f40988497e32db7af219bfccbd7212c813ad3b6a 100644 (file)
--- 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 4bbc7f21e91b2defcc523e09f052bcbe69266fe5..b884fec7ccb2ac6ff3575d60e2a21e06fe716dcc 100644 (file)
--- 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 f1e6fe17c4459b716d9c5fc3563ed25385cea56a..4d90e8268189e3744e1f5897c6e89560f9d1afc9 100644 (file)
--- 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))));
 }