From 0402790001bdf34f639c0c78c8cbd89c2c1ec2ad Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 30 Jun 2009 21:21:46 -0500
Subject: [PATCH] compiler.cfg Remove height tracking for ##call instructions,
 wire in ##no-tco instruction

---
 basis/compiler/cfg/builder/builder.factor       | 17 +++++++----------
 .../cfg/instructions/instructions.factor        |  5 ++++-
 .../cfg/stack-analysis/stack-analysis.factor    |  3 ++-
 basis/compiler/cfg/utilities/utilities.factor   |  5 +----
 basis/compiler/codegen/codegen.factor           |  2 ++
 5 files changed, 16 insertions(+), 16 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 265643f3d7..7b7adf848e 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -72,18 +72,15 @@ GENERIC: emit-node ( node -- )
     basic-block get successors>> push
     basic-block off ;
 
-: emit-call ( word height -- )
-    over loops get key?
-    [ drop loops get at local-recursive-call ]
+: emit-call ( word -- )
+    dup loops get key?
+    [ loops get at local-recursive-call ]
     [ ##call ##branch begin-basic-block ]
     if ;
 
 ! #recursive
-: recursive-height ( #recursive -- n )
-    [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
-
 : emit-recursive ( #recursive -- )
-    [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
+    [ label>> id>> emit-call ]
     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
 
 : remember-loop ( label -- )
@@ -152,10 +149,10 @@ M: #dispatch emit-node
 ! #call
 M: #call emit-node
     dup word>> dup "intrinsic" word-prop
-    [ emit-intrinsic ] [ swap call-height emit-call ] if ;
+    [ emit-intrinsic ] [ nip emit-call ] if ;
 
 ! #call-recursive
-M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
+M: #call-recursive emit-node label>> id>> emit-call ;
 
 ! #push
 M: #push emit-node
@@ -180,7 +177,7 @@ M: #return-recursive emit-node
     [ ##epilogue ##return ] unless ;
 
 ! #terminate
-M: #terminate emit-node drop ;
+M: #terminate emit-node drop ##no-tco ;
 
 ! FFI
 : return-size ( ctype -- n )
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 4ce9c59e7e..17a02175d5 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -53,10 +53,13 @@ INSN: ##inc-r { n integer } ;
 
 ! Subroutine calls
 INSN: ##stack-frame stack-frame ;
-INSN: ##call word { height integer } ;
+INSN: ##call word ;
 INSN: ##jump word ;
 INSN: ##return ;
 
+! Dummy instruction that simply inhibits TCO
+INSN: ##no-tco ;
+
 ! Jump tables
 INSN: ##dispatch src temp ;
 
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 1e7f33c7e0..fb71fe332d 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -48,7 +48,8 @@ M: ##inc-r visit
 ! Instructions which don't have any effect on the stack
 UNION: neutral-insn
     ##effect
-    ##flushable ;
+    ##flushable
+    ##no-tco ;
 
 M: neutral-insn visit , ;
 
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index e415008808..99a138a763 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -35,8 +35,5 @@ IN: compiler.cfg.utilities
 
 : stop-iterating ( -- next ) end-basic-block f ;
 
-: call-height ( ##call -- n )
-    [ out-d>> length ] [ in-d>> length ] bi - ;
-
 : emit-primitive ( node -- )
-    [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
+    word>> ##call ##branch begin-basic-block ;
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index a1583d2a5d..df6e91aec9 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -67,6 +67,8 @@ SYMBOL: labels
 : lookup-label ( id -- label )
     labels get [ drop <label> ] cache ;
 
+M: ##no-tco generate-insn drop ;
+
 M: ##load-immediate generate-insn
     [ dst>> register ] [ val>> ] bi %load-immediate ;