compiler.cfg.stack-analysis: make it pass more tests

basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor

@@ -1,37 +1,51 @@
-USING: compiler.cfg.debugger compiler.cfg.linearization
+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.checker compiler.cfg.height compiler.cfg.rpo
+compiler.cfg.dce compiler.cfg.registers sets ;
 IN: compiler.cfg.stack-analysis.tests
 
 [ f ] [ 1 2 H{ { 2 1 } } maybe-set-at ] unit-test
 [ t ] [ 1 3 H{ { 2 1 } } clone maybe-set-at ] unit-test
 [ t ] [ 3 2 H{ { 2 1 } } clone maybe-set-at ] unit-test
 
-: linearize ( cfg -- seq )
+! Fundamental invariant: a basic block should not load or store a value more than once
-    build-mr instructions>> ;
+: check-for-redundant-ops ( rpo -- )
+    [
+        instructions>>
+        [
+            [ ##peek? ] filter [ loc>> ] map duplicates empty?
+            [ "Redundant peeks" throw ] unless
+        ] [
+            [ ##replace? ] filter [ loc>> ] map duplicates empty?
+            [ "Redundant replaces" throw ] unless
+        ] bi
+    ] each ;
 
 : test-stack-analysis ( quot -- mr )
     dup cfg? [ test-cfg first ] unless
-    compute-predecessors optimize-stack
+    compute-predecessors
-    dup check-cfg ;
+    entry>> reverse-post-order
+    optimize-stack
+    dup [ [ normalize-height ] change-instructions drop ] each
+    dup check-rpo dup check-for-redundant-ops ;
 
 [ ] [ [ ] test-stack-analysis drop ] unit-test
 
 ! Only peek once
-[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
+[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize-basic-blocks [ ##peek? ] count ] unit-test
 
 ! Redundant replace is redundant
-[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
+[ f ] [ [ dup drop ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
-[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
+[ f ] [ [ swap swap ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
 
 ! Replace required here
-[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
+[ t ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
-[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
+[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
 
 ! Only one replace, at the end
-[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
+[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize-basic-blocks [ ##replace? ] count ] unit-test
 
 ! Do we support the full language?
 [ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
@@ -49,10 +63,10 @@ IN: compiler.cfg.stack-analysis.tests
 [ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
 
 ! This should be a total no-op
-[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
+[ f ] [ [ [ ] dip ] test-stack-analysis linearize-basic-blocks [ ##replace? ] any? ] unit-test
 
 ! Don't insert inc-d/inc-r; that's wrong!
-[ 2 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
+[ 1 ] [ [ dup ] test-stack-analysis linearize-basic-blocks [ ##inc-d? ] count ] unit-test
 
 ! Bug in height tracking
 [ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
@@ -64,3 +78,26 @@ IN: compiler.cfg.stack-analysis.tests
 [ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test
 [ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test
 [ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
+
+! Make sure the replace stores a value with the right height
+[ ] [
+    [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize-basic-blocks
+    [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
+] unit-test
+
+! translate-loc was the wrong way round
+[ ] [
+    [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize-basic-blocks
+    [ [ ##load-immediate? ] count 2 assert= ]
+    [ [ ##peek? ] count 1 assert= ]
+    [ [ ##replace? ] count 3 assert= ]
+    tri
+] unit-test
+
+[ ] [
+    [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize-basic-blocks
+    [ [ ##load-immediate? ] count 2 assert= ]
+    [ [ ##peek? ] count 1 assert= ]
+    [ [ ##replace? ] count 1 assert= ]
+    tri
+] unit-test

basis/compiler/cfg/stack-analysis/stack-analysis.factor

@@ -1,9 +1,9 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel namespaces math sequences fry deques grouping
+USING: accessors assocs kernel namespaces math sequences fry grouping
-search-deques dlists sets make combinators compiler.cfg.copy-prop
+sets make combinators compiler.cfg.copy-prop compiler.cfg.def-use
-compiler.cfg.def-use compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.instructions compiler.cfg.registers compiler.cfg.rpo
-compiler.cfg.rpo compiler.cfg.hats ;
+compiler.cfg.hats ;
 IN: compiler.cfg.stack-analysis
 
 ! Convert stack operations to register operations
@@ -34,19 +34,34 @@ M: state clone
 : changed-loc ( loc -- )
     state get changed-locs>> conjoin ;
 
-: changed-loc? ( loc -- ? )
-    state get changed-locs>> key? ;
-
 : record-replace ( src loc -- )
     dup changed-loc state get locs>vregs>> set-at ;
 
+GENERIC: height-for ( loc -- n )
+
+M: ds-loc height-for drop state get d-height>> ;
+M: rs-loc height-for drop state get r-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 -- ? )
-    state get actual-locs>vregs>> at = ;
+    dup 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 ] [ ##replace ] if
+        [ 2drop ] [ untranslate-loc ##replace ] if
     ] assoc-each ;
 
 : clear-state ( state -- )
@@ -66,12 +81,6 @@ ERROR: poisoned-state state ;
 
 : poison-state ( -- ) state get t >>poisoned? drop ;
 
-GENERIC: translate-loc ( loc -- loc' )
-
-M: ds-loc translate-loc n>> state get d-height>> + <ds-loc> ;
-
-M: rs-loc translate-loc n>> state get r-height>> + <rs-loc> ;
-
 ! Abstract interpretation
 GENERIC: visit ( insn -- )
 
@@ -162,12 +171,6 @@ M: ##alien-callback visit , ;
 
 M: ##dispatch-label visit , ;
 
-! Basic blocks we still need to look at
-SYMBOL: work-list
-
-: add-to-work-list ( basic-block -- )
-    work-list get push-front ;
-
 ! Maps basic-blocks to states
 SYMBOLS: state-in state-out ;
 
@@ -222,8 +225,20 @@ SYMBOL: phi-nodes
 : merge-locs ( state predecessors states -- state )
     [ locs>vregs>> ] map (merge-locs) >>locs>vregs ;
 
+: merge-loc' ( locs>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
+    dup all-equal? [ first ] [ drop f ] if ;
+
 : merge-actual-locs ( state predecessors states -- state )
-    [ actual-locs>vregs>> ] map (merge-locs) >>actual-locs>vregs ;
+    nip
+    [ actual-locs>vregs>> ] map
+    dup [ keys ] map concat prune
+    [ [ nip ] [ merge-loc' ] 2bi ] with
+    H{ } map>assoc
+    [ nip ] assoc-filter
+    >>actual-locs>vregs ;
 
 : merge-changed-locs ( state predecessors states -- state )
     nip [ changed-locs>> ] map assoc-combine >>changed-locs ;
@@ -266,12 +281,8 @@ ERROR: cannot-merge-poisoned states ;
 : set-block-in-state ( state bb -- )
     [ clone ] dip state-in get set-at ;
 
-: set-block-out-state ( state bb -- changed? )
+: set-block-out-state ( state bb -- )
-    [ clone ] dip state-out get maybe-set-at ;
+    [ clone ] dip state-out get set-at ;
-
-: finish-block ( bb state -- )
-    [ drop ] [ swap set-block-out-state ] 2bi
-    [ successors>> [ add-to-work-list ] each ] [ drop ] if ;
 
 : visit-block ( bb -- )
     ! block-in-state may add phi nodes at the start of the basic block
@@ -281,21 +292,17 @@ ERROR: cannot-merge-poisoned states ;
         [ swap set-block-in-state ] [
             [
                 [ instructions>> [ visit ] each ]
-                [ state get finish-block ]
+                [ [ state get ] dip set-block-out-state ]
                 [ ]
                 tri
             ] with-state
         ] 2bi
     ] V{ } make >>instructions drop ;
 
-: visit-blocks ( bb -- )
+: optimize-stack ( rpo -- rpo )
-    reverse-post-order [ visit-block ] each ;
-
-: optimize-stack ( cfg -- cfg )
     [
         H{ } clone copies set
         H{ } clone state-in set
         H{ } clone state-out set
-        <hashed-dlist> work-list set
+        dup [ visit-block ] each
-        dup entry>> visit-blocks
     ] with-scope ;