marginally faster generic arithmetic

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

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

library/compiler/simplifier.factor

@@ -71,11 +71,7 @@ USE: words
     ] ifte ;
 
 : simplify-node ( node rest -- rest ? )
-    over car "simplify" word-property [
+    over car "simplify" [ swap , f ] singleton ;
-        call
-    ] [
-        swap , f
-    ] ifte* ;
 
 : 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 [
+    dup car car "follow" [ ] singleton ;
-        call
-    ] [
-        drop
-    ] ifte ;
 
 #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 ? )
+GENERIC: simplify-call ( node rest -- rest ? )
-M: cons call-simplifier ( node 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 [ simplify-call ] "simplify" set-word-property
-#call-label [ call-simplifier ] "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

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.

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

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

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)
-	{
-	case FIXNUM_TYPE:
-		type = type2;
-		break;
-	case BIGNUM_TYPE:
 	switch(type2)
 	{
 	case FIXNUM_TYPE:
+		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(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 = type2;
+			break;
+		default:
 			type = type1;
 			break;
+		}
+		break;
 	default:
 		type = type2;
 		break;
 	}
-		break;
-	default:
-		type = type1;
-		break;
-	}
 
-	return type;
+	dpush(tag_fixnum(type));
-}
-
-void primitive_arithmetic_type(void)
-{
-	CELL obj2 = dpop();
-	CELL obj1 = dpop();
-	dpush(tag_fixnum(arithmetic_type(obj1,obj2)));
 }
 
 bool realp(CELL tagged)

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

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()); \
+	y = untag_bignum_fast(dpop()); \
-	x = to_bignum(dpop());
+	x = untag_bignum_fast(dpop());
 
 void primitive_bignum_add(void)
 {

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

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()); \
+	y = untag_float_fast(dpop()); \
-	x = to_float(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))));
 }