From a2717958f05e30a176fc7a8ec1098443fd8b114e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sat, 18 Dec 2004 00:27:42 +0000
Subject: [PATCH] compiler does tail call optimization

---
 library/compiler/linearizer.factor       |  6 +++--
 library/compiler/simplifier.factor       | 31 +++++++++++++++++++++---
 library/test/benchmark/empty-loop.factor |  4 +--
 library/test/benchmark/fac.factor        |  6 ++++-
 library/test/benchmark/hashtables.factor |  7 +++---
 library/test/benchmark/strings.factor    |  5 ++--
 library/test/benchmark/vectors.factor    |  8 +++---
 library/test/compiler/simplifier.factor  | 29 +++++++++++++++++++++-
 library/test/crashes.factor              |  2 ++
 library/test/test.factor                 |  1 +
 native/types.h                           |  4 +--
 11 files changed, 82 insertions(+), 21 deletions(-)

diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 2198c80490..41451106eb 100644
--- a/library/compiler/linearizer.factor
+++ b/library/compiler/linearizer.factor
@@ -129,7 +129,7 @@ SYMBOL: #target ( part of jump table )
     <label> [
         #jump-t swons ,
         (linearize) ( false branch )
-        <label> dup #jump swons ,
+        <label> dup #jump-label swons ,
     ] keep label, ( branch target of BRANCH-T )
     swap (linearize) ( true branch )
     label, ( branch target of false branch end ) ;
@@ -147,7 +147,9 @@ SYMBOL: #target ( part of jump table )
 
 : dispatch-body ( end label/param -- )
     #! Output each branch, with a jump to the end label.
-    [ uncons label, (linearize) dup #jump swons , ] each drop ;
+    [
+        uncons label, (linearize) dup #jump-label swons ,
+    ] each drop ;
 
 : check-dispatch ( vtable -- )
     length num-types = [
diff --git a/library/compiler/simplifier.factor b/library/compiler/simplifier.factor
index d1aa097c75..93bf71c7d6 100644
--- a/library/compiler/simplifier.factor
+++ b/library/compiler/simplifier.factor
@@ -63,8 +63,15 @@ USE: words
         ] each drop
     ] make-list ;
 
+: singleton ( word op default -- )
+    >r word-property dup [
+        r> drop call
+    ] [
+        drop r> call
+    ] ifte ;
+
 : simplify-node ( node rest -- rest ? )
-    over car "simplifier" word-property [
+    over car "simplify" word-property [
         call
     ] [
         swap , f
@@ -79,7 +86,23 @@ USE: words
 : simplify ( linear -- linear )
     purge-labels [ (simplify) ] make-list ;
 
-: follows? ( op list -- ? ) dup [ car car = ] [ 2drop f ] ifte ;
+: follow ( linear -- linear )
+    dup car car "follow" word-property dup [
+        call
+    ] [
+        drop
+    ] ifte ;
+
+#label [
+    cdr follow
+] "follow" set-word-property
+
+#jump-label [
+    uncons >r cdr r> find-label follow
+] "follow" set-word-property
+
+: follows? ( op linear -- ? )
+    follow dup [ car car = ] [ 2drop f ] ifte ;
 
 GENERIC: call-simplifier ( node rest -- rest ? )
 M: cons call-simplifier ( node rest -- ? )
@@ -93,5 +116,5 @@ M: return-follows call-simplifier ( node rest -- rest ? )
         [ #call-label | #jump-label ]
     ] assoc swons , r> t ;
 
-#call [ call-simplifier ] "simplifier" set-word-property
-#call-label [ call-simplifier ] "simplifier" set-word-property
+#call [ call-simplifier ] "simplify" set-word-property
+#call-label [ call-simplifier ] "simplify" set-word-property
diff --git a/library/test/benchmark/empty-loop.factor b/library/test/benchmark/empty-loop.factor
index 135ad5aac6..c9eb24ed22 100644
--- a/library/test/benchmark/empty-loop.factor
+++ b/library/test/benchmark/empty-loop.factor
@@ -5,10 +5,10 @@ USE: math
 USE: test
 
 : empty-loop-1 ( n -- )
-    [ ] times ;
+    [ ] times ; compiled
 
 : empty-loop-2 ( n -- )
-    [ drop ] times* ;
+    [ drop ] times* ; compiled
 
 [ ] [ 5000000 empty-loop-1 ] unit-test
 [ ] [ 5000000 empty-loop-2 ] unit-test
diff --git a/library/test/benchmark/fac.factor b/library/test/benchmark/fac.factor
index 1af33514eb..c72c123d3d 100644
--- a/library/test/benchmark/fac.factor
+++ b/library/test/benchmark/fac.factor
@@ -1,5 +1,9 @@
 IN: scratchpad
 USE: math
 USE: test
+USE: compiler
 
-[ 1 ] [ 10000 fac 10000 [ succ / ] times* ] unit-test
+: fac-benchmark
+    10000 fac 10000 [ succ / ] times* ; compiled
+
+[ 1 ] [ fac-benchmark ] unit-test
diff --git a/library/test/benchmark/hashtables.factor b/library/test/benchmark/hashtables.factor
index 373dee8c74..528e28cd1b 100644
--- a/library/test/benchmark/hashtables.factor
+++ b/library/test/benchmark/hashtables.factor
@@ -4,16 +4,17 @@ USE: math
 USE: test
 USE: unparser
 USE: hashtables
+USE: compiler
 
 ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
 
 : store-hash ( hashtable n -- )
-    [ dup >hex swap pick set-hash ] times* drop ;
+    [ dup >hex swap pick set-hash ] times* drop ; compiled
 
 : lookup-hash ( hashtable n -- )
-    [ unparse over hash drop ] times* drop ;
+    [ unparse over hash drop ] times* drop ; compiled
 
 : hashtable-benchmark ( n -- )
-    60000 <hashtable> swap 2dup store-hash lookup-hash ;
+    60000 <hashtable> swap 2dup store-hash lookup-hash ; compiled
 
 [ ] [ 80000 hashtable-benchmark ] unit-test
diff --git a/library/test/benchmark/strings.factor b/library/test/benchmark/strings.factor
index 6978260664..986387bab2 100644
--- a/library/test/benchmark/strings.factor
+++ b/library/test/benchmark/strings.factor
@@ -3,6 +3,7 @@ USE: kernel
 USE: math
 USE: test
 USE: lists
+USE: compiler
 
 ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
 
@@ -14,9 +15,9 @@ USE: lists
         string-step
     ] [
         2drop
-    ] ifte ;
+    ] ifte ; compiled
 
 : string-benchmark ( n -- )
-    "abcdef" 10 [ 2dup string-step ] times 2drop ;
+    "abcdef" 10 [ 2dup string-step ] times 2drop ; compiled
 
 [ ] [ 1000000 string-benchmark ] unit-test
diff --git a/library/test/benchmark/vectors.factor b/library/test/benchmark/vectors.factor
index 5060d19f20..80de85a7ae 100644
--- a/library/test/benchmark/vectors.factor
+++ b/library/test/benchmark/vectors.factor
@@ -7,17 +7,17 @@ USE: test
 ! http://inferno.bell-labs.com/cm/cs/who/bwk/interps/pap.html
 
 : fill-vector ( n -- vector )
-    dup <vector> swap [ dup pick set-vector-nth ] times* ;
+    dup <vector> swap [ dup pick set-vector-nth ] times* ; compiled
 
 : copy-elt ( vec-y vec-x n -- )
     #! Copy nth element from vec-x to vec-y.
-    rot >r tuck >r vector-nth r> r> set-vector-nth ;
+    rot >r tuck >r vector-nth r> r> set-vector-nth ; compiled
 
 : copy-vector ( vec-y vec-x n -- )
     #! Copy first n-1 elements from vec-x to vec-y.
-    [ >r 2dup r> copy-elt ] times* 2drop ;
+    [ >r 2dup r> copy-elt ] times* 2drop ; compiled
 
 : vector-benchmark ( n -- )
-    0 <vector> over fill-vector rot copy-vector ; ! compiled
+    0 <vector> over fill-vector rot copy-vector ; compiled
 
 [ ] [ 4000000 vector-benchmark ] unit-test
diff --git a/library/test/compiler/simplifier.factor b/library/test/compiler/simplifier.factor
index 7fed469a33..222e94f10b 100644
--- a/library/test/compiler/simplifier.factor
+++ b/library/test/compiler/simplifier.factor
@@ -6,8 +6,35 @@ USE: lists
 
 [ [ ] ] [ [ ] simplify ] unit-test
 [ [ [ #return ] ] ] [ [ [ #return ] ] simplify ] unit-test
-[ [ [ #jump | car ] ] ] [ [ [ #call | car ] [ #return ] ] simplify ] unit-test
+[ [ #jump | car ] ] [ [ [ #call | car ] [ #return ] ] simplify car ] unit-test
 
 [ [ [ #return ] ] ]
 [ 123 [ [ #call | car ] [ #label | 123 ] [ #return ] ] find-label ]
 unit-test
+
+[ [ [ #return ] ] ]
+[ [ [ #label | 123 ] [ #return ] ] follow ]
+unit-test
+
+[ [ [ #return ] ] ]
+[
+    [
+        [ #jump-label | 123 ]
+        [ #call | car ]
+        [ #label | 123 ]
+        [ #return ]
+    ] follow
+]
+unit-test
+
+[
+    [ #jump | car ]
+]
+[
+    [
+        [ #call | car ]
+        [ #jump-label | 123 ]
+        [ #label | 123 ]
+        [ #return ]
+    ] simplify car
+] unit-test
diff --git a/library/test/crashes.factor b/library/test/crashes.factor
index 0c8af6e019..26620bbb3d 100644
--- a/library/test/crashes.factor
+++ b/library/test/crashes.factor
@@ -54,3 +54,5 @@ USE: lists
 ! See how well callstack overflow is handled
 : callstack-overflow callstack-overflow f ;
 [ callstack-overflow ] unit-test-fails
+
+[ [ cdr cons ] word-plist ] unit-test-fails
diff --git a/library/test/test.factor b/library/test/test.factor
index eeb93eea0d..8fced0fc5e 100644
--- a/library/test/test.factor
+++ b/library/test/test.factor
@@ -119,6 +119,7 @@ USE: unparser
     cpu "x86" = [
         [
             "compiler/optimizer"
+            "compiler/simplifier"
             "compiler/simple"
             "compiler/stack"
             "compiler/ifte"
diff --git a/native/types.h b/native/types.h
index 2bbf947eb7..3d02a45543 100644
--- a/native/types.h
+++ b/native/types.h
@@ -51,7 +51,7 @@ INLINE CELL tag_header(CELL cell)
 	return RETAG(cell << TAG_BITS,HEADER_TYPE);
 }
 
-#define HEADER_DEBUG
+/* #define HEADER_DEBUG */
 
 INLINE CELL untag_header(CELL cell)
 {
@@ -80,7 +80,7 @@ INLINE void type_check(CELL type, CELL tagged)
 	if(type < HEADER_TYPE)
 	{
 #ifdef HEADER_DEBUG
-		if(type == WORD_TYPE && object_type(tagged) != WORD_TYPE)
+		if(TAG(tagged) == WORD_TYPE && object_type(tagged) != WORD_TYPE)
 			critical_error("word header check",tagged);
 #endif
 		if(TAG(tagged) == type)