simple labels optimization

Makefile

@@ -3,7 +3,7 @@ ifdef DEBUG
 	DEFAULT_CFLAGS = -g
 	STRIP = touch
 else
-	DEFAULT_CFLAGS = -Wall -O3 -fomit-frame-pointer $(SITE_CFLAGS)
+	DEFAULT_CFLAGS = -Wall -O3 -ffast-math -fomit-frame-pointer $(SITE_CFLAGS)
 	STRIP = strip
 endif
 

library/compiler/linearizer.factor

@@ -5,13 +5,19 @@ USING: compiler-backend errors generic lists inference kernel
 math namespaces prettyprint sequences
 strings words ;
 
+SYMBOL: simple-labels
+
 GENERIC: linearize* ( node -- )
 
 : linearize ( dataflow -- linear )
     #! Transform dataflow IR into linear IR. This strips out
     #! stack flow information, and flattens conditionals into
     #! jumps and labels.
-    [ %prologue , linearize* ] { } make ;
+    [
+        { } clone simple-labels set
+        %prologue ,
+        linearize*
+    ] { } make ;
 
 : linearize-next node-successor linearize* ;
 
@@ -19,12 +25,26 @@ M: f linearize* ( f -- ) drop ;
 
 M: node linearize* ( node -- ) linearize-next ;
 
+: simple-label? ( #label -- ? )
+    #! A simple label only contains tail calls to itself.
+    dup node-param swap node-child [
+        dup #call-label? [
+            [ node-param = not ] keep node-successor #return? or
+        ] [
+            2drop t
+        ] ifte
+    ] all-nodes-with? ;
+
+: simple-label ( #label -- )
+    dup node-param %label , node-child linearize* ;
+
 M: #label linearize* ( node -- )
-    <label> dup %return-to , >r
+    dup simple-label? [
-    dup node-param %label ,
+        dup node-param simple-labels get push
-    dup node-child linearize*
+        dup simple-label
-    r> %label ,
+    ] [
-    linearize-next ;
+        dup <label> [ %return-to , simple-label ] keep %label ,
+    ] ifte linearize-next ;
 
 : ?tail-call ( node caller jumper -- next )
     >r >r dup node-successor #return? [
@@ -82,4 +102,8 @@ M: #dispatch linearize* ( vtable -- )
     node-children dispatch-head dispatch-body ;
 
 M: #return linearize* ( node -- )
-    drop f %return , ;
+    #! Simple label returns do not count, since simple labels do
+    #! not push a stack frame on the C stack.
+    dup node-param simple-labels get memq? [
+        f %return ,
+    ] unless drop ;

library/inference/words.factor

@@ -31,17 +31,21 @@ hashtables parser prettyprint ;
     " was already attempted, and failed" append3
     inference-error ;
 
-: with-block ( word [[ label quot ]] quot -- block-node )
+: with-recursive-state ( word label quot -- )
-    #! Execute a quotation with the word on the stack, and add
+    >r over word-def cons cons
-    #! its dataflow contribution to a new #label node in the IR.
+    recursive-state [ cons ] change r>
-    >r 2dup cons recursive-state [ cons ] change r>
+    call
-    [ swap car #label slip ] with-nesting
     recursive-state [ cdr ] change ; inline
 
 : inline-block ( word -- node-block )
-    gensym over word-def cons [
+    gensym 2dup [
-        #entry node,  word-def infer-quot  t #return node,
+        [
-    ] with-block ;
+            dup #label >r
+            #entry node,
+            swap word-def infer-quot
+            #return node, r>
+        ] with-nesting
+    ] with-recursive-state ;
 
 : infer-compound ( word base-case -- effect )
     #! Infer a word's stack effect in a separate inferencer

library/math/complex.factor

@@ -12,8 +12,10 @@ IN: math
 
 UNION: number real complex ;
 
-M: real real ;
+! These should be defined on real, not object, but real? is
-M: real imaginary drop 0 ;
+! expensive.
+M: object real ;
+M: object imaginary drop 0 ;
 
 M: number = ( n n -- ? ) number= ;
 

native/float.c

@@ -1,12 +1,5 @@
 #include "factor.h"
 
-F_FLOAT* make_float(double n)
-{
-	F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
-	flo->n = n;
-	return flo;
-}
-
 double to_float(CELL tagged)
 {
 	F_RATIO* r;

native/float.h

@@ -3,7 +3,12 @@ typedef struct {
 	double n;
 } F_FLOAT;
 
-F_FLOAT* make_float(double n);
+INLINE F_FLOAT* make_float(double n)
+{
+	F_FLOAT* flo = allot_object(FLOAT_TYPE,sizeof(F_FLOAT));
+	flo->n = n;
+	return flo;
+}
 
 INLINE double untag_float_fast(CELL tagged)
 {