compiler.cfg: introduce less temporaries when building CFG

basis/compiler/cfg/builder/blocks/blocks.factor

@@ -27,7 +27,7 @@ IN: compiler.cfg.builder.blocks
     (begin-basic-block) ;
 
 : emit-trivial-block ( quot -- )
-    building get empty? [ ##branch begin-basic-block ] unless
+    ##branch begin-basic-block
     call
     ##branch begin-basic-block ; inline
 

basis/compiler/cfg/builder/builder.factor

@@ -72,11 +72,6 @@ GENERIC: emit-node ( node -- )
     basic-block get successors>> push
     end-basic-block ;
 
-: emit-trivial-block ( quot -- )
-    basic-block get instructions>> empty? [ ##branch begin-basic-block ] unless
-    call
-    ##branch begin-basic-block ; inline
-
 : emit-call ( word height -- )
     over loops get key?
     [ drop loops get at emit-loop-call ]
@@ -109,9 +104,6 @@ M: #recursive emit-node
 : emit-if ( node -- )
     children>> [ emit-branch ] map emit-conditional ;
 
-: ##branch-t ( vreg -- )
-    \ f tag-number cc/= ##compare-imm-branch ;
-
 : trivial-branch? ( nodes -- value ? )
     dup length 1 = [
         first dup #push? [ literal>> t ] [ drop f f ] if
@@ -135,15 +127,23 @@ M: #recursive emit-node
 : emit-trivial-not-if ( -- )
     ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
 
+: emit-actual-if ( #if -- )
+    ! Inputs to the final instruction need to be copied because of
+    ! loc>vreg sync
+    ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
+
 M: #if emit-node
     {
         { [ dup trivial-if? ] [ drop emit-trivial-if ] }
         { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
-        [ ds-pop ##branch-t emit-if ]
+        [ emit-actual-if ]
     } cond ;
 
 ! #dispatch
 M: #dispatch emit-node
+    ! Inputs to the final instruction need to be copied because of
+    ! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
+    ! though.
     ds-pop ^^offset>slot i ##dispatch emit-if ;
 
 ! #call

basis/compiler/cfg/hats/hats.factor

@@ -18,7 +18,7 @@ IN: compiler.cfg.hats
 : ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
 
 : ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
-: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
+: ^^copy ( src -- dst ) ^^i1 ##copy ; inline
 : ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline
 : ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline
 : ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline
@@ -74,7 +74,7 @@ IN: compiler.cfg.hats
 : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline
 : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline
 : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline
-: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline
+: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline
 : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline
 : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline
 : ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline

basis/compiler/cfg/intrinsics/fixnum/fixnum.factor

@@ -69,7 +69,9 @@ IN: compiler.cfg.intrinsics.fixnum
     [ ##call -1 adjust-d ] with-branch ;
 
 : emit-fixnum-overflow-op ( quot word -- )
-    [ [ (2inputs) ] dip call ] dip
+    ! Inputs to the final instruction need to be copied because
+    ! of loc>vreg sync
+    [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
     [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
     emit-conditional ; inline
 

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

@@ -1,9 +1,12 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors assocs kernel math namespaces sets make sequences
-compiler.cfg compiler.cfg.hats
+compiler.cfg
-compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.hats
-compiler.cfg.stacks.height ;
+compiler.cfg.instructions
+compiler.cfg.registers
+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
@@ -14,24 +17,31 @@ SYMBOLS: peek-sets replace-sets ;
 SYMBOL: locs>vregs
 
 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
+: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
 
 TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
 
-SYMBOLS: copies local-peek-set local-replace-set ;
+SYMBOLS: local-peek-set local-replace-set replace-mapping ;
-
-: record-copy ( dst src -- ) swap copies get set-at ;
-: resolve-copy ( vreg -- vreg' ) copies get ?at drop ;
 
 GENERIC: translate-local-loc ( loc -- loc' )
 M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
 M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
 
+: emit-stack-changes ( -- )
+    replace-mapping get dup assoc-empty? [ drop ] [
+        [ [ loc>vreg ] dip ] assoc-map parallel-copy
+    ] if ;
+
 : emit-height-changes ( -- )
-    ! Insert height changes prior to the last instruction
-    building get pop
     current-height get
     [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
-    [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi
+    [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ;
+
+: emit-changes ( -- )
+    ! Insert height and stack changes prior to the last instruction
+    building get pop
+    emit-stack-changes
+    emit-height-changes
     , ;
 
 ! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
@@ -49,27 +59,28 @@ M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
 
 : peek-loc ( loc -- vreg )
     translate-local-loc
-    [ dup local-replace-set get key? [ drop ] [ local-peek-set get conjoin ] if ]
+    dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
-    [ loc>vreg [ i ] dip [ record-copy ] [ ##copy ] [ drop ] 2tri ]
+    dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
-    bi ;
 
 : replace-loc ( vreg loc -- )
     translate-local-loc
-    2dup [ resolve-copy ] dip loc>vreg = [ 2drop ] [
+    2dup loc>vreg =
+    [ nip replace-mapping get delete-at ]
+    [
         [ local-replace-set get conjoin ]
-        [ loc>vreg swap ##copy ]
+        [ replace-mapping get set-at ]
         bi
     ] if ;
 
 : begin-local-analysis ( -- )
-    H{ } clone copies set
     H{ } clone local-peek-set set
     H{ } clone local-replace-set set
+    H{ } clone replace-mapping set
     current-height get 0 >>emit-d 0 >>emit-r drop
     current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
 
 : end-local-analysis ( -- )
-    emit-height-changes
+    emit-changes
     local-peek-set get basic-block get peek-sets get set-at
     local-replace-set get basic-block get replace-sets get set-at ;
 

basis/compiler/cfg/stacks/stacks.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: math sequences kernel namespaces accessors compiler.cfg
+USING: math sequences kernel namespaces accessors biassocs compiler.cfg
 compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
 compiler.cfg.predecessors compiler.cfg.stacks.local
 compiler.cfg.stacks.height compiler.cfg.stacks.global
@@ -8,7 +8,7 @@ compiler.cfg.stacks.finalize ;
 IN: compiler.cfg.stacks
 
 : begin-stack-analysis ( -- )
-    H{ } clone locs>vregs set
+    <bihash> locs>vregs set
     H{ } clone ds-heights set
     H{ } clone rs-heights set
     H{ } clone peek-sets set