Fewer unnecessary dependence edges between stack operations, implemented by reviving stack height normalization. Now, 40% of spills and reloads are eliminated in total

basis/compiler/cfg/dependence/dependence.factor

@@ -53,16 +53,6 @@ M: node hashcode* nip number>> ;
 
 UNION: stack-read-write ##peek ##replace ;
 
-PREDICATE: ds-read-write < stack-read-write
-    loc>> ds-loc? ;
-UNION: data-stack-insn
-    ##inc-d ds-read-write ;
-
-PREDICATE: rs-read-write < stack-read-write
-    loc>> rs-loc? ;
-UNION: retain-stack-insn
-    ##inc-r rs-read-write ;
-
 UNION: ##alien-read
     ##alien-double ##alien-float ##alien-cell ##alien-vector
     ##alien-signed-1 ##alien-signed-2 ##alien-signed-4
@@ -92,11 +82,8 @@ UNION: alien-call-insn
 
 GENERIC: add-control-edge ( node insn -- )
 
-M: data-stack-insn add-control-edge
-    drop data-stack-insn chain ;
-
-M: retain-stack-insn add-control-edge
-    drop retain-stack-insn chain ;
+M: stack-read-write add-control-edge
+    loc>> chain ;
 
 M: alien-memory-insn add-control-edge
     drop alien-memory-insn chain ;

basis/compiler/cfg/height/height.factor

@@ -0,0 +1,55 @@
+! Copyright (C) 2008, 2009 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
+compiler.cfg.rpo ;
+IN: compiler.cfg.height
+
+! Combine multiple stack height changes into one at the
+! start of the basic block.
+
+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 ;
+
+GENERIC: normalize-height* ( insn -- insn' )
+
+: normalize-inc-d/r ( insn stack -- insn' )
+    swap n>> '[ _ - ] change f ; inline
+
+M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
+M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
+
+GENERIC: loc-stack ( loc -- stack )
+
+M: ds-loc loc-stack drop ds-height ;
+M: rs-loc loc-stack drop rs-height ;
+
+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
+
+M: ##peek normalize-height* normalize-peek/replace ;
+M: ##replace normalize-height* normalize-peek/replace ;
+
+M: insn normalize-height* ;
+
+: 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 ;
+
+: normalize-height ( cfg -- cfg' )
+    [ height-step ] local-optimization ;

basis/compiler/cfg/height/summary.txt

@@ -0,0 +1 @@
+Stack height normalization coalesces height changes at start of basic block

basis/compiler/cfg/optimizer/optimizer.factor

@@ -5,6 +5,7 @@ compiler.cfg.tco
 compiler.cfg.useless-conditionals
 compiler.cfg.branch-splitting
 compiler.cfg.block-joining
+compiler.cfg.height
 compiler.cfg.ssa.construction
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
@@ -30,6 +31,7 @@ SYMBOL: check-optimizer?
     delete-useless-conditionals
     split-branches
     join-blocks
+    normalize-height
     construct-ssa
     alias-analysis
     value-numbering

basis/compiler/cfg/scheduling/scheduling.factor

@@ -58,8 +58,11 @@ ERROR: bad-delete-at key assoc ;
 : cut-by ( seq quot -- before after )
     dupd find drop [ cut ] [ f ] if* ; inline
 
+UNION: initial-insn
+    ##phi ##inc-d ##inc-r ;
+
 : split-3-ways ( insns -- first middle last )
-    [ ##phi? not ] cut-by unclip-last ;
+    [ initial-insn? not ] cut-by unclip-last ;
 
 : reorder ( insns -- insns' )
     split-3-ways [