compiler.cfg.stacks: more accurate deconcatenatization inserts fewer partially redundant ##peeks. 11% improvement on benchmark.beust2, 2% reduction in ##peek and ##replace instructions inserted

basis/compiler/cfg/builder/builder.factor

@@ -19,6 +19,7 @@ compiler.cfg.instructions
 compiler.cfg.predecessors
 compiler.cfg.builder.blocks
 compiler.cfg.stacks
+compiler.cfg.stacks.local
 compiler.alien ;
 IN: compiler.cfg.builder
 
@@ -159,14 +160,32 @@ M: #push emit-node
     literal>> ^^load-literal ds-push ;
 
 ! #shuffle
+
+! Even though low level IR has its own dead code elimination pass,
+! we try not to introduce useless ##peeks here, since this reduces
+! the accuracy of global stack analysis.
+
+: make-input-map ( #shuffle -- assoc )
+    ! Assoc maps high-level IR values to stack locations.
+    [
+        [ in-d>> <reversed> [ <ds-loc> swap set ] each-index ]
+        [ in-r>> <reversed> [ <rs-loc> swap set ] each-index ] bi
+    ] H{ } make-assoc ;
+
+: make-output-seq ( values mapping input-map -- vregs )
+    '[ _ at _ at peek-loc ] map ;
+
+: load-shuffle ( #shuffle mapping input-map -- ds-vregs rs-vregs )
+    [ [ out-d>> ] 2dip make-output-seq ]
+    [ [ out-r>> ] 2dip make-output-seq ] 3bi ;
+
+: store-shuffle ( #shuffle ds-vregs rs-vregs -- )
+    [ [ in-d>> length neg inc-d ] dip ds-store ]
+    [ [ in-r>> length neg inc-r ] dip rs-store ]
+    bi-curry* bi ;
+
 M: #shuffle emit-node
-    dup
-    H{ } clone
-    [ [ in-d>> [ length ds-load ] keep ] dip '[ _ set-at ] 2each ]
-    [ [ in-r>> [ length rs-load ] keep ] dip '[ _ set-at ] 2each ]
-    [ nip ] 2tri
-    [ [ [ out-d>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map ds-store ]
-    [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
+    dup dup [ mapping>> ] [ make-input-map ] bi load-shuffle store-shuffle ;
 
 ! #return
 : emit-return ( -- )

basis/compiler/cfg/stacks/finalize/finalize.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces assocs kernel fry accessors sequences make math
+USING: namespaces assocs kernel fry accessors sequences make math locals
 combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions
 compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local
 compiler.cfg.stacks.global compiler.cfg.stacks.height ;
@@ -8,13 +8,23 @@ IN: compiler.cfg.stacks.finalize
 
 ! This pass inserts peeks and replaces.
 
-: inserting-peeks ( from to -- assoc )
-    peek-in swap [ peek-out ] [ avail-out ] bi
-    assoc-union assoc-diff ;
+:: inserting-peeks ( from to -- assoc )
+    ! A peek is inserted on an edge if the destination anticipates
+    ! the stack location, the source does not anticipate it and
+    ! it is not available from the source in a register.
+    to anticip-in
+    from anticip-out from avail-out assoc-union
+    assoc-diff ;
 
-: inserting-replaces ( from to -- assoc )
-    [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
-    assoc-union assoc-diff ;
+:: inserting-replaces ( from to -- assoc )
+    ! A replace is inserted on an edge if two conditions hold:
+    ! - the location is not dead at the destination, OR
+    !   the location is live at the destination but not available
+    !   at the destination
+    ! - the location is pending in the source but not the destination
+    from pending-out to pending-in assoc-diff
+    to dead-in to live-in to anticip-in assoc-diff assoc-diff
+    assoc-diff ;
 
 : each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
     '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
@@ -33,7 +43,7 @@ ERROR: bad-peek dst loc ;
     ! If both blocks are subroutine calls, don't bother
     ! computing anything.
     2dup [ kill-block? ] both? [ 2drop ] [
-        2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
+        2dup [ [ insert-replaces ] [ insert-peeks ] 2bi ] V{ } make
         [ 2drop ] [ <simple-block> insert-basic-block ] if-empty
     ] if ;
 

basis/compiler/cfg/stacks/global/global.factor

@@ -4,36 +4,56 @@ USING: assocs kernel combinators compiler.cfg.dataflow-analysis
 compiler.cfg.stacks.local ;
 IN: compiler.cfg.stacks.global
 
-! Peek analysis. Peek-in is the set of all locations anticipated at
-! the start of a basic block.
-BACKWARD-ANALYSIS: peek
+: transfer-peeked-locs ( assoc bb -- assoc' )
+    [ replace-set assoc-diff ] [ peek-set assoc-union ] bi ;
 
-M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ;
+! A stack location is anticipated at a location if every path from
+! the location to an exit block will read the stack location
+! before writing it.
+BACKWARD-ANALYSIS: anticip
 
-! Replace analysis. Replace-in is the set of all locations which
-! will be overwritten at some point after the start of a basic block.
-FORWARD-ANALYSIS: replace
+M: anticip-analysis transfer-set drop transfer-peeked-locs ;
 
-M: replace-analysis transfer-set drop replace-set assoc-union ;
+! A stack location is live at a location if some path from
+! the location to an exit block will read the stack location
+! before writing it.
+BACKWARD-ANALYSIS: live
 
-! Availability analysis. Avail-out is the set of all locations
-! in registers at the end of a basic block.
+M: live-analysis transfer-set drop transfer-peeked-locs ;
+
+M: live-analysis join-sets drop assoc-combine ;
+
+! A stack location is available at a location if all paths from
+! the entry block to the location load the location into a
+! register.
 FORWARD-ANALYSIS: avail
 
-M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ;
+M: avail-analysis transfer-set
+    drop [ peek-set assoc-union ] [ replace-set assoc-union ] bi ;
 
-! Kill analysis. Kill-in is the set of all locations
-! which are going to be overwritten.
-BACKWARD-ANALYSIS: kill
+! A stack location is pending at a location if all paths from
+! the entry block to the location write the location.
+FORWARD-ANALYSIS: pending
 
-M: kill-analysis transfer-set drop kill-set assoc-union ;
+M: pending-analysis transfer-set
+    drop replace-set assoc-union ;
+
+! A stack location is dead at a location if no paths from the
+! location to the exit block read the location before writing it.
+BACKWARD-ANALYSIS: dead
+
+M: dead-analysis transfer-set
+    drop
+    [ kill-set assoc-union ]
+    [ replace-set assoc-union ] bi ;
 
 ! Main word
 : compute-global-sets ( cfg -- cfg' )
     {
-        [ compute-peek-sets ]
-        [ compute-replace-sets ]
+        [ compute-anticip-sets ]
+        [ compute-live-sets ]
+        [ compute-pending-sets ]
+        [ compute-dead-sets ]
         [ compute-avail-sets ]
-        [ compute-kill-sets ]
         [ ]
     } cleave ;

basis/compiler/cfg/stacks/local/local.factor

@@ -10,8 +10,13 @@ compiler.cfg.stacks.height
 compiler.cfg.parallel-copy ;
 IN: compiler.cfg.stacks.local
 
-! Local stack analysis. We build local peek and replace sets for every basic
-! block while constructing the CFG.
+! Local stack analysis. We build three sets for every basic block
+! in the CFG:
+! - peek-set: all stack locations that the block reads before writing
+! - replace-set: all stack locations that the block writes
+! - kill-set: all stack locations which become unavailable after the
+!   block ends because of the stack height being decremented
+! This is done while constructing the CFG.
 
 SYMBOLS: peek-sets replace-sets kill-sets ;
 
@@ -80,9 +85,8 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
 : compute-local-kill-set ( -- assoc )
     basic-block get current-height get
     [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
-    [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ]
-    [ drop local-replace-set get at ] 2tri
-    [ append unique dup ] dip update ;
+    [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ] 2bi
+    append unique ;
 
 : begin-local-analysis ( -- )
     H{ } clone local-peek-set set

basis/compiler/tests/codegen.factor

@@ -392,4 +392,13 @@ cell 4 = [
  [ 3 3 2 ] [ 4 3 "" coalescing-bug-4 ] unit-test
  [ 2 3 1 ] [ 2 3 V{ } coalescing-bug-4 ] unit-test
  [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
- [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
+ [ 3 3 1 ] [ 4 3 V{ } coalescing-bug-4 ] unit-test
+ 
+! Global stack analysis dataflow equations are wrong
+: some-word ( a -- b ) 2 + ;
+: global-dcn-bug-1 ( a b -- c d )
+    dup [ [ drop 1 ] dip ] [ [ some-word ] dip ] if
+    dup [ [ 1 fixnum+fast ] dip ] [ [ drop 1 ] dip ] if ;
+
+[ 2 t ] [ 0 t global-dcn-bug-1 ] unit-test
+[ 1 f ] [ 0 f global-dcn-bug-1 ] unit-test