diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor index 4f4f9ad7b3..8e96255bdd 100644 --- a/basis/compiler/cfg/builder/blocks/blocks.factor +++ b/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 diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 4ae5cfcc57..ed1069d043 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/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 diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 287d0a6999..4c1999943f 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/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 diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 0eeeb0b12d..d4b9db58c8 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/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 diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor index a484464a59..754789042a 100644 --- a/basis/compiler/cfg/stacks/local/local.factor +++ b/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.instructions compiler.cfg.registers -compiler.cfg.stacks.height ; +compiler.cfg +compiler.cfg.hats +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 ; - -: record-copy ( dst src -- ) swap copies get set-at ; -: resolve-copy ( vreg -- vreg' ) copies get ?at drop ; +SYMBOLS: local-peek-set local-replace-set replace-mapping ; GENERIC: translate-local-loc ( loc -- loc' ) M: ds-loc translate-local-loc n>> current-height get d>> - ; M: rs-loc translate-local-loc n>> current-height get r>> - ; +: 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>> - ; : peek-loc ( loc -- vreg ) translate-local-loc - [ dup local-replace-set get key? [ drop ] [ local-peek-set get conjoin ] if ] - [ loc>vreg [ i ] dip [ record-copy ] [ ##copy ] [ drop ] 2tri ] - bi ; + dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless + dup replace-mapping get at [ ] [ loc>vreg ] ?if ; : 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 ; diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index f68b70467a..2683222fb8 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/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 + locs>vregs set H{ } clone ds-heights set H{ } clone rs-heights set H{ } clone peek-sets set