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

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

@@ -42,20 +42,20 @@ IN: compiler.cfg.stack-analysis.merge
     [ [ keys ] map concat prune ] keep
     '[ dup _ [ at ] with map ] H{ } map>assoc ;
 
-: insert-peek ( predecessor state loc -- vreg )
-    '[ _ _ swap translate-loc ^^peek ] add-instructions ;
+: insert-peek ( predecessor loc -- vreg )
+    '[ _ ^^peek ] add-instructions ;
 
-: merge-loc ( predecessors states vregs loc -- vreg )
+: merge-loc ( predecessors vregs loc -- vreg )
     ! Insert a ##phi in the current block where the input
     ! is the vreg storing loc from each predecessor block
-    '[ dup [ 2nip ] [ drop _ insert-peek ] if ] 3map
+    '[ [ ] [ _ insert-peek ] ?if ] 2map
     dup all-equal? [ first ] [ ^^phi ] if ;
 
 :: merge-locs ( state predecessors states -- state )
     states [ locs>vregs>> ] map states collect-locs
     [| key value |
         key
-        predecessors states value key merge-loc
+        predecessors value key merge-loc
     ] assoc-map
     state translate-locs
     state (>>locs>vregs)

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

@@ -8,26 +8,11 @@ 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
-: check-for-redundant-ops ( cfg -- )
-    [
-        instructions>>
-        [
-            [ ##peek? ] filter [ loc>> ] map duplicates empty?
-            [ "Redundant peeks" throw ] unless
-        ] [
-            [ ##replace? ] filter [ loc>> ] map duplicates empty?
-            [ "Redundant replaces" throw ] unless
-        ] bi
-    ] each-basic-block ;
-
 : test-stack-analysis ( quot -- cfg )
     dup cfg? [ test-cfg first ] unless
     compute-predecessors
-    delete-useless-blocks
-    delete-useless-conditionals
     stack-analysis
-    dup check-cfg
-    dup check-for-redundant-ops ;
+    dup check-cfg ;
 
 : linearize ( cfg -- mr )
     flatten-cfg instructions>> ;
@@ -116,7 +101,7 @@ local-only? off
 ! Correct height tracking
 [ t ] [
     [ pick [ <array> ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code
-    reverse-post-order 2 swap nth
+    reverse-post-order 3 swap nth
     instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi*
     2array { D 1 D 0 } set=
 ] unit-test
@@ -144,4 +129,34 @@ local-only? off
     drop
 
     3 get instructions>> second loc>>
+] unit-test
+
+! Do inserted ##peeks reference the correct stack location if
+! an ##inc-d/r was also inserted?
+[ D 0 ] [
+    V{ T{ ##branch } } 0 test-bb
+
+    V{ T{ ##branch } } 1 test-bb
+
+    V{
+        T{ ##peek f V int-regs 1 D 0 }
+        T{ ##branch }
+    } 2 test-bb
+
+    V{
+        T{ ##call f \ + -1 }
+        T{ ##inc-d 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>> [ ##peek? ] find nip loc>>
 ] unit-test