From 605b37a9496665b28fee8b14e6977255b27d33ee Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 18 Jul 2009 23:08:53 -0500
Subject: [PATCH] compiler.cfg.builder: annotate calls with height changes,
 once again

---
 basis/compiler/cfg/builder/builder.factor         | 15 +++++++++------
 basis/compiler/cfg/dcn/height/height.factor       | 10 +++++-----
 .../compiler/cfg/instructions/instructions.factor |  2 +-
 .../compiler/cfg/intrinsics/fixnum/fixnum.factor  |  2 +-
 basis/compiler/cfg/utilities/utilities.factor     |  5 ++++-
 5 files changed, 20 insertions(+), 14 deletions(-)

diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor
index 2eff8b9e28..30c15b787f 100755
--- a/basis/compiler/cfg/builder/builder.factor
+++ b/basis/compiler/cfg/builder/builder.factor
@@ -63,15 +63,18 @@ GENERIC: emit-node ( node -- )
     basic-block get successors>> push
     basic-block off ;
 
-: emit-call ( word -- )
-    dup loops get key?
-    [ loops get at emit-loop-call ]
+: emit-call ( word height -- )
+    over loops get key?
+    [ drop loops get at emit-loop-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>> emit-call ]
+    [ [ label>> id>> ] [ recursive-height ] bi emit-call ]
     [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
 
 : remember-loop ( label -- )
@@ -133,10 +136,10 @@ M: #dispatch emit-node
 ! #call
 M: #call emit-node
     dup word>> dup "intrinsic" word-prop
-    [ emit-intrinsic ] [ nip emit-call ] if ;
+    [ emit-intrinsic ] [ swap call-height emit-call ] if ;
 
 ! #call-recursive
-M: #call-recursive emit-node label>> id>> emit-call ;
+M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
 
 ! #push
 M: #push emit-node
diff --git a/basis/compiler/cfg/dcn/height/height.factor b/basis/compiler/cfg/dcn/height/height.factor
index 2c799a28e7..ec505d81f2 100644
--- a/basis/compiler/cfg/dcn/height/height.factor
+++ b/basis/compiler/cfg/dcn/height/height.factor
@@ -17,14 +17,14 @@ M: insn ds-height-change drop 0 ;
 
 M: ##inc-d ds-height-change n>> ;
 
-! XXX
-! M: ##call ds-height-change height>> ;
+M: ##call ds-height-change height>> ;
 
-M: ##call ds-height-change drop 0 ;
+: alien-node-height ( node -- )
+    params>> [ out-d>> length ] [ in-d>> length ] bi - ;
 
-M: ##alien-invoke ds-height-change height>> ;
+M: ##alien-invoke ds-height-change alien-node-height ;
 
-M: ##alien-indirect ds-height-change height>> ;
+M: ##alien-indirect ds-height-change alien-node-height ;
 
 GENERIC: rs-height-change ( insn -- n )
 
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index d1b7592aaf..dc656d61fa 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -53,7 +53,7 @@ INSN: ##inc-r { n integer } ;
 
 ! Subroutine calls
 INSN: ##stack-frame stack-frame ;
-INSN: ##call word ;
+INSN: ##call word { height integer } ;
 INSN: ##jump word ;
 INSN: ##return ;
 
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index 5dc04d47e1..cfc07624fe 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -65,7 +65,7 @@ IN: compiler.cfg.intrinsics.fixnum
     [ -2 ##inc-d ds-push ] with-branch ;
 
 : emit-overflow-case ( word -- final-bb )
-    [ ##call ] with-branch ;
+    [ -1 ##call ] with-branch ;
 
 : emit-fixnum-overflow-op ( quot word -- )
     [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip
diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor
index 9cb8bf26f9..32da1a5d06 100644
--- a/basis/compiler/cfg/utilities/utilities.factor
+++ b/basis/compiler/cfg/utilities/utilities.factor
@@ -33,8 +33,11 @@ IN: compiler.cfg.utilities
     building off
     basic-block off ;
 
+: call-height ( #call -- n )
+    [ out-d>> length ] [ in-d>> length ] bi - ;
+
 : emit-primitive ( node -- )
-    word>> ##call ##branch begin-basic-block ;
+    [ word>> ] [ call-height ] bi ##call ##branch begin-basic-block ;
 
 : with-branch ( quot -- final-bb )
     [