diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index be8c434e36..17c391636f 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -42,9 +42,13 @@ M: bit-array set-nth-unsafe [ byte/bit set-bit ] 2keep swap n>byte set-alien-unsigned-1 ; -: clear-bits ( bit-array -- ) 0 (set-bits) ; +GENERIC: clear-bits ( bit-array -- ) -: set-bits ( bit-array -- ) -1 (set-bits) ; +M: bit-array clear-bits 0 (set-bits) ; + +GENERIC: set-bits ( bit-array -- ) + +M: bit-array set-bits -1 (set-bits) ; M: bit-array clone [ length>> ] [ underlying>> clone ] bi bit-array boa ; diff --git a/basis/combinators/short-circuit/short-circuit-docs.factor b/basis/combinators/short-circuit/short-circuit-docs.factor index 6cd18201fe..66ba001094 100644 --- a/basis/combinators/short-circuit/short-circuit-docs.factor +++ b/basis/combinators/short-circuit/short-circuit-docs.factor @@ -1,62 +1,46 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax io.streams.string quotations -math ; +math kernel ; IN: combinators.short-circuit HELP: 0&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true." } ; +{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 0|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if any quotation in the sequence returns true." } ; +{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the first true result, or " { $link f } } } +{ $description "If every quotation in the sequence outputs " { $link f } ", outputs " { $link f } ", otherwise outputs the result of the first quotation that did not yield " { $link f } "." } ; HELP: 1&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same element from the datastack and must output a boolean." } ; +{ $values { "obj" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 1|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } +{ $values { "obj" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } } { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same element from the datastack and must return a boolean." } ; HELP: 2&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same two elements from the datastack and must output a boolean." } ; +{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 2|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } +{ $values { "obj1" object } { "obj2" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } } { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same two elements from the datastack and must return a boolean." } ; HELP: 3&& -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } -{ $description "Returns true if every quotation in the sequence of quotations returns true. Each quotation gets the same three elements from the datastack and must output a boolean." } ; +{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations with stack effect " { $snippet "( -- )" } } { "?" "the result of the last quotation, or " { $link f } } } +{ $description "If every quotation in the sequence outputs a true value, outputs the result of the last quotation, otherwise outputs " { $link f } "." } ; HELP: 3|| -{ $values - { "quots" "a sequence of quotations" } - { "quot" quotation } } +{ $values { "obj1" object } { "obj2" object } { "obj3" object } { "quots" "a sequence of quotations" } { "?" "the first true result, or " { $link f } } } { $description "Returns true if any quotation in the sequence returns true. Each quotation takes the same three elements from the datastack and must return a boolean." } ; HELP: n&& { $values - { "quots" "a sequence of quotations" } { "N" integer } + { "quots" "a sequence of quotations" } { "n" integer } { "quot" quotation } } -{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each AND quotation." } ; +{ $description "A macro that rewrites the code to pass " { $snippet "n" } " parameters from the stack to each quotation, evaluating the result in the same manner as " { $link 0&& } "." } ; HELP: n|| { $values diff --git a/basis/combinators/short-circuit/short-circuit-tests.factor b/basis/combinators/short-circuit/short-circuit-tests.factor index e392d67d2a..b2bcb2a60f 100644 --- a/basis/combinators/short-circuit/short-circuit-tests.factor +++ b/basis/combinators/short-circuit/short-circuit-tests.factor @@ -1,32 +1,25 @@ - USING: kernel math tools.test combinators.short-circuit ; - IN: combinators.short-circuit.tests -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test +[ 5 ] [ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& ] unit-test +[ 30 ] [ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& ] unit-test -: must-be-t ( in -- ) [ t ] swap unit-test ; -: must-be-f ( in -- ) [ f ] swap unit-test ; +[ f ] [ { [ 1 ] [ f ] [ 3 ] } 0&& ] unit-test +[ f ] [ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] unit-test +[ f ] [ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& ] unit-test -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +[ "factor" ] [ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| ] unit-test +[ 11 ] [ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| ] unit-test +[ 30 ] [ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| ] unit-test +[ f ] [ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] unit-test -[ { [ 1 ] [ 2 ] [ 3 ] } 0&& 3 = ] must-be-t -[ 3 { [ 0 > ] [ odd? ] [ 2 + ] } 1&& 5 = ] must-be-t -[ 10 20 { [ + 0 > ] [ - even? ] [ + ] } 2&& 30 = ] must-be-t +: compiled-&& ( a -- ? ) { [ 0 > ] [ even? ] [ 2 + ] } 1&& ; -[ { [ 1 ] [ f ] [ 3 ] } 0&& 3 = ] must-be-f -[ 3 { [ 0 > ] [ even? ] [ 2 + ] } 1&& ] must-be-f -[ 10 20 { [ + 0 > ] [ - odd? ] [ + ] } 2&& 30 = ] must-be-f +[ f ] [ 3 compiled-&& ] unit-test +[ 4 ] [ 2 compiled-&& ] unit-test -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -[ { [ 10 0 < ] [ f ] [ "factor" ] } 0|| "factor" = ] must-be-t - -[ 10 { [ odd? ] [ 100 > ] [ 1 + ] } 1|| 11 = ] must-be-t - -[ 10 20 { [ + odd? ] [ + 100 > ] [ + ] } 2|| 30 = ] must-be-t - -[ { [ 10 0 < ] [ f ] [ 0 1 = ] } 0|| ] must-be-f - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ; +[ 30 ] [ 10 20 compiled-|| ] unit-test +[ 2 ] [ 1 1 compiled-|| ] unit-test \ No newline at end of file diff --git a/basis/combinators/short-circuit/short-circuit.factor b/basis/combinators/short-circuit/short-circuit.factor index d8bab4dd34..a625a462af 100644 --- a/basis/combinators/short-circuit/short-circuit.factor +++ b/basis/combinators/short-circuit/short-circuit.factor @@ -12,10 +12,17 @@ MACRO:: n&& ( quots n -- quot ) n '[ _ nnip ] suffix 1array [ cond ] 3append ; -MACRO: 0&& ( quots -- quot ) '[ _ 0 n&& ] ; -MACRO: 1&& ( quots -- quot ) '[ _ 1 n&& ] ; -MACRO: 2&& ( quots -- quot ) '[ _ 2 n&& ] ; -MACRO: 3&& ( quots -- quot ) '[ _ 3 n&& ] ; + + +: 0&& ( quots -- ? ) [ ] unoptimized-&& ; +: 1&& ( obj quots -- ? ) [ with ] unoptimized-&& ; +: 2&& ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-&& ; +: 3&& ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-&& ; MACRO:: n|| ( quots n -- quot ) [ f ] quots [| q | @@ -27,7 +34,14 @@ MACRO:: n|| ( quots n -- quot ) n '[ drop _ ndrop t ] [ f ] 2array suffix 1array [ cond ] 3append ; -MACRO: 0|| ( quots -- quot ) '[ _ 0 n|| ] ; -MACRO: 1|| ( quots -- quot ) '[ _ 1 n|| ] ; -MACRO: 2|| ( quots -- quot ) '[ _ 2 n|| ] ; -MACRO: 3|| ( quots -- quot ) '[ _ 3 n|| ] ; + + +: 0|| ( quots -- ? ) [ ] unoptimized-|| ; +: 1|| ( obj quots -- ? ) [ with ] unoptimized-|| ; +: 2|| ( obj1 obj2 quots -- ? ) [ with with ] unoptimized-|| ; +: 3|| ( obj1 obj2 obj3 quots -- ? ) [ with with with ] unoptimized-|| ; diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor new file mode 100644 index 0000000000..982f0866e6 --- /dev/null +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators.short-circuit kernel sequences math +compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.utilities ; +IN: compiler.cfg.block-joining + +! Joining blocks that are not calls and are connected by a single CFG edge. +! Predecessors must be recomputed after this. Also this pass does not +! update ##phi nodes and should therefore only run before stack analysis. + +: kill-vreg-block? ( bb -- ? ) + instructions>> { + [ length 2 >= ] + [ penultimate kill-vreg-insn? ] + } 1&& ; + +: predecessor ( bb -- pred ) + predecessors>> first ; inline + +: join-block? ( bb -- ? ) + { + [ predecessors>> length 1 = ] + [ predecessor kill-vreg-block? not ] + [ predecessor successors>> length 1 = ] + [ [ predecessor ] keep back-edge? not ] + } 1&& ; + +: join-instructions ( bb pred -- ) + [ instructions>> ] bi@ dup pop* push-all ; + +: update-successors ( bb pred -- ) + [ successors>> ] dip (>>successors) ; + +: join-block ( bb pred -- ) + [ join-instructions ] [ update-successors ] 2bi ; + +: join-blocks ( cfg -- cfg' ) + dup post-order [ + dup join-block? + [ dup predecessor join-block ] [ drop ] if + ] each + cfg-changed ; diff --git a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor b/basis/compiler/cfg/branch-folding/branch-folding-tests.factor deleted file mode 100644 index 964620d2d3..0000000000 --- a/basis/compiler/cfg/branch-folding/branch-folding-tests.factor +++ /dev/null @@ -1,85 +0,0 @@ -IN: compiler.cfg.branch-folding.tests -USING: compiler.cfg.branch-folding compiler.cfg.instructions -compiler.cfg compiler.cfg.registers compiler.cfg.debugger -arrays compiler.cfg.phi-elimination compiler.cfg.dce -compiler.cfg.predecessors kernel accessors assocs -sequences classes namespaces tools.test cpu.architecture ; - -V{ T{ ##branch } } 0 test-bb - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< } -} 1 test-bb - -V{ - T{ ##load-immediate f V int-regs 1 1 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##load-immediate f V int-regs 2 2 } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##phi f V int-regs 3 { } } - T{ ##replace f V int-regs 3 D 0 } - T{ ##return } -} 4 test-bb - -4 get instructions>> first -2 get V int-regs 1 2array -3 get V int-regs 2 2array 2array ->>inputs drop - -test-diamond - -[ ] [ cfg new 0 get >>entry fold-branches compute-predecessors eliminate-phis drop ] unit-test - -[ 1 ] [ 1 get successors>> length ] unit-test -[ t ] [ 1 get successors>> first 3 get eq? ] unit-test - -[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test -[ 2 ] [ 4 get instructions>> length ] unit-test - -V{ - T{ ##peek f V int-regs 0 D 0 } - T{ ##branch } -} 0 test-bb - -V{ - T{ ##peek f V int-regs 1 D 1 } - T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< } -} 1 test-bb - -V{ - T{ ##copy f V int-regs 2 V int-regs 0 } - T{ ##branch } -} 2 test-bb - -V{ - T{ ##phi f V int-regs 3 V{ } } - T{ ##branch } -} 3 test-bb - -V{ - T{ ##replace f V int-regs 3 D 0 } - T{ ##return } -} 4 test-bb - -1 get V int-regs 1 2array -2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs) - -test-diamond - -[ ] [ - cfg new 0 get >>entry - compute-predecessors - fold-branches - compute-predecessors - eliminate-dead-code - drop -] unit-test - -[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/branch-folding/branch-folding.factor b/basis/compiler/cfg/branch-folding/branch-folding.factor deleted file mode 100644 index 627db63c9f..0000000000 --- a/basis/compiler/cfg/branch-folding/branch-folding.factor +++ /dev/null @@ -1,30 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators.short-circuit kernel sequences vectors -compiler.cfg.instructions compiler.cfg.rpo ; -IN: compiler.cfg.branch-folding - -! Fold comparisons where both inputs are the same. Predecessors must be -! recomputed after this - -: fold-branch? ( bb -- ? ) - instructions>> last { - [ ##compare-branch? ] - [ [ src1>> ] [ src2>> ] bi = ] - } 1&& ; - -: chosen-successor ( bb -- succ ) - [ instructions>> last cc>> { cc= cc<= cc>= } memq? 0 1 ? ] - [ successors>> ] - bi nth ; - -: fold-branch ( bb -- ) - dup chosen-successor 1vector >>successors - instructions>> [ pop* ] [ [ \ ##branch new-insn ] dip push ] bi ; - -: fold-branches ( cfg -- cfg' ) - dup [ - dup fold-branch? - [ fold-branch ] [ drop ] if - ] each-basic-block - f >>post-order ; \ No newline at end of file diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor new file mode 100644 index 0000000000..89f26f7928 --- /dev/null +++ b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor @@ -0,0 +1,85 @@ +USING: accessors assocs compiler.cfg +compiler.cfg.branch-splitting compiler.cfg.debugger +compiler.cfg.predecessors compiler.cfg.rpo compiler.cfg.instructions fry kernel +tools.test namespaces sequences vectors ; +IN: compiler.cfg.branch-splitting.tests + +: get-predecessors ( cfg -- assoc ) + H{ } clone [ '[ [ predecessors>> ] keep _ set-at ] each-basic-block ] keep ; + +: check-predecessors ( cfg -- ) + [ get-predecessors ] + [ compute-predecessors drop ] + [ get-predecessors ] tri assert= ; + +: check-branch-splitting ( cfg -- ) + compute-predecessors + split-branches + check-predecessors ; + +: test-branch-splitting ( -- ) + cfg new 0 get >>entry check-branch-splitting ; + +V{ T{ ##branch } } 0 test-bb + +V{ T{ ##branch } } 1 test-bb + +V{ T{ ##branch } } 2 test-bb + +V{ T{ ##branch } } 3 test-bb + +V{ T{ ##branch } } 4 test-bb + +test-diamond + +[ ] [ test-branch-splitting ] unit-test + +V{ T{ ##branch } } 0 test-bb + +V{ T{ ##branch } } 1 test-bb + +V{ T{ ##branch } } 2 test-bb + +V{ T{ ##branch } } 3 test-bb + +V{ T{ ##branch } } 4 test-bb + +V{ T{ ##branch } } 5 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop + +1 get 3 get 4 get V{ } 2sequence >>successors drop + +2 get 3 get 4 get V{ } 2sequence >>successors drop + +[ ] [ test-branch-splitting ] unit-test + +V{ T{ ##branch } } 0 test-bb + +V{ T{ ##branch } } 1 test-bb + +V{ T{ ##branch } } 2 test-bb + +V{ T{ ##branch } } 3 test-bb + +V{ T{ ##branch } } 4 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop + +1 get 3 get 4 get V{ } 2sequence >>successors drop + +2 get 4 get 1vector >>successors drop + +[ ] [ test-branch-splitting ] unit-test + +V{ T{ ##branch } } 0 test-bb + +V{ T{ ##branch } } 1 test-bb + +V{ T{ ##branch } } 2 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop + +1 get 2 get 1vector >>successors drop + +[ ] [ test-branch-splitting ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index f7e9ea9cbf..2ab476e20c 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -1,37 +1,81 @@ ! Copyright (C) 2009 Doug Coleman, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors combinators.short-circuit kernel math sequences -compiler.cfg.def-use compiler.cfg compiler.cfg.rpo ; +USING: accessors combinators.short-circuit kernel math math.order +sequences assocs namespaces vectors fry arrays splitting +compiler.cfg.def-use compiler.cfg compiler.cfg.rpo +compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.branch-splitting -! Predecessors must be recomputed after this +: clone-renamings ( insns -- assoc ) + [ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ; -: split-branch-for ( bb predecessor -- ) - [ +: clone-instructions ( insns -- insns' ) + dup clone-renamings renamings [ [ - - swap - [ instructions>> [ clone ] map >>instructions ] - [ successors>> clone >>successors ] - bi - ] keep - ] dip - [ [ 2dup eq? [ 2drop ] [ 2nip ] if ] with with map ] change-successors - drop ; + clone + dup rename-insn-defs + dup rename-insn-uses + dup fresh-insn-temps + ] map + ] with-variable ; + +: clone-basic-block ( bb -- bb' ) + ! The new block gets the same RPO number as the old one. + ! This is just to make 'back-edge?' work. + + swap + [ instructions>> clone-instructions >>instructions ] + [ successors>> clone >>successors ] + [ number>> >>number ] + tri ; + +: new-blocks ( bb -- copies ) + dup predecessors>> [ + [ clone-basic-block ] dip + 1vector >>predecessors + ] with map ; + +: update-predecessor-successor ( pred copy old-bb -- ) + '[ + [ _ _ 3dup nip eq? [ drop nip ] [ 2drop ] if ] map + ] change-successors drop ; + +: update-predecessor-successors ( copies old-bb -- ) + [ predecessors>> swap ] keep + '[ _ update-predecessor-successor ] 2each ; + +: update-successor-predecessor ( copies old-bb succ -- ) + [ + swap 1array split swap join V{ } like + ] change-predecessors drop ; + +: update-successor-predecessors ( copies old-bb -- ) + dup successors>> [ + update-successor-predecessor + ] with with each ; : split-branch ( bb -- ) - dup predecessors>> [ split-branch-for ] with each ; + [ new-blocks ] keep + [ update-predecessor-successors ] + [ update-successor-predecessors ] + 2bi ; -: split-branches? ( bb -- ? ) +UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ; + +: split-instructions? ( insns -- ? ) + [ [ irrelevant? not ] count 5 <= ] + [ last ##fixnum-overflow? not ] + bi and ; + +: split-branch? ( bb -- ? ) { - [ successors>> empty? ] - [ predecessors>> length 1 > ] - [ instructions>> [ defs-vregs ] any? not ] - [ instructions>> [ temp-vregs ] any? not ] + [ dup successors>> [ back-edge? ] with any? not ] + [ predecessors>> length 2 4 between? ] + [ instructions>> split-instructions? ] } 1&& ; : split-branches ( cfg -- cfg' ) dup [ - dup split-branches? [ split-branch ] [ drop ] if + dup split-branch? [ split-branch ] [ drop ] if ] each-basic-block - f >>post-order ; + cfg-changed ; diff --git a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor index e5be2d9eb9..71798da6fc 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces accessors math.order assocs kernel sequences combinators make classes words cpu.architecture @@ -36,12 +36,6 @@ M: insn compute-stack-frame* ] when ; \ _spill t frame-required? set-word-prop -\ ##fixnum-add t frame-required? set-word-prop -\ ##fixnum-sub t frame-required? set-word-prop -\ ##fixnum-mul t frame-required? set-word-prop -\ ##fixnum-add-tail f frame-required? set-word-prop -\ ##fixnum-sub-tail f frame-required? set-word-prop -\ ##fixnum-mul-tail f frame-required? set-word-prop : compute-stack-frame ( insns -- ) frame-required? off diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 8cf141f3f4..2eff8b9e28 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -14,6 +14,7 @@ compiler.cfg.stacks compiler.cfg.utilities compiler.cfg.registers compiler.cfg.intrinsics +compiler.cfg.comparisons compiler.cfg.stack-frame compiler.cfg.instructions compiler.alien ; @@ -22,30 +23,20 @@ IN: compiler.cfg.builder ! Convert tree SSA IR to CFG SSA IR. SYMBOL: procedures -SYMBOL: current-word -SYMBOL: current-label SYMBOL: loops -: add-procedure ( -- ) - basic-block get current-word get current-label get - procedures get push ; - : begin-procedure ( word label -- ) end-basic-block begin-basic-block H{ } clone loops set - current-label set - current-word set - add-procedure ; + [ basic-block get ] 2dip + procedures get push ; : with-cfg-builder ( nodes word label quot -- ) '[ begin-procedure @ ] with-scope ; inline GENERIC: emit-node ( node -- ) -: check-basic-block ( node -- node' ) - basic-block get [ drop f ] unless ; inline - : emit-nodes ( nodes -- ) [ basic-block get [ emit-node ] [ drop ] if ] each ; @@ -97,17 +88,10 @@ M: #recursive emit-node ! #if : emit-branch ( obj -- final-bb ) - [ - begin-basic-block - emit-nodes - basic-block get dup [ ##branch ] when - ] with-scope ; + [ emit-nodes ] with-branch ; : emit-if ( node -- ) - children>> [ emit-branch ] map - end-basic-block - begin-basic-block - basic-block get '[ [ _ swap successors>> push ] when* ] each ; + children>> [ emit-branch ] map emit-conditional ; : ##branch-t ( vreg -- ) \ f tag-number cc/= ##compare-imm-branch ; diff --git a/basis/compiler/cfg/cfg.factor b/basis/compiler/cfg/cfg.factor index 68d7e15a5d..f856efac78 100644 --- a/basis/compiler/cfg/cfg.factor +++ b/basis/compiler/cfg/cfg.factor @@ -1,9 +1,6 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel arrays vectors accessors assocs sets -namespaces math make fry sequences -combinators.short-circuit -compiler.cfg.instructions ; +USING: kernel math vectors arrays accessors namespaces ; IN: compiler.cfg TUPLE: basic-block < identity-tuple @@ -22,36 +19,12 @@ M: basic-block hashcode* nip id>> ; V{ } clone >>predecessors \ basic-block counter >>id ; -: empty-block? ( bb -- ? ) - instructions>> { - [ length 1 = ] - [ first ##branch? ] - } 1&& ; - -SYMBOL: visited - -: (skip-empty-blocks) ( bb -- bb' ) - dup visited get key? [ - dup empty-block? [ - dup visited get conjoin - successors>> first (skip-empty-blocks) - ] when - ] unless ; - -: skip-empty-blocks ( bb -- bb' ) - H{ } clone visited [ (skip-empty-blocks) ] with-variable ; - -: add-instructions ( bb quot -- ) - [ instructions>> building ] dip '[ - building get pop - _ dip - building get push - ] with-variable ; inline - TUPLE: cfg { entry basic-block } word label spill-counts post-order ; : ( entry word label -- cfg ) f f cfg boa ; +: cfg-changed ( cfg -- cfg ) f >>post-order ; inline + TUPLE: mr { instructions array } word label ; : ( instructions word label -- mr ) diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index e7d9dbdd9c..49ea775600 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -16,9 +16,9 @@ ERROR: last-insn-not-a-jump insn ; [ ##return? ] [ ##callback-return? ] [ ##jump? ] - [ ##fixnum-add-tail? ] - [ ##fixnum-sub-tail? ] - [ ##fixnum-mul-tail? ] + [ ##fixnum-add? ] + [ ##fixnum-sub? ] + [ ##fixnum-mul? ] [ ##no-tco? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; diff --git a/basis/compiler/cfg/comparisons/comparisons.factor b/basis/compiler/cfg/comparisons/comparisons.factor new file mode 100644 index 0000000000..576d541230 --- /dev/null +++ b/basis/compiler/cfg/comparisons/comparisons.factor @@ -0,0 +1,36 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs math.order sequences ; +IN: compiler.cfg.comparisons + +SYMBOLS: cc< cc<= cc= cc> cc>= cc/= ; + +: negate-cc ( cc -- cc' ) + H{ + { cc< cc>= } + { cc<= cc> } + { cc> cc<= } + { cc>= cc< } + { cc= cc/= } + { cc/= cc= } + } at ; + +: swap-cc ( cc -- cc' ) + H{ + { cc< cc> } + { cc<= cc>= } + { cc> cc< } + { cc>= cc<= } + { cc= cc= } + { cc/= cc/= } + } at ; + +: evaluate-cc ( result cc -- ? ) + H{ + { cc< { +lt+ } } + { cc<= { +lt+ +eq+ } } + { cc= { +eq+ } } + { cc>= { +eq+ +gt+ } } + { cc> { +gt+ } } + { cc/= { +lt+ +gt+ } } + } at memq? ; \ No newline at end of file diff --git a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor new file mode 100644 index 0000000000..975adfa6cb --- /dev/null +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -0,0 +1,140 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs deques dlists kernel locals sequences lexer +namespaces functors compiler.cfg.rpo compiler.cfg.utilities +compiler.cfg ; +IN: compiler.cfg.dataflow-analysis + +GENERIC: join-sets ( sets dfa -- set ) +GENERIC: transfer-set ( in-set bb dfa -- out-set ) +GENERIC: block-order ( cfg dfa -- bbs ) +GENERIC: successors ( bb dfa -- seq ) +GENERIC: predecessors ( bb dfa -- seq ) + + ( cfg dfa -- queue ) + block-order [ push-all-front ] keep ; + +GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) + +M: kill-block compute-in-set 3drop f ; + +M:: basic-block compute-in-set ( bb out-sets dfa -- set ) + bb dfa predecessors [ out-sets at ] map dfa join-sets ; + +:: update-in-set ( bb in-sets out-sets dfa -- ? ) + bb out-sets dfa compute-in-set + bb in-sets maybe-set-at ; inline + +GENERIC# compute-out-set 2 ( bb out-sets dfa -- set ) + +M: kill-block compute-out-set 3drop f ; + +M:: basic-block compute-out-set ( bb in-sets dfa -- set ) + bb in-sets at bb dfa transfer-set ; + +:: update-out-set ( bb in-sets out-sets dfa -- ? ) + bb in-sets dfa compute-out-set + bb out-sets maybe-set-at ; inline + +:: dfa-step ( bb in-sets out-sets dfa work-list -- ) + bb in-sets out-sets dfa update-in-set [ + bb in-sets out-sets dfa update-out-set [ + bb dfa successors work-list push-all-front + ] when + ] when ; inline + +:: run-dataflow-analysis ( cfg dfa -- in-sets out-sets ) + H{ } clone :> in-sets + H{ } clone :> out-sets + cfg dfa :> work-list + work-list [ in-sets out-sets dfa work-list dfa-step ] slurp-deque + in-sets + out-sets ; inline + +M: dataflow-analysis join-sets drop assoc-refine ; + +FUNCTOR: define-analysis ( name -- ) + +name-analysis DEFINES-CLASS ${name}-analysis +name-ins DEFINES ${name}-ins +name-outs DEFINES ${name}-outs +name-in DEFINES ${name}-in +name-out DEFINES ${name}-out + +WHERE + +SINGLETON: name-analysis + +SYMBOL: name-ins + +: name-in ( bb -- set ) name-ins get at ; + +SYMBOL: name-outs + +: name-out ( bb -- set ) name-outs get at ; + +;FUNCTOR + +! ! ! Forward dataflow analysis + +MIXIN: forward-analysis +INSTANCE: forward-analysis dataflow-analysis + +M: forward-analysis block-order drop reverse-post-order ; +M: forward-analysis successors drop successors>> ; +M: forward-analysis predecessors drop predecessors>> ; + +FUNCTOR: define-forward-analysis ( name -- ) + +name-analysis IS ${name}-analysis +name-ins IS ${name}-ins +name-outs IS ${name}-outs +compute-name-sets DEFINES compute-${name}-sets + +WHERE + +INSTANCE: name-analysis forward-analysis + +: compute-name-sets ( cfg -- ) + name-analysis run-dataflow-analysis + [ name-ins set ] [ name-outs set ] bi* ; + +;FUNCTOR + +! ! ! Backward dataflow analysis + +MIXIN: backward-analysis +INSTANCE: backward-analysis dataflow-analysis + +M: backward-analysis block-order drop post-order ; +M: backward-analysis successors drop predecessors>> ; +M: backward-analysis predecessors drop successors>> ; + +FUNCTOR: define-backward-analysis ( name -- ) + +name-analysis IS ${name}-analysis +name-ins IS ${name}-ins +name-outs IS ${name}-outs +compute-name-sets DEFINES compute-${name}-sets + +WHERE + +INSTANCE: name-analysis backward-analysis + +: compute-name-sets ( cfg -- ) + \ name-analysis run-dataflow-analysis + [ name-outs set ] [ name-ins set ] bi* ; + +;FUNCTOR + +PRIVATE> + +SYNTAX: FORWARD-ANALYSIS: + scan [ define-analysis ] [ define-forward-analysis ] bi ; + +SYNTAX: BACKWARD-ANALYSIS: + scan [ define-analysis ] [ define-backward-analysis ] bi ; diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 60805124cd..e355ee2ac1 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -26,7 +26,7 @@ M: word test-cfg ] map ; : insn. ( insn -- ) - tuple>array [ pprint bl ] each nl ; + tuple>array but-last [ pprint bl ] each nl ; : mr. ( mrs -- ) [ diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index 43ea89f284..c8a9d1861b 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -8,6 +8,7 @@ GENERIC: temp-vregs ( insn -- seq ) GENERIC: uses-vregs ( insn -- seq ) M: ##flushable defs-vregs dst>> 1array ; +M: ##fixnum-overflow defs-vregs dst>> 1array ; M: insn defs-vregs drop f ; M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ; @@ -21,8 +22,6 @@ M: ##set-string-nth-fast temp-vregs temp>> 1array ; M: ##compare temp-vregs temp>> 1array ; M: ##compare-imm temp-vregs temp>> 1array ; M: ##compare-float temp-vregs temp>> 1array ; -M: ##fixnum-mul temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; -M: ##fixnum-mul-tail temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: ##gc temp-vregs [ temp1>> ] [ temp2>> ] bi 2array ; M: _dispatch temp-vregs temp>> 1array ; M: insn temp-vregs drop f ; diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor new file mode 100644 index 0000000000..210d5614c2 --- /dev/null +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -0,0 +1,76 @@ +IN: compiler.cfg.dominance.tests +USING: tools.test sequences vectors namespaces kernel accessors assocs sets +math.ranges arrays compiler.cfg compiler.cfg.dominance compiler.cfg.debugger +compiler.cfg.predecessors ; + +: test-dominance ( -- ) + cfg new 0 get >>entry + compute-predecessors + compute-dominance + drop ; + +! Example with no back edges +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop +1 get 3 get 1vector >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop + +[ ] [ test-dominance ] unit-test + +[ t ] [ 0 get dom-parent 0 get eq? ] unit-test +[ t ] [ 1 get dom-parent 0 get eq? ] unit-test +[ t ] [ 2 get dom-parent 0 get eq? ] unit-test +[ t ] [ 4 get dom-parent 0 get eq? ] unit-test +[ t ] [ 3 get dom-parent 1 get eq? ] unit-test +[ t ] [ 5 get dom-parent 4 get eq? ] unit-test + +[ t ] [ 0 get dom-children 1 get 2 get 4 get 3array set= ] unit-test + +[ { 4 } ] [ 1 get dom-frontier [ number>> ] map ] unit-test +[ { 4 } ] [ 2 get dom-frontier [ number>> ] map ] unit-test +[ { } ] [ 0 get dom-frontier ] unit-test +[ { } ] [ 4 get dom-frontier ] unit-test + +! Example from the paper +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop +1 get 3 get 1vector >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 3 get 1vector >>successors drop + +[ ] [ test-dominance ] unit-test + +[ t ] [ 0 4 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test + +! The other example from the paper +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop +1 get 5 get 1vector >>successors drop +2 get 4 get 3 get V{ } 2sequence >>successors drop +5 get 4 get 1vector >>successors drop +4 get 5 get 3 get V{ } 2sequence >>successors drop +3 get 4 get 1vector >>successors drop + +[ ] [ test-dominance ] unit-test + +[ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor index 750a46ee6c..9c8fc79619 100644 --- a/basis/compiler/cfg/dominance/dominance.factor +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs combinators compiler.cfg.rpo -compiler.cfg.stack-analysis fry kernel math.order namespaces -sequences ; +USING: accessors assocs combinators sets math fry kernel math.order +namespaces sequences sorting compiler.cfg.rpo ; IN: compiler.cfg.dominance ! Reference: @@ -11,31 +10,83 @@ IN: compiler.cfg.dominance ! Keith D. Cooper, Timothy J. Harvey, and Ken Kennedy ! http://www.cs.rice.edu/~keith/EMBED/dom.pdf -SYMBOL: idoms - -: idom ( bb -- bb' ) idoms get at ; +! Also, a nice overview is given in these lecture notes: +! http://llvm.cs.uiuc.edu/~vadve/CS526/public_html/Notes/4ssa.4up.pdf idom(bb) +SYMBOL: dom-parents + +PRIVATE> + +: dom-parent ( bb -- bb' ) dom-parents get at ; + +> ] compare { - { +lt+ [ [ idom ] dip intersect ] } - { +gt+ [ idom intersect ] } + { +gt+ [ [ dom-parent ] dip intersect ] } + { +lt+ [ dom-parent intersect ] } [ 2drop ] } case ; : compute-idom ( bb -- idom ) - predecessors>> [ idom ] map sift + predecessors>> [ dom-parent ] filter [ ] [ intersect ] map-reduce ; : iterate ( rpo -- changed? ) [ [ compute-idom ] keep set-idom ] map [ ] any? ; +: compute-dom-parents ( cfg -- ) + H{ } clone dom-parents set + reverse-post-order + unclip dup set-idom drop '[ _ iterate ] loop ; + +! Maps bb -> {bb' | idom(bb') = bb} +SYMBOL: dom-childrens + PRIVATE> -: compute-dominance ( cfg -- cfg ) - H{ } clone idoms set - dup reverse-post-order - unclip dup set-idom drop '[ _ iterate ] loop ; \ No newline at end of file +: dom-children ( bb -- seq ) dom-childrens get at ; + + DF(bb) +SYMBOL: dom-frontiers + +PRIVATE> + +: dom-frontier ( bb -- set ) dom-frontiers get at keys ; + +> dup length 2 >= [ + [ compute-dom-frontier ] with each + ] [ 2drop ] if + ] each-basic-block ; + +PRIVATE> + +: compute-dominance ( cfg -- cfg' ) + [ compute-dom-parents compute-dom-children ] + [ compute-dom-frontiers ] + [ ] + tri ; diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index b61f091fad..287d0a6999 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -27,6 +27,7 @@ IN: compiler.cfg.hats : ^^add-imm ( src1 src2 -- dst ) ^^i2 ##add-imm ; inline : ^^sub ( src1 src2 -- dst ) ^^i2 ##sub ; inline : ^^sub-imm ( src1 src2 -- dst ) ^^i2 ##sub-imm ; inline +: ^^neg ( src -- dst ) [ 0 ^^load-literal ] dip ^^sub ; inline : ^^mul ( src1 src2 -- dst ) ^^i2 ##mul ; inline : ^^mul-imm ( src1 src2 -- dst ) ^^i2 ##mul-imm ; inline : ^^and ( input mask -- output ) ^^i2 ##and ; inline @@ -35,8 +36,11 @@ IN: compiler.cfg.hats : ^^or-imm ( src1 src2 -- dst ) ^^i2 ##or-imm ; inline : ^^xor ( src1 src2 -- dst ) ^^i2 ##xor ; inline : ^^xor-imm ( src1 src2 -- dst ) ^^i2 ##xor-imm ; inline +: ^^shl ( src1 src2 -- dst ) ^^i2 ##shl ; inline : ^^shl-imm ( src1 src2 -- dst ) ^^i2 ##shl-imm ; inline +: ^^shr ( src1 src2 -- dst ) ^^i2 ##shr ; inline : ^^shr-imm ( src1 src2 -- dst ) ^^i2 ##shr-imm ; inline +: ^^sar ( src1 src2 -- dst ) ^^i2 ##sar ; inline : ^^sar-imm ( src1 src2 -- dst ) ^^i2 ##sar-imm ; inline : ^^not ( src -- dst ) ^^i1 ##not ; inline : ^^log2 ( src -- dst ) ^^i1 ##log2 ; inline @@ -73,5 +77,7 @@ IN: compiler.cfg.hats : ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; 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 +: ^^fixnum-sub ( src1 src2 -- dst ) ^^i2 ##fixnum-sub ; inline +: ^^fixnum-mul ( src1 src2 -- dst ) ^^i2 ##fixnum-mul ; inline : ^^phi ( inputs -- dst ) ^^i1 ##phi ; inline \ No newline at end of file diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index abbb86cb16..d1b7592aaf 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -86,21 +86,15 @@ INSN: ##or < ##commutative ; INSN: ##or-imm < ##commutative-imm ; INSN: ##xor < ##commutative ; INSN: ##xor-imm < ##commutative-imm ; +INSN: ##shl < ##binary ; INSN: ##shl-imm < ##binary-imm ; +INSN: ##shr < ##binary ; INSN: ##shr-imm < ##binary-imm ; +INSN: ##sar < ##binary ; INSN: ##sar-imm < ##binary-imm ; INSN: ##not < ##unary ; INSN: ##log2 < ##unary ; -! Overflowing arithmetic -TUPLE: ##fixnum-overflow < insn src1 src2 ; -INSN: ##fixnum-add < ##fixnum-overflow ; -INSN: ##fixnum-add-tail < ##fixnum-overflow ; -INSN: ##fixnum-sub < ##fixnum-overflow ; -INSN: ##fixnum-sub-tail < ##fixnum-overflow ; -INSN: ##fixnum-mul < ##fixnum-overflow temp1 temp2 ; -INSN: ##fixnum-mul-tail < ##fixnum-overflow temp1 temp2 ; - : ##tag-fixnum ( dst src -- ) tag-bits get ##shl-imm ; inline : ##untag-fixnum ( dst src -- ) tag-bits get ##sar-imm ; inline @@ -181,44 +175,7 @@ INSN: ##loop-entry ; INSN: ##phi < ##pure inputs ; -! Condition codes -SYMBOL: cc< -SYMBOL: cc<= -SYMBOL: cc= -SYMBOL: cc> -SYMBOL: cc>= -SYMBOL: cc/= - -: negate-cc ( cc -- cc' ) - H{ - { cc< cc>= } - { cc<= cc> } - { cc> cc<= } - { cc>= cc< } - { cc= cc/= } - { cc/= cc= } - } at ; - -: swap-cc ( cc -- cc' ) - H{ - { cc< cc> } - { cc<= cc>= } - { cc> cc< } - { cc>= cc<= } - { cc= cc= } - { cc/= cc/= } - } at ; - -: evaluate-cc ( result cc -- ? ) - H{ - { cc< { +lt+ } } - { cc<= { +lt+ +eq+ } } - { cc= { +eq+ } } - { cc>= { +eq+ +gt+ } } - { cc> { +gt+ } } - { cc/= { +lt+ +gt+ } } - } at memq? ; - +! Conditionals TUPLE: ##conditional-branch < insn { src1 vreg } { src2 vreg } cc ; INSN: ##compare-branch < ##conditional-branch ; @@ -230,6 +187,12 @@ INSN: ##compare-imm < ##binary-imm cc temp ; INSN: ##compare-float-branch < ##conditional-branch ; INSN: ##compare-float < ##binary cc temp ; +! Overflowing arithmetic +TUPLE: ##fixnum-overflow < insn { dst vreg } { src1 vreg } { src2 vreg } ; +INSN: ##fixnum-add < ##fixnum-overflow ; +INSN: ##fixnum-sub < ##fixnum-overflow ; +INSN: ##fixnum-mul < ##fixnum-overflow ; + INSN: ##gc { temp1 vreg } { temp2 vreg } live-values ; ! Instructions used by machine IR only. @@ -250,6 +213,12 @@ INSN: _compare-imm-branch label { src1 vreg } { src2 integer } cc ; INSN: _compare-float-branch < _conditional-branch ; +! Overflowing arithmetic +TUPLE: _fixnum-overflow < insn label { dst vreg } { src1 vreg } { src2 vreg } ; +INSN: _fixnum-add < _fixnum-overflow ; +INSN: _fixnum-sub < _fixnum-overflow ; +INSN: _fixnum-mul < _fixnum-overflow ; + TUPLE: spill-slot n ; C: spill-slot INSN: _gc { temp1 vreg } { temp2 vreg } gc-roots gc-root-count gc-root-size ; @@ -261,3 +230,19 @@ INSN: _reload dst class n ; INSN: _copy dst src class ; INSN: _spill-counts counts ; +! Instructions that poison the stack state +UNION: poison-insn + ##jump + ##return + ##callback-return ; + +! Instructions that kill all live vregs +UNION: kill-vreg-insn + poison-insn + ##stack-frame + ##call + ##prologue + ##epilogue + ##alien-invoke + ##alien-indirect + ##alien-callback ; diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 9efac9e81a..5dc04d47e1 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -1,13 +1,14 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: sequences accessors layouts kernel math namespaces -combinators fry locals +USING: sequences accessors layouts kernel math math.intervals +namespaces combinators fry arrays compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions compiler.cfg.utilities -compiler.cfg.registers ; +compiler.cfg.registers +compiler.cfg.comparisons ; IN: compiler.cfg.intrinsics.fixnum : emit-both-fixnums? ( -- ) @@ -20,44 +21,27 @@ IN: compiler.cfg.intrinsics.fixnum : tag-literal ( n -- tagged ) literal>> [ tag-fixnum ] [ \ f tag-number ] if* ; -: emit-fixnum-imm-op1 ( infos insn -- dst ) - [ ds-pop ds-drop ] [ first tag-literal ] [ ] tri* call ; inline +: emit-fixnum-op ( insn -- ) + [ 2inputs ] dip call ds-push ; inline -: emit-fixnum-imm-op2 ( infos insn -- dst ) - [ ds-drop ds-pop ] [ second tag-literal ] [ ] tri* call ; inline +: emit-fixnum-left-shift ( -- ) + [ ^^untag-fixnum ^^shl ] emit-fixnum-op ; -: (emit-fixnum-op) ( insn -- dst ) - [ 2inputs ] dip call ; inline +: emit-fixnum-right-shift ( -- ) + [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ; -:: emit-fixnum-op ( node insn imm-insn -- ) - [let | infos [ node node-input-infos ] | - infos second value-info-small-tagged? - [ infos imm-insn emit-fixnum-imm-op2 ] - [ insn (emit-fixnum-op) ] if - ds-push - ] ; inline - -:: emit-commutative-fixnum-op ( node insn imm-insn -- ) - [let | infos [ node node-input-infos ] | - { - { [ infos first value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op1 ] } - { [ infos second value-info-small-tagged? ] [ infos imm-insn emit-fixnum-imm-op2 ] } - [ insn (emit-fixnum-op) ] - } cond - ds-push - ] ; inline +: emit-fixnum-shift-general ( -- ) + D 0 ^^peek 0 cc> ##compare-imm-branch + [ emit-fixnum-left-shift ] with-branch + [ emit-fixnum-right-shift ] with-branch + 2array emit-conditional ; : emit-fixnum-shift-fast ( node -- ) - dup node-input-infos dup second value-info-small-fixnum? [ - nip - [ ds-drop ds-pop ] dip - second literal>> dup sgn { - { -1 [ neg tag-bits get + ^^sar-imm ^^tag-fixnum ] } - { 0 [ drop ] } - { 1 [ ^^shl-imm ] } - } case - ds-push - ] [ drop emit-primitive ] if ; + node-input-infos second interval>> { + { [ dup 0 [a,inf] interval-subset? ] [ drop emit-fixnum-left-shift ] } + { [ dup 0 [-inf,a] interval-subset? ] [ drop emit-fixnum-right-shift ] } + [ drop emit-fixnum-shift-general ] + } cond ; : emit-fixnum-bitnot ( -- ) ds-pop ^^not tag-mask get ^^xor-imm ds-push ; @@ -65,34 +49,11 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum-log2 ( -- ) ds-pop ^^log2 tag-bits get ^^sub-imm ^^tag-fixnum ds-push ; -: (emit-fixnum*fast) ( -- dst ) - 2inputs ^^untag-fixnum ^^mul ; +: emit-fixnum*fast ( -- ) + 2inputs ^^untag-fixnum ^^mul ds-push ; -: (emit-fixnum*fast-imm1) ( infos -- dst ) - [ ds-pop ds-drop ] [ first literal>> ] bi* ^^mul-imm ; - -: (emit-fixnum*fast-imm2) ( infos -- dst ) - [ ds-drop ds-pop ] [ second literal>> ] bi* ^^mul-imm ; - -: emit-fixnum*fast ( node -- ) - node-input-infos - dup first value-info-small-fixnum? drop f - [ - (emit-fixnum*fast-imm1) - ] [ - dup second value-info-small-fixnum? - [ (emit-fixnum*fast-imm2) ] [ drop (emit-fixnum*fast) ] if - ] if - ds-push ; - -: (emit-fixnum-comparison) ( cc -- quot1 quot2 ) - [ ^^compare ] [ ^^compare-imm ] bi-curry ; inline - -: emit-eq ( node -- ) - cc= (emit-fixnum-comparison) emit-commutative-fixnum-op ; - -: emit-fixnum-comparison ( node cc -- ) - (emit-fixnum-comparison) emit-fixnum-op ; +: emit-fixnum-comparison ( cc -- ) + '[ _ ^^compare ] emit-fixnum-op ; : emit-bignum>fixnum ( -- ) ds-pop ^^bignum>integer ^^tag-fixnum ds-push ; @@ -100,6 +61,28 @@ IN: compiler.cfg.intrinsics.fixnum : emit-fixnum>bignum ( -- ) ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; -: emit-fixnum-overflow-op ( quot -- next ) - [ 2inputs 1 ##inc-d ] dip call ##branch - begin-basic-block ; inline +: emit-no-overflow-case ( dst -- final-bb ) + [ -2 ##inc-d ds-push ] with-branch ; + +: emit-overflow-case ( word -- final-bb ) + [ ##call ] with-branch ; + +: emit-fixnum-overflow-op ( quot word -- ) + [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip + [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array + emit-conditional ; inline + +: fixnum+overflow ( x y -- z ) [ >bignum ] bi@ + ; + +: fixnum-overflow ( x y -- z ) [ >bignum ] bi@ - ; + +: fixnum*overflow ( x y -- z ) [ >bignum ] bi@ * ; + +: emit-fixnum+ ( -- ) + [ ^^fixnum-add ] \ fixnum+overflow emit-fixnum-overflow-op ; + +: emit-fixnum- ( -- ) + [ ^^fixnum-sub ] \ fixnum-overflow emit-fixnum-overflow-op ; + +: emit-fixnum* ( -- ) + [ ^^untag-fixnum ^^fixnum-mul ] \ fixnum*overflow emit-fixnum-overflow-op ; \ No newline at end of file diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index df01bba89b..2618db0904 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -8,7 +8,8 @@ compiler.cfg.intrinsics.allot compiler.cfg.intrinsics.fixnum compiler.cfg.intrinsics.float compiler.cfg.intrinsics.slots -compiler.cfg.intrinsics.misc ; +compiler.cfg.intrinsics.misc +compiler.cfg.comparisons ; QUALIFIED: kernel QUALIFIED: arrays QUALIFIED: byte-arrays @@ -40,8 +41,8 @@ IN: compiler.cfg.intrinsics math.private:fixnum<= math.private:fixnum>= math.private:fixnum> - math.private:bignum>fixnum - math.private:fixnum>bignum + ! math.private:bignum>fixnum + ! math.private:fixnum>bignum kernel:eq? slots.private:slot slots.private:set-slot @@ -99,23 +100,23 @@ IN: compiler.cfg.intrinsics { \ kernel.private:tag [ drop emit-tag ] } { \ kernel.private:getenv [ emit-getenv ] } { \ math.private:both-fixnums? [ drop emit-both-fixnums? ] } - { \ math.private:fixnum+ [ drop [ ##fixnum-add ] emit-fixnum-overflow-op ] } - { \ math.private:fixnum- [ drop [ ##fixnum-sub ] emit-fixnum-overflow-op ] } - { \ math.private:fixnum* [ drop [ i i ##fixnum-mul ] emit-fixnum-overflow-op ] } - { \ math.private:fixnum+fast [ [ ^^add ] [ ^^add-imm ] emit-commutative-fixnum-op ] } - { \ math.private:fixnum-fast [ [ ^^sub ] [ ^^sub-imm ] emit-fixnum-op ] } - { \ math.private:fixnum-bitand [ [ ^^and ] [ ^^and-imm ] emit-commutative-fixnum-op ] } - { \ math.private:fixnum-bitor [ [ ^^or ] [ ^^or-imm ] emit-commutative-fixnum-op ] } - { \ math.private:fixnum-bitxor [ [ ^^xor ] [ ^^xor-imm ] emit-commutative-fixnum-op ] } + { \ math.private:fixnum+ [ drop emit-fixnum+ ] } + { \ math.private:fixnum- [ drop emit-fixnum- ] } + { \ math.private:fixnum* [ drop emit-fixnum* ] } + { \ math.private:fixnum+fast [ drop [ ^^add ] emit-fixnum-op ] } + { \ math.private:fixnum-fast [ drop [ ^^sub ] emit-fixnum-op ] } + { \ math.private:fixnum-bitand [ drop [ ^^and ] emit-fixnum-op ] } + { \ math.private:fixnum-bitor [ drop [ ^^or ] emit-fixnum-op ] } + { \ math.private:fixnum-bitxor [ drop [ ^^xor ] emit-fixnum-op ] } { \ math.private:fixnum-shift-fast [ emit-fixnum-shift-fast ] } { \ math.private:fixnum-bitnot [ drop emit-fixnum-bitnot ] } { \ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] } - { \ math.private:fixnum*fast [ emit-fixnum*fast ] } - { \ math.private:fixnum< [ cc< emit-fixnum-comparison ] } - { \ math.private:fixnum<= [ cc<= emit-fixnum-comparison ] } - { \ math.private:fixnum>= [ cc>= emit-fixnum-comparison ] } - { \ math.private:fixnum> [ cc> emit-fixnum-comparison ] } - { \ kernel:eq? [ emit-eq ] } + { \ math.private:fixnum*fast [ drop emit-fixnum*fast ] } + { \ math.private:fixnum< [ drop cc< emit-fixnum-comparison ] } + { \ math.private:fixnum<= [ drop cc<= emit-fixnum-comparison ] } + { \ math.private:fixnum>= [ drop cc>= emit-fixnum-comparison ] } + { \ math.private:fixnum> [ drop cc> emit-fixnum-comparison ] } + { \ kernel:eq? [ drop cc= emit-fixnum-comparison ] } { \ math.private:bignum>fixnum [ drop emit-bignum>fixnum ] } { \ math.private:fixnum>bignum [ drop emit-fixnum>bignum ] } { \ math.private:float+ [ drop [ ^^add-float ] emit-float-op ] } diff --git a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor index e99c2ba710..ef8a9c56f8 100644 --- a/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor +++ b/basis/compiler/cfg/linear-scan/allocation/coalescing/coalescing.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences +USING: accessors kernel sequences namespaces assocs fry combinators.short-circuit compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation.state ; @@ -20,9 +20,16 @@ IN: compiler.cfg.linear-scan.allocation.coalescing [ avoids-inactive-intervals? ] } 1&& ; +: reuse-spill-slot ( old new -- ) + [ vreg>> spill-slots get at ] dip '[ _ vreg>> spill-slots get set-at ] when* ; + +: reuse-register ( old new -- ) + reg>> >>reg drop ; + +: (coalesce) ( old new -- ) + [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ; + : coalesce ( live-interval -- ) dup copy-from>> active-interval - [ [ add-active ] [ [ delete-active ] [ add-handled ] bi ] bi* ] - [ reg>> >>reg drop ] - 2bi ; + [ reuse-spill-slot ] [ reuse-register ] [ (coalesce) ] 2tri ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor index b89c1f4de2..14046a91f1 100644 --- a/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor +++ b/basis/compiler/cfg/linear-scan/allocation/spilling/spilling.factor @@ -17,7 +17,7 @@ ERROR: bad-live-ranges interval ; ] [ drop ] if ; : trim-before-ranges ( live-interval -- ) - [ ranges>> ] [ uses>> last ] bi + [ ranges>> ] [ uses>> last 1 + ] bi [ '[ from>> _ <= ] filter-here ] [ swap last (>>to) ] 2bi ; diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 143e84aaf4..98deca9472 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -19,7 +19,7 @@ IN: compiler.cfg.linear-scan.assignment SYMBOL: pending-intervals : add-active ( live-interval -- ) - pending-intervals get push ; + dup end>> pending-intervals get heap-push ; ! Minheap of live intervals which still need a register allocation SYMBOL: unhandled-intervals @@ -37,7 +37,7 @@ SYMBOL: register-live-ins SYMBOL: register-live-outs : init-assignment ( live-intervals -- ) - V{ } clone pending-intervals set + pending-intervals set unhandled-intervals set H{ } clone register-live-ins set H{ } clone register-live-outs set @@ -61,12 +61,17 @@ SYMBOL: register-live-outs register->register ] [ drop ] if ; +: (expire-old-intervals) ( n heap -- ) + dup heap-empty? [ 2drop ] [ + 2dup heap-peek nip <= [ 2drop ] [ + dup heap-pop drop [ handle-spill ] [ handle-copy ] bi + (expire-old-intervals) + ] if + ] if ; + : expire-old-intervals ( n -- ) [ - [ pending-intervals get ] dip '[ - dup end>> _ < - [ [ handle-spill ] [ handle-copy ] bi f ] [ drop t ] if - ] filter-here + pending-intervals get (expire-old-intervals) ] { } make mapping-instructions % ; : insert-reload ( live-interval -- ) @@ -111,14 +116,12 @@ ERROR: overlapping-registers intervals ; dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ; : active-intervals ( n -- intervals ) - pending-intervals get [ covers? ] with filter + pending-intervals get heap-values [ covers? ] with filter check-assignment? get [ dup check-assignment ] when ; M: vreg-insn assign-registers-in-insn - dup [ all-vregs ] [ insn#>> active-intervals ] bi - '[ _ [ vreg>> = ] with find nip ] map - register-mapping - >>regs drop ; + dup [ all-vregs ] [ insn#>> active-intervals register-mapping ] bi + extract-keys >>regs drop ; M: ##gc assign-registers-in-insn ! This works because ##gc is always the first instruction @@ -150,7 +153,7 @@ ERROR: bad-live-values live-values ; : begin-block ( bb -- ) dup basic-block set - dup block-from prepare-insn + dup block-from activate-new-intervals [ [ live-in ] [ block-from ] bi compute-live-values ] keep register-live-ins get set-at ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index 06817071d4..df521c1988 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -12,6 +12,7 @@ compiler.cfg.predecessors compiler.cfg.rpo compiler.cfg.linearization compiler.cfg.debugger +compiler.cfg.comparisons compiler.cfg.linear-scan compiler.cfg.linear-scan.numbering compiler.cfg.linear-scan.live-intervals @@ -82,9 +83,9 @@ check-numbering? on T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } { start 0 } - { end 1 } + { end 2 } { uses V{ 0 1 } } - { ranges V{ T{ live-range f 0 1 } } } + { ranges V{ T{ live-range f 0 2 } } } } T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } @@ -107,9 +108,9 @@ check-numbering? on T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } { start 0 } - { end 0 } + { end 1 } { uses V{ 0 } } - { ranges V{ T{ live-range f 0 0 } } } + { ranges V{ T{ live-range f 0 1 } } } } T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } @@ -132,9 +133,9 @@ check-numbering? on T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } { start 0 } - { end 0 } + { end 1 } { uses V{ 0 } } - { ranges V{ T{ live-range f 0 0 } } } + { ranges V{ T{ live-range f 0 1 } } } } T{ live-interval { vreg T{ vreg { reg-class int-regs } { n 1 } } } @@ -384,7 +385,7 @@ SYMBOL: max-uses [ \ live-interval new swap int-regs swap vreg boa >>vreg - max-uses get random 2 max [ not-taken ] replicate natural-sort + max-uses get random 2 max [ not-taken 2 * ] replicate natural-sort [ >>uses ] [ first >>start ] bi dup uses>> last >>end dup [ start>> ] [ end>> ] bi 1vector >>ranges @@ -1317,38 +1318,6 @@ USING: math.private ; allocate-registers drop ] unit-test -! Spill slot liveness was computed incorrectly, leading to a FEP -! early in bootstrap on x86-32 -[ t ] [ - [ - H{ } clone live-ins set - H{ } clone live-outs set - H{ } clone phi-live-ins set - T{ basic-block - { id 12345 } - { instructions - V{ - T{ ##gc f V int-regs 6 V int-regs 7 } - T{ ##peek f V int-regs 0 D 0 } - T{ ##peek f V int-regs 1 D 1 } - T{ ##peek f V int-regs 2 D 2 } - T{ ##peek f V int-regs 3 D 3 } - T{ ##peek f V int-regs 4 D 4 } - T{ ##peek f V int-regs 5 D 5 } - T{ ##replace f V int-regs 0 D 1 } - T{ ##replace f V int-regs 1 D 2 } - T{ ##replace f V int-regs 2 D 3 } - T{ ##replace f V int-regs 3 D 4 } - T{ ##replace f V int-regs 4 D 5 } - T{ ##replace f V int-regs 5 D 0 } - } - } - } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan) - instructions>> first - live-values>> assoc-empty? - ] with-scope -] unit-test - [ f ] [ T{ live-range f 0 10 } T{ live-range f 20 30 } @@ -1541,6 +1510,7 @@ SYMBOL: linear-scan-result compute-liveness dup reverse-post-order { { int-regs regs } } (linear-scan) + cfg-changed flatten-cfg 1array mr. ] with-scope ; @@ -1802,7 +1772,8 @@ test-diamond 2 get instructions>> first regs>> V int-regs 1 swap at assert= ] unit-test -[ _copy ] [ 3 get instructions>> second class ] unit-test +! Not until splitting is finished +! [ _copy ] [ 3 get instructions>> second class ] unit-test ! Resolve pass; make sure the spilling is done correctly V{ T{ ##peek f V int-regs 3 R 1 } T{ ##branch } } 0 test-bb @@ -1834,7 +1805,7 @@ test-diamond [ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test -[ _spill ] [ 2 get instructions>> first class ] unit-test +[ _spill ] [ 2 get successors>> first instructions>> first class ] unit-test [ _spill ] [ 3 get instructions>> second class ] unit-test @@ -1890,7 +1861,7 @@ V{ [ t ] [ 2 get instructions>> [ _spill? ] any? ] unit-test -[ t ] [ 3 get instructions>> [ _spill? ] any? ] unit-test +[ t ] [ 3 get predecessors>> first instructions>> [ _spill? ] any? ] unit-test [ t ] [ 5 get instructions>> [ _reload? ] any? ] unit-test @@ -1957,7 +1928,7 @@ V{ [ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> ] map ] unit-test ! Resolve pass should insert this -[ _reload ] [ 5 get instructions>> first class ] unit-test +[ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test ! Some random bug V{ @@ -2188,12 +2159,7 @@ V{ T{ ##replace { src V int-regs 85 } { loc D 1 } } T{ ##replace { src V int-regs 89 } { loc D 4 } } T{ ##replace { src V int-regs 96 } { loc R 0 } } - T{ ##fixnum-mul - { src1 V int-regs 128 } - { src2 V int-regs 129 } - { temp1 V int-regs 132 } - { temp2 V int-regs 133 } - } + T{ ##replace { src V int-regs 129 } { loc R 0 } } T{ ##branch } } 2 test-bb @@ -2284,202 +2250,159 @@ V{ [ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test -! Another push-all reduction to demonstrate numbering anamoly -V{ T{ ##prologue } T{ ##branch } } -0 test-bb +! Fencepost error in assignment pass +V{ T{ ##branch } } 0 test-bb V{ - T{ ##peek { dst V int-regs 1 } { loc D 0 } } - T{ ##slot-imm - { dst V int-regs 5 } - { obj V int-regs 1 } - { slot 3 } - { tag 7 } - } - T{ ##peek { dst V int-regs 7 } { loc D 1 } } - T{ ##slot-imm - { dst V int-regs 12 } - { obj V int-regs 7 } - { slot 1 } - { tag 6 } - } - T{ ##add - { dst V int-regs 25 } - { src1 V int-regs 5 } - { src2 V int-regs 12 } - } - T{ ##compare-branch - { src1 V int-regs 25 } - { src2 V int-regs 5 } - { cc cc> } - } -} -1 test-bb + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare-imm-branch f V int-regs 0 5 cc= } +} 1 test-bb + +V{ T{ ##branch } } 2 test-bb V{ - T{ ##slot-imm - { dst V int-regs 41 } - { obj V int-regs 1 } - { slot 2 } - { tag 7 } - } - T{ ##slot-imm - { dst V int-regs 44 } - { obj V int-regs 41 } - { slot 1 } - { tag 6 } - } - T{ ##compare-branch - { src1 V int-regs 25 } - { src2 V int-regs 44 } - { cc cc> } - } -} -2 test-bb - -V{ - T{ ##add-imm - { dst V int-regs 54 } - { src1 V int-regs 25 } - { src2 8 } - } - T{ ##load-immediate { dst V int-regs 55 } { val 24 } } - T{ ##inc-d { n 4 } } - T{ ##inc-r { n 1 } } - T{ ##replace { src V int-regs 25 } { loc D 2 } } - T{ ##replace { src V int-regs 1 } { loc D 3 } } - T{ ##replace { src V int-regs 5 } { loc D 4 } } - T{ ##replace { src V int-regs 1 } { loc D 1 } } - T{ ##replace { src V int-regs 54 } { loc D 0 } } - T{ ##replace { src V int-regs 12 } { loc R 0 } } - T{ ##fixnum-mul - { src1 V int-regs 54 } - { src2 V int-regs 55 } - { temp1 V int-regs 58 } - { temp2 V int-regs 59 } - } + T{ ##peek f V int-regs 1 D 0 } + T{ ##peek f V int-regs 2 D 0 } + T{ ##replace f V int-regs 1 D 0 } + T{ ##replace f V int-regs 2 D 0 } T{ ##branch } -} -3 test-bb +} 3 test-bb V{ - T{ ##peek { dst V int-regs 60 } { loc D 1 } } - T{ ##slot-imm - { dst V int-regs 66 } - { obj V int-regs 60 } - { slot 2 } - { tag 7 } - } - T{ ##inc-d { n 1 } } - T{ ##inc-r { n 1 } } - T{ ##replace { src V int-regs 66 } { loc D 0 } } - T{ ##replace { src V int-regs 60 } { loc R 0 } } - T{ ##call { word resize-string } } - T{ ##branch } -} -4 test-bb - -V{ - T{ ##peek { dst V int-regs 67 } { loc R 0 } } - T{ ##peek { dst V int-regs 68 } { loc D 0 } } - T{ ##set-slot-imm - { src V int-regs 68 } - { obj V int-regs 67 } - { slot 2 } - { tag 7 } - } - T{ ##write-barrier - { src V int-regs 67 } - { card# V int-regs 75 } - { table V int-regs 76 } - } - T{ ##inc-d { n -1 } } - T{ ##inc-r { n -1 } } - T{ ##peek { dst V int-regs 94 } { loc D 0 } } - T{ ##peek { dst V int-regs 96 } { loc D 1 } } - T{ ##peek { dst V int-regs 98 } { loc D 2 } } - T{ ##peek { dst V int-regs 100 } { loc D 3 } } - T{ ##peek { dst V int-regs 102 } { loc D 4 } } - T{ ##peek { dst V int-regs 106 } { loc R 0 } } - T{ ##copy { dst V int-regs 95 } { src V int-regs 94 } } - T{ ##copy { dst V int-regs 97 } { src V int-regs 96 } } - T{ ##copy { dst V int-regs 99 } { src V int-regs 98 } } - T{ ##copy { dst V int-regs 101 } { src V int-regs 100 } } - T{ ##copy { dst V int-regs 103 } { src V int-regs 102 } } - T{ ##copy { dst V int-regs 107 } { src V int-regs 106 } } - T{ ##branch } -} -5 test-bb - -V{ - T{ ##inc-d { n 3 } } - T{ ##inc-r { n 1 } } - T{ ##copy { dst V int-regs 95 } { src V int-regs 1 } } - T{ ##copy { dst V int-regs 97 } { src V int-regs 25 } } - T{ ##copy { dst V int-regs 99 } { src V int-regs 1 } } - T{ ##copy { dst V int-regs 101 } { src V int-regs 5 } } - T{ ##copy { dst V int-regs 103 } { src V int-regs 7 } } - T{ ##copy { dst V int-regs 107 } { src V int-regs 12 } } - T{ ##branch } -} -6 test-bb - -V{ - T{ ##load-immediate - { dst V int-regs 78 } - { val 4611686018427387896 } - } - T{ ##and - { dst V int-regs 81 } - { src1 V int-regs 97 } - { src2 V int-regs 78 } - } - T{ ##set-slot-imm - { src V int-regs 81 } - { obj V int-regs 95 } - { slot 3 } - { tag 7 } - } - T{ ##inc-d { n -2 } } - T{ ##copy { dst V int-regs 110 } { src V int-regs 99 } } - T{ ##copy { dst V int-regs 111 } { src V int-regs 101 } } - T{ ##copy { dst V int-regs 112 } { src V int-regs 103 } } - T{ ##copy { dst V int-regs 117 } { src V int-regs 107 } } - T{ ##branch } -} -7 test-bb - -V{ - T{ ##inc-d { n 1 } } - T{ ##inc-r { n 1 } } - T{ ##copy { dst V int-regs 110 } { src V int-regs 1 } } - T{ ##copy { dst V int-regs 111 } { src V int-regs 5 } } - T{ ##copy { dst V int-regs 112 } { src V int-regs 7 } } - T{ ##copy { dst V int-regs 117 } { src V int-regs 12 } } - T{ ##branch } -} -8 test-bb - -V{ - T{ ##inc-d { n 1 } } - T{ ##inc-r { n -1 } } - T{ ##replace { src V int-regs 117 } { loc D 0 } } - T{ ##replace { src V int-regs 110 } { loc D 1 } } - T{ ##replace { src V int-regs 111 } { loc D 2 } } - T{ ##replace { src V int-regs 112 } { loc D 3 } } - T{ ##epilogue } + T{ ##replace f V int-regs 0 D 0 } T{ ##return } -} -9 test-bb +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test + +[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test + +[ 1 ] [ 3 get predecessors>> first instructions>> [ _spill? ] count ] unit-test + +[ 1 ] [ 4 get instructions>> [ _reload? ] count ] unit-test + +! Another test case for fencepost error in assignment pass +V{ T{ ##branch } } 0 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare-imm-branch f V int-regs 0 5 cc= } +} 1 test-bb + +V{ + T{ ##peek f V int-regs 1 D 0 } + T{ ##peek f V int-regs 2 D 0 } + T{ ##replace f V int-regs 1 D 0 } + T{ ##replace f V int-regs 2 D 0 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace f V int-regs 0 D 0 } + T{ ##return } +} 4 test-bb + +test-diamond + +[ ] [ { 1 2 } test-linear-scan-on-cfg ] unit-test + +[ 0 ] [ 1 get instructions>> [ _spill? ] count ] unit-test + +[ 1 ] [ 2 get instructions>> [ _spill? ] count ] unit-test + +[ 1 ] [ 2 get instructions>> [ _reload? ] count ] unit-test + +[ 0 ] [ 3 get instructions>> [ _spill? ] count ] unit-test + +[ 0 ] [ 4 get instructions>> [ _reload? ] count ] unit-test + +! GC check tests + +! Spill slot liveness was computed incorrectly, leading to a FEP +! early in bootstrap on x86-32 +[ t ] [ + [ + H{ } clone live-ins set + H{ } clone live-outs set + H{ } clone phi-live-ins set + T{ basic-block + { id 12345 } + { instructions + V{ + T{ ##gc f V int-regs 6 V int-regs 7 } + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##peek f V int-regs 2 D 2 } + T{ ##peek f V int-regs 3 D 3 } + T{ ##peek f V int-regs 4 D 4 } + T{ ##peek f V int-regs 5 D 5 } + T{ ##replace f V int-regs 0 D 1 } + T{ ##replace f V int-regs 1 D 2 } + T{ ##replace f V int-regs 2 D 3 } + T{ ##replace f V int-regs 3 D 4 } + T{ ##replace f V int-regs 4 D 5 } + T{ ##replace f V int-regs 5 D 0 } + } + } + } dup 1array { { int-regs V{ 0 1 2 3 } } } (linear-scan) + instructions>> first + live-values>> assoc-empty? + ] with-scope +] unit-test + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##replace f V int-regs 1 D 1 } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##gc f V int-regs 2 V int-regs 3 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##replace f V int-regs 0 D 0 } + T{ ##return } +} 2 test-bb 0 get 1 get 1vector >>successors drop -1 get 2 get 8 get V{ } 2sequence >>successors drop -2 get 3 get 6 get V{ } 2sequence >>successors drop -3 get 4 get 1vector >>successors drop -4 get 5 get 1vector >>successors drop -5 get 7 get 1vector >>successors drop -6 get 7 get 1vector >>successors drop -7 get 9 get 1vector >>successors drop -8 get 9 get 1vector >>successors drop +1 get 2 get 1vector >>successors drop -[ ] [ { 1 2 3 4 5 } test-linear-scan-on-cfg ] unit-test \ No newline at end of file +[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test + +[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test + + + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##compare-imm-branch f V int-regs 1 5 cc= } +} 0 test-bb + +V{ + T{ ##gc f V int-regs 2 V int-regs 3 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##return } +} 1 test-bb + +V{ + T{ ##return } +} 2 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop + +[ ] [ { 1 2 3 } test-linear-scan-on-cfg ] unit-test + +[ H{ { V int-regs 0 3 } } ] [ 1 get instructions>> first live-values>> ] unit-test diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index 77d66c274d..c17aa23e83 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -40,4 +40,5 @@ IN: compiler.cfg.linear-scan init-mapping dup reverse-post-order machine-registers (linear-scan) spill-counts get >>spill-counts + cfg-changed ] with-scope ; diff --git a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor index bf7e8bc042..68a780d42a 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces kernel assocs accessors sequences math math.order fry -combinators compiler.cfg.instructions compiler.cfg.registers +combinators binary-search compiler.cfg.instructions compiler.cfg.registers compiler.cfg.def-use compiler.cfg.liveness compiler.cfg ; IN: compiler.cfg.linear-scan.live-intervals @@ -16,16 +16,21 @@ split-before split-after split-next start end ranges uses copy-from ; -: covers? ( insn# live-interval -- ? ) - ranges>> [ [ from>> ] [ to>> ] bi between? ] with any? ; +GENERIC: covers? ( insn# obj -- ? ) -: child-interval-at ( insn# interval -- interval' ) - dup split-after>> [ - 2dup split-after>> start>> < - [ split-before>> ] [ split-after>> ] if - child-interval-at - ] [ nip ] if ; +M: f covers? 2drop f ; +M: live-range covers? [ from>> ] [ to>> ] bi between? ; + +M: live-interval covers? ( insn# live-interval -- ? ) + ranges>> + dup length 4 <= [ + [ covers? ] with any? + ] [ + [ drop ] [ [ from>> <=> ] with search nip ] 2bi + covers? + ] if ; + ERROR: dead-value-error vreg ; : shorten-range ( n live-interval -- ) @@ -122,10 +127,10 @@ M: ##copy-float compute-live-intervals* dup ranges>> [ first from>> ] [ last to>> ] bi [ >>start ] [ >>end ] bi* drop ; -: check-start/end ( live-interval -- ) - [ [ start>> ] [ uses>> first ] bi assert= ] - [ [ end>> ] [ uses>> last ] bi assert= ] - bi ; +ERROR: bad-live-interval live-interval ; + +: check-start ( live-interval -- ) + dup start>> -1 = [ bad-live-interval ] [ drop ] if ; : finish-live-intervals ( live-intervals -- ) ! Since live intervals are computed in a backward order, we have @@ -135,7 +140,7 @@ M: ##copy-float compute-live-intervals* [ ranges>> reverse-here ] [ uses>> reverse-here ] [ compute-start/end ] - [ check-start/end ] + [ check-start ] } cleave ] each ; diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor deleted file mode 100644 index b5e95258bf..0000000000 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ /dev/null @@ -1,7 +0,0 @@ -USING: arrays compiler.cfg.linear-scan.resolve kernel -tools.test ; -IN: compiler.cfg.linear-scan.resolve.tests - -[ { 1 2 3 4 5 6 } ] [ - { 3 4 } V{ 1 2 } clone [ { 5 6 } 3append-here ] keep >array -] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 7b7f242e4e..f7ed994f18 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -3,6 +3,7 @@ USING: accessors arrays assocs combinators combinators.short-circuit fry kernel locals make math sequences +compiler.cfg.utilities compiler.cfg.instructions compiler.cfg.linear-scan.assignment compiler.cfg.linear-scan.mapping compiler.cfg.liveness ; @@ -30,42 +31,14 @@ IN: compiler.cfg.linear-scan.resolve [ resolve-value-data-flow ] with with each ] { } make ; -: fork? ( from to -- ? ) - { - [ drop successors>> length 1 >= ] - [ nip predecessors>> length 1 = ] - } 2&& ; inline - -: insert-position/fork ( from to -- before after ) - nip instructions>> [ >array ] [ dup delete-all ] bi swap ; - -: join? ( from to -- ? ) - { - [ drop successors>> length 1 = ] - [ nip predecessors>> length 1 >= ] - } 2&& ; inline - -: insert-position/join ( from to -- before after ) - drop instructions>> dup pop 1array ; - -: insert-position ( bb to -- before after ) - { - { [ 2dup fork? ] [ insert-position/fork ] } - { [ 2dup join? ] [ insert-position/join ] } - } cond ; - -: 3append-here ( seq2 seq1 seq3 -- ) - #! Mutate seq1 - swap '[ _ push-all ] bi@ ; - -: perform-mappings ( mappings bb to -- ) - pick empty? [ 3drop ] [ - [ mapping-instructions ] 2dip - insert-position 3append-here +: perform-mappings ( bb to mappings -- ) + dup empty? [ 3drop ] [ + mapping-instructions + insert-basic-block ] if ; : resolve-edge-data-flow ( bb to -- ) - [ compute-mappings ] [ perform-mappings ] 2bi ; + 2dup compute-mappings perform-mappings ; : resolve-block-data-flow ( bb -- ) dup successors>> [ resolve-edge-data-flow ] with each ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index 15e7cef553..9faa1e9e38 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -5,6 +5,7 @@ combinators assocs arrays locals cpu.architecture compiler.cfg compiler.cfg.rpo compiler.cfg.liveness +compiler.cfg.comparisons compiler.cfg.stack-frame compiler.cfg.instructions ; IN: compiler.cfg.linearization @@ -30,8 +31,10 @@ M: insn linearize-insn , drop ; M: ##branch linearize-insn drop dup successors>> first emit-branch ; +: successors ( bb -- first second ) successors>> first2 ; inline + : (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc ) - [ dup successors>> first2 ] + [ dup successors ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline : binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) @@ -51,6 +54,19 @@ M: ##compare-imm-branch linearize-insn M: ##compare-float-branch linearize-insn [ binary-conditional _compare-float-branch ] with-regs emit-branch ; +: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 ) + [ dup successors number>> ] + [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline + +M: ##fixnum-add linearize-insn + [ overflow-conditional _fixnum-add ] with-regs emit-branch ; + +M: ##fixnum-sub linearize-insn + [ overflow-conditional _fixnum-sub ] with-regs emit-branch ; + +M: ##fixnum-mul linearize-insn + [ overflow-conditional _fixnum-mul ] with-regs emit-branch ; + M: ##dispatch linearize-insn swap [ [ [ src>> ] [ temp>> ] bi _dispatch ] with-regs ] diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index 8a46b32070..9dc320660c 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -43,9 +43,6 @@ SYMBOL: work-list [ nip kill-set ] 2bi assoc-diff ; -: conjoin-at ( value key assoc -- ) - [ dupd ?set-at ] change-at ; - : compute-phi-live-in ( basic-block -- phi-live-in ) instructions>> [ ##phi? ] filter [ f ] [ H{ } clone [ diff --git a/basis/compiler/cfg/local/local.factor b/basis/compiler/cfg/local/local.factor index 5d78397998..2f5f5b18e3 100644 --- a/basis/compiler/cfg/local/local.factor +++ b/basis/compiler/cfg/local/local.factor @@ -1,10 +1,14 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry accessors kernel assocs compiler.cfg.liveness compiler.cfg.rpo ; +USING: locals accessors kernel assocs namespaces +compiler.cfg compiler.cfg.liveness compiler.cfg.rpo ; IN: compiler.cfg.local -: optimize-basic-block ( bb init-quot insn-quot -- ) - [ '[ live-in keys @ ] ] [ '[ _ change-instructions drop ] ] bi* bi ; inline +:: optimize-basic-block ( bb init-quot insn-quot -- ) + bb basic-block set + bb live-in keys init-quot call + bb insn-quot change-instructions drop ; inline -: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' ) - [ dup ] 2dip '[ _ _ optimize-basic-block ] each-basic-block ; inline \ No newline at end of file +:: local-optimization ( cfg init-quot: ( live-in -- ) insn-quot: ( insns -- insns' ) -- cfg' ) + cfg [ init-quot insn-quot optimize-basic-block ] each-basic-block + cfg ; inline \ No newline at end of file diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index 93adc4c0f9..1eb1996da4 100755 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -1,8 +1,8 @@ USING: accessors arrays compiler.cfg.checker compiler.cfg.debugger compiler.cfg.def-use compiler.cfg.instructions fry kernel kernel.private math -math.private sbufs sequences sequences.private sets -slots.private strings tools.test vectors layouts ; +math.partial-dispatch math.private sbufs sequences sequences.private sets +slots.private strings strings.private tools.test vectors layouts ; IN: compiler.cfg.optimizer.tests ! Miscellaneous tests @@ -31,6 +31,19 @@ IN: compiler.cfg.optimizer.tests [ [ 2 fixnum+ ] when 3 ] [ [ 2 fixnum- ] when 3 ] [ 10000 [ ] times ] + [ + over integer? [ + over dup 16 <-integer-fixnum + [ 0 >=-integer-fixnum ] [ drop f ] if [ + nip dup + [ ] [ ] if + ] [ 2drop f ] if + ] [ 2drop f ] if + ] + [ + pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if + set-string-nth-fast + ] } [ [ [ ] ] dip '[ _ test-mr first check-mr ] unit-test ] each diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 84eb8a84d1..1af0fcbc53 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -6,10 +6,10 @@ compiler.cfg.predecessors compiler.cfg.useless-conditionals compiler.cfg.stack-analysis compiler.cfg.branch-splitting +compiler.cfg.block-joining compiler.cfg.alias-analysis compiler.cfg.value-numbering compiler.cfg.dce -compiler.cfg.branch-folding compiler.cfg.write-barrier compiler.cfg.liveness compiler.cfg.rpo @@ -29,15 +29,15 @@ SYMBOL: check-optimizer? ! The passes that need this document it. [ optimize-tail-calls - compute-predecessors delete-useless-conditionals + compute-predecessors split-branches + join-blocks compute-predecessors stack-analysis compute-liveness alias-analysis value-numbering - fold-branches compute-predecessors eliminate-dead-code eliminate-write-barriers diff --git a/basis/compiler/cfg/phi-elimination/authors.txt b/basis/compiler/cfg/phi-elimination/authors.txt index d4f5d6b3ae..a44f8d7f8d 100644 --- a/basis/compiler/cfg/phi-elimination/authors.txt +++ b/basis/compiler/cfg/phi-elimination/authors.txt @@ -1 +1,2 @@ -Slava Pestov \ No newline at end of file +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor index 4577e70997..22afc0b32b 100644 --- a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor +++ b/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor @@ -1,7 +1,10 @@ -IN: compiler.cfg.phi-elimination.tests +! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers -compiler.cfg.debugger compiler.cfg.phi-elimination kernel accessors -sequences classes namespaces tools.test cpu.architecture arrays ; +compiler.cfg.comparisons compiler.cfg.debugger locals +compiler.cfg.phi-elimination kernel accessors sequences classes +namespaces tools.test cpu.architecture arrays ; +IN: compiler.cfg.phi-elimination.tests V{ T{ ##branch } } 0 test-bb @@ -33,8 +36,20 @@ V{ test-diamond +3 vreg-counter set-global + [ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test -[ T{ ##copy f V int-regs 3 V int-regs 1 } ] [ 2 get instructions>> second ] unit-test -[ T{ ##copy f V int-regs 3 V int-regs 2 } ] [ 3 get instructions>> second ] unit-test -[ 2 ] [ 4 get instructions>> length ] unit-test \ No newline at end of file +[ T{ ##copy f V int-regs 4 V int-regs 1 } ] [ + 2 get successors>> first instructions>> first +] unit-test + +[ T{ ##copy f V int-regs 4 V int-regs 2 } ] [ + 3 get successors>> first instructions>> first +] unit-test + +[ T{ ##copy f V int-regs 3 V int-regs 4 } ] [ + 4 get instructions>> first +] unit-test + +[ 3 ] [ 4 get instructions>> length ] unit-test diff --git a/basis/compiler/cfg/phi-elimination/phi-elimination.factor b/basis/compiler/cfg/phi-elimination/phi-elimination.factor index 9c2f0adafd..7e73f0b854 100644 --- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor +++ b/basis/compiler/cfg/phi-elimination/phi-elimination.factor @@ -1,17 +1,26 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs fry kernel sequences -compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; +USING: accessors assocs fry kernel sequences namespaces +compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.utilities compiler.cfg.hats make +locals ; IN: compiler.cfg.phi-elimination : insert-copy ( predecessor input output -- ) '[ _ _ swap ##copy ] add-instructions ; -: eliminate-phi ( ##phi -- ) - [ inputs>> ] [ dst>> ] bi '[ _ insert-copy ] assoc-each ; +: eliminate-phi ( ##phi -- ##copy ) + i + [ [ inputs>> ] dip '[ _ insert-copy ] assoc-each ] + [ [ dst>> ] dip \ ##copy new-insn ] + 2bi ; : eliminate-phi-step ( bb -- ) - instructions>> [ dup ##phi? [ eliminate-phi f ] [ drop t ] if ] filter-here ; + H{ } clone added-instructions set + [ instructions>> [ dup ##phi? [ eliminate-phi ] when ] change-each ] + [ insert-basic-blocks ] + bi ; : eliminate-phis ( cfg -- cfg' ) - dup [ eliminate-phi-step ] each-basic-block ; \ No newline at end of file + dup [ eliminate-phi-step ] each-basic-block + cfg-changed ; diff --git a/basis/compiler/cfg/registers/registers.factor b/basis/compiler/cfg/registers/registers.factor index 71f313be5a..c5b3907153 100644 --- a/basis/compiler/cfg/registers/registers.factor +++ b/basis/compiler/cfg/registers/registers.factor @@ -1,11 +1,17 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors namespaces kernel arrays parser ; +USING: accessors namespaces kernel arrays parser math math.order ; IN: compiler.cfg.registers ! Virtual registers, used by CFG and machine IRs -TUPLE: vreg { reg-class read-only } { n read-only } ; +TUPLE: vreg { reg-class read-only } { n fixnum read-only } ; + +M: vreg equal? over vreg? [ [ n>> ] bi@ eq? ] [ 2drop f ] if ; + +M: vreg hashcode* nip n>> ; + SYMBOL: vreg-counter + : next-vreg ( reg-class -- vreg ) \ vreg-counter counter vreg boa ; ! Stack locations -- 'n' is an index starting from the top of the stack diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor new file mode 100644 index 0000000000..8dbcadfe8b --- /dev/null +++ b/basis/compiler/cfg/renaming/renaming.factor @@ -0,0 +1,155 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel namespaces sequences +compiler.cfg.instructions compiler.cfg.registers ; +IN: compiler.cfg.renaming + +SYMBOL: renamings + +: rename-value ( vreg -- vreg' ) renamings get at ; + +GENERIC: rename-insn-defs ( insn -- ) + +M: ##flushable rename-insn-defs + [ rename-value ] change-dst + drop ; + +M: ##fixnum-overflow rename-insn-defs + [ rename-value ] change-dst + drop ; + +M: _fixnum-overflow rename-insn-defs + [ rename-value ] change-dst + drop ; + +M: insn rename-insn-defs drop ; + +GENERIC: rename-insn-uses ( insn -- ) + +M: ##effect rename-insn-uses + [ rename-value ] change-src + drop ; + +M: ##unary rename-insn-uses + [ rename-value ] change-src + drop ; + +M: ##binary rename-insn-uses + [ rename-value ] change-src1 + [ rename-value ] change-src2 + drop ; + +M: ##binary-imm rename-insn-uses + [ rename-value ] change-src1 + drop ; + +M: ##slot rename-insn-uses + [ rename-value ] change-obj + [ rename-value ] change-slot + drop ; + +M: ##slot-imm rename-insn-uses + [ rename-value ] change-obj + drop ; + +M: ##set-slot rename-insn-uses + dup call-next-method + [ rename-value ] change-obj + [ rename-value ] change-slot + drop ; + +M: ##string-nth rename-insn-uses + [ rename-value ] change-obj + [ rename-value ] change-index + drop ; + +M: ##set-string-nth-fast rename-insn-uses + dup call-next-method + [ rename-value ] change-obj + [ rename-value ] change-index + drop ; + +M: ##set-slot-imm rename-insn-uses + dup call-next-method + [ rename-value ] change-obj + drop ; + +M: ##alien-getter rename-insn-uses + dup call-next-method + [ rename-value ] change-src + drop ; + +M: ##alien-setter rename-insn-uses + dup call-next-method + [ rename-value ] change-value + drop ; + +M: ##conditional-branch rename-insn-uses + [ rename-value ] change-src1 + [ rename-value ] change-src2 + drop ; + +M: ##compare-imm-branch rename-insn-uses + [ rename-value ] change-src1 + drop ; + +M: ##dispatch rename-insn-uses + [ rename-value ] change-src + drop ; + +M: ##fixnum-overflow rename-insn-uses + [ rename-value ] change-src1 + [ rename-value ] change-src2 + drop ; + +M: insn rename-insn-uses drop ; + +: fresh-vreg ( vreg -- vreg' ) + reg-class>> next-vreg ; + +GENERIC: fresh-insn-temps ( insn -- ) + +M: ##write-barrier fresh-insn-temps + [ fresh-vreg ] change-card# + [ fresh-vreg ] change-table + drop ; + +M: ##unary/temp fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: ##allot fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: ##dispatch fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: ##slot fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: ##set-slot fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: ##string-nth fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: ##set-string-nth-fast fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: ##compare fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: ##compare-imm fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: ##compare-float fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: ##gc fresh-insn-temps + [ fresh-vreg ] change-temp1 + [ fresh-vreg ] change-temp2 + drop ; + +M: _dispatch fresh-insn-temps + [ fresh-vreg ] change-temp drop ; + +M: insn fresh-insn-temps drop ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/ssa-tests.factor b/basis/compiler/cfg/ssa/ssa-tests.factor new file mode 100644 index 0000000000..c53d30af5d --- /dev/null +++ b/basis/compiler/cfg/ssa/ssa-tests.factor @@ -0,0 +1,79 @@ +USING: accessors compiler.cfg compiler.cfg.debugger +compiler.cfg.dominance compiler.cfg.instructions +compiler.cfg.predecessors compiler.cfg.ssa assocs +compiler.cfg.registers cpu.architecture kernel namespaces sequences +tools.test vectors ; +IN: compiler.cfg.ssa.tests + +! Reset counters so that results are deterministic w.r.t. hash order +0 vreg-counter set-global +0 basic-block set-global + +V{ + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add-imm f V int-regs 2 V int-regs 1 50 } + T{ ##add-imm f V int-regs 2 V int-regs 2 10 } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##load-immediate f V int-regs 3 3 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##load-immediate f V int-regs 3 4 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace f V int-regs 3 D 0 } + T{ ##return } +} 3 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop +1 get 3 get 1vector >>successors drop +2 get 3 get 1vector >>successors drop + +: test-ssa ( -- ) + cfg new 0 get >>entry + compute-predecessors + compute-dominance + construct-ssa + drop ; + +[ ] [ test-ssa ] unit-test + +[ + V{ + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add-imm f V int-regs 2 V int-regs 1 50 } + T{ ##add-imm f V int-regs 3 V int-regs 2 10 } + T{ ##branch } + } +] [ 0 get instructions>> ] unit-test + +[ + V{ + T{ ##load-immediate f V int-regs 4 3 } + T{ ##branch } + } +] [ 1 get instructions>> ] unit-test + +[ + V{ + T{ ##load-immediate f V int-regs 5 4 } + T{ ##branch } + } +] [ 2 get instructions>> ] unit-test + +[ + V{ + T{ ##phi f V int-regs 6 H{ { 1 V int-regs 4 } { 2 V int-regs 5 } } } + T{ ##replace f V int-regs 6 D 0 } + T{ ##return } + } +] [ + 3 get instructions>> + [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/ssa.factor b/basis/compiler/cfg/ssa/ssa.factor new file mode 100644 index 0000000000..e11701965b --- /dev/null +++ b/basis/compiler/cfg/ssa/ssa.factor @@ -0,0 +1,146 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel accessors sequences fry dlists +deques assocs sets math combinators sorting +compiler.cfg +compiler.cfg.rpo +compiler.cfg.def-use +compiler.cfg.renaming +compiler.cfg.registers +compiler.cfg.dominance +compiler.cfg.instructions ; +IN: compiler.cfg.ssa + +! SSA construction. Predecessors and dominance must be computed first. + +! This is the classical algorithm based on dominance frontiers: +! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.25.8240 + +! Eventually might be worth trying something fancier: +! http://portal.acm.org/citation.cfm?id=1065887.1065890 + +> [ + defs-vregs [ + _ push-at + ] with each + ] with each + ] each-basic-block ; + +SYMBOLS: has-already ever-on-work-list work-list ; + +: init-insert-phi-nodes ( bbs -- ) + H{ } clone has-already set + [ unique ever-on-work-list set ] + [ [ push-all-front ] keep work-list set ] bi ; + +: add-to-work-list ( bb -- ) + dup ever-on-work-list get key? [ drop ] [ + [ ever-on-work-list get conjoin ] + [ work-list get push-front ] + bi + ] if ; + +: insert-phi-node-later ( vreg bb -- ) + [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep + inserting-phi-nodes get push-at ; + +: compute-phi-node-in ( vreg bb -- ) + dup has-already get key? [ 2drop ] [ + [ insert-phi-node-later ] + [ has-already get conjoin ] + [ add-to-work-list ] + tri + ] if ; + +: compute-phi-nodes-for ( vreg bbs -- ) + dup length 2 >= [ + init-insert-phi-nodes + work-list get [ + dom-frontier [ + compute-phi-node-in + ] with each + ] with slurp-deque + ] [ 2drop ] if ; + +: compute-phi-nodes ( -- ) + H{ } clone inserting-phi-nodes set + defs get [ compute-phi-nodes-for ] assoc-each ; + +: insert-phi-nodes-in ( phis bb -- ) + [ append ] change-instructions drop ; + +: insert-phi-nodes ( -- ) + inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ; + +SYMBOLS: stacks originals ; + +: init-renaming ( -- ) + H{ } clone stacks set + H{ } clone originals set ; + +: gen-name ( vreg -- vreg' ) + [ reg-class>> next-vreg ] keep + [ stacks get push-at ] + [ swap originals get set-at ] + [ drop ] + 2tri ; + +: top-name ( vreg -- vreg' ) + stacks get at last ; + +GENERIC: rename-insn ( insn -- ) + +M: insn rename-insn + [ dup uses-vregs [ dup top-name ] { } map>assoc renamings set rename-insn-uses ] + [ dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ] + bi ; + +M: ##phi rename-insn + dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ; + +: rename-insns ( bb -- ) + instructions>> [ rename-insn ] each ; + +: rename-successor-phi ( phi bb -- ) + swap inputs>> [ top-name ] change-at ; + +: rename-successor-phis ( succ bb -- ) + [ inserting-phi-nodes get at ] dip + '[ _ rename-successor-phi ] each ; + +: rename-successors-phis ( bb -- ) + [ successors>> ] keep '[ _ rename-successor-phis ] each ; + +: pop-stacks ( bb -- ) + instructions>> [ + defs-vregs originals get stacks get + '[ _ at _ at pop* ] each + ] each ; + +: rename-in-block ( bb -- ) + { + [ rename-insns ] + [ rename-successors-phis ] + [ dom-children [ rename-in-block ] each ] + [ pop-stacks ] + } cleave ; + +: rename ( cfg -- ) + init-renaming + entry>> rename-in-block ; + +PRIVATE> + +: construct-ssa ( cfg -- cfg' ) + dup [ compute-defs compute-phi-nodes insert-phi-nodes ] [ rename ] bi ; \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor index 14a81958a9..5883777861 100644 --- a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor +++ b/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor @@ -1,8 +1,8 @@ IN: compiler.cfg.stack-analysis.merge.tests USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors -compiler.cfg.instructions compiler.cfg.stack-analysis.state -compiler.cfg compiler.cfg.registers compiler.cfg.debugger -cpu.architecture make assocs + compiler.cfg.instructions compiler.cfg.stack-analysis.state +compiler.cfg.utilities compiler.cfg compiler.cfg.registers +compiler.cfg.debugger cpu.architecture make assocs namespaces sequences kernel classes ; [ @@ -11,13 +11,15 @@ sequences kernel classes ; ] [ - V{ T{ ##branch } } >>instructions - V{ T{ ##branch } } >>instructions 2array + V{ T{ ##branch } } >>instructions dup 1 set + V{ T{ ##branch } } >>instructions dup 2 set 2array H{ { D 0 V int-regs 0 } } >>locs>vregs H{ { D 0 V int-regs 1 } } >>locs>vregs 2array - [ merge-locs locs>vregs>> keys ] { } make first inputs>> values + H{ } clone added-instructions set + V{ } clone added-phis set + merge-locs locs>vregs>> keys added-phis get values first ] unit-test [ @@ -26,15 +28,16 @@ sequences kernel classes ; ] [ - V{ T{ ##branch } } >>instructions - V{ T{ ##branch } } >>instructions 2array + V{ T{ ##branch } } >>instructions dup 1 set + V{ T{ ##branch } } >>instructions dup 2 set 2array - [ - - H{ { D 0 V int-regs 1 } } >>locs>vregs 2array + + H{ { D 0 V int-regs 1 } } >>locs>vregs 2array - [ merge-locs locs>vregs>> keys ] { } make drop - ] keep first instructions>> first class + H{ } clone added-instructions set + V{ } clone added-phis set + [ merge-locs locs>vregs>> keys ] { } make drop + 1 get added-instructions get at first class ] unit-test [ @@ -42,15 +45,17 @@ sequences kernel classes ; ] [ - V{ T{ ##branch } } >>instructions - V{ T{ ##branch } } >>instructions 2array + V{ T{ ##branch } } >>instructions dup 1 set + V{ T{ ##branch } } >>instructions dup 2 set 2array - [ - -1 >>ds-height - 2array + H{ } clone added-instructions set + V{ } clone added-phis set - [ merge-ds-heights ds-height>> ] { } make drop - ] keep first instructions>> first class + -1 >>ds-height + 2array + + [ merge-ds-heights ds-height>> ] { } make drop + 1 get added-instructions get at first class ] unit-test [ @@ -63,6 +68,9 @@ sequences kernel classes ; V{ T{ ##branch } } >>instructions V{ T{ ##branch } } >>instructions 2array + H{ } clone added-instructions set + V{ } clone added-phis set + [ -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs H{ { D 0 V int-regs 1 } } >>locs>vregs 2array @@ -82,6 +90,9 @@ sequences kernel classes ; V{ T{ ##branch } } >>instructions V{ T{ ##branch } } >>instructions 2array + H{ } clone added-instructions set + V{ } clone added-phis set + [ -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs -1 >>ds-height H{ { D -1 V int-regs 1 } } >>locs>vregs 2array diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor index b6c443a2d3..a53fd7494e 100644 --- a/basis/compiler/cfg/stack-analysis/merge/merge.factor +++ b/basis/compiler/cfg/stack-analysis/merge/merge.factor @@ -1,12 +1,11 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel assocs sequences accessors fry combinators grouping -sets locals compiler.cfg compiler.cfg.hats compiler.cfg.instructions -compiler.cfg.stack-analysis.state ; +USING: kernel assocs sequences accessors fry combinators grouping sets +arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats +compiler.cfg.instructions compiler.cfg.stack-analysis.state +compiler.cfg.registers compiler.cfg.utilities cpu.architecture ; IN: compiler.cfg.stack-analysis.merge -! XXX critical edges - : initial-state ( bb states -- state ) 2drop ; : single-predecessor ( bb states -- state ) nip first clone ; @@ -27,14 +26,14 @@ IN: compiler.cfg.stack-analysis.merge [ nip first >>rs-height ] [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ; -: assoc-map-values ( assoc quot -- assoc' ) +: assoc-map-keys ( assoc quot -- assoc' ) '[ _ dip ] assoc-map ; inline : translate-locs ( assoc state -- assoc' ) - '[ _ translate-loc ] assoc-map-values ; + '[ _ translate-loc ] assoc-map-keys ; : untranslate-locs ( assoc state -- assoc' ) - '[ _ untranslate-loc ] assoc-map-values ; + '[ _ untranslate-loc ] assoc-map-keys ; : collect-locs ( loc-maps states -- assoc ) ! assoc maps locs to sequences @@ -45,12 +44,16 @@ IN: compiler.cfg.stack-analysis.merge : insert-peek ( predecessor loc state -- vreg ) '[ _ _ translate-loc ^^peek ] add-instructions ; +SYMBOL: added-phis + +: add-phi-later ( inputs -- vreg ) + [ int-regs next-vreg dup ] dip 2array added-phis get push ; + : merge-loc ( predecessors vregs loc state -- vreg ) ! Insert a ##phi in the current block where the input ! is the vreg storing loc from each predecessor block - [ dup ] 3dip '[ [ ] [ _ _ insert-peek ] ?if ] 2map - dup all-equal? [ nip first ] [ zip ^^phi ] if ; + dup all-equal? [ first ] [ add-phi-later ] if ; :: merge-locs ( state predecessors states -- state ) states [ locs>vregs>> ] map states collect-locs @@ -77,30 +80,36 @@ IN: compiler.cfg.stack-analysis.merge over translate-locs >>changed-locs ; -ERROR: cannot-merge-poisoned states ; +:: insert-phis ( bb -- ) + bb predecessors>> :> predecessors + [ + added-phis get [| dst inputs | + dst predecessors inputs zip ##phi + ] assoc-each + ] V{ } make bb instructions>> over push-all + bb (>>instructions) ; -: multiple-predecessors ( bb states -- state ) - dup [ not ] any? [ - 2drop +:: multiple-predecessors ( bb states -- state ) + states [ not ] any? [ + + bb add-to-work-list ] [ - dup [ poisoned?>> ] any? [ - cannot-merge-poisoned - ] [ - [ state new ] 2dip - [ predecessors>> ] dip - { - [ merge-ds-heights ] - [ merge-rs-heights ] - [ merge-locs ] - [ nip merge-actual-locs ] - [ nip merge-changed-locs ] - } 2cleave - ] if + [ + H{ } clone added-instructions set + V{ } clone added-phis set + bb predecessors>> :> predecessors + state new + predecessors states merge-ds-heights + predecessors states merge-rs-heights + predecessors states merge-locs + states merge-actual-locs + states merge-changed-locs + bb insert-basic-blocks + bb insert-phis + ] with-scope ] if ; : merge-states ( bb states -- state ) - ! If any states are poisoned, save all registers - ! to the stack in each branch dup length { { 0 [ initial-state ] } { 1 [ single-predecessor ] } diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor index cbc939b1f2..9fbf7acf78 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor @@ -91,15 +91,15 @@ IN: compiler.cfg.stack-analysis.tests ! Sync before a back-edge, not after ! ##peeks should be inserted before a ##loop-entry ! Don't optimize out the constants -[ 1 t ] [ +[ t ] [ [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize - [ [ ##add-imm? ] count ] [ [ ##load-immediate? ] any? ] bi + [ ##load-immediate? ] any? ] unit-test ! Correct height tracking [ t ] [ [ pick [ ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code - reverse-post-order 3 swap nth + reverse-post-order 4 swap nth instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi* 2array { D 1 D 0 } set= ] unit-test @@ -126,7 +126,7 @@ IN: compiler.cfg.stack-analysis.tests stack-analysis drop - 3 get instructions>> second loc>> + 3 get successors>> first instructions>> first loc>> ] unit-test ! Do inserted ##peeks reference the correct stack location if @@ -156,7 +156,7 @@ IN: compiler.cfg.stack-analysis.tests stack-analysis drop - 3 get instructions>> [ ##peek? ] find nip loc>> + 3 get successors>> first instructions>> [ ##peek? ] find nip loc>> ] unit-test ! Missing ##replace @@ -170,9 +170,9 @@ IN: compiler.cfg.stack-analysis.tests ! Inserted ##peeks reference the wrong stack location [ t ] [ [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis - eliminate-dead-code reverse-post-order 3 swap nth + eliminate-dead-code reverse-post-order 4 swap nth instructions>> [ ##peek? ] filter [ loc>> ] map - { R 0 D 0 D 1 } set= + { D 0 D 1 } set= ] unit-test [ D 0 ] [ @@ -200,5 +200,5 @@ IN: compiler.cfg.stack-analysis.tests stack-analysis drop - 3 get instructions>> [ ##peek? ] find nip loc>> + 3 get successors>> first instructions>> [ ##peek? ] find nip loc>> ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis.factor b/basis/compiler/cfg/stack-analysis/stack-analysis.factor index fb71fe332d..cf15c0a312 100644 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ b/basis/compiler/cfg/stack-analysis/stack-analysis.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel namespaces math sequences fry grouping -sets make combinators +sets make combinators dlists deques compiler.cfg compiler.cfg.copy-prop compiler.cfg.def-use @@ -10,9 +10,12 @@ compiler.cfg.registers compiler.cfg.rpo compiler.cfg.hats compiler.cfg.stack-analysis.state -compiler.cfg.stack-analysis.merge ; +compiler.cfg.stack-analysis.merge +compiler.cfg.utilities ; IN: compiler.cfg.stack-analysis +SYMBOL: global-optimization? + : redundant-replace? ( vreg loc -- ? ) dup state get untranslate-loc n>> 0 < [ 2drop t ] [ state get actual-locs>vregs>> at = ] if ; @@ -58,17 +61,16 @@ UNION: sync-if-back-edge ##conditional-branch ##compare-imm-branch ##dispatch - ##loop-entry ; - -: back-edge? ( from to -- ? ) - [ number>> ] bi@ > ; + ##loop-entry + ##fixnum-overflow ; : sync-state? ( -- ? ) basic-block get successors>> [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ; M: sync-if-back-edge visit - sync-state? [ sync-state ] when , ; + global-optimization? get [ sync-state? [ sync-state ] when ] unless + , ; : eliminate-peek ( dst src -- ) ! the requested stack location is already in 'src' @@ -85,42 +87,16 @@ M: ##replace visit M: ##copy visit [ call-next-method ] [ record-copy ] bi ; -! Instructions that poison the stack state -UNION: poison-insn - ##jump - ##return - ##callback-return - ##fixnum-mul-tail - ##fixnum-add-tail - ##fixnum-sub-tail ; - M: poison-insn visit call-next-method poison-state ; -! Instructions that kill all live vregs -UNION: kill-vreg-insn - poison-insn - ##stack-frame - ##call - ##prologue - ##epilogue - ##fixnum-mul - ##fixnum-add - ##fixnum-sub - ##alien-invoke - ##alien-indirect - ##alien-callback ; - M: kill-vreg-insn visit sync-state , ; ! Maps basic-blocks to states -SYMBOLS: state-in state-out ; +SYMBOL: state-out : block-in-state ( bb -- states ) dup predecessors>> state-out get '[ _ at ] map merge-states ; -: set-block-in-state ( state bb -- ) - [ clone ] dip state-in get set-at ; - : set-block-out-state ( state bb -- ) [ clone ] dip state-out get set-at ; @@ -130,20 +106,20 @@ SYMBOLS: state-in state-out ; [ dup basic-block set dup block-in-state - [ swap set-block-in-state ] [ - state [ - [ instructions>> [ visit ] each ] - [ [ state get ] dip set-block-out-state ] - [ ] - tri - ] with-variable - ] 2bi + state [ + [ instructions>> [ visit ] each ] + [ [ state get ] dip set-block-out-state ] + [ ] + tri + ] with-variable ] V{ } make >>instructions drop ; : stack-analysis ( cfg -- cfg' ) [ + work-list set H{ } clone copies set - H{ } clone state-in set H{ } clone state-out set dup [ visit-block ] each-basic-block + global-optimization? get [ work-list get [ visit-block ] slurp-deque ] when + cfg-changed ] with-scope ; diff --git a/basis/compiler/cfg/stack-analysis/state/state.factor b/basis/compiler/cfg/stack-analysis/state/state.factor index f701b84763..25fa249853 100644 --- a/basis/compiler/cfg/stack-analysis/state/state.factor +++ b/basis/compiler/cfg/stack-analysis/state/state.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces assocs sets math +USING: kernel accessors namespaces assocs sets math deques compiler.cfg.registers ; IN: compiler.cfg.stack-analysis.state @@ -47,3 +47,7 @@ M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - ; GENERIC# untranslate-loc 1 ( loc state -- loc' ) M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + ; M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + ; + +SYMBOL: work-list + +: add-to-work-list ( bb -- ) work-list get push-front ; diff --git a/basis/compiler/cfg/tco/tco.factor b/basis/compiler/cfg/tco/tco.factor index df5d962999..3dbdf148e9 100644 --- a/basis/compiler/cfg/tco/tco.factor +++ b/basis/compiler/cfg/tco/tco.factor @@ -2,10 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators.short-circuit kernel math namespaces sequences fry combinators +compiler.utilities compiler.cfg compiler.cfg.rpo compiler.cfg.hats -compiler.cfg.instructions ; +compiler.cfg.instructions +compiler.cfg.utilities ; IN: compiler.cfg.tco ! Tail call optimization. You must run compute-predecessors after this @@ -18,8 +20,6 @@ IN: compiler.cfg.tco [ second ##return? ] } 1&& ; -: penultimate ( seq -- elt ) [ length 2 - ] keep nth ; - : tail-call? ( bb -- ? ) { [ instructions>> { [ length 2 >= ] [ last ##branch? ] } 1&& ] @@ -53,28 +53,11 @@ IN: compiler.cfg.tco [ [ cfg get entry>> successors>> first ] dip successors>> push ] tri ; -: fixnum-tail-call? ( bb -- ? ) - instructions>> penultimate - { [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] } 1|| ; - -GENERIC: convert-fixnum-tail-call* ( src1 src2 insn -- insn' ) - -M: ##fixnum-add convert-fixnum-tail-call* drop \ ##fixnum-add-tail new-insn ; -M: ##fixnum-sub convert-fixnum-tail-call* drop \ ##fixnum-sub-tail new-insn ; -M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn ; - -: convert-fixnum-tail-call ( bb -- ) - [ - [ src1>> ] [ src2>> ] [ ] tri - convert-fixnum-tail-call* - ] convert-tail-call ; - : optimize-tail-call ( bb -- ) dup tail-call? [ { { [ dup loop-tail-call? ] [ convert-loop-tail-call ] } { [ dup word-tail-call? ] [ convert-word-tail-call ] } - { [ dup fixnum-tail-call? ] [ convert-fixnum-tail-call ] } [ drop ] } cond ] [ drop ] if ; @@ -82,4 +65,4 @@ M: ##fixnum-mul convert-fixnum-tail-call* drop i i \ ##fixnum-mul-tail new-insn : optimize-tail-calls ( cfg -- cfg' ) dup cfg set dup [ optimize-tail-call ] each-basic-block - f >>post-order ; \ No newline at end of file + cfg-changed ; \ No newline at end of file diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index d30a02b0d3..87be509c6f 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -11,10 +11,6 @@ IN: compiler.cfg.two-operand ! since x86 has LEA and IMUL instructions which are effectively ! three-operand addition and multiplication, respectively. -: make-copy ( dst src -- insn ) \ ##copy new-insn ; inline - -: make-copy/float ( dst src -- insn ) \ ##copy-float new-insn ; inline - : convert-two-operand/integer ( insn -- ) [ [ dst>> ] [ src1>> ] bi ##copy ] [ dup dst>> >>src1 , ] @@ -40,10 +36,15 @@ M: ##or convert-two-operand* convert-two-operand/integer ; M: ##or-imm convert-two-operand* convert-two-operand/integer ; M: ##xor convert-two-operand* convert-two-operand/integer ; M: ##xor-imm convert-two-operand* convert-two-operand/integer ; +M: ##shl convert-two-operand* convert-two-operand/integer ; M: ##shl-imm convert-two-operand* convert-two-operand/integer ; +M: ##shr convert-two-operand* convert-two-operand/integer ; M: ##shr-imm convert-two-operand* convert-two-operand/integer ; +M: ##sar convert-two-operand* convert-two-operand/integer ; M: ##sar-imm convert-two-operand* convert-two-operand/integer ; +M: ##fixnum-overflow convert-two-operand* convert-two-operand/integer ; + M: ##add-float convert-two-operand* convert-two-operand/float ; M: ##sub-float convert-two-operand* convert-two-operand/float ; M: ##mul-float convert-two-operand* convert-two-operand/float ; diff --git a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor index 6f4a6eea55..cc98d08042 100644 --- a/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor +++ b/basis/compiler/cfg/useless-conditionals/useless-conditionals.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences math combinators combinators.short-circuit -classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; +classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo +compiler.cfg.utilities ; IN: compiler.cfg.useless-conditionals : delete-conditional? ( bb -- ? ) @@ -18,4 +19,4 @@ IN: compiler.cfg.useless-conditionals dup [ dup delete-conditional? [ delete-conditional ] [ drop ] if ] each-basic-block - f >>post-order ; + cfg-changed ; diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 99a138a763..9cb8bf26f9 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math layouts make sequences combinators -cpu.architecture namespaces compiler.cfg -compiler.cfg.instructions ; +USING: accessors assocs combinators combinators.short-circuit +compiler.cfg compiler.cfg.instructions cpu.architecture kernel +layouts locals make math namespaces sequences sets vectors fry ; IN: compiler.cfg.utilities : value-info-small-fixnum? ( value-info -- ? ) @@ -33,7 +33,65 @@ IN: compiler.cfg.utilities building off basic-block off ; -: stop-iterating ( -- next ) end-basic-block f ; - : emit-primitive ( node -- ) word>> ##call ##branch begin-basic-block ; + +: with-branch ( quot -- final-bb ) + [ + begin-basic-block + call + basic-block get dup [ ##branch ] when + ] with-scope ; inline + +: emit-conditional ( branches -- ) + end-basic-block + begin-basic-block + basic-block get '[ [ _ swap successors>> push ] when* ] each ; + +: back-edge? ( from to -- ? ) + [ number>> ] bi@ >= ; + +: empty-block? ( bb -- ? ) + instructions>> { + [ length 1 = ] + [ first ##branch? ] + } 1&& ; + +SYMBOL: visited + +: (skip-empty-blocks) ( bb -- bb' ) + dup visited get key? [ + dup empty-block? [ + dup visited get conjoin + successors>> first (skip-empty-blocks) + ] when + ] unless ; + +: skip-empty-blocks ( bb -- bb' ) + H{ } clone visited [ (skip-empty-blocks) ] with-variable ; + +! assoc mapping predecessors to sequences +SYMBOL: added-instructions + +: add-instructions ( predecessor quot -- ) + [ + added-instructions get + [ drop V{ } clone ] cache + building + ] dip with-variable ; inline + +:: insert-basic-block ( from to bb -- ) + bb from 1vector >>predecessors drop + bb to 1vector >>successors drop + to predecessors>> [ dup from eq? [ drop bb ] when ] change-each + from successors>> [ dup to eq? [ drop bb ] when ] change-each ; + +: ( insns -- bb ) + + swap >vector + \ ##branch new-insn over push + >>instructions ; + +: insert-basic-blocks ( bb -- ) + [ added-instructions get ] dip + '[ [ _ ] dip insert-basic-block ] assoc-each ; diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor index bf750231c7..76ad3d892f 100644 --- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor +++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor @@ -1,7 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors classes kernel math namespaces combinators -compiler.cfg.instructions compiler.cfg.value-numbering.graph ; +combinators.short-circuit compiler.cfg.instructions +compiler.cfg.value-numbering.graph ; IN: compiler.cfg.value-numbering.expressions ! Referentially-transparent expressions @@ -11,15 +12,29 @@ TUPLE: binary-expr < expr in1 in2 ; TUPLE: commutative-expr < binary-expr ; TUPLE: compare-expr < binary-expr cc ; TUPLE: constant-expr < expr value ; +TUPLE: reference-expr < expr value ; : ( constant -- expr ) f swap constant-expr boa ; inline M: constant-expr equal? over constant-expr? [ - [ [ value>> ] bi@ = ] - [ [ value>> class ] bi@ = ] 2bi - and + { + [ [ value>> class ] bi@ = ] + [ [ value>> ] bi@ = ] + } 2&& + ] [ 2drop f ] if ; + +: ( constant -- expr ) + f swap reference-expr boa ; inline + +M: reference-expr equal? + over reference-expr? [ + [ value>> ] bi@ { + { [ 2dup eq? ] [ 2drop t ] } + { [ 2dup [ float? ] both? ] [ fp-bitwise= ] } + [ 2drop f ] + } cond ] [ 2drop f ] if ; ! Expressions whose values are inputs to the basic block. We @@ -39,6 +54,8 @@ GENERIC: >expr ( insn -- expr ) M: ##load-immediate >expr val>> ; +M: ##load-reference >expr obj>> ; + M: ##unary >expr [ class ] [ src>> vreg>vn ] bi unary-expr boa ; diff --git a/basis/compiler/cfg/value-numbering/propagate/propagate.factor b/basis/compiler/cfg/value-numbering/propagate/propagate.factor deleted file mode 100644 index d5c9830c0b..0000000000 --- a/basis/compiler/cfg/value-numbering/propagate/propagate.factor +++ /dev/null @@ -1,69 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces assocs sequences kernel accessors -compiler.cfg.instructions compiler.cfg.value-numbering.graph ; -IN: compiler.cfg.value-numbering.propagate - -! If two vregs compute the same value, replace references to -! the latter with the former. - -: resolve ( vreg -- vreg' ) vreg>vn vn>vreg ; inline - -GENERIC: propagate ( insn -- insn ) - -M: ##effect propagate - [ resolve ] change-src ; - -M: ##unary propagate - [ resolve ] change-src ; - -M: ##binary propagate - [ resolve ] change-src1 - [ resolve ] change-src2 ; - -M: ##binary-imm propagate - [ resolve ] change-src1 ; - -M: ##slot propagate - [ resolve ] change-obj - [ resolve ] change-slot ; - -M: ##slot-imm propagate - [ resolve ] change-obj ; - -M: ##set-slot propagate - call-next-method - [ resolve ] change-obj - [ resolve ] change-slot ; - -M: ##string-nth propagate - [ resolve ] change-obj - [ resolve ] change-index ; - -M: ##set-slot-imm propagate - call-next-method - [ resolve ] change-obj ; - -M: ##alien-getter propagate - call-next-method - [ resolve ] change-src ; - -M: ##alien-setter propagate - call-next-method - [ resolve ] change-value ; - -M: ##conditional-branch propagate - [ resolve ] change-src1 - [ resolve ] change-src2 ; - -M: ##compare-imm-branch propagate - [ resolve ] change-src1 ; - -M: ##dispatch propagate - [ resolve ] change-src ; - -M: ##fixnum-overflow propagate - [ resolve ] change-src1 - [ resolve ] change-src2 ; - -M: insn propagate ; diff --git a/basis/compiler/cfg/value-numbering/propagate/summary.txt b/basis/compiler/cfg/value-numbering/propagate/summary.txt deleted file mode 100644 index fd56a8e099..0000000000 --- a/basis/compiler/cfg/value-numbering/propagate/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Propagation pass to update code after value numbering diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index ca7a959a82..fcd1b1c9ac 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -1,16 +1,32 @@ ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors locals combinators combinators.short-circuit arrays +USING: accessors combinators combinators.short-circuit arrays fry kernel layouts math namespaces sequences cpu.architecture -math.bitwise compiler.cfg.hats compiler.cfg.instructions +math.bitwise math.order classes vectors +compiler.cfg +compiler.cfg.hats +compiler.cfg.comparisons +compiler.cfg.instructions compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.simplify ; IN: compiler.cfg.value-numbering.rewrite -GENERIC: rewrite ( insn -- insn' ) +: vreg-small-constant? ( vreg -- ? ) + vreg>expr { + [ constant-expr? ] + [ value>> small-enough? ] + } 1&& ; -M: insn rewrite ; +! Outputs f to mean no change + +GENERIC: rewrite* ( insn -- insn/f ) + +: rewrite ( insn -- insn' ) + dup [ number-values ] [ rewrite* ] bi + [ rewrite ] [ ] ?if ; + +M: insn rewrite* drop f ; : ##branch-t? ( insn -- ? ) dup ##compare-imm-branch? [ @@ -49,13 +65,16 @@ M: insn rewrite ; [ src2>> tag-mask get bitand 0 = ] } 1&& ; inline +: tagged>constant ( n -- n' ) + tag-bits get neg shift ; inline + : (rewrite-tagged-comparison) ( insn -- src1 src2 cc ) [ src1>> vreg>expr in1>> vn>vreg ] - [ src2>> tag-bits get neg shift ] + [ src2>> tagged>constant ] [ cc>> ] tri ; inline -GENERIC: rewrite-tagged-comparison ( insn -- insn' ) +GENERIC: rewrite-tagged-comparison ( insn -- insn/f ) M: ##compare-imm-branch rewrite-tagged-comparison (rewrite-tagged-comparison) \ ##compare-imm-branch new-insn ; @@ -64,41 +83,6 @@ M: ##compare-imm rewrite-tagged-comparison [ dst>> ] [ (rewrite-tagged-comparison) ] bi i \ ##compare-imm new-insn ; -M: ##compare-imm-branch rewrite - dup rewrite-boolean-comparison? [ rewrite-boolean-comparison ] when - dup ##compare-imm-branch? [ - dup rewrite-tagged-comparison? [ rewrite-tagged-comparison ] when - ] when ; - -:: >compare-imm ( insn swap? -- insn' ) - insn dst>> - insn src1>> - insn src2>> swap? [ swap ] when vreg>constant - insn cc>> swap? [ swap-cc ] when - i \ ##compare-imm new-insn ; inline - -! M: ##compare rewrite -! dup [ src1>> ] [ src2>> ] bi -! [ vreg>expr constant-expr? ] bi@ 2array { -! { { f t } [ f >compare-imm ] } -! { { t f } [ t >compare-imm ] } -! [ drop ] -! } case ; - -:: >compare-imm-branch ( insn swap? -- insn' ) - insn src1>> - insn src2>> swap? [ swap ] when vreg>constant - insn cc>> swap? [ swap-cc ] when - \ ##compare-imm-branch new-insn ; inline - -! M: ##compare-branch rewrite -! dup [ src1>> ] [ src2>> ] bi -! [ vreg>expr constant-expr? ] bi@ 2array { -! { { f t } [ f >compare-imm-branch ] } -! { { t f } [ t >compare-imm-branch ] } -! [ drop ] -! } case ; - : rewrite-redundant-comparison? ( insn -- ? ) { [ src1>> vreg>expr compare-expr? ] @@ -114,101 +98,259 @@ M: ##compare-imm-branch rewrite } case swap cc= eq? [ [ negate-cc ] change-cc ] when ; -M: ##compare-imm rewrite - dup rewrite-redundant-comparison? [ - rewrite-redundant-comparison - dup number-values rewrite - ] when - dup ##compare-imm? [ - dup rewrite-tagged-comparison? [ - rewrite-tagged-comparison - dup number-values rewrite - ] when - ] when ; +ERROR: bad-comparison ; -: constant-fold ( insn -- insn' ) - dup dst>> vreg>expr dup constant-expr? [ - [ dst>> ] [ value>> ] bi* \ ##load-immediate new-insn - dup number-values - ] [ - drop +: (fold-compare-imm) ( insn -- ? ) + [ [ src1>> vreg>constant ] [ src2>> ] bi ] [ cc>> ] bi + pick integer? + [ [ <=> ] dip evaluate-cc ] + [ + 2nip { + { cc= [ f ] } + { cc/= [ t ] } + [ bad-comparison ] + } case ] if ; -: (new-imm-insn) ( insn dst src1 n op -- new-insn/insn ) - [ cell-bits bits ] dip over small-enough? [ - new-insn dup number-values nip - ] [ - 2drop 2drop - ] if constant-fold ; inline +: fold-compare-imm? ( insn -- ? ) + src1>> vreg>expr [ constant-expr? ] [ reference-expr? ] bi or ; -: new-imm-insn ( insn dst src n op -- n' op' ) - 2dup [ sgn ] dip 2array +: fold-branch ( ? -- insn ) + 0 1 ? + basic-block get [ nth 1vector ] change-successors drop + \ ##branch new-insn ; + +: fold-compare-imm-branch ( insn -- insn/f ) + (fold-compare-imm) fold-branch ; + +M: ##compare-imm-branch rewrite* { - { { -1 ##add-imm } [ drop neg \ ##sub-imm (new-imm-insn) ] } - { { -1 ##sub-imm } [ drop neg \ ##add-imm (new-imm-insn) ] } - [ drop (new-imm-insn) ] - } case ; inline + { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] } + { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } + { [ dup fold-compare-imm? ] [ fold-compare-imm-branch ] } + [ drop f ] + } cond ; -: combine-imm? ( insn op -- ? ) - [ src1>> vreg>expr op>> ] dip = ; +: swap-compare ( src1 src2 cc swap? -- src1 src2 cc ) + [ [ swap ] dip swap-cc ] when ; inline -: (combine-imm) ( insn quot op -- insn ) +: >compare-imm-branch ( insn swap? -- insn' ) + [ + [ src1>> ] + [ src2>> ] + [ cc>> ] + tri + ] dip + swap-compare + [ vreg>constant ] dip + \ ##compare-imm-branch new-insn ; inline + +: self-compare? ( insn -- ? ) + [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ = ; inline + +: (rewrite-self-compare) ( insn -- ? ) + cc>> { cc= cc<= cc>= } memq? ; + +: rewrite-self-compare-branch ( insn -- insn' ) + (rewrite-self-compare) fold-branch ; + +M: ##compare-branch rewrite* + { + { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] } + { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] } + { [ dup self-compare? ] [ rewrite-self-compare-branch ] } + [ drop f ] + } cond ; + +: >compare-imm ( insn swap? -- insn' ) + [ + { + [ dst>> ] + [ src1>> ] + [ src2>> ] + [ cc>> ] + } cleave + ] dip + swap-compare + [ vreg>constant ] dip + i \ ##compare-imm new-insn ; inline + +: >boolean-insn ( insn ? -- insn' ) + [ dst>> ] dip + { + { t [ t \ ##load-reference new-insn ] } + { f [ \ f tag-number \ ##load-immediate new-insn ] } + } case ; + +: rewrite-self-compare ( insn -- insn' ) + dup (rewrite-self-compare) >boolean-insn ; + +M: ##compare rewrite* + { + { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] } + { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] } + { [ dup self-compare? ] [ rewrite-self-compare ] } + [ drop f ] + } cond ; + +: fold-compare-imm ( insn -- insn' ) + dup (fold-compare-imm) >boolean-insn ; + +M: ##compare-imm rewrite* + { + { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] } + { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } + { [ dup fold-compare-imm? ] [ fold-compare-imm ] } + [ drop f ] + } cond ; + +: constant-fold? ( insn -- ? ) + src1>> vreg>expr constant-expr? ; inline + +GENERIC: constant-fold* ( x y insn -- z ) + +M: ##add-imm constant-fold* drop + ; +M: ##sub-imm constant-fold* drop - ; +M: ##mul-imm constant-fold* drop * ; +M: ##and-imm constant-fold* drop bitand ; +M: ##or-imm constant-fold* drop bitor ; +M: ##xor-imm constant-fold* drop bitxor ; +M: ##shr-imm constant-fold* drop [ cell-bits 2^ wrap ] dip neg shift ; +M: ##sar-imm constant-fold* drop neg shift ; +M: ##shl-imm constant-fold* drop shift ; + +: constant-fold ( insn -- insn' ) + [ dst>> ] + [ [ src1>> vreg>constant ] [ src2>> ] [ ] tri constant-fold* ] bi + \ ##load-immediate new-insn ; inline + +: reassociate? ( insn -- ? ) + [ src1>> vreg>expr op>> ] [ class ] bi = ; inline + +: reassociate ( insn op -- insn ) [ { - [ ] [ dst>> ] [ src1>> vreg>expr [ in1>> vn>vreg ] [ in2>> vn>constant ] bi ] [ src2>> ] - } cleave - ] [ call ] [ ] tri* new-imm-insn ; inline + [ ] + } cleave constant-fold* + ] dip + over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline -:: combine-imm ( insn quot op -- insn ) - insn op combine-imm? [ - insn quot op (combine-imm) - ] [ - insn - ] if ; inline - -M: ##add-imm rewrite +M: ##add-imm rewrite* { - { [ dup \ ##add-imm combine-imm? ] [ [ + ] \ ##add-imm (combine-imm) ] } - { [ dup \ ##sub-imm combine-imm? ] [ [ - ] \ ##sub-imm (combine-imm) ] } - [ ] + { [ dup constant-fold? ] [ constant-fold ] } + { [ dup reassociate? ] [ \ ##add-imm reassociate ] } + [ drop f ] } cond ; -M: ##sub-imm rewrite +: sub-imm>add-imm ( insn -- insn' ) + [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough? + [ \ ##add-imm new-insn ] [ 3drop f ] if ; + +M: ##sub-imm rewrite* { - { [ dup \ ##add-imm combine-imm? ] [ [ - ] \ ##add-imm (combine-imm) ] } - { [ dup \ ##sub-imm combine-imm? ] [ [ + ] \ ##sub-imm (combine-imm) ] } - [ ] + { [ dup constant-fold? ] [ constant-fold ] } + [ sub-imm>add-imm ] } cond ; -M: ##mul-imm rewrite - dup src2>> dup power-of-2? [ - [ [ dst>> ] [ src1>> ] bi ] [ log2 ] bi* \ ##shl-imm new-insn - dup number-values - ] [ - drop [ * ] \ ##mul-imm combine-imm - ] if ; +: strength-reduce-mul ( insn -- insn' ) + [ [ dst>> ] [ src1>> ] bi ] [ src2>> log2 ] bi \ ##shl-imm new-insn ; -M: ##and-imm rewrite [ bitand ] \ ##and-imm combine-imm ; +: strength-reduce-mul? ( insn -- ? ) + src2>> power-of-2? ; -M: ##or-imm rewrite [ bitor ] \ ##or-imm combine-imm ; +M: ##mul-imm rewrite* + { + { [ dup constant-fold? ] [ constant-fold ] } + { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] } + { [ dup reassociate? ] [ \ ##mul-imm reassociate ] } + [ drop f ] + } cond ; -M: ##xor-imm rewrite [ bitxor ] \ ##xor-imm combine-imm ; +M: ##and-imm rewrite* + { + { [ dup constant-fold? ] [ constant-fold ] } + { [ dup reassociate? ] [ \ ##and-imm reassociate ] } + [ drop f ] + } cond ; -: rewrite-add? ( insn -- ? ) - src2>> { - [ vreg>expr constant-expr? ] - [ vreg>constant small-enough? ] - } 1&& ; +M: ##or-imm rewrite* + { + { [ dup constant-fold? ] [ constant-fold ] } + { [ dup reassociate? ] [ \ ##or-imm reassociate ] } + [ drop f ] + } cond ; -M: ##add rewrite - dup rewrite-add? [ - [ dst>> ] - [ src1>> ] - [ src2>> vreg>constant ] tri \ ##add-imm new-insn - dup number-values - ] when ; +M: ##xor-imm rewrite* + { + { [ dup constant-fold? ] [ constant-fold ] } + { [ dup reassociate? ] [ \ ##xor-imm reassociate ] } + [ drop f ] + } cond ; -M: ##sub rewrite constant-fold ; +M: ##shl-imm rewrite* + { + { [ dup constant-fold? ] [ constant-fold ] } + [ drop f ] + } cond ; + +M: ##shr-imm rewrite* + { + { [ dup constant-fold? ] [ constant-fold ] } + [ drop f ] + } cond ; + +M: ##sar-imm rewrite* + { + { [ dup constant-fold? ] [ constant-fold ] } + [ drop f ] + } cond ; + +: insn>imm-insn ( insn op swap? -- ) + swap [ + [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] dip + [ swap ] when vreg>constant + ] dip new-insn ; inline + +: rewrite-arithmetic ( insn op -- ? ) + { + { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] } + [ 2drop f ] + } cond ; inline + +: rewrite-arithmetic-commutative ( insn op -- ? ) + { + { [ over src2>> vreg-small-constant? ] [ f insn>imm-insn ] } + { [ over src1>> vreg-small-constant? ] [ t insn>imm-insn ] } + [ 2drop f ] + } cond ; inline + +M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ; + +: subtraction-identity? ( insn -- ? ) + [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ; + +: rewrite-subtraction-identity ( insn -- insn' ) + dst>> 0 \ ##load-immediate new-insn ; + +M: ##sub rewrite* + { + { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] } + [ \ ##sub-imm rewrite-arithmetic ] + } cond ; + +M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ; + +M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ; + +M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ; + +M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ; + +M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ; + +M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ; + +M: ##sar rewrite* \ ##sar-imm rewrite-arithmetic ; diff --git a/basis/compiler/cfg/value-numbering/simplify/simplify.factor b/basis/compiler/cfg/value-numbering/simplify/simplify.factor index b7526528e4..5934643acc 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -32,6 +32,8 @@ M: unary-expr simplify* : expr-zero? ( expr -- ? ) T{ constant-expr f f 0 } = ; inline +: expr-one? ( expr -- ? ) T{ constant-expr f f 1 } = ; inline + : >binary-expr< ( expr -- in1 in2 ) [ in1>> vn>expr ] [ in2>> vn>expr ] bi ; inline @@ -44,18 +46,54 @@ M: unary-expr simplify* : simplify-sub ( expr -- vn/expr/f ) >binary-expr< { - { [ 2dup eq? ] [ 2drop T{ constant-expr f f 0 } ] } { [ dup expr-zero? ] [ drop ] } [ 2drop f ] } cond ; inline -: useless-shift? ( in1 in2 -- ? ) +: simplify-mul ( expr -- vn/expr/f ) + >binary-expr< { + { [ over expr-one? ] [ drop ] } + { [ dup expr-one? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: simplify-and ( expr -- vn/expr/f ) + >binary-expr< { + { [ 2dup eq? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: simplify-or ( expr -- vn/expr/f ) + >binary-expr< { + { [ 2dup eq? ] [ drop ] } + { [ over expr-zero? ] [ nip ] } + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: simplify-xor ( expr -- vn/expr/f ) + >binary-expr< { + { [ over expr-zero? ] [ nip ] } + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: useless-shr? ( in1 in2 -- ? ) over op>> \ ##shl-imm eq? [ [ in2>> ] [ expr>vn ] bi* = ] [ 2drop f ] if ; inline -: simplify-shift ( expr -- vn/expr/f ) - >binary-expr< - 2dup useless-shift? [ drop in1>> ] [ 2drop f ] if ; inline +: simplify-shr ( expr -- vn/expr/f ) + >binary-expr< { + { [ 2dup useless-shr? ] [ drop in1>> ] } + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; inline + +: simplify-shl ( expr -- vn/expr/f ) + >binary-expr< { + { [ dup expr-zero? ] [ drop ] } + [ 2drop f ] + } cond ; inline M: binary-expr simplify* dup op>> { @@ -63,8 +101,20 @@ M: binary-expr simplify* { \ ##add-imm [ simplify-add ] } { \ ##sub [ simplify-sub ] } { \ ##sub-imm [ simplify-sub ] } - { \ ##shr-imm [ simplify-shift ] } - { \ ##sar-imm [ simplify-shift ] } + { \ ##mul [ simplify-mul ] } + { \ ##mul-imm [ simplify-mul ] } + { \ ##and [ simplify-and ] } + { \ ##and-imm [ simplify-and ] } + { \ ##or [ simplify-or ] } + { \ ##or-imm [ simplify-or ] } + { \ ##xor [ simplify-xor ] } + { \ ##xor-imm [ simplify-xor ] } + { \ ##shr [ simplify-shr ] } + { \ ##shr-imm [ simplify-shr ] } + { \ ##sar [ simplify-shr ] } + { \ ##sar-imm [ simplify-shr ] } + { \ ##shl [ simplify-shl ] } + { \ ##shl-imm [ simplify-shl ] } [ 2drop f ] } case ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 5063273bf4..bd2bb692b7 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -1,8 +1,10 @@ IN: compiler.cfg.value-numbering.tests USING: compiler.cfg.value-numbering compiler.cfg.instructions -compiler.cfg.registers compiler.cfg.debugger cpu.architecture -tools.test kernel math combinators.short-circuit accessors -sequences compiler.cfg vectors arrays ; +compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons +cpu.architecture tools.test kernel math combinators.short-circuit +accessors sequences compiler.cfg.predecessors locals +compiler.cfg.phi-elimination compiler.cfg.dce compiler.cfg.liveness +compiler.cfg assocs vectors arrays layouts namespaces ; : trim-temps ( insns -- insns ) [ @@ -17,6 +19,56 @@ sequences compiler.cfg vectors arrays ; { } init-value-numbering value-numbering-step ; +! Folding constants together +[ + { + T{ ##load-reference f V int-regs 0 0.0 } + T{ ##load-reference f V int-regs 1 -0.0 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f V int-regs 1 D 1 } + } +] [ + { + T{ ##load-reference f V int-regs 0 0.0 } + T{ ##load-reference f V int-regs 1 -0.0 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f V int-regs 1 D 1 } + } test-value-numbering +] unit-test + +[ + { + T{ ##load-reference f V int-regs 0 0.0 } + T{ ##load-reference f V int-regs 1 0.0 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f V int-regs 0 D 1 } + } +] [ + { + T{ ##load-reference f V int-regs 0 0.0 } + T{ ##load-reference f V int-regs 1 0.0 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f V int-regs 1 D 1 } + } test-value-numbering +] unit-test + +[ + { + T{ ##load-reference f V int-regs 0 t } + T{ ##load-reference f V int-regs 1 t } + T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f V int-regs 0 D 1 } + } +] [ + { + T{ ##load-reference f V int-regs 0 t } + T{ ##load-reference f V int-regs 1 t } + T{ ##replace f V int-regs 0 D 0 } + T{ ##replace f V int-regs 1 D 1 } + } test-value-numbering +] unit-test + +! Copy propagation [ { T{ ##peek f V int-regs 45 D 1 } @@ -31,58 +83,7 @@ sequences compiler.cfg vectors arrays ; } test-value-numbering ] unit-test -[ - { - T{ ##load-immediate f V int-regs 2 8 } - T{ ##peek f V int-regs 3 D 0 } - T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 } - T{ ##replace f V int-regs 4 D 0 } - } -] [ - { - T{ ##load-immediate f V int-regs 2 8 } - T{ ##peek f V int-regs 3 D 0 } - T{ ##slot-imm f V int-regs 4 V int-regs 3 1 3 } - T{ ##replace f V int-regs 4 D 0 } - } test-value-numbering -] unit-test - -[ t ] [ - { - T{ ##peek f V int-regs 1 D 0 } - T{ ##dispatch f V int-regs 1 V int-regs 2 } - } dup test-value-numbering = -] unit-test - -[ t ] [ - { - T{ ##peek f V int-regs 16 D 0 } - T{ ##peek f V int-regs 17 D -1 } - T{ ##sar-imm f V int-regs 18 V int-regs 17 3 } - T{ ##add-imm f V int-regs 19 V int-regs 16 13 } - T{ ##add f V int-regs 21 V int-regs 18 V int-regs 19 } - T{ ##alien-unsigned-1 f V int-regs 22 V int-regs 21 } - T{ ##shl-imm f V int-regs 23 V int-regs 22 3 } - T{ ##replace f V int-regs 23 D 0 } - } dup test-value-numbering = -] unit-test - -[ - { - T{ ##peek f V int-regs 1 D 0 } - T{ ##shl-imm f V int-regs 2 V int-regs 1 3 } - T{ ##shr-imm f V int-regs 3 V int-regs 2 3 } - T{ ##replace f V int-regs 1 D 0 } - } -] [ - { - T{ ##peek f V int-regs 1 D 0 } - T{ ##mul-imm f V int-regs 2 V int-regs 1 8 } - T{ ##shr-imm f V int-regs 3 V int-regs 2 3 } - T{ ##replace f V int-regs 3 D 0 } - } test-value-numbering -] unit-test - +! Compare propagation [ { T{ ##load-reference f V int-regs 1 + } @@ -157,15 +158,1173 @@ sequences compiler.cfg vectors arrays ; } test-value-numbering trim-temps ] unit-test +! Immediate operand conversion [ { - T{ ##copy f V int-regs 48 V int-regs 45 } - T{ ##compare-imm-branch f V int-regs 45 7 cc/= } + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add-imm f V int-regs 2 V int-regs 0 100 } } ] [ - { V int-regs 45 } init-value-numbering { - T{ ##copy f V int-regs 48 V int-regs 45 } - T{ ##compare-imm-branch f V int-regs 48 7 cc/= } - } value-numbering-step + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 } + } test-value-numbering ] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add-imm f V int-regs 2 V int-regs 0 100 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add-imm f V int-regs 2 V int-regs 0 -100 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 0 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##sub f V int-regs 1 V int-regs 0 V int-regs 0 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##mul-imm f V int-regs 2 V int-regs 0 100 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##mul-imm f V int-regs 2 V int-regs 0 100 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 1 D 0 } + T{ ##shl-imm f V int-regs 2 V int-regs 1 3 } + } +] [ + { + T{ ##peek f V int-regs 1 D 0 } + T{ ##mul-imm f V int-regs 2 V int-regs 1 8 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##and-imm f V int-regs 2 V int-regs 0 100 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##and-imm f V int-regs 2 V int-regs 0 100 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##or-imm f V int-regs 2 V int-regs 0 100 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##or-imm f V int-regs 2 V int-regs 0 100 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##xor-imm f V int-regs 2 V int-regs 0 100 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##xor-imm f V int-regs 2 V int-regs 0 100 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc<= } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##compare f V int-regs 2 V int-regs 0 V int-regs 1 cc<= } + } test-value-numbering trim-temps +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##compare-imm f V int-regs 2 V int-regs 0 100 cc>= } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##compare f V int-regs 2 V int-regs 1 V int-regs 0 cc<= } + } test-value-numbering trim-temps +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##compare-imm-branch f V int-regs 0 100 cc<= } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##compare-branch f V int-regs 0 V int-regs 1 cc<= } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##compare-imm-branch f V int-regs 0 100 cc>= } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##compare-branch f V int-regs 1 V int-regs 0 cc<= } + } test-value-numbering trim-temps +] unit-test + +! Reassociation +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##add-imm f V int-regs 4 V int-regs 0 150 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##add f V int-regs 4 V int-regs 2 V int-regs 3 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##add-imm f V int-regs 4 V int-regs 0 150 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add f V int-regs 2 V int-regs 1 V int-regs 0 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##add-imm f V int-regs 4 V int-regs 0 50 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##add-imm f V int-regs 2 V int-regs 0 -100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##add-imm f V int-regs 4 V int-regs 0 -150 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##sub f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##sub f V int-regs 4 V int-regs 2 V int-regs 3 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##mul-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##mul f V int-regs 4 V int-regs 2 V int-regs 3 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##mul-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##mul-imm f V int-regs 4 V int-regs 0 5000 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##mul f V int-regs 2 V int-regs 1 V int-regs 0 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##mul f V int-regs 4 V int-regs 3 V int-regs 2 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##and-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##and-imm f V int-regs 4 V int-regs 0 32 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##and f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##and f V int-regs 4 V int-regs 2 V int-regs 3 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##and-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##and-imm f V int-regs 4 V int-regs 0 32 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##and f V int-regs 2 V int-regs 1 V int-regs 0 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##and f V int-regs 4 V int-regs 3 V int-regs 2 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##or-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##or-imm f V int-regs 4 V int-regs 0 118 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##or f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##or f V int-regs 4 V int-regs 2 V int-regs 3 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##or-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##or-imm f V int-regs 4 V int-regs 0 118 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##or f V int-regs 2 V int-regs 1 V int-regs 0 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##or f V int-regs 4 V int-regs 3 V int-regs 2 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##xor-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##xor-imm f V int-regs 4 V int-regs 0 86 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##xor f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##xor f V int-regs 4 V int-regs 2 V int-regs 3 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##xor-imm f V int-regs 2 V int-regs 0 100 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##xor-imm f V int-regs 4 V int-regs 0 86 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 100 } + T{ ##xor f V int-regs 2 V int-regs 1 V int-regs 0 } + T{ ##load-immediate f V int-regs 3 50 } + T{ ##xor f V int-regs 4 V int-regs 3 V int-regs 2 } + } test-value-numbering +] unit-test + +! Simplification +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##load-immediate f V int-regs 2 0 } + T{ ##add-imm f V int-regs 3 V int-regs 0 0 } + T{ ##replace f V int-regs 0 D 0 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } + T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } + T{ ##replace f V int-regs 3 D 0 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##load-immediate f V int-regs 2 0 } + T{ ##add-imm f V int-regs 3 V int-regs 0 0 } + T{ ##replace f V int-regs 0 D 0 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } + T{ ##sub f V int-regs 3 V int-regs 0 V int-regs 2 } + T{ ##replace f V int-regs 3 D 0 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##load-immediate f V int-regs 2 0 } + T{ ##or-imm f V int-regs 3 V int-regs 0 0 } + T{ ##replace f V int-regs 0 D 0 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } + T{ ##or f V int-regs 3 V int-regs 0 V int-regs 2 } + T{ ##replace f V int-regs 3 D 0 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##load-immediate f V int-regs 2 0 } + T{ ##xor-imm f V int-regs 3 V int-regs 0 0 } + T{ ##replace f V int-regs 0 D 0 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##peek f V int-regs 1 D 1 } + T{ ##sub f V int-regs 2 V int-regs 1 V int-regs 1 } + T{ ##xor f V int-regs 3 V int-regs 0 V int-regs 2 } + T{ ##replace f V int-regs 3 D 0 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 1 } + T{ ##shl-imm f V int-regs 2 V int-regs 0 0 } + T{ ##replace f V int-regs 0 D 0 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 1 } + T{ ##mul f V int-regs 2 V int-regs 0 V int-regs 1 } + T{ ##replace f V int-regs 2 D 0 } + } test-value-numbering +] unit-test + +! Constant folding +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 3 } + T{ ##load-immediate f V int-regs 3 4 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 3 } + T{ ##add f V int-regs 3 V int-regs 1 V int-regs 2 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 3 } + T{ ##load-immediate f V int-regs 3 -2 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 3 } + T{ ##sub f V int-regs 3 V int-regs 1 V int-regs 2 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 2 } + T{ ##load-immediate f V int-regs 2 3 } + T{ ##load-immediate f V int-regs 3 6 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 2 } + T{ ##load-immediate f V int-regs 2 3 } + T{ ##mul f V int-regs 3 V int-regs 1 V int-regs 2 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 2 } + T{ ##load-immediate f V int-regs 2 1 } + T{ ##load-immediate f V int-regs 3 0 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 2 } + T{ ##load-immediate f V int-regs 2 1 } + T{ ##and f V int-regs 3 V int-regs 1 V int-regs 2 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 2 } + T{ ##load-immediate f V int-regs 2 1 } + T{ ##load-immediate f V int-regs 3 3 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 2 } + T{ ##load-immediate f V int-regs 2 1 } + T{ ##or f V int-regs 3 V int-regs 1 V int-regs 2 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 2 } + T{ ##load-immediate f V int-regs 2 3 } + T{ ##load-immediate f V int-regs 3 1 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 2 } + T{ ##load-immediate f V int-regs 2 3 } + T{ ##xor f V int-regs 3 V int-regs 1 V int-regs 2 } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 3 8 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 1 } + T{ ##shl-imm f V int-regs 3 V int-regs 1 3 } + } test-value-numbering +] unit-test + +cell 8 = [ + [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 -1 } + T{ ##load-immediate f V int-regs 3 HEX: ffffffffffff } + } + ] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 -1 } + T{ ##shr-imm f V int-regs 3 V int-regs 1 16 } + } test-value-numbering + ] unit-test +] when + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 -8 } + T{ ##load-immediate f V int-regs 3 -4 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 -8 } + T{ ##sar-imm f V int-regs 3 V int-regs 1 1 } + } test-value-numbering +] unit-test + +cell 8 = [ + [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 65536 } + T{ ##load-immediate f V int-regs 2 140737488355328 } + T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } + } + ] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 65536 } + T{ ##shl-imm f V int-regs 2 V int-regs 1 31 } + T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } + } test-value-numbering + ] unit-test + + [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 2 140737488355328 } + T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } + } + ] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 2 140737488355328 } + T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } + } test-value-numbering + ] unit-test + + [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 2 2147483647 } + T{ ##add-imm f V int-regs 3 V int-regs 0 2147483647 } + T{ ##add-imm f V int-regs 4 V int-regs 3 2147483647 } + } + ] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 2 2147483647 } + T{ ##add f V int-regs 3 V int-regs 0 V int-regs 2 } + T{ ##add f V int-regs 4 V int-regs 3 V int-regs 2 } + } test-value-numbering + ] unit-test +] when + +! Branch folding +[ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##load-immediate f V int-regs 3 5 } + } +] [ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc= } + } test-value-numbering +] unit-test + +[ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##load-reference f V int-regs 3 t } + } +] [ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc/= } + } test-value-numbering +] unit-test + +[ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##load-reference f V int-regs 3 t } + } +] [ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##compare f V int-regs 3 V int-regs 1 V int-regs 2 cc< } + } test-value-numbering +] unit-test + +[ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##load-immediate f V int-regs 3 5 } + } +] [ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##compare f V int-regs 3 V int-regs 2 V int-regs 1 cc< } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 5 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc< } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-reference f V int-regs 1 t } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 5 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc> } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-reference f V int-regs 1 t } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc>= } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-immediate f V int-regs 1 5 } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc/= } + } test-value-numbering +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-reference f V int-regs 1 t } + } +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc= } + } test-value-numbering +] unit-test + +: test-branch-folding ( insns -- insns' n ) + + [ V{ 0 1 } clone >>successors basic-block set test-value-numbering ] keep + successors>> first ; + +[ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##branch } + } + 1 +] [ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##compare-branch f V int-regs 1 V int-regs 2 cc= } + } test-branch-folding +] unit-test + +[ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##branch } + } + 0 +] [ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##compare-branch f V int-regs 1 V int-regs 2 cc/= } + } test-branch-folding +] unit-test + +[ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##branch } + } + 0 +] [ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##compare-branch f V int-regs 1 V int-regs 2 cc< } + } test-branch-folding +] unit-test + +[ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##branch } + } + 1 +] [ + { + T{ ##load-immediate f V int-regs 1 1 } + T{ ##load-immediate f V int-regs 2 2 } + T{ ##compare-branch f V int-regs 2 V int-regs 1 cc< } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } + } + 1 +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } + } + 0 +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare-branch f V int-regs 0 V int-regs 0 cc<= } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } + } + 1 +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare-branch f V int-regs 0 V int-regs 0 cc> } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } + } + 0 +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare-branch f V int-regs 0 V int-regs 0 cc>= } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } + } + 0 +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare-branch f V int-regs 0 V int-regs 0 cc= } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } + } + 1 +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare-branch f V int-regs 0 V int-regs 0 cc/= } + } test-branch-folding +] unit-test + +[ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##load-reference f V int-regs 1 t } + T{ ##branch } + } + 0 +] [ + { + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare f V int-regs 1 V int-regs 0 V int-regs 0 cc<= } + T{ ##compare-imm-branch f V int-regs 1 5 cc/= } + } test-branch-folding +] unit-test + +! More branch folding tests +V{ T{ ##branch } } 0 test-bb + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< } +} 1 test-bb + +V{ + T{ ##load-immediate f V int-regs 1 1 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##load-immediate f V int-regs 2 2 } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##phi f V int-regs 3 { } } + T{ ##replace f V int-regs 3 D 0 } + T{ ##return } +} 4 test-bb + +4 get instructions>> first +2 get V int-regs 1 2array +3 get V int-regs 2 2array 2array +>>inputs drop + +test-diamond + +[ ] [ + cfg new 0 get >>entry + compute-liveness + value-numbering + compute-predecessors + eliminate-phis drop +] unit-test + +[ 1 ] [ 1 get successors>> length ] unit-test + +[ t ] [ 1 get successors>> first 3 get eq? ] unit-test + +[ 3 ] [ 4 get instructions>> length ] unit-test + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 0 test-bb + +V{ + T{ ##peek f V int-regs 1 D 1 } + T{ ##compare-branch f V int-regs 1 V int-regs 1 cc< } +} 1 test-bb + +V{ + T{ ##copy f V int-regs 2 V int-regs 0 } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##phi f V int-regs 3 V{ } } + T{ ##branch } +} 3 test-bb + +V{ + T{ ##replace f V int-regs 3 D 0 } + T{ ##return } +} 4 test-bb + +1 get V int-regs 1 2array +2 get V int-regs 0 2array 2array 3 get instructions>> first (>>inputs) + +test-diamond + +[ ] [ + cfg new 0 get >>entry + compute-predecessors + compute-liveness + value-numbering + compute-predecessors + eliminate-dead-code + drop +] unit-test + +[ t ] [ 1 get successors>> first 3 get eq? ] unit-test + +[ 1 ] [ 3 get instructions>> first inputs>> assoc-size ] unit-test + +V{ T{ ##prologue } T{ ##branch } } 0 test-bb + +V{ + T{ ##peek { dst V int-regs 15 } { loc D 0 } } + T{ ##copy { dst V int-regs 16 } { src V int-regs 15 } } + T{ ##copy { dst V int-regs 17 } { src V int-regs 15 } } + T{ ##copy { dst V int-regs 18 } { src V int-regs 15 } } + T{ ##copy { dst V int-regs 19 } { src V int-regs 15 } } + T{ ##compare + { dst V int-regs 20 } + { src1 V int-regs 18 } + { src2 V int-regs 19 } + { cc cc= } + { temp V int-regs 22 } + } + T{ ##copy { dst V int-regs 21 } { src V int-regs 20 } } + T{ ##compare-imm-branch + { src1 V int-regs 21 } + { src2 5 } + { cc cc/= } + } +} 1 test-bb + +V{ + T{ ##copy { dst V int-regs 23 } { src V int-regs 15 } } + T{ ##copy { dst V int-regs 24 } { src V int-regs 15 } } + T{ ##load-reference { dst V int-regs 25 } { obj t } } + T{ ##branch } +} 2 test-bb + +V{ + T{ ##replace { src V int-regs 25 } { loc D 0 } } + T{ ##epilogue } + T{ ##return } +} 3 test-bb + +V{ + T{ ##copy { dst V int-regs 26 } { src V int-regs 15 } } + T{ ##copy { dst V int-regs 27 } { src V int-regs 15 } } + T{ ##add + { dst V int-regs 28 } + { src1 V int-regs 26 } + { src2 V int-regs 27 } + } + T{ ##branch } +} 4 test-bb + +V{ + T{ ##replace { src V int-regs 28 } { loc D 0 } } + T{ ##epilogue } + T{ ##return } +} 5 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 4 get V{ } 2sequence >>successors drop +2 get 3 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop + +[ ] [ + cfg new 0 get >>entry + compute-liveness value-numbering eliminate-dead-code drop +] unit-test + +[ f ] [ 1 get instructions>> [ ##peek? ] any? ] unit-test diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 9f5473c62f..e49555e06e 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -1,16 +1,19 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: namespaces assocs biassocs classes kernel math accessors -sorting sets sequences +sorting sets sequences fry +compiler.cfg compiler.cfg.local compiler.cfg.liveness +compiler.cfg.renaming compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions -compiler.cfg.value-numbering.propagate compiler.cfg.value-numbering.simplify compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering +! Local value numbering. Predecessors must be recomputed after this + : number-input-values ( live-in -- ) [ [ f next-input-expr simplify ] dip set-vn ] each ; @@ -19,8 +22,18 @@ IN: compiler.cfg.value-numbering init-expressions number-input-values ; +: vreg>vreg-mapping ( -- assoc ) + vregs>vns get [ keys ] keep + '[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ; + +: rename-uses ( insns -- ) + vreg>vreg-mapping renamings [ + [ rename-insn-uses ] each + ] with-variable ; + : value-numbering-step ( insns -- insns' ) - [ [ number-values ] [ rewrite propagate ] bi ] map ; + [ rewrite ] map dup rename-uses ; : value-numbering ( cfg -- cfg' ) - [ init-value-numbering ] [ value-numbering-step ] local-optimization ; + [ init-value-numbering ] [ value-numbering-step ] local-optimization + cfg-changed ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index df6e91aec9..5df0114244 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -165,24 +165,21 @@ M: ##or generate-insn dst/src1/src2 %or ; M: ##or-imm generate-insn dst/src1/src2 %or-imm ; M: ##xor generate-insn dst/src1/src2 %xor ; M: ##xor-imm generate-insn dst/src1/src2 %xor-imm ; +M: ##shl generate-insn dst/src1/src2 %shl ; M: ##shl-imm generate-insn dst/src1/src2 %shl-imm ; +M: ##shr generate-insn dst/src1/src2 %shr ; M: ##shr-imm generate-insn dst/src1/src2 %shr-imm ; +M: ##sar generate-insn dst/src1/src2 %sar ; M: ##sar-imm generate-insn dst/src1/src2 %sar-imm ; M: ##not generate-insn dst/src %not ; M: ##log2 generate-insn dst/src %log2 ; -: src1/src2 ( insn -- src1 src2 ) - [ src1>> register ] [ src2>> register ] bi ; inline +: label/dst/src1/src2 ( insn -- label dst src1 src2 ) + [ label>> lookup-label ] [ dst/src1/src2 ] bi ; inline -: src1/src2/temp1/temp2 ( insn -- src1 src2 temp1 temp2 ) - [ src1/src2 ] [ temp1>> register ] [ temp2>> register ] tri ; inline - -M: ##fixnum-add generate-insn src1/src2 %fixnum-add ; -M: ##fixnum-add-tail generate-insn src1/src2 %fixnum-add-tail ; -M: ##fixnum-sub generate-insn src1/src2 %fixnum-sub ; -M: ##fixnum-sub-tail generate-insn src1/src2 %fixnum-sub-tail ; -M: ##fixnum-mul generate-insn src1/src2/temp1/temp2 %fixnum-mul ; -M: ##fixnum-mul-tail generate-insn src1/src2/temp1/temp2 %fixnum-mul-tail ; +M: _fixnum-add generate-insn label/dst/src1/src2 %fixnum-add ; +M: _fixnum-sub generate-insn label/dst/src1/src2 %fixnum-sub ; +M: _fixnum-mul generate-insn label/dst/src1/src2 %fixnum-mul ; : dst/src/temp ( insn -- dst src temp ) [ dst/src ] [ temp>> register ] bi ; inline diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 82da31b5fe..9f573019c2 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -314,4 +314,11 @@ M: cucumber equal? "The cucumber has no equal" throw ; ! Regression from Doug's value numbering changes [ t ] [ 2 [ 1 swap fixnum< ] compile-call ] unit-test -[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test \ No newline at end of file +[ 3 ] [ 2 [ 1 swap fixnum< [ 3 ] [ 4 ] if ] compile-call ] unit-test + +cell 4 = [ + [ 0 ] [ 101 [ dup fixnum-fast 1 fixnum+fast 20 fixnum-shift-fast 20 fixnum-shift-fast ] compile-call ] unit-test +] when + +! Regression from Slava's value numbering changes +[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/intrinsics.factor b/basis/compiler/tests/intrinsics.factor index df7f1c8513..0e620e068c 100644 --- a/basis/compiler/tests/intrinsics.factor +++ b/basis/compiler/tests/intrinsics.factor @@ -213,12 +213,25 @@ IN: compiler.tests.intrinsics [ -1 ] [ [ -123 -64 fixnum-shift ] compile-call ] unit-test [ -1 ] [ -123 -64 [ fixnum-shift ] compile-call ] unit-test -[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test -[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test -[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test +[ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test +[ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test +[ 4294967296 ] [ 1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test +[ -4294967296 ] [ -1 32 [ fixnum-shift ] compile-call ] unit-test +[ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test +[ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test -[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test -[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test +[ 8 ] [ 1 3 [ fixnum-shift-fast ] compile-call ] unit-test +[ 8 ] [ 1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test +[ 8 ] [ 1 [ 3 fixnum-shift-fast ] compile-call ] unit-test +[ 8 ] [ [ 1 3 fixnum-shift-fast ] compile-call ] unit-test +[ -8 ] [ -1 3 [ fixnum-shift-fast ] compile-call ] unit-test +[ -8 ] [ -1 3 [ 15 bitand fixnum-shift-fast ] compile-call ] unit-test +[ -8 ] [ -1 [ 3 fixnum-shift-fast ] compile-call ] unit-test +[ -8 ] [ [ -1 3 fixnum-shift-fast ] compile-call ] unit-test + +[ 2 ] [ 8 -2 [ fixnum-shift-fast ] compile-call ] unit-test +[ 2 ] [ 8 2 [ 15 bitand neg fixnum-shift-fast ] compile-call ] unit-test +[ 2 ] [ 8 [ -2 fixnum-shift-fast ] compile-call ] unit-test [ 4294967296 ] [ 1 32 [ fixnum-shift ] compile-call ] unit-test [ 4294967296 ] [ 1 [ 32 fixnum-shift ] compile-call ] unit-test @@ -227,6 +240,13 @@ IN: compiler.tests.intrinsics [ -4294967296 ] [ -1 [ 32 fixnum-shift ] compile-call ] unit-test [ -4294967296 ] [ -1 [ 16 fixnum-shift 16 fixnum-shift ] compile-call ] unit-test +[ HEX: 10000000 ] [ HEX: 1000000 HEX: 10 [ fixnum* ] compile-call ] unit-test +[ HEX: 10000000 ] [ HEX: -10000000 >fixnum [ 0 swap fixnum- ] compile-call ] unit-test +[ HEX: 10000000 ] [ HEX: -fffffff >fixnum [ 1 swap fixnum- ] compile-call ] unit-test + +[ t ] [ 1 27 fixnum-shift dup [ fixnum+ ] compile-call 1 28 fixnum-shift = ] unit-test +[ -268435457 ] [ 1 28 shift neg >fixnum [ -1 fixnum+ ] compile-call ] unit-test + [ t ] [ 1 20 shift 1 20 shift [ fixnum* ] compile-call 1 40 shift = ] unit-test [ t ] [ 1 20 shift neg 1 20 shift [ fixnum* ] compile-call 1 40 shift neg = ] unit-test [ t ] [ 1 20 shift neg 1 20 shift neg [ fixnum* ] compile-call 1 40 shift = ] unit-test diff --git a/basis/compiler/tree/cleanup/cleanup-tests.factor b/basis/compiler/tree/cleanup/cleanup-tests.factor index e5b75bb5b0..228a4e3efb 100755 --- a/basis/compiler/tree/cleanup/cleanup-tests.factor +++ b/basis/compiler/tree/cleanup/cleanup-tests.factor @@ -242,6 +242,11 @@ M: float detect-float ; { fixnum-shift-fast } inlined? ] unit-test +[ t ] [ + [ 1 swap 7 bitand shift ] + { shift fixnum-shift } inlined? +] unit-test + cell-bits 32 = [ [ t ] [ [ { fixnum fixnum } declare 1 swap 31 bitand shift ] diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor index 4fc4f4814b..d6906d6348 100644 --- a/basis/compiler/tree/debugger/debugger.factor +++ b/basis/compiler/tree/debugger/debugger.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2008 Slava Pestov. +! Copyright (C) 2006, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel assocs match fry accessors namespaces make effects sequences sequences.private quotations generic macros arrays @@ -15,7 +15,9 @@ compiler.tree.def-use compiler.tree.builder compiler.tree.optimizer compiler.tree.combinators -compiler.tree.checker ; +compiler.tree.checker +compiler.tree.dead-code +compiler.tree.modular-arithmetic ; FROM: fry => _ ; RENAME: _ match => __ IN: compiler.tree.debugger @@ -201,8 +203,15 @@ SYMBOL: node-count : cleaned-up-tree ( quot -- nodes ) [ - check-optimizer? on - build-tree optimize-tree + build-tree + analyze-recursive + normalize + propagate + cleanup + compute-def-use + remove-dead-code + compute-def-use + optimize-modular-arithmetic ] with-scope ; : inlined? ( quot seq/word -- ? ) diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index 0e72deb6fa..9b278dde9b 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors sequences words memoize combinators classes classes.builtin classes.tuple math.partial-dispatch -fry assocs +fry assocs combinators.short-circuit compiler.tree compiler.tree.combinators compiler.tree.propagation.info @@ -29,10 +29,12 @@ GENERIC: finalize* ( node -- nodes ) M: #copy finalize* drop f ; M: #shuffle finalize* - dup - [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] - [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at ] map sequence= ] - bi and [ drop f ] when ; + dup { + [ [ in-d>> length ] [ out-d>> length ] bi = ] + [ [ in-r>> length ] [ out-r>> length ] bi = ] + [ [ in-d>> ] [ out-d>> ] [ mapping>> ] tri '[ _ at = ] 2all? ] + [ [ in-r>> ] [ out-r>> ] [ mapping>> ] tri '[ _ at = ] 2all? ] + } 1&& [ drop f ] when ; MEMO: cached-expansion ( word -- nodes ) def>> splice-final ; @@ -46,6 +48,9 @@ M: predicate finalize-word [ drop ] } cond ; +M: math-partial finalize-word + dup primitive? [ drop ] [ nip cached-expansion ] if ; + M: word finalize-word drop ; M: #call finalize* diff --git a/basis/compiler/tree/modular-arithmetic/authors.txt b/basis/compiler/tree/modular-arithmetic/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/basis/compiler/tree/modular-arithmetic/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor index 6e1c32d89d..13555d45f7 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor @@ -1,12 +1,15 @@ +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. IN: compiler.tree.modular-arithmetic.tests USING: kernel kernel.private tools.test math math.partial-dispatch math.private accessors slots.private sequences strings sbufs compiler.tree.builder -compiler.tree.optimizer -compiler.tree.debugger ; +compiler.tree.normalization +compiler.tree.debugger +alien.accessors layouts combinators byte-arrays ; : test-modular-arithmetic ( quot -- quot' ) - build-tree optimize-tree nodes>quot ; + cleaned-up-tree nodes>quot ; [ [ >R >fixnum R> >fixnum fixnum+fast ] ] [ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test @@ -135,4 +138,36 @@ TUPLE: declared-fixnum { x fixnum } ; ] unit-test [ [ >fixnum 255 fixnum-bitand ] ] -[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test \ No newline at end of file +[ [ >integer 256 rem ] test-modular-arithmetic ] unit-test + +[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-1 ] ] +[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-1 ] test-modular-arithmetic ] unit-test + +[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-2 ] ] +[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-2 ] test-modular-arithmetic ] unit-test + +cell { + { 4 [ [ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-unsigned-4 ] ] ] } + { 8 [ [ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-unsigned-4 ] ] ] } +} case +[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-4 ] test-modular-arithmetic ] unit-test + +[ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-unsigned-8 ] ] +[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-unsigned-8 ] test-modular-arithmetic ] unit-test + +[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-signed-1 ] ] +[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-1 ] test-modular-arithmetic ] unit-test + +[ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-signed-2 ] ] +[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-2 ] test-modular-arithmetic ] unit-test + +cell { + { 4 [ [ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-signed-4 ] ] ] } + { 8 [ [ [ "COMPLEX SHUFFLE" fixnum+fast "COMPLEX SHUFFLE" set-alien-signed-4 ] ] ] } +} case +[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-4 ] test-modular-arithmetic ] unit-test + +[ [ "COMPLEX SHUFFLE" fixnum+ "COMPLEX SHUFFLE" set-alien-signed-8 ] ] +[ [ [ { fixnum fixnum } declare + ] 2dip set-alien-signed-8 ] test-modular-arithmetic ] unit-test + +[ t ] [ [ { fixnum byte-array } declare [ + ] with map ] { + fixnum+ >fixnum } inlined? ] unit-test diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor index 31939a0d22..148286faba 100644 --- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor +++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: math math.partial-dispatch namespaces sequences sets accessors assocs words kernel memoize fry combinators -combinators.short-circuit +combinators.short-circuit layouts alien.accessors compiler.tree compiler.tree.combinators compiler.tree.def-use @@ -28,6 +28,16 @@ IN: compiler.tree.modular-arithmetic { bitand bitor bitxor bitnot } [ t "modular-arithmetic" set-word-prop ] each +{ + >fixnum + set-alien-unsigned-1 set-alien-signed-1 + set-alien-unsigned-2 set-alien-signed-2 +} +cell 8 = [ + { set-alien-unsigned-4 set-alien-signed-4 } append +] when +[ t "low-order" set-word-prop ] each + SYMBOL: modularize-values : modular-value? ( value -- ? ) @@ -54,7 +64,7 @@ M: node maybe-modularize* 2drop ; GENERIC: compute-modularized-values* ( node -- ) M: #call compute-modularized-values* - dup word>> \ >fixnum eq? + dup word>> "low-order" word-prop [ in-d>> first maybe-modularize ] [ drop ] if ; M: node compute-modularized-values* drop ; diff --git a/basis/compiler/tree/propagation/call-effect/authors.txt b/basis/compiler/tree/propagation/call-effect/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/basis/compiler/tree/propagation/call-effect/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor new file mode 100644 index 0000000000..5964bcee35 --- /dev/null +++ b/basis/compiler/tree/propagation/call-effect/call-effect-tests.factor @@ -0,0 +1,51 @@ +! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: compiler.tree.propagation.call-effect tools.test fry math effects kernel +compiler.tree.builder compiler.tree.optimizer compiler.tree.debugger sequences ; +IN: compiler.tree.propagation.call-effect.tests + +[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test +[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test +[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test +[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test + +[ t ] [ [ + ] cached-effect (( a b -- c )) effect= ] unit-test +[ t ] [ 5 [ + ] curry cached-effect (( a -- c )) effect= ] unit-test +[ t ] [ 5 [ ] curry cached-effect (( -- c )) effect= ] unit-test +[ t ] [ [ dup ] [ drop ] compose cached-effect (( a -- b )) effect= ] unit-test +[ t ] [ [ drop ] [ dup ] compose cached-effect (( a b -- c d )) effect= ] unit-test +[ t ] [ [ 2drop ] [ dup ] compose cached-effect (( a b c -- d e )) effect= ] unit-test +[ t ] [ [ 1 2 3 ] [ 2drop ] compose cached-effect (( -- a )) effect= ] unit-test +[ t ] [ [ 1 2 ] [ 3drop ] compose cached-effect (( a -- )) effect= ] unit-test + +: optimized-quot ( quot -- quot' ) + build-tree optimize-tree nodes>quot ; + +: compiled-call2 ( a quot: ( a -- b ) -- b ) + call( a -- b ) ; + +: compiled-execute2 ( a b word: ( a b -- c ) -- c ) + execute( a b -- c ) ; + +[ [ 3 ] ] [ [ 1 2 \ + execute( a b -- c ) ] optimized-quot ] unit-test +[ [ 3 ] ] [ [ 1 2 [ + ] call( a b -- c ) ] optimized-quot ] unit-test +[ [ 3 ] ] [ [ 1 2 '[ _ + ] call( a -- b ) ] optimized-quot ] unit-test +[ [ 3 ] ] [ [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] optimized-quot ] unit-test + +[ 1 2 { [ + ] } first compiled-call2 ] must-fail +[ 3 ] [ 1 2 { + } first compiled-execute2 ] unit-test +[ 3 ] [ 1 2 '[ _ + ] compiled-call2 ] unit-test +[ 3 ] [ 1 2 '[ _ ] [ + ] compose compiled-call2 ] unit-test +[ 3 ] [ 1 2 \ + compiled-execute2 ] unit-test + +[ 3 ] [ 1 2 { [ + ] } first call( a b -- c ) ] unit-test +[ 3 ] [ 1 2 { + } first execute( a b -- c ) ] unit-test +[ 3 ] [ 1 2 '[ _ + ] call( a -- b ) ] unit-test +[ 3 ] [ 1 2 '[ _ ] [ + ] compose call( a -- b ) ] unit-test + +[ t ] [ [ 2 '[ _ ] [ + ] compose ] final-info first infer-value (( object -- object )) effect= ] unit-test +[ t ] [ [ 2 '[ _ ] 1 '[ _ + ] compose ] final-info first infer-value (( -- object )) effect= ] unit-test +[ t ] [ [ 2 '[ _ + ] ] final-info first infer-value (( object -- object )) effect= ] unit-test +[ f ] [ [ [ [ ] [ 1 ] if ] ] final-info first infer-value ] unit-test +[ f ] [ [ [ 1 ] '[ @ ] ] final-info first infer-value ] unit-test +[ f ] [ [ dup drop ] final-info first infer-value ] unit-test diff --git a/basis/stack-checker/call-effect/call-effect.factor b/basis/compiler/tree/propagation/call-effect/call-effect.factor similarity index 57% rename from basis/stack-checker/call-effect/call-effect.factor rename to basis/compiler/tree/propagation/call-effect/call-effect.factor index b3b678d93d..bc18aa6ec1 100644 --- a/basis/stack-checker/call-effect/call-effect.factor +++ b/basis/compiler/tree/propagation/call-effect/call-effect.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2009 Slava Pestov. +! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors combinators combinators.private effects fry kernel kernel.private make sequences continuations quotations -stack-checker stack-checker.transforms words math ; -IN: stack-checker.call-effect +words math stack-checker stack-checker.transforms +compiler.tree.propagation.info slots.private ; +IN: compiler.tree.propagation.call-effect ! call( and execute( have complex expansions. @@ -84,18 +85,14 @@ M: quotation cached-effect [ drop call-effect-slow ] if ; inline -\ call-effect [ - inline-cache new '[ - _ - 3dup nip cache-hit? [ - drop call-effect-unsafe - ] [ - call-effect-fast - ] if - ] -] 0 define-transform +: call-effect-ic ( quot effect inline-cache -- ) + 3dup nip cache-hit? + [ drop call-effect-unsafe ] + [ call-effect-fast ] + if ; inline -\ call-effect t "no-compile" set-word-prop +: call-effect>quot ( effect -- quot ) + inline-cache new '[ drop _ _ call-effect-ic ] ; : execute-effect-slow ( word effect -- ) [ '[ _ execute ] ] dip call-effect-slow ; inline @@ -116,8 +113,72 @@ M: quotation cached-effect if ; inline : execute-effect>quot ( effect -- quot ) - inline-cache new '[ _ _ execute-effect-ic ] ; + inline-cache new '[ drop _ _ execute-effect-ic ] ; -\ execute-effect [ execute-effect>quot ] 1 define-transform +: last2 ( seq -- penultimate ultimate ) + 2 tail* first2 ; -\ execute-effect t "no-compile" set-word-prop \ No newline at end of file +: top-two ( #call -- effect value ) + in-d>> last2 [ value-info ] bi@ + literal>> swap ; + +ERROR: uninferable ; + +: remove-effect-input ( effect -- effect' ) + (( -- object )) swap compose-effects ; + +: (infer-value) ( value-info -- effect ) + dup class>> { + { \ quotation [ + literal>> [ uninferable ] unless* cached-effect + dup +unknown+ = [ uninferable ] when + ] } + { \ curry [ + slots>> third (infer-value) + remove-effect-input + ] } + { \ compose [ + slots>> last2 [ (infer-value) ] bi@ + compose-effects + ] } + [ uninferable ] + } case ; + +: infer-value ( value-info -- effect/f ) + [ (infer-value) ] + [ dup uninferable? [ 2drop f ] [ rethrow ] if ] + recover ; + +: (value>quot) ( value-info -- quot ) + dup class>> { + { \ quotation [ literal>> '[ drop @ ] ] } + { \ curry [ + slots>> third (value>quot) + '[ [ obj>> ] [ quot>> @ ] bi ] + ] } + { \ compose [ + slots>> last2 [ (value>quot) ] bi@ + '[ [ first>> @ ] [ second>> @ ] bi ] + ] } + } case ; + +: value>quot ( value-info -- quot: ( code effect -- ) ) + (value>quot) '[ drop @ ] ; + +: call-inlining ( #call -- quot/f ) + top-two dup infer-value [ + pick effect<= + [ nip value>quot ] + [ drop call-effect>quot ] if + ] [ drop call-effect>quot ] if* ; + +\ call-effect [ call-inlining ] "custom-inlining" set-word-prop + +: execute-inlining ( #call -- quot/f ) + top-two >literal< [ + 2dup swap execute-effect-unsafe? + [ nip '[ 2drop _ execute ] ] + [ drop execute-effect>quot ] if + ] [ drop execute-effect>quot ] if ; + +\ execute-effect [ execute-inlining ] "custom-inlining" set-word-prop diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor index 2f5c166ac5..f5ea64bc0a 100644 --- a/basis/compiler/tree/propagation/known-words/known-words.factor +++ b/basis/compiler/tree/propagation/known-words/known-words.factor @@ -6,14 +6,16 @@ math.parser math.order layouts words sequences sequences.private arrays assocs classes classes.algebra combinators generic.math splitting fry locals classes.tuple alien.accessors classes.tuple.private slots.private definitions strings.private -vectors hashtables generic +vectors hashtables generic quotations stack-checker.state compiler.tree.comparisons compiler.tree.propagation.info compiler.tree.propagation.nodes compiler.tree.propagation.slots compiler.tree.propagation.simple -compiler.tree.propagation.constraints ; +compiler.tree.propagation.constraints +compiler.tree.propagation.call-effect +compiler.tree.propagation.transforms ; IN: compiler.tree.propagation.known-words \ fixnum @@ -226,39 +228,6 @@ generic-comparison-ops [ ] "outputs" set-word-prop ] assoc-each -: rem-custom-inlining ( #call -- quot/f ) - second value-info literal>> dup integer? - [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; - -{ - mod-integer-integer - mod-integer-fixnum - mod-fixnum-integer - fixnum-mod -} [ - [ - in-d>> dup first value-info interval>> [0,inf] interval-subset? - [ rem-custom-inlining ] [ drop f ] if - ] "custom-inlining" set-word-prop -] each - -\ rem [ - in-d>> rem-custom-inlining -] "custom-inlining" set-word-prop - -{ - bitand-integer-integer - bitand-integer-fixnum - bitand-fixnum-integer -} [ - [ - in-d>> second value-info >literal< [ - 0 most-positive-fixnum between? - [ [ >fixnum ] bi@ fixnum-bitand ] f ? - ] when - ] "custom-inlining" set-word-prop -] each - { numerator denominator } [ [ drop integer ] "outputs" set-word-prop ] each @@ -313,15 +282,6 @@ generic-comparison-ops [ "outputs" set-word-prop ] each -! Generate more efficient code for common idiom -\ clone [ - in-d>> first value-info literal>> { - { V{ } [ [ drop { } 0 vector boa ] ] } - { H{ } [ [ drop 0 ] ] } - [ drop f ] - } case -] "custom-inlining" set-word-prop - \ slot [ dup literal?>> [ literal>> swap value-info-slot ] [ 2drop object-info ] if @@ -345,17 +305,3 @@ generic-comparison-ops [ bi ] [ 2drop object-info ] if ] "outputs" set-word-prop - -\ instance? [ - in-d>> second value-info literal>> dup class? - [ "predicate" word-prop '[ drop @ ] ] [ drop f ] if -] "custom-inlining" set-word-prop - -\ equal? [ - ! If first input has a known type and second input is an - ! object, we convert this to [ swap equal? ]. - in-d>> first2 value-info class>> object class= [ - value-info class>> \ equal? specific-method - [ swap equal? ] f ? - ] [ drop f ] if -] "custom-inlining" set-word-prop diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 32c9f4ed0b..8ec98ccc66 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -9,7 +9,7 @@ compiler.tree.propagation.info compiler.tree.def-use compiler.tree.debugger compiler.tree.checker slots.private words hashtables classes assocs locals specialized-arrays.double system sorting math.libm -math.intervals quotations ; +math.intervals quotations effects ; IN: compiler.tree.propagation.tests [ V{ } ] [ [ ] final-classes ] unit-test @@ -84,9 +84,9 @@ IN: compiler.tree.propagation.tests [ float ] [ [ { float float } declare mod ] final-math-class ] unit-test -[ V{ integer } ] [ [ 255 bitand ] final-classes ] unit-test +[ V{ fixnum } ] [ [ 255 bitand ] final-classes ] unit-test -[ V{ integer } ] [ +[ V{ fixnum } ] [ [ [ 255 bitand ] [ 65535 bitand ] bi + ] final-classes ] unit-test @@ -640,6 +640,10 @@ MIXIN: empty-mixin [ { bignum integer } declare [ shift ] keep ] final-classes ] unit-test +[ V{ fixnum } ] [ [ >fixnum 15 bitand 1 swap shift ] final-classes ] unit-test + +[ V{ fixnum } ] [ [ 15 bitand 1 swap shift ] final-classes ] unit-test + [ V{ fixnum } ] [ [ { fixnum } declare log2 ] final-classes ] unit-test @@ -704,3 +708,39 @@ TUPLE: circle me ; ! Joe found an oversight [ V{ integer } ] [ [ >integer ] final-classes ] unit-test + +TUPLE: foo bar ; + +[ t ] [ [ foo new ] { new } inlined? ] unit-test + +GENERIC: whatever ( x -- y ) +M: number whatever drop foo ; + +[ t ] [ [ 1 whatever new ] { new } inlined? ] unit-test + +: that-thing ( -- class ) foo ; + +[ f ] [ [ that-thing new ] { new } inlined? ] unit-test + +GENERIC: whatever2 ( x -- y ) +M: number whatever2 drop H{ { 1 1 } { 2 2 } { 3 3 } { 4 4 } { 5 6 } } ; +M: f whatever2 ; + +[ t ] [ [ 1 whatever2 at ] { at* hashcode* } inlined? ] unit-test +[ f ] [ [ whatever2 at ] { at* hashcode* } inlined? ] unit-test + +[ t ] [ [ { 1 2 3 } member? ] { member? } inlined? ] unit-test +[ f ] [ [ { 1 2 3 } swap member? ] { member? } inlined? ] unit-test + +[ t ] [ [ { 1 2 3 } memq? ] { memq? } inlined? ] unit-test +[ f ] [ [ { 1 2 3 } swap memq? ] { memq? } inlined? ] unit-test + +[ t ] [ [ V{ } clone ] { clone (clone) } inlined? ] unit-test +[ f ] [ [ { } clone ] { clone (clone) } inlined? ] unit-test + +[ f ] [ [ instance? ] { instance? } inlined? ] unit-test +[ f ] [ [ 5 instance? ] { instance? } inlined? ] unit-test +[ t ] [ [ array instance? ] { instance? } inlined? ] unit-test + +[ t ] [ [ (( a b c -- c b a )) shuffle ] { shuffle } inlined? ] unit-test +[ f ] [ [ { 1 2 3 } swap shuffle ] { shuffle } inlined? ] unit-test diff --git a/basis/compiler/tree/propagation/transforms/authors.txt b/basis/compiler/tree/propagation/transforms/authors.txt new file mode 100644 index 0000000000..a44f8d7f8d --- /dev/null +++ b/basis/compiler/tree/propagation/transforms/authors.txt @@ -0,0 +1,2 @@ +Slava Pestov +Daniel Ehrenberg diff --git a/basis/compiler/tree/propagation/transforms/transforms.factor b/basis/compiler/tree/propagation/transforms/transforms.factor new file mode 100644 index 0000000000..3fd7af0324 --- /dev/null +++ b/basis/compiler/tree/propagation/transforms/transforms.factor @@ -0,0 +1,205 @@ +! Copyright (C) 2008, 2009 Slava Pestov, Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences words fry generic accessors classes.tuple +classes classes.algebra definitions stack-checker.state quotations +classes.tuple.private math math.partial-dispatch math.private +math.intervals layouts math.order vectors hashtables +combinators effects generalizations assocs sets +combinators.short-circuit sequences.private locals +stack-checker namespaces compiler.tree.propagation.info ; +IN: compiler.tree.propagation.transforms + +\ equal? [ + ! If first input has a known type and second input is an + ! object, we convert this to [ swap equal? ]. + in-d>> first2 value-info class>> object class= [ + value-info class>> \ equal? specific-method + [ swap equal? ] f ? + ] [ drop f ] if +] "custom-inlining" set-word-prop + +: rem-custom-inlining ( #call -- quot/f ) + second value-info literal>> dup integer? + [ power-of-2? [ 1- bitand ] f ? ] [ drop f ] if ; + +{ + mod-integer-integer + mod-integer-fixnum + mod-fixnum-integer + fixnum-mod +} [ + [ + in-d>> dup first value-info interval>> [0,inf] interval-subset? + [ rem-custom-inlining ] [ drop f ] if + ] "custom-inlining" set-word-prop +] each + +\ rem [ + in-d>> rem-custom-inlining +] "custom-inlining" set-word-prop + +{ + bitand-integer-integer + bitand-integer-fixnum + bitand-fixnum-integer + bitand +} [ + [ + in-d>> second value-info >literal< [ + 0 most-positive-fixnum between? + [ [ >fixnum ] bi@ fixnum-bitand ] f ? + ] when + ] "custom-inlining" set-word-prop +] each + +! Speeds up 2^ +\ shift [ + in-d>> first value-info literal>> 1 = [ + cell-bits tag-bits get - 1 - + '[ + >fixnum dup 0 < [ 2drop 0 ] [ + dup _ < [ fixnum-shift ] [ + fixnum-shift + ] if + ] if + ] + ] [ f ] if +] "custom-inlining" set-word-prop + +! Generate more efficient code for common idiom +\ clone [ + in-d>> first value-info literal>> { + { V{ } [ [ drop { } 0 vector boa ] ] } + { H{ } [ [ drop 0 ] ] } + [ drop f ] + } case +] "custom-inlining" set-word-prop + +ERROR: bad-partial-eval quot word ; + +: check-effect ( quot word -- ) + 2dup [ infer ] [ stack-effect ] bi* effect<= + [ 2drop ] [ bad-partial-eval ] if ; + +:: define-partial-eval ( word quot n -- ) + word [ + in-d>> n tail* + [ value-info ] map + dup [ literal?>> ] all? [ + [ literal>> ] map + n firstn + quot call dup [ + [ n ndrop ] prepose + dup word check-effect + ] when + ] [ drop f ] if + ] "custom-inlining" set-word-prop ; + +: inline-new ( class -- quot/f ) + dup tuple-class? [ + dup inlined-dependency depends-on + [ all-slots [ initial>> literalize ] map ] + [ tuple-layout '[ _ ] ] + bi append >quotation + ] [ drop f ] if ; + +\ new [ inline-new ] 1 define-partial-eval + +\ instance? [ + dup class? + [ "predicate" word-prop ] [ drop f ] if +] 1 define-partial-eval + +! Shuffling +: nths-quot ( indices -- quot ) + [ [ '[ _ swap nth ] ] map ] [ length ] bi + '[ _ cleave _ narray ] ; + +\ shuffle [ + shuffle-mapping nths-quot +] 1 define-partial-eval + +! Index search +\ index [ + dup sequence? [ + dup length 4 >= [ + dup length zip >hashtable '[ _ at ] + ] [ drop f ] if + ] [ drop f ] if +] 1 define-partial-eval + +: memq-quot ( seq -- newquot ) + [ [ dupd eq? ] curry [ drop t ] ] { } map>assoc + [ drop f ] suffix [ cond ] curry ; + +\ memq? [ + dup sequence? [ memq-quot ] [ drop f ] if +] 1 define-partial-eval + +! Membership testing +: member-quot ( seq -- newquot ) + dup length 4 <= [ + [ drop f ] swap + [ literalize [ t ] ] { } map>assoc linear-case-quot + ] [ + unique [ key? ] curry + ] if ; + +\ member? [ + dup sequence? [ member-quot ] [ drop f ] if +] 1 define-partial-eval + +! Fast at for integer maps +CONSTANT: lookup-table-at-max 256 + +: lookup-table-at? ( assoc -- ? ) + #! Can we use a fast byte array test here? + { + [ assoc-size 4 > ] + [ values [ ] all? ] + [ keys [ integer? ] all? ] + [ keys [ 0 lookup-table-at-max between? ] all? ] + } 1&& ; + +: lookup-table-seq ( assoc -- table ) + [ keys supremum 1+ ] keep '[ _ at ] { } map-as ; + +: lookup-table-quot ( seq -- newquot ) + lookup-table-seq + '[ + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup >boolean + ] [ 2drop f f ] if + ] [ 2drop f f ] if + ] ; + +: fast-lookup-table-at? ( assoc -- ? ) + values { + [ [ integer? ] all? ] + [ [ 0 254 between? ] all? ] + } 1&& ; + +: fast-lookup-table-seq ( assoc -- table ) + lookup-table-seq [ 255 or ] B{ } map-as ; + +: fast-lookup-table-quot ( seq -- newquot ) + fast-lookup-table-seq + '[ + _ over integer? [ + 2dup bounds-check? [ + nth-unsafe dup 255 eq? [ drop f f ] [ t ] if + ] [ 2drop f f ] if + ] [ 2drop f f ] if + ] ; + +: at-quot ( assoc -- quot ) + dup lookup-table-at? [ + dup fast-lookup-table-at? [ + fast-lookup-table-quot + ] [ + lookup-table-quot + ] if + ] [ drop f ] if ; + +\ at* [ at-quot ] 1 define-partial-eval diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index ac276b6e41..c21be39adb 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -27,4 +27,6 @@ SYMBOL: yield-hook yield-hook [ [ ] ] initialize : alist-max ( alist -- pair ) - [ ] [ [ [ second ] bi@ > ] most ] map-reduce ; \ No newline at end of file + [ ] [ [ [ second ] bi@ > ] most ] map-reduce ; + +: penultimate ( seq -- elt ) [ length 2 - ] keep nth ; diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index 556424f50c..deb44db41a 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -76,18 +76,18 @@ HOOK: %or cpu ( dst src1 src2 -- ) HOOK: %or-imm cpu ( dst src1 src2 -- ) HOOK: %xor cpu ( dst src1 src2 -- ) HOOK: %xor-imm cpu ( dst src1 src2 -- ) +HOOK: %shl cpu ( dst src1 src2 -- ) HOOK: %shl-imm cpu ( dst src1 src2 -- ) +HOOK: %shr cpu ( dst src1 src2 -- ) HOOK: %shr-imm cpu ( dst src1 src2 -- ) +HOOK: %sar cpu ( dst src1 src2 -- ) HOOK: %sar-imm cpu ( dst src1 src2 -- ) HOOK: %not cpu ( dst src -- ) HOOK: %log2 cpu ( dst src -- ) -HOOK: %fixnum-add cpu ( src1 src2 -- ) -HOOK: %fixnum-add-tail cpu ( src1 src2 -- ) -HOOK: %fixnum-sub cpu ( src1 src2 -- ) -HOOK: %fixnum-sub-tail cpu ( src1 src2 -- ) -HOOK: %fixnum-mul cpu ( src1 src2 temp1 temp2 -- ) -HOOK: %fixnum-mul-tail cpu ( src1 src2 temp1 temp2 -- ) +HOOK: %fixnum-add cpu ( label dst src1 src2 -- ) +HOOK: %fixnum-sub cpu ( label dst src1 src2 -- ) +HOOK: %fixnum-mul cpu ( label dst src1 src2 -- ) HOOK: %integer>bignum cpu ( dst src temp -- ) HOOK: %bignum>integer cpu ( dst src temp -- ) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 96a99f4d5e..727131aa25 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -51,8 +51,6 @@ M: x86.32 reserved-area-size 0 ; M: x86.32 %alien-invoke 0 CALL rc-relative rel-dlsym ; -M: x86.32 %alien-invoke-tail 0 JMP rc-relative rel-dlsym ; - M: x86.32 return-struct-in-registers? ( c-type -- ? ) c-type [ return-in-registers?>> ] diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 5390d7e0c8..8eb04eb2b5 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -167,11 +167,6 @@ M: x86.64 %alien-invoke rc-absolute-cell rel-dlsym R11 CALL ; -M: x86.64 %alien-invoke-tail - R11 0 MOV - rc-absolute-cell rel-dlsym - R11 JMP ; - M: x86.64 %prepare-alien-indirect ( -- ) "unbox_alien" f %alien-invoke RBP RAX MOV ; diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 15c54aa7d8..6b4a93885c 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -4,9 +4,14 @@ USING: accessors assocs alien alien.c-types arrays strings cpu.x86.assembler cpu.x86.assembler.private cpu.architecture kernel kernel.private math memory namespaces make sequences words system layouts combinators math.order fry locals -compiler.constants compiler.cfg.registers -compiler.cfg.instructions compiler.cfg.intrinsics -compiler.cfg.stack-frame compiler.codegen compiler.codegen.fixup ; +compiler.constants +compiler.cfg.registers +compiler.cfg.instructions +compiler.cfg.intrinsics +compiler.cfg.comparisons +compiler.cfg.stack-frame +compiler.codegen +compiler.codegen.fixup ; IN: cpu.x86 << enable-fixnum-log2 >> @@ -124,83 +129,18 @@ M: x86 %log2 BSR ; : ?MOV ( dst src -- ) 2dup = [ 2drop ] [ MOV ] if ; inline -:: move>args ( src1 src2 -- ) - { - { [ src1 param-reg-2 = ] [ param-reg-1 src2 ?MOV param-reg-1 param-reg-2 XCHG ] } - { [ src1 param-reg-1 = ] [ param-reg-2 src2 ?MOV ] } - { [ src2 param-reg-1 = ] [ param-reg-2 src1 ?MOV param-reg-1 param-reg-2 XCHG ] } - { [ src2 param-reg-2 = ] [ param-reg-1 src1 ?MOV ] } - [ - param-reg-1 src1 MOV - param-reg-2 src2 MOV - ] - } cond ; - -HOOK: %alien-invoke-tail cpu ( func dll -- ) - -:: overflow-template ( src1 src2 insn inverse func -- ) -