Merge branch 'master' of git://factorcode.org/git/factor

diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor
index cb569377589cdba3ca8101715078ccc017bf5c93..60805124cd2c82a16f1df2656fc149810cfb1741 100644 (file)
--- 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 (file)
index 14a0a54..0000000
--- 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 (file)
index ce1974a..0000000
--- 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 401241722fe74f9296c6753e03cc6a4df8c1a5bb..be3fb2bea8fde22de2ec00dca80b9bc9fc6b789c 100644 (file)
--- 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 60dfbd83bca4c26374c5717df629bc15d99f94ee..49352da0f71715bd9ebbba3f3592190dc19ce3c5 100644 (file)
--- 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 3e98d6c9f09abca261d9f2449ec2fd311dac86e9..d575450f438e3f23b329ddaf91090ad742c15505 100644 (file)
--- 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 9d481ef1d2b1edffe297a372ba27b591954de253..e789fc9c2138f5d4494ae3cdf239d95964d946df 100644 (file)
--- 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
@@ -25,9 +24,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 0882bed06e696d5b9fe255d9376dd5cd52ec8f83..71f313be5a0b53736ebab5f83468a7dda4fab217 100644 (file)
--- 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 (file)
index 0000000..e519308
--- /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 9db6d595bf363cb849c585d23807df7b2e1d7f53..25b0c3003374234e12ce9b18b3e984d58704a5cb 100644 (file)
--- 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 ;
+
+: merge-ds-heights ( state predecessors states -- state )
+    [ ds-height>> ] map dup all-equal?
+    [ nip first >>ds-height ]
+    [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
+
+: save-rs-height ( n -- )
+    dup 0 = [ drop ] [ ##inc-r ] if ;
+
+: merge-rs-heights ( state predecessors states -- state )
+    [ rs-height>> ] map dup all-equal?
+    [ nip first >>rs-height ]
+    [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
 
-: must-equal ( seq -- elt )
-    dup all-equal? [ first ] [ must-equal-failed ] if ;
+: assoc-map-values ( assoc quot -- assoc' )
+    '[ _ dip ] assoc-map ; inline
 
-: merge-heights ( state predecessors states -- state )
-    nip
-    [ [ ds-height>> ] map must-equal >>ds-height ]
-    [ [ rs-height>> ] map must-equal >>rs-height ] bi ;
+: translate-locs ( assoc state -- assoc' )
+    '[ _ translate-loc ] assoc-map-values ;
 
-: insert-peek ( predecessor loc -- vreg )
-    ! XXX critical edges
-    '[ _ ^^peek ] add-instructions ;
+: untranslate-locs ( assoc state -- assoc' )
+    '[ _ untranslate-loc ] assoc-map-values ;
 
-: merge-loc ( predecessors locs>vregs loc -- vreg )
+: 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 )
-    [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
+:: 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-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 35018257047e6b9a6c8a956f624a35ca8874a125..e01d870bf2b42e64ec8b02f7a2b9dfcef75d435f 100644 (file)
--- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
+++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
@@ -2,9 +2,9 @@ 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 ;
+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
@@ -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 ;
@@ -113,3 +112,36 @@ local-only? off
     [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
     [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi
 ] unit-test
+
+! Correct height tracking
+[ 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 ] [
+    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 3946e0b897b19959bdb2d90671f41f8f5e4c0c3a..0e06a2fdf5f2f2c06b21b4b23f924b7b9fa00bd0 100644 (file)
--- 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 d8cec0183f997a21d9d9ec45d7d6e1201357b2af..f701b847630e8fb0b4bc9d2d93643f592847d531 100644 (file)
--- 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> ;