From 785c341c9bd3b5bce2a60c6140cbb96b692e0eff Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 21 Jun 2009 00:58:36 -0500
Subject: [PATCH 1/9] 50% speedup using unsafe nth/set-nth/exchange in
 checksums.sha

---
 basis/checksums/sha/sha.factor | 104 ++++++++++++++++-----------------
 1 file changed, 51 insertions(+), 53 deletions(-)

diff --git a/basis/checksums/sha/sha.factor b/basis/checksums/sha/sha.factor
index 287c39b2a1..35262bb0b0 100644
--- a/basis/checksums/sha/sha.factor
+++ b/basis/checksums/sha/sha.factor
@@ -1,10 +1,10 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel splitting grouping math sequences namespaces make
-io.binary math.bitwise checksums checksums.common
-sbufs strings combinators.smart math.ranges fry combinators
-accessors locals checksums.stream multiline literals
-generalizations ;
+USING: accessors checksums checksums.common checksums.stream
+combinators combinators.smart fry generalizations grouping
+io.binary kernel literals locals make math math.bitwise
+math.ranges multiline namespaces sbufs sequences
+sequences.private splitting strings ;
 IN: checksums.sha
 
 SINGLETON: sha1
@@ -230,21 +230,21 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
 
 : prepare-M-256 ( n seq -- )
     {
-        [ [ 16 - ] dip nth ]
-        [ [ 15 - ] dip nth s0-256 ]
-        [ [ 7 - ] dip nth ]
-        [ [ 2 - ] dip nth s1-256 w+ w+ w+ ]
+        [ [ 16 - ] dip nth-unsafe ]
+        [ [ 15 - ] dip nth-unsafe s0-256 ]
+        [ [ 7 - ] dip nth-unsafe ]
+        [ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ]
         [ ]
-    } 2cleave set-nth ; inline
+    } 2cleave set-nth-unsafe ; inline
 
 : prepare-M-512 ( n seq -- )
     {
-        [ [ 16 - ] dip nth ]
-        [ [ 15 - ] dip nth s0-512 ]
-        [ [ 7 - ] dip nth ]
-        [ [ 2 - ] dip nth s1-512 w+ w+ w+ ]
+        [ [ 16 - ] dip nth-unsafe ]
+        [ [ 15 - ] dip nth-unsafe s0-512 ]
+        [ [ 7 - ] dip nth-unsafe ]
+        [ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ]
         [ ]
-    } 2cleave set-nth ; inline
+    } 2cleave set-nth-unsafe ; inline
 
 : ch ( x y z -- x' )
     [ bitxor bitand ] keep bitxor ; inline
@@ -258,36 +258,36 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
 GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
 
 :: T1-256 ( n M H sha2 -- T1 )
-    n M nth
-    n sha2 K>> nth +
+    n M nth-unsafe
+    n sha2 K>> nth-unsafe +
     e H slice3 ch w+
-    e H nth S1-256 w+
-    h H nth w+ ; inline
+    e H nth-unsafe S1-256 w+
+    h H nth-unsafe w+ ; inline
 
 : T2-256 ( H -- T2 )
-    [ a swap nth S0-256 ]
+    [ a swap nth-unsafe S0-256 ]
     [ a swap slice3 maj w+ ] bi ; inline
 
 :: T1-512 ( n M H sha2 -- T1 )
-    n M nth
-    n sha2 K>> nth +
+    n M nth-unsafe
+    n sha2 K>> nth-unsafe +
     e H slice3 ch w+
-    e H nth S1-512 w+
-    h H nth w+ ; inline
+    e H nth-unsafe S1-512 w+
+    h H nth-unsafe w+ ; inline
 
 : T2-512 ( H -- T2 )
-    [ a swap nth S0-512 ]
+    [ a swap nth-unsafe S0-512 ]
     [ a swap slice3 maj w+ ] bi ; inline
 
 : update-H ( T1 T2 H -- )
-    h g pick exchange
-    g f pick exchange
-    f e pick exchange
-    pick d pick nth w+ e pick set-nth
-    d c pick exchange
-    c b pick exchange
-    b a pick exchange
-    [ w+ a ] dip set-nth ; inline
+    h g pick exchange-unsafe
+    g f pick exchange-unsafe
+    f e pick exchange-unsafe
+    pick d pick nth-unsafe w+ e pick set-nth-unsafe
+    d c pick exchange-unsafe
+    c b pick exchange-unsafe
+    b a pick exchange-unsafe
+    [ w+ a ] dip set-nth-unsafe ; inline
 
 : prepare-message-schedule ( seq sha2 -- w-seq )
     [ word-size>> <sliced-groups> [ be> ] map ]
@@ -309,7 +309,7 @@ M: sha2-short checksum-block
     [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
 
 : seq>byte-array ( seq n -- string )
-    '[ _ >be ] map B{ } join ;
+    '[ _ >be ] map B{ } concat-as ;
 
 : sha1>checksum ( sha2 -- bytes )
     H>> 4 seq>byte-array ;
@@ -342,16 +342,14 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
     drop
     [ <sha-256-state> ] dip add-checksum-stream get-checksum ;
 
-
-
 : sha1-W ( t seq -- )
     {
-        [ [ 3 - ] dip nth ]
-        [ [ 8 - ] dip nth bitxor ]
-        [ [ 14 - ] dip nth bitxor ]
-        [ [ 16 - ] dip nth bitxor 1 bitroll-32 ]
+        [ [ 3 - ] dip nth-unsafe ]
+        [ [ 8 - ] dip nth-unsafe bitxor ]
+        [ [ 14 - ] dip nth-unsafe bitxor ]
+        [ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
         [ ]
-    } 2cleave set-nth ;
+    } 2cleave set-nth-unsafe ;
 
 : prepare-sha1-message-schedule ( seq -- w-seq )
     4 <sliced-groups> [ be> ] map
@@ -368,11 +366,11 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
     } case ;
 
 :: inner-loop ( n H W K -- temp )
-    a H nth :> A
-    b H nth :> B
-    c H nth :> C
-    d H nth :> D
-    e H nth :> E
+    a H nth-unsafe :> A
+    b H nth-unsafe :> B
+    c H nth-unsafe :> C
+    d H nth-unsafe :> D
+    e H nth-unsafe :> E
     [
         A 5 bitroll-32
 
@@ -380,19 +378,19 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
 
         E
 
-        n K nth
+        n K nth-unsafe
 
-        n W nth
+        n W nth-unsafe
     ] sum-outputs 32 bits ;
 
 :: process-sha1-chunk ( bytes H W K state -- )
     80 [
         H W K inner-loop
-        d H nth e H set-nth
-        c H nth d H set-nth
-        b H nth 30 bitroll-32 c H set-nth
-        a H nth b H set-nth
-        a H set-nth
+        d H nth-unsafe e H set-nth-unsafe
+        c H nth-unsafe d H set-nth-unsafe
+        b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
+        a H nth-unsafe b H set-nth-unsafe
+        a H set-nth-unsafe
     ] each
     state [ H [ w+ ] 2map ] change-H drop ; inline
 

From 166afc57843490d1f51643533442bf39b0fa6974 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 21 Jun 2009 00:59:06 -0500
Subject: [PATCH 2/9] add scaffold words for default vocab roots

---
 basis/tools/scaffold/scaffold.factor | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor
index 5c8b868483..5fdc5ce087 100755
--- a/basis/tools/scaffold/scaffold.factor
+++ b/basis/tools/scaffold/scaffold.factor
@@ -266,6 +266,14 @@ PRIVATE>
         [ nip require ]
     } 2cleave ;
 
+: scaffold-core ( string -- ) "resource:core" swap scaffold-vocab ;
+
+: scaffold-basis ( string -- ) "resource:basis" swap scaffold-vocab ;
+
+: scaffold-extra ( string -- ) "resource:extra" swap scaffold-vocab ;
+
+: scaffold-work ( string -- ) "resource:work" swap scaffold-vocab ;
+
 <PRIVATE
 
 : tests-file-string ( vocab -- string )

From 3afd2599ced7f6a2462c0182a9728edcd2c47147 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Mon, 22 Jun 2009 11:55:42 -0500
Subject: [PATCH 3/9] fix cursor 3map

---
 extra/cursors/cursors-tests.factor | 5 +++++
 extra/cursors/cursors.factor       | 9 +++++----
 2 files changed, 10 insertions(+), 4 deletions(-)

diff --git a/extra/cursors/cursors-tests.factor b/extra/cursors/cursors-tests.factor
index 8294eb05e8..8821d4570c 100644
--- a/extra/cursors/cursors-tests.factor
+++ b/extra/cursors/cursors-tests.factor
@@ -37,3 +37,8 @@ IN: cursors.tests
 
 [ { 111 222 } ]
 [ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test
+
+: test-3map ( -- seq )
+     { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ;
+
+[ { 111 222 } ] [ test-3map ] unit-test
diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor
index 14cc1fdf7f..dc08656f7e 100644
--- a/extra/cursors/cursors.factor
+++ b/extra/cursors/cursors.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generalizations kernel math sequences
-sequences.private ;
+sequences.private fry ;
 IN: cursors
 
 GENERIC: cursor-done? ( cursor -- ? )
@@ -127,12 +127,13 @@ M: to-sequence cursor-write
 : 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline
 
 : find-done3? ( cursor1 cursor2 cursor3 quot -- ? )
-    3 nover 3array [ cursor-done? ] any?
-    [ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline
+    [ 3 ndrop t ] swap '[ [ cursor-get-unsafe ] tri@ @ ]
+    [ 3 ndup 3 narray [ cursor-done? ] any? ] 2dip if ; inline
 
 : cursor-until3 ( cursor cursor quot -- )
     [ find-done3? not ]
-    [ drop [ cursor-advance ] tri@ ] bi-curry bi-curry bi-curry bi-curry while ; inline
+    [ drop [ cursor-advance ] tri@ ]
+    bi-curry bi-curry bi-curry bi-curry while ; inline
 
 : cursor-each3 ( cursor cursor quot -- )
     [ f ] compose cursor-until3 ; inline

From 7a88c5ae8a884df266e335fd699db82701e97b56 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 26 Jun 2009 16:31:20 -0500
Subject: [PATCH 4/9] variants vocab for ADTs

---
 core/classes/tuple/parser/parser.factor | 14 ++++--
 extra/variants/authors.txt              |  1 +
 extra/variants/summary.txt              |  1 +
 extra/variants/variants-tests.factor    | 21 +++++++++
 extra/variants/variants.factor          | 59 +++++++++++++++++++++++++
 5 files changed, 92 insertions(+), 4 deletions(-)
 create mode 100644 extra/variants/authors.txt
 create mode 100644 extra/variants/summary.txt
 create mode 100644 extra/variants/variants-tests.factor
 create mode 100644 extra/variants/variants.factor

diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor
index efb77e3274..6b106e48d9 100644
--- a/core/classes/tuple/parser/parser.factor
+++ b/core/classes/tuple/parser/parser.factor
@@ -33,7 +33,7 @@ ERROR: invalid-slot-name name ;
 : parse-long-slot-name ( -- spec )
     [ scan , \ } parse-until % ] { } make ;
 
-: parse-slot-name ( string/f -- ? )
+: parse-slot-name-delim ( end-delim string/f -- ? )
     #! This isn't meant to enforce any kind of policy, just
     #! to check for mistakes of this form:
     #!
@@ -43,12 +43,18 @@ ERROR: invalid-slot-name name ;
     {
         { [ dup not ] [ unexpected-eof ] }
         { [ dup { ":" "(" "<" "\"" "!" } member? ] [ invalid-slot-name ] }
-        { [ dup ";" = ] [ drop f ] }
+        { [ 2dup = ] [ drop f ] }
         [ dup "{" = [ drop parse-long-slot-name ] when , t ]
-    } cond ;
+    } cond nip ;
+
+: parse-tuple-slots-delim ( end-delim -- )
+    dup scan parse-slot-name-delim [ parse-tuple-slots-delim ] [ drop ] if ;
+
+: parse-slot-name ( string/f -- ? )
+    ";" swap parse-slot-name-delim ;
 
 : parse-tuple-slots ( -- )
-    scan parse-slot-name [ parse-tuple-slots ] when ;
+    ";" parse-tuple-slots-delim ;
 
 : parse-tuple-definition ( -- class superclass slots )
     CREATE-CLASS
diff --git a/extra/variants/authors.txt b/extra/variants/authors.txt
new file mode 100644
index 0000000000..f13c9c1e77
--- /dev/null
+++ b/extra/variants/authors.txt
@@ -0,0 +1 @@
+Joe Groff
diff --git a/extra/variants/summary.txt b/extra/variants/summary.txt
new file mode 100644
index 0000000000..142366be00
--- /dev/null
+++ b/extra/variants/summary.txt
@@ -0,0 +1 @@
+Syntax and combinators for manipulating algebraic data types
diff --git a/extra/variants/variants-tests.factor b/extra/variants/variants-tests.factor
new file mode 100644
index 0000000000..ef48b36b9c
--- /dev/null
+++ b/extra/variants/variants-tests.factor
@@ -0,0 +1,21 @@
+! (c)2009 Joe Groff bsd license
+USING: kernel math tools.test variants ;
+IN: variants.tests
+
+VARIANT: list
+    nil
+    cons: { { first object } { rest list } }
+    ;
+
+[ t ] [ nil list? ] unit-test
+[ t ] [ 1 nil <cons> list? ] unit-test
+[ f ] [ 1 list? ] unit-test
+
+: list-length ( list -- length )
+    {
+        { nil  [ 0 ] }
+        { cons [ nip list-length 1 + ] }
+    } match ;
+
+[ 4 ]
+[ 5 6 7 8 nil <cons> <cons> <cons> <cons> list-length ] unit-test
diff --git a/extra/variants/variants.factor b/extra/variants/variants.factor
new file mode 100644
index 0000000000..5cb786afde
--- /dev/null
+++ b/extra/variants/variants.factor
@@ -0,0 +1,59 @@
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays classes classes.mixin classes.parser
+classes.singleton classes.tuple classes.tuple.parser
+classes.union combinators inverse kernel lexer macros make
+parser quotations sequences slots splitting words ;
+IN: variants
+
+PREDICATE: variant-class < mixin-class "variant" word-prop ;
+
+M: variant-class initial-value*
+    dup members [ no-initial-value ]
+    [ nip first dup word? [ initial-value* ] unless ] if-empty ;
+
+: define-tuple-class-and-boa-word ( class superclass slots -- )
+    pick [ define-tuple-class ] dip
+    dup name>> "<" ">" surround create-in swap define-boa-word ;
+
+: define-variant-member ( member -- class )
+    dup array? [ first3 pick [ define-tuple-class-and-boa-word ] dip ] [ dup define-singleton-class ] if ;
+
+: define-variant-class ( class members -- )
+    [ [ define-mixin-class ] [ t "variant" set-word-prop ] [ ] tri ] dip
+    [ define-variant-member swap add-mixin-instance ] with each ;
+
+: parse-variant-tuple-member ( name -- member )
+    create-class-in tuple
+    "{" expect
+    [ "}" parse-tuple-slots-delim ] { } make
+    3array ;
+
+: parse-variant-member ( name -- member )
+    ":" ?tail [ parse-variant-tuple-member ] [ create-class-in ] if ;
+
+: parse-variant-members ( -- members )
+    [ scan dup ";" = not ]
+    [ parse-variant-member ] produce nip ;
+
+SYNTAX: VARIANT:
+    CREATE-CLASS
+    parse-variant-members
+    define-variant-class ;
+
+MACRO: unboa ( class -- )
+    <wrapper> \ boa [ ] 2sequence [undo] ;
+
+GENERIC# (match-branch) 1 ( class quot -- class quot' )
+
+M: singleton-class (match-branch)
+    \ drop prefix ;
+M: object (match-branch)
+    over \ unboa [ ] 2sequence prepend ;
+
+: ?class ( object -- class )
+    dup word? [ class ] unless ;
+
+MACRO: match ( branches -- )
+    [ dup callable? [ first2 (match-branch) 2array ] unless ] map
+    [ \ dup \ ?class ] dip \ case [ ] 4sequence ;
+

From 911acd6a4a228fe09c7801c02a8b29966449be9e Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 26 Jun 2009 17:12:08 -0500
Subject: [PATCH 5/9] docs for variants

---
 extra/variants/variants-docs.factor | 63 +++++++++++++++++++++++++++++
 1 file changed, 63 insertions(+)
 create mode 100644 extra/variants/variants-docs.factor

diff --git a/extra/variants/variants-docs.factor b/extra/variants/variants-docs.factor
new file mode 100644
index 0000000000..8ba1623f2e
--- /dev/null
+++ b/extra/variants/variants-docs.factor
@@ -0,0 +1,63 @@
+! (c)2009 Joe Groff bsd license
+USING: arrays classes classes.singleton classes.tuple help.markup
+help.syntax kernel multiline slots quotations ;
+IN: variants
+
+HELP: VARIANT:
+{ $syntax <"
+VARIANT: class-name
+    singleton
+    singleton
+    tuple: { slot slot slot ... }
+    .
+    .
+    .
+    ; "> }
+{ $description "Defines " { $snippet "class-name" } " as a union of the following " { $link singleton-class } " and " { $link tuple-class } " definitions. Each " { $snippet "singleton" } " word is defined as a " { $snippet "singleton-class" } ", and each " { $snippet "tuple" } " word is defined aas a " { $snippet "tuple-class" } " with the given set of " { $snippet "slot" } "s, using the same syntax for slot specifiers as " { $link POSTPONE: TUPLE: } ". Typed tuple slots are able to recursively reference the variant " { $snippet "class-name" } " being defined. For " { $snippet "tuple" } " types, a " { $link boa } " constructor word " { $snippet "<tuple>" } " is defined as well." }
+{ $examples { $code <"
+USING: kernel variants ;
+IN: scratchpad
+
+VARIANT: list
+    nil
+    cons: { { first object } { rest list } }
+    ;
+"> } } ;
+
+HELP: match
+{ $values { "branches" array } }
+{ $description "Dispatches on the type of the value on the top of the stack. If the type is a " { $link singleton-class } ", the corresponding quotation is called with an empty stack. If the type is a " { $link tuple-class } ", the tuple slots are pushed onto the stack by order of arguments." }
+{ $examples { $example <"
+USING: kernel math prettyprint variants ;
+IN: scratchpad
+
+VARIANT: list
+    nil
+    cons: { { first object } { rest list } }
+    ;
+
+: list-length ( list -- length )
+    {
+        { nil [ 0 ] }
+        { cons [ nip list-length 1 + ] }
+    } match ;
+
+1 2 3 4 nil <cons> <cons> <cons> <cons> list-length .
+"> "4" } } ;
+
+HELP: unboa
+{ $values { "class" class } }
+{ $description "Decomposes a tuple of type " { $snippet "class" } " into its component slot values by order of arguments. The inverse of " { $link boa } "." } ;
+
+HELP: variant-class
+{ $class-description "This class comprises class names that have been defined with " { $link POSTPONE: VARIANT: } ". When a " { $snippet "variant-class" } " is used as the type of a specialized " { $link tuple } " slot, the variant's first member type is used as the default " { $link initial-value } "." } ;
+
+{ POSTPONE: VARIANT: variant-class match } related-words
+
+ARTICLE: "variants" "Algebraic data types"
+"The " { $vocab-link "variants" } " vocabulary provides syntax and combinators for defining and manipulating algebraic data types."
+{ $subsection POSTPONE: VARIANT: }
+{ $subsection variant-class }
+{ $subsection match } ;
+
+ABOUT: "variants"

From 96baede36a78602abac1a2b964303ef8c6cdbb39 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 26 Jun 2009 17:29:55 -0500
Subject: [PATCH 6/9] Redesign compiler.cfg.stack-analysis to make
 compiler.cfg.height redundant, and to fix some problems

---
 basis/compiler/cfg/debugger/debugger.factor   | 15 ++-
 basis/compiler/cfg/height/height.factor       | 55 -----------
 basis/compiler/cfg/height/summary.txt         |  1 -
 .../cfg/linear-scan/debugger/debugger.factor  |  3 -
 .../cfg/linear-scan/linear-scan-tests.factor  |  6 --
 .../linear-scan/resolve/resolve-tests.factor  |  3 +-
 basis/compiler/cfg/optimizer/optimizer.factor |  3 +-
 basis/compiler/cfg/registers/registers.factor |  7 +-
 .../stack-analysis/merge/merge-tests.factor   | 93 ++++++++++++++++++
 .../cfg/stack-analysis/merge/merge.factor     | 95 +++++++++++--------
 .../stack-analysis-tests.factor               | 34 ++++++-
 .../cfg/stack-analysis/stack-analysis.factor  | 62 +++---------
 .../cfg/stack-analysis/state/state.factor     | 22 +++--
 13 files changed, 233 insertions(+), 166 deletions(-)
 delete mode 100644 basis/compiler/cfg/height/height.factor
 delete mode 100644 basis/compiler/cfg/height/summary.txt
 create mode 100644 basis/compiler/cfg/stack-analysis/merge/merge-tests.factor

diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index cb56937758..60805124cd 100644
--- a/basis/compiler/cfg/debugger/debugger.factor
+++ b/basis/compiler/cfg/debugger/debugger.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences quotations namespaces io
+USING: kernel words sequences quotations namespaces io vectors
 classes.tuple accessors prettyprint prettyprint.config
 prettyprint.backend prettyprint.custom prettyprint.sections
 parser compiler.tree.builder compiler.tree.optimizer
@@ -8,7 +8,7 @@ compiler.cfg.builder compiler.cfg.linearization
 compiler.cfg.registers compiler.cfg.stack-frame
 compiler.cfg.linear-scan compiler.cfg.two-operand
 compiler.cfg.liveness compiler.cfg.optimizer
-compiler.cfg.mr ;
+compiler.cfg.mr compiler.cfg ;
 IN: compiler.cfg.debugger
 
 GENERIC: test-cfg ( quot -- cfgs )
@@ -49,3 +49,12 @@ M: vreg pprint*
 M: ds-loc pprint* \ D pprint-loc ;
 
 M: rs-loc pprint* \ R pprint-loc ;
+
+: test-bb ( insns n -- )
+    [ <basic-block> swap >>number swap >>instructions ] keep set ;
+
+: test-diamond ( -- )
+    1 get 1vector 0 get (>>successors)
+    2 get 3 get V{ } 2sequence 1 get (>>successors)
+    4 get 1vector 2 get (>>successors)
+    4 get 1vector 3 get (>>successors) ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/height/height.factor b/basis/compiler/cfg/height/height.factor
deleted file mode 100644
index 14a0a54715..0000000000
--- a/basis/compiler/cfg/height/height.factor
+++ /dev/null
@@ -1,55 +0,0 @@
-! 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.liveness compiler.cfg.local ;
-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' )
-    [ drop ] [ height-step ] local-optimization ;
diff --git a/basis/compiler/cfg/height/summary.txt b/basis/compiler/cfg/height/summary.txt
deleted file mode 100644
index ce1974ad60..0000000000
--- a/basis/compiler/cfg/height/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Stack height normalization coalesces height changes at start of basic block
diff --git a/basis/compiler/cfg/linear-scan/debugger/debugger.factor b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
index 401241722f..be3fb2bea8 100644
--- a/basis/compiler/cfg/linear-scan/debugger/debugger.factor
+++ b/basis/compiler/cfg/linear-scan/debugger/debugger.factor
@@ -34,6 +34,3 @@ IN: compiler.cfg.linear-scan.debugger
 
 : live-intervals. ( seq -- )
     [ interval-picture ] map simple-table. ;
-
-: test-bb ( insns n -- )
-    [ <basic-block> swap >>number swap >>instructions ] keep set ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 60dfbd83bc..49352da0f7 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -1563,12 +1563,6 @@ V{
     T{ ##return }
 } 4 test-bb
 
-: test-diamond ( -- )
-    1 get 1vector 0 get (>>successors)
-    2 get 3 get V{ } 2sequence 1 get (>>successors)
-    4 get 1vector 2 get (>>successors)
-    4 get 1vector 3 get (>>successors) ;
-
 test-diamond
 
 { 1 2 3 4 } test-linear-scan-on-cfg
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index 3e98d6c9f0..d575450f43 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -3,7 +3,8 @@ compiler.cfg.linear-scan.debugger
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
-compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
+compiler.cfg.registers compiler.cfg.rpo
+compiler.cfg.debugger cpu.architecture kernel
 namespaces tools.test vectors ;
 IN: compiler.cfg.linear-scan.resolve.tests
 
diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 9d481ef1d2..60c2380f7e 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -25,9 +25,8 @@ SYMBOL: check-optimizer?
 : optimize-cfg ( cfg -- cfg' )
     [
         compute-predecessors
-        delete-useless-blocks
+        ! delete-useless-blocks
         delete-useless-conditionals
-        normalize-height
         stack-analysis
         compute-liveness
         alias-analysis
diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor
index 0882bed06e..71f313be5a 100644
--- a/basis/compiler/cfg/registers/registers.factor
+++ b/basis/compiler/cfg/registers/registers.factor
@@ -8,7 +8,12 @@ TUPLE: vreg { reg-class read-only } { n read-only } ;
 SYMBOL: vreg-counter
 : next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ;
 
-! Stack locations
+! Stack locations -- 'n' is an index starting from the top of the stack
+! going down. So 0 is the top of the stack, 1 is what would be the top
+! of the stack after a 'drop', and so on.
+
+! ##inc-d and ##inc-r affect locations as follows. Location D 0 before
+! an ##inc-d 1 becomes D 1 after ##inc-d 1.
 TUPLE: loc { n read-only } ;
 
 TUPLE: ds-loc < loc ;
diff --git a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
new file mode 100644
index 0000000000..e519308974
--- /dev/null
+++ b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
@@ -0,0 +1,93 @@
+IN: compiler.cfg.stack-analysis.merge.tests
+USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
+compiler.cfg.instructions compiler.cfg.stack-analysis.state
+compiler.cfg compiler.cfg.registers compiler.cfg.debugger
+cpu.architecture make assocs
+sequences kernel classes ;
+
+[
+    { D 0 }
+    { V int-regs 0 V int-regs 1 }
+] [
+    <state>
+
+    <basic-block> V{ T{ ##branch } } >>instructions
+    <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+    <state> H{ { D 0 V int-regs 0 } } >>locs>vregs
+    <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+    [ merge-locs locs>vregs>> keys ] { } make first inputs>>
+] unit-test
+
+[
+    { D 0 }
+    ##peek
+] [
+    <state>
+
+    <basic-block> V{ T{ ##branch } } >>instructions
+    <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+    [
+        <state>
+        <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+        [ merge-locs locs>vregs>> keys ] { } make drop
+    ] keep first instructions>> first class
+] unit-test
+
+[
+    0 ##inc-d
+] [
+    <state>
+
+    <basic-block> V{ T{ ##branch } } >>instructions
+    <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+    [
+        <state> -1 >>ds-height
+        <state> 2array
+
+        [ merge-ds-heights ds-height>> ] { } make drop
+    ] keep first instructions>> first class
+] unit-test
+
+[
+    0
+    { D 0 }
+    { 1 1 }
+] [
+    <state>
+
+    <basic-block> V{ T{ ##branch } } >>instructions
+    <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+    [
+        <state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
+        <state> H{ { D 0 V int-regs 1 } } >>locs>vregs 2array
+
+        [ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop
+    ] keep
+    [ instructions>> length ] map
+] unit-test
+
+[
+    -1
+    { D -1 }
+    { 1 1 }
+] [
+    <state>
+
+    <basic-block> V{ T{ ##branch } } >>instructions
+    <basic-block> V{ T{ ##branch } } >>instructions 2array
+
+    [
+        <state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
+        <state> -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array
+
+        [ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop
+        [ ds-height>> ] [ locs>vregs>> keys ] bi
+    ] keep
+    [ instructions>> length ] map
+] unit-test
diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor
index 9db6d595bf..25b0c30033 100644
--- a/basis/compiler/cfg/stack-analysis/merge/merge.factor
+++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor
@@ -1,65 +1,83 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs sequences accessors fry combinators grouping
-sets compiler.cfg compiler.cfg.hats
+sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.stack-analysis.state ;
 IN: compiler.cfg.stack-analysis.merge
 
+! XXX critical edges
+
 : initial-state ( bb states -- state ) 2drop <state> ;
 
 : single-predecessor ( bb states -- state ) nip first clone ;
 
-ERROR: must-equal-failed seq ;
+: save-ds-height ( n -- )
+    dup 0 = [ drop ] [ ##inc-d ] if ;
 
-: must-equal ( seq -- elt )
-    dup all-equal? [ first ] [ must-equal-failed ] if ;
+: merge-ds-heights ( state predecessors states -- state )
+    [ ds-height>> ] map dup all-equal?
+    [ nip first >>ds-height ]
+    [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
 
-: merge-heights ( state predecessors states -- state )
-    nip
-    [ [ ds-height>> ] map must-equal >>ds-height ]
-    [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
+: save-rs-height ( n -- )
+    dup 0 = [ drop ] [ ##inc-r ] if ;
 
-: insert-peek ( predecessor loc -- vreg )
-    ! XXX critical edges
-    '[ _ ^^peek ] add-instructions ;
+: merge-rs-heights ( state predecessors states -- state )
+    [ rs-height>> ] map dup all-equal?
+    [ nip first >>rs-height ]
+    [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
 
-: merge-loc ( predecessors locs>vregs loc -- vreg )
+: assoc-map-values ( assoc quot -- assoc' )
+    '[ _ dip ] assoc-map ; inline
+
+: translate-locs ( assoc state -- assoc' )
+    '[ _ translate-loc ] assoc-map-values ;
+
+: untranslate-locs ( assoc state -- assoc' )
+    '[ _ untranslate-loc ] assoc-map-values ;
+
+: collect-locs ( loc-maps states -- assoc )
+    ! assoc maps locs to sequences of vregs
+    [ untranslate-locs ] 2map
+    [ [ keys ] map concat prune ] keep
+    '[ dup _ [ at ] with map ] H{ } map>assoc ;
+
+: insert-peek ( predecessor state loc -- vreg )
+    '[ _ _ swap translate-loc ^^peek ] add-instructions ;
+
+: merge-loc ( predecessors states vregs loc -- vreg )
     ! Insert a ##phi in the current block where the input
     ! is the vreg storing loc from each predecessor block
-    [ '[ [ _ ] dip at ] map ] keep
-    '[ [ ] [ _ insert-peek ] ?if ] 2map
+    '[ dup [ 2nip ] [ drop _ insert-peek ] if ] 3map
     dup all-equal? [ first ] [ ^^phi ] if ;
 
-: (merge-locs) ( predecessors assocs -- assoc )
-    dup [ keys ] map concat prune
-    [ [ 2nip ] [ merge-loc ] 3bi ] with with
-    H{ } map>assoc ;
+:: merge-locs ( state predecessors states -- state )
+    states [ locs>vregs>> ] map states collect-locs
+    [| key value |
+        key
+        predecessors states value key merge-loc
+    ] assoc-map
+    state translate-locs
+    state (>>locs>vregs)
+    state ;
 
-: merge-locs ( state predecessors states -- state )
-    [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
-
-: merge-actual-loc ( locs>vregs loc -- vreg )
-    '[ [ _ ] dip at ] map
+: merge-actual-loc ( vregs -- vreg/f )
     dup all-equal? [ first ] [ drop f ] if ;
 
-: merge-actual-locs ( state predecessors states -- state )
-    nip
-    [ actual-locs>vregs>> ] map
-    dup [ keys ] map concat prune
-    [ [ nip ] [ merge-actual-loc ] 2bi ] with
-    H{ } map>assoc
-    [ nip ] assoc-filter
+: merge-actual-locs ( state states -- state )
+    [ [ actual-locs>vregs>> ] map ] keep collect-locs
+    [ merge-actual-loc ] assoc-map [ nip ] assoc-filter
+    over translate-locs
     >>actual-locs>vregs ;
 
-: merge-changed-locs ( state predecessors states -- state )
-    nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
+: merge-changed-locs ( state states -- state )
+    [ changed-locs>> ] map assoc-combine >>changed-locs ;
 
 ERROR: cannot-merge-poisoned states ;
 
 : multiple-predecessors ( bb states -- state )
     dup [ not ] any? [
-        [ <state> ] 2dip
-        sift merge-heights
+        2drop <state>
     ] [
         dup [ poisoned?>> ] any? [
             cannot-merge-poisoned
@@ -67,10 +85,11 @@ ERROR: cannot-merge-poisoned states ;
             [ state new ] 2dip
             [ predecessors>> ] dip
             {
+                [ merge-ds-heights ]
+                [ merge-rs-heights ]
                 [ merge-locs ]
-                [ merge-actual-locs ]
-                [ merge-heights ]
-                [ merge-changed-locs ]
+                [ nip merge-actual-locs ]
+                [ nip merge-changed-locs ]
             } 2cleave
         ] if
     ] if ;
@@ -82,4 +101,4 @@ ERROR: cannot-merge-poisoned states ;
         { 0 [ initial-state ] }
         { 1 [ single-predecessor ] }
         [ drop multiple-predecessors ]
-    } case ;
\ No newline at end of file
+    } case ;
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index 3501825704..cb0a800927 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -4,7 +4,7 @@ compiler.cfg.instructions sequences kernel tools.test accessors
 sequences.private alien math combinators.private compiler.cfg
 compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
 compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
-sets namespaces ;
+sets namespaces arrays cpu.architecture ;
 IN: compiler.cfg.stack-analysis.tests
 
 ! Fundamental invariant: a basic block should not load or store a value more than once
@@ -113,3 +113,35 @@ local-only? off
     [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
     [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
 ] unit-test
+
+! Correct height tracking
+[ D 1 D 0 ] [
+    [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
+    reverse-post-order 2 swap nth
+    instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
+] unit-test
+
+[ D 1 ] [
+    V{ T{ ##branch } } 0 test-bb
+
+    V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb
+
+    V{
+        T{ ##peek f V int-regs 1 D 2 }
+        T{ ##inc-d f -1 }
+        T{ ##branch }
+    } 2 test-bb
+
+    V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb
+
+    V{ T{ ##return } } 4 test-bb
+
+    test-diamond
+
+    cfg new 0 get >>entry
+    compute-predecessors
+    stack-analysis
+    drop
+
+    3 get instructions>> second loc>>
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
index 3946e0b897..0e06a2fdf5 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor
@@ -13,32 +13,14 @@ compiler.cfg.stack-analysis.state
 compiler.cfg.stack-analysis.merge ;
 IN: compiler.cfg.stack-analysis
 
-! Convert stack operations to register operations
-GENERIC: height-for ( loc -- n )
-
-M: ds-loc height-for drop state get ds-height>> ;
-M: rs-loc height-for drop state get rs-height>> ;
-
-: (translate-loc) ( loc -- n height ) [ n>> ] [ height-for ] bi ; inline
-
-GENERIC: translate-loc ( loc -- loc' )
-
-M: ds-loc translate-loc (translate-loc) - <ds-loc> ;
-M: rs-loc translate-loc (translate-loc) - <rs-loc> ;
-
-GENERIC: untranslate-loc ( loc -- loc' )
-
-M: ds-loc untranslate-loc (translate-loc) + <ds-loc> ;
-M: rs-loc untranslate-loc (translate-loc) + <rs-loc> ;
-
 : redundant-replace? ( vreg loc -- ? )
-    dup untranslate-loc n>> 0 <
+    dup state get untranslate-loc n>> 0 <
     [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
 
 : save-changed-locs ( state -- )
     [ changed-locs>> ] [ locs>vregs>> ] bi '[
         _ at swap 2dup redundant-replace?
-        [ 2drop ] [ untranslate-loc ##replace ] if
+        [ 2drop ] [ state get untranslate-loc ##replace ] if
     ] assoc-each ;
 
 ERROR: poisoned-state state ;
@@ -46,6 +28,8 @@ ERROR: poisoned-state state ;
 : sync-state ( -- )
     state get {
         [ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
+        [ ds-height>> save-ds-height ]
+        [ rs-height>> save-rs-height ]
         [ save-changed-locs ]
         [ clear-state ]
     } cleave ;
@@ -55,18 +39,16 @@ ERROR: poisoned-state state ;
 ! Abstract interpretation
 GENERIC: visit ( insn -- )
 
-: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
+M: ##inc-d visit
+    n>> state get [ + ] change-ds-height drop ;
 
-M: ##inc-d visit [ , ] [ n>> adjust-ds ] bi ;
-
-: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
-
-M: ##inc-r visit [ , ] [ n>> adjust-rs ] bi ;
+M: ##inc-r visit
+    n>> state get [ + ] change-rs-height drop ;
 
 ! Instructions which don't have any effect on the stack
 UNION: neutral-insn
-    ##flushable
-    ##effect ;
+    ##effect
+    ##flushable ;
 
 M: neutral-insn visit , ;
 
@@ -97,20 +79,16 @@ M: sync-if-back-edge visit
     [ ##copy ] [ swap copies get set-at ] 2bi ;
 
 M: ##peek visit
-    dup
-    [ dst>> ] [ loc>> translate-loc ] bi
-    dup loc>vreg dup [ nip eliminate-peek drop ] [ drop record-peek , ] if ;
+    [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
+    [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
 
 M: ##replace visit
-    [ src>> resolve ] [ loc>> translate-loc ] bi
+    [ src>> resolve ] [ loc>> state get translate-loc ] bi
     record-replace ;
 
 M: ##copy visit
     [ call-next-method ] [ record-copy ] bi ;
 
-M: ##call visit
-    [ call-next-method ] [ height>> adjust-ds ] bi ;
-
 ! Instructions that poison the stack state
 UNION: poison-insn
     ##jump
@@ -133,21 +111,11 @@ UNION: kill-vreg-insn
     ##fixnum-add
     ##fixnum-sub
     ##alien-invoke
-    ##alien-indirect ;
+    ##alien-indirect
+    ##alien-callback ;
 
 M: kill-vreg-insn visit sync-state , ;
 
-: visit-alien-node ( node -- )
-    params>> [ out-d>> length ] [ in-d>> length ] bi - adjust-ds ;
-
-M: ##alien-invoke visit
-    [ call-next-method ] [ visit-alien-node ] bi ;
-
-M: ##alien-indirect visit
-    [ call-next-method ] [ visit-alien-node ] bi ;
-
-M: ##alien-callback visit , ;
-
 ! Maps basic-blocks to states
 SYMBOLS: state-in state-out ;
 
diff --git a/basis/compiler/cfg/stack-analysis/state/state.factor b/basis/compiler/cfg/stack-analysis/state/state.factor
index d8cec0183f..f701b84763 100644
--- a/basis/compiler/cfg/stack-analysis/state/state.factor
+++ b/basis/compiler/cfg/stack-analysis/state/state.factor
@@ -1,11 +1,14 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors namespaces assocs sets math ;
+USING: kernel accessors namespaces assocs sets math
+compiler.cfg.registers ;
 IN: compiler.cfg.stack-analysis.state
 
 TUPLE: state
 locs>vregs actual-locs>vregs changed-locs
-ds-height rs-height poisoned? ;
+{ ds-height integer }
+{ rs-height integer }
+poisoned? ;
 
 : <state> ( -- state )
     state new
@@ -33,11 +36,14 @@ M: state clone
     dup changed-loc state get locs>vregs>> set-at ;
 
 : clear-state ( state -- )
-    [ locs>vregs>> clear-assoc ]
-    [ actual-locs>vregs>> clear-assoc ]
-    [ changed-locs>> clear-assoc ]
-    tri ;
+    0 >>ds-height 0 >>rs-height
+    [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri
+    [ clear-assoc ] tri@ ;
 
-: adjust-ds ( n -- ) state get [ + ] change-ds-height drop ;
+GENERIC# translate-loc 1 ( loc state -- loc' )
+M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
 
-: adjust-rs ( n -- ) state get [ + ] change-rs-height drop ;
+GENERIC# untranslate-loc 1 ( loc state -- loc' )
+M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;

From ef32eb2e72b5b5523c4fed4e06818f16170d36ed Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 26 Jun 2009 17:44:33 -0500
Subject: [PATCH 7/9] Fix bootstrap and unit test

---
 basis/compiler/cfg/optimizer/optimizer.factor               | 1 -
 .../compiler/cfg/stack-analysis/stack-analysis-tests.factor | 6 +++---
 2 files changed, 3 insertions(+), 4 deletions(-)

diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor
index 60c2380f7e..e789fc9c21 100644
--- a/basis/compiler/cfg/optimizer/optimizer.factor
+++ b/basis/compiler/cfg/optimizer/optimizer.factor
@@ -3,7 +3,6 @@
 USING: kernel sequences accessors combinators namespaces
 compiler.cfg.predecessors
 compiler.cfg.useless-blocks
-compiler.cfg.height
 compiler.cfg.stack-analysis
 compiler.cfg.alias-analysis
 compiler.cfg.value-numbering
diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
index cb0a800927..e01d870bf2 100644
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -2,7 +2,7 @@ USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
 compiler.cfg.predecessors compiler.cfg.stack-analysis
 compiler.cfg.instructions sequences kernel tools.test accessors
 sequences.private alien math combinators.private compiler.cfg
-compiler.cfg.checker compiler.cfg.height compiler.cfg.rpo
+compiler.cfg.checker compiler.cfg.rpo
 compiler.cfg.dce compiler.cfg.registers compiler.cfg.useless-blocks
 sets namespaces arrays cpu.architecture ;
 IN: compiler.cfg.stack-analysis.tests
@@ -25,7 +25,6 @@ IN: compiler.cfg.stack-analysis.tests
     compute-predecessors
     delete-useless-blocks
     delete-useless-conditionals
-    normalize-height
     stack-analysis
     dup check-cfg
     dup check-for-redundant-ops ;
@@ -115,10 +114,11 @@ local-only? off
 ] unit-test
 
 ! Correct height tracking
-[ D 1 D 0 ] [
+[ t ] [
     [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
     reverse-post-order 2 swap nth
     instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
+    2array { D 1 D 0 } set=
 ] unit-test
 
 [ D 1 ] [

From 9fd65ad32412c8dda2afec61cef760f943d9ed3a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 26 Jun 2009 21:46:59 -0500
Subject: [PATCH 8/9] add collect-values to histogram

---
 extra/histogram/histogram.factor | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/extra/histogram/histogram.factor b/extra/histogram/histogram.factor
index 70ddfd3af5..d5c6ab3778 100755
--- a/extra/histogram/histogram.factor
+++ b/extra/histogram/histogram.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences assocs ;
+USING: kernel sequences assocs fry ;
 IN: histogram
 
 <PRIVATE
@@ -24,3 +24,6 @@ PRIVATE>
 
 : histogram ( seq -- hashtable )
     [ inc-at ] sequence>hashtable ;
+
+: collect-values ( seq quot: ( obj hashtable -- ) -- hash )
+    '[ [ dup @ ] dip push-at ] sequence>hashtable ; inline

From 90017eb2489aa2ce4b253a961bde84b4b13ddf0e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 26 Jun 2009 21:48:21 -0500
Subject: [PATCH 9/9] add spill-temp to compiler.cfg.instructions, implement
 parallel register assignment in linear-scan.resolve

---
 .../cfg/instructions/instructions.factor      |   2 +
 .../linear-scan/resolve/resolve-tests.factor  | 154 +++++++++++++++++-
 .../cfg/linear-scan/resolve/resolve.factor    | 126 +++++++++++++-
 3 files changed, 271 insertions(+), 11 deletions(-)

diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 1bf94985a6..5b3e1af930 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -247,3 +247,5 @@ INSN: _spill src class n ;
 INSN: _reload dst class n ;
 INSN: _copy dst src class ;
 INSN: _spill-counts counts ;
+
+SYMBOL: temp-spill
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
index 3e98d6c9f0..717cf36e14 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor
@@ -1,10 +1,10 @@
-USING: accessors arrays compiler.cfg compiler.cfg.instructions
-compiler.cfg.linear-scan.debugger
+USING: accessors arrays classes compiler.cfg
+compiler.cfg.instructions compiler.cfg.linear-scan.debugger
 compiler.cfg.linear-scan.live-intervals
 compiler.cfg.linear-scan.numbering
 compiler.cfg.linear-scan.resolve compiler.cfg.predecessors
 compiler.cfg.registers compiler.cfg.rpo cpu.architecture kernel
-namespaces tools.test vectors ;
+multiline namespaces tools.test vectors ;
 IN: compiler.cfg.linear-scan.resolve.tests
 
 [ { 1 2 3 4 5 6 } ] [
@@ -62,4 +62,150 @@ T{ live-interval
 
 [ f ] [
     1 get test-live-interval-2 reload-from
-] unit-test
\ No newline at end of file
+] unit-test
+
+[
+    {
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    }
+] [
+    {
+        T{ register->memory { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 3 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } trace-chains
+] unit-test
+
+[
+    {
+        T{ _copy { dst 5 } { src 4 } { class int-regs } }
+        T{ _spill { src 1 } { class int-regs } { n 6 } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _reload { dst 0 } { class int-regs } { n 6 } }
+        T{ _spill { src 1 } { class float-regs } { n 7 } }
+        T{ _copy { dst 1 } { src 0 } { class float-regs } }
+        T{ _reload { dst 0 } { class float-regs } { n 7 } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
+        T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
+        T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _spill { src 1 } { class int-regs } { n 3 } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 0 } { src 2 } { class int-regs } }
+        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _spill { src 1 } { class int-regs } { n 3 } }
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 0 } { src 2 } { class int-regs } }
+        T{ _reload { dst 2 } { class int-regs } { n 3 } }
+    }
+] [
+    {
+        T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
+        T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    {
+        T{ _copy { dst 1 } { src 0 } { class int-regs } }
+        T{ _copy { dst 2 } { src 0 } { class int-regs } }
+    }
+] [
+    {
+        T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
+        T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    { }
+] [
+    {
+       T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
+
+[
+    { T{ _spill { src 4 } { class int-regs } { n 4 } } }
+] [
+    {
+       T{ register->memory { from 4 } { to 4 } { reg-class int-regs } }
+    } mapping-instructions
+] unit-test
diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
index 55a2eab41b..b29a661fbf 100644
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@@ -1,9 +1,11 @@
-! Copyright (C) 2009 Slava Pestov
+! Copyright (C) 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math namespaces sequences
-classes.tuple classes.parser parser fry words make arrays
-locals combinators compiler.cfg.linear-scan.live-intervals
-compiler.cfg.liveness compiler.cfg.instructions ;
+USING: accessors arrays assocs classes.parser classes.tuple
+combinators combinators.short-circuit compiler.cfg.instructions
+compiler.cfg.linear-scan.live-intervals compiler.cfg.liveness
+fry hashtables histogram kernel locals make math math.order
+namespaces parser prettyprint random sequences sets
+sorting.functor sorting.slots words ;
 IN: compiler.cfg.linear-scan.resolve
 
 <<
@@ -75,8 +77,118 @@ M: memory->register >insn
 M: register->register >insn
     [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
 
+GENERIC: >collision-table ( operation -- )
+
+M: memory->memory >collision-table
+    [ from>> ] [ to>> ] bi = [ "Not allowed" throw ] unless ;
+
+M: register->memory >collision-table
+    [ from>> ] [ reg-class>> ] [ to>> ] tri _spill ;
+
+M: memory->register >collision-table
+    [ to>> ] [ reg-class>> ] [ from>> ] tri _reload ;
+
+M: register->register >collision-table
+    [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
+
+SYMBOL: froms
+SYMBOL: tos
+
+SINGLETONS: memory register ;
+
+GENERIC: from-loc ( operation -- obj )
+M: memory->memory from-loc drop memory ;
+M: register->memory from-loc drop register ;
+M: memory->register from-loc drop memory ;
+M: register->register from-loc drop register ;
+
+GENERIC: to-loc ( operation -- obj )
+M: memory->memory to-loc drop memory ;
+M: register->memory to-loc drop memory ;
+M: memory->register to-loc drop register ;
+M: register->register to-loc drop register ;
+
+: from-reg ( operation -- seq )
+    [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
+
+: to-reg ( operation -- seq )
+    [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
+
+: (trace-chain) ( pair -- )
+    to-reg froms get at [
+        dup length 1 = [
+            first [ , ] [ (trace-chain) ] bi
+        ] [
+            drop
+        ] if
+    ] when* ;
+
+: trace-chain ( pair -- seq )
+    [ [ , ] [ (trace-chain) ] bi ] { } make reverse ;
+
+: start? ( operations -- pair )
+    from-reg tos get key? not ;
+
+: init-temp-spill ( operations -- )
+    [ [ to>> ] [ from>> ] bi max ] [ max ] map-reduce
+    1 + temp-spill set ;
+
+: set-tos/froms ( operations -- )
+    {
+        [ [ from-reg ] collect-values froms set ]
+        [ [ to-reg ] collect-values tos set ]
+    } cleave ;
+
+: trace-chains ( operations -- operations' )
+    [ set-tos/froms ]
+    [ [ start? ] filter [ trace-chain ] map concat ] bi ;
+
+: break-cycle-n ( operations -- operations' )
+    unclip [ trace-chains ] dip
+    [
+        [ from>> temp-spill get ]
+        [ reg-class>> ] bi \ register->memory boa
+    ] [
+        [ to>> temp-spill [ get ] [ inc ] bi swap ]
+        [ reg-class>> ] bi \ memory->register boa
+    ] bi [ 1array ] bi@ surround ;
+
+: break-cycle ( operations -- operations' )
+    dup length {
+        { 1 [ drop { } ] }
+        [ drop break-cycle-n ]
+    } case ;
+
+: follow-cycle ( obj -- seq )
+   dup dup associate [
+        [ to-reg froms get at first dup dup ] dip
+        [ maybe-set-at ] keep swap
+    ] loop nip keys ;
+
+: (group-cycles) ( seq -- )
+    [
+        unclip follow-cycle [ diff ] keep , (group-cycles)
+    ] unless-empty ;
+
+: group-cycles ( seq -- seqs )
+    [ (group-cycles) ] { } make ;
+
+: partition-mappings ( mappings -- no-cycles cycles )
+    [ start? not ] partition
+    [ trace-chain ] map concat tuck diff ;
+
+: parallel-mappings ( operations -- seq )
+    partition-mappings [
+        group-cycles [ break-cycle ] map concat append
+    ] unless-empty ;
+
 : mapping-instructions ( mappings -- insns )
-    [ [ >insn ] each ] { } make ;
+    [
+        [ init-temp-spill ]
+        [ set-tos/froms ]
+        [ parallel-mappings ] tri
+        [ [ >insn ] each ] { } make
+    ] with-scope ;
 
 : fork? ( from to -- ? )
     [ successors>> length 1 >= ]
@@ -115,4 +227,4 @@ M: register->register >insn
     dup successors>> [ resolve-edge-data-flow ] with each ;
 
 : resolve-data-flow ( rpo -- )
-    [ resolve-block-data-flow ] each ;
\ No newline at end of file
+    [ resolve-block-data-flow ] each ;