compiler.cfg.height: clean it up a bit

diff --git a/basis/compiler/cfg/height/height-tests.factor b/basis/compiler/cfg/height/height-tests.factor
new file mode 100644 (file)
index 0000000..e4b290b
--- /dev/null
+++ b/basis/compiler/cfg/height/height-tests.factor
@@ -0,0 +1,26 @@
+USING: compiler.cfg.height compiler.cfg.instructions\r
+compiler.cfg.registers tools.test ;\r
+IN: compiler.cfg.height.tests\r
+\r
+[\r
+    V{\r
+        T{ ##inc-r f -1 f }\r
+        T{ ##inc-d f 4 f }\r
+        T{ ##peek f 0 D 4 f }\r
+        T{ ##peek f 1 D 0 f }\r
+        T{ ##replace f 0 R -1 f }\r
+        T{ ##replace f 1 R 0 f }\r
+        T{ ##peek f 2 D 0 f }\r
+    }\r
+] [\r
+    V{\r
+        T{ ##peek f 0 D 0 }\r
+        T{ ##inc-d f 3 }\r
+        T{ ##peek f 1 D -1 }\r
+        T{ ##replace f 0 R 0 }\r
+        T{ ##inc-r f -1 }\r
+        T{ ##replace f 1 R 0 }\r
+        T{ ##inc-d f 1 }\r
+        T{ ##peek f 2 D 0 }\r
+    } height-step\r
+] unit-test\r

diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
index 4471508877a6678c3219f5b337d2bdb6b2a23064..8594e6d9b51c131b67a54f5437621c487709068a 100644 (file)
--- a/basis/compiler/cfg/height/height.factor
+++ b/basis/compiler/cfg/height/height.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math namespaces sequences kernel fry
 compiler.cfg compiler.cfg.registers compiler.cfg.instructions
@@ -11,19 +11,17 @@ IN: compiler.cfg.height
 SYMBOL: ds-height
 SYMBOL: rs-height
 
-GENERIC: compute-heights ( insn -- )
-
-M: ##inc-d compute-heights n>> ds-height [ + ] change ;
-M: ##inc-r compute-heights n>> rs-height [ + ] change ;
-M: insn compute-heights drop ;
+: init-height ( -- )
+    0 ds-height set
+    0 rs-height set ;
 
-GENERIC: normalize-height* ( insn -- insn' )
+GENERIC: visit-insn ( insn -- )
 
-: normalize-inc-d/r ( insn stack -- insn' )
-    swap n>> '[ _ - ] change f ; inline
+: normalize-inc-d/r ( insn stack -- )
+    swap n>> '[ _ + ] change ; inline
 
-M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
-M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
+M: ##inc-d visit-insn ds-height normalize-inc-d/r ;
+M: ##inc-r visit-insn rs-height normalize-inc-d/r ;
 
 GENERIC: loc-stack ( loc -- stack )
 
@@ -35,21 +33,23 @@ GENERIC: <loc> ( n stack -- loc )
 M: ds-loc <loc> drop <ds-loc> ;
 M: rs-loc <loc> drop <rs-loc> ;
 
-: normalize-peek/replace ( insn -- insn' )
-    [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
+: normalize-peek/replace ( insn -- )
+    [ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc
+    drop ; inline
 
-M: ##peek normalize-height* normalize-peek/replace ;
-M: ##replace normalize-height* normalize-peek/replace ;
+M: ##peek visit-insn normalize-peek/replace ;
+M: ##replace visit-insn normalize-peek/replace ;
 
-M: insn normalize-height* ;
+M: insn visit-insn drop ;
 
 : height-step ( insns -- insns' )
-    0 ds-height set
-    0 rs-height set
-    [ [ compute-heights ] each ]
-    [ [ [ normalize-height* ] map sift ] with-scope ] bi
-    ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
-    rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
+    init-height
+    [ <reversed> [ visit-insn ] each ]
+    [
+        [ [ ##inc-d? ] [ ##inc-r? ] bi or not ] filter!
+        ds-height get [ \ ##inc-d new-insn prefix ] unless-zero
+        rs-height get [ \ ##inc-r new-insn prefix ] unless-zero
+    ] bi ;
 
 : normalize-height ( cfg -- cfg' )
     dup [ height-step ] simple-optimization ;