compiler does tail call optimization

diff --git a/library/compiler/linearizer.factor b/library/compiler/linearizer.factor
index 2198c80490a3e96e3285216bed8c04fe5c8667c9..41451106eb1963fcee1bc44a74e10d771ba97e60 100644 (file)
--- 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 d1aa097c7571d79dcc79789da1941822d50aa174..93bf71c7d63f542f039188a5d5e047ce21149877 100644 (file)
--- 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 135ad5aac61036199f740a11c6c0442cb2205428..c9eb24ed22e0f86fdcb90bfbe5766493dd4cc9d8 100644 (file)
--- 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 1af33514eb1608c1cae3a931ffb642bc04916506..c72c123d3d70d8f935b46145d6de4d658780fefc 100644 (file)
--- 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 373dee8c7412cc6fcb14702d2e3432a5b6215743..528e28cd1b0a61dc7793e24db68a848e50e51e8b 100644 (file)
--- 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 6978260664f87fec5f62c173f99b27fa2064d5b0..986387bab21773c43df9ec810ab6a42064a29eef 100644 (file)
--- 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 5060d19f20915f825f2da50dad3989a243728abd..80de85a7ae8fc983697a2cb63686cc0377017d19 100644 (file)
--- 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 7fed469a33dbd1ab20ba91ab68a4df6181e2196c..222e94f10b9eb11699743da472b9c530682b31c4 100644 (file)
--- 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 0c8af6e0199b0eaf0591ab93ade5c99f3ab0f9a7..26620bbb3d5bc06b53e7f1b10581514cdd9217de 100644 (file)
--- 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 eeb93eea0df36b62f0483d251fa31c22ac3a574b..8fced0fc5e01de67db177e4acfb349191fab0638 100644 (file)
--- 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 2bbf947eb78e8083333d4107502d334d81ee3bfc..3d02a45543ff2fddd8919b04f02a8f6c32a20f19 100644 (file)
--- 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)