From: Sam Anklesaria Date: Tue, 28 Jul 2009 21:42:38 +0000 (-0500) Subject: Merge branch 'master' of git://factorcode.org/git/factor X-Git-Tag: 0.97~5838^2~33 X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=fe86d9f56e644403ad5f72afac955a1b0d083e7d;hp=0c104ca1269e7184ac8866e5899e3b8a39348c29 Merge branch 'master' of git://factorcode.org/git/factor --- diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index 17c391636f..42655aceb8 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -61,7 +61,7 @@ M: bit-array like drop dup bit-array? [ >bit-array ] unless ; M: bit-array new-sequence drop ; M: bit-array equal? - over bit-array? [ sequence= ] [ 2drop f ] if ; + over bit-array? [ [ underlying>> ] bi@ sequence= ] [ 2drop f ] if ; M: bit-array resize [ drop ] [ diff --git a/basis/bit-sets/bit-sets.factor b/basis/bit-sets/bit-sets.factor index 0e97968965..34b7f13dc2 100644 --- a/basis/bit-sets/bit-sets.factor +++ b/basis/bit-sets/bit-sets.factor @@ -26,4 +26,6 @@ HINTS: bit-set-intersect bit-array bit-array ; : bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ; -HINTS: bit-set-diff bit-array bit-array ; \ No newline at end of file +HINTS: bit-set-diff bit-array bit-array ; + +: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ; \ No newline at end of file diff --git a/basis/byte-arrays/hex/authors.txt b/basis/byte-arrays/hex/authors.txt new file mode 100644 index 0000000000..8f20b8c31e --- /dev/null +++ b/basis/byte-arrays/hex/authors.txt @@ -0,0 +1,2 @@ +Maxim Savchenko +Slava Pestov diff --git a/basis/byte-arrays/hex/hex-docs.factor b/basis/byte-arrays/hex/hex-docs.factor new file mode 100644 index 0000000000..8a2b842fc9 --- /dev/null +++ b/basis/byte-arrays/hex/hex-docs.factor @@ -0,0 +1,8 @@ +! Copyright (C) 2009 Maxim Savchenko, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +IN: byte-arrays.hex +USING: byte-arrays help.markup help.syntax ; + +HELP: HEX{ +{ $syntax "HEX{ 0123 45 67 89abcdef }" } +{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ; diff --git a/basis/byte-arrays/hex/hex.factor b/basis/byte-arrays/hex/hex.factor new file mode 100644 index 0000000000..f1b9a52303 --- /dev/null +++ b/basis/byte-arrays/hex/hex.factor @@ -0,0 +1,11 @@ +! Copyright (C) 2009 Maxim Savchenko, Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: grouping lexer ascii parser sequences kernel math.parser ; +IN: byte-arrays.hex + +SYNTAX: HEX{ + "}" parse-tokens "" join + [ blank? not ] filter + 2 group [ hex> ] B{ } map-as + parsed ; + diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index d47b954ecf..9995567ec8 100644 --- a/basis/circular/circular.factor +++ b/basis/circular/circular.factor @@ -43,11 +43,10 @@ TUPLE: growing-circular < circular length ; M: growing-circular length length>> ; > length ] bi = ; -: set-last ( elt seq -- ) - [ length 1- ] keep set-nth ; PRIVATE> : push-growing-circular ( elt circular -- ) diff --git a/basis/compiler/cfg/block-joining/block-joining.factor b/basis/compiler/cfg/block-joining/block-joining.factor index 982f0866e6..b4c7223435 100644 --- a/basis/compiler/cfg/block-joining/block-joining.factor +++ b/basis/compiler/cfg/block-joining/block-joining.factor @@ -8,20 +8,14 @@ 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 -- ? ) { + [ kill-block? not ] [ predecessors>> length 1 = ] - [ predecessor kill-vreg-block? not ] + [ predecessor kill-block? not ] [ predecessor successors>> length 1 = ] [ [ predecessor ] keep back-edge? not ] } 1&& ; diff --git a/basis/compiler/cfg/branch-splitting/branch-splitting.factor b/basis/compiler/cfg/branch-splitting/branch-splitting.factor index 2ab476e20c..8618932e14 100644 --- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor +++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor @@ -6,18 +6,8 @@ compiler.cfg.def-use compiler.cfg compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ; IN: compiler.cfg.branch-splitting -: clone-renamings ( insns -- assoc ) - [ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ; - : clone-instructions ( insns -- insns' ) - dup clone-renamings renamings [ - [ - clone - dup rename-insn-defs - dup rename-insn-uses - dup fresh-insn-temps - ] map - ] with-variable ; + [ clone dup fresh-insn-temps ] map ; : clone-basic-block ( bb -- bb' ) ! The new block gets the same RPO number as the old one. @@ -62,18 +52,33 @@ IN: compiler.cfg.branch-splitting UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ; -: split-instructions? ( insns -- ? ) - [ [ irrelevant? not ] count 5 <= ] - [ last ##fixnum-overflow? not ] - bi and ; +: split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ; -: split-branch? ( bb -- ? ) +: short-tail-block? ( bb -- ? ) + [ successors>> empty? ] [ instructions>> length 2 = ] bi and ; + +: short-block? ( bb -- ? ) + ! If block is empty, always split + [ predecessors>> length ] [ instructions>> length 1 - ] bi * 10 <= ; + +: cond-cond-block? ( bb -- ? ) { - [ dup successors>> [ back-edge? ] with any? not ] - [ predecessors>> length 2 4 between? ] - [ instructions>> split-instructions? ] + [ predecessors>> length 2 = ] + [ successors>> length 2 = ] + [ instructions>> length 20 <= ] } 1&& ; +: split-branch? ( bb -- ? ) + dup loop-entry? [ drop f ] [ + dup predecessors>> length 1 <= [ drop f ] [ + { + [ short-block? ] + [ short-tail-block? ] + [ cond-cond-block? ] + } 1|| + ] if + ] if ; + : split-branches ( cfg -- cfg' ) dup [ dup split-branch? [ split-branch ] [ drop ] if 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 71798da6fc..76b10dda01 100644 --- a/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor +++ b/basis/compiler/cfg/build-stack-frame/build-stack-frame.factor @@ -13,10 +13,16 @@ SYMBOL: spill-counts GENERIC: compute-stack-frame* ( insn -- ) : request-stack-frame ( stack-frame -- ) + frame-required? on stack-frame [ max-stack-frame ] change ; -M: ##stack-frame compute-stack-frame* - frame-required? on +M: ##alien-invoke compute-stack-frame* + stack-frame>> request-stack-frame ; + +M: ##alien-indirect compute-stack-frame* + stack-frame>> request-stack-frame ; + +M: ##alien-callback compute-stack-frame* stack-frame>> request-stack-frame ; M: ##call compute-stack-frame* @@ -45,8 +51,6 @@ M: insn compute-stack-frame* GENERIC: insert-pro/epilogues* ( insn -- ) -M: ##stack-frame insert-pro/epilogues* drop ; - M: ##prologue insert-pro/epilogues* drop frame-required? get [ stack-frame get _prologue ] when ; diff --git a/basis/compiler/cfg/builder/blocks/blocks.factor b/basis/compiler/cfg/builder/blocks/blocks.factor new file mode 100644 index 0000000000..8e96255bdd --- /dev/null +++ b/basis/compiler/cfg/builder/blocks/blocks.factor @@ -0,0 +1,74 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays fry kernel make math namespaces sequences +compiler.cfg compiler.cfg.instructions compiler.cfg.stacks +compiler.cfg.stacks.local ; +IN: compiler.cfg.builder.blocks + +: set-basic-block ( basic-block -- ) + [ basic-block set ] [ instructions>> building set ] bi + begin-local-analysis ; + +: initial-basic-block ( -- ) + set-basic-block ; + +: end-basic-block ( -- ) + basic-block get [ end-local-analysis ] when + building off + basic-block off ; + +: (begin-basic-block) ( -- ) + + basic-block get [ dupd successors>> push ] when* + set-basic-block ; + +: begin-basic-block ( -- ) + basic-block get [ end-local-analysis ] when + (begin-basic-block) ; + +: emit-trivial-block ( quot -- ) + ##branch begin-basic-block + call + ##branch begin-basic-block ; inline + +: call-height ( #call -- n ) + [ out-d>> length ] [ in-d>> length ] bi - ; + +: emit-primitive ( node -- ) + [ + [ word>> ##call ] + [ call-height adjust-d ] bi + ] emit-trivial-block ; + +: begin-branch ( -- ) clone-current-height (begin-basic-block) ; + +: end-branch ( -- pair/f ) + ! pair is { final-bb final-height } + basic-block get dup [ + ##branch + end-local-analysis + current-height get clone 2array + ] when ; + +: with-branch ( quot -- pair/f ) + [ begin-branch call end-branch ] with-scope ; inline + +: set-successors ( branches -- ) + ! Set the successor of each branch's final basic block to the + ! current block. + basic-block get dup [ + '[ [ [ _ ] dip first successors>> push ] when* ] each + ] [ 2drop ] if ; + +: merge-heights ( branches -- ) + ! If all elements are f, that means every branch ended with a backward + ! jump so the height is irrelevant since this block is unreachable. + [ ] find nip [ second current-height set ] [ end-basic-block ] if* ; + +: emit-conditional ( branches -- ) + ! branchies is a sequence of pairs as above + end-basic-block + [ merge-heights begin-basic-block ] + [ set-successors ] + bi ; + diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor index 4a481a09d8..2de7c7c3d1 100644 --- a/basis/compiler/cfg/builder/builder-tests.factor +++ b/basis/compiler/cfg/builder/builder-tests.factor @@ -1,12 +1,30 @@ IN: compiler.cfg.builder.tests -USING: tools.test kernel sequences -words sequences.private fry prettyprint alien alien.accessors -math.private compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays -kernel.private math ; +USING: tools.test kernel sequences words sequences.private fry +prettyprint alien alien.accessors math.private compiler.tree.builder +compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger +compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker +arrays locals byte-arrays kernel.private math slots.private vectors sbufs +strings math.partial-dispatch strings.private ; ! Just ensure that various CFGs build correctly. -: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ; +: unit-test-cfg ( quot -- ) + '[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ; + +: blahblah ( nodes -- ? ) + { fixnum } declare [ + dup 3 bitand 1 = [ drop t ] [ + dup 3 bitand 2 = [ + blahblah + ] [ drop f ] if + ] if + ] any? ; inline recursive + +: more? ( x -- ? ) ; + +: test-case-1 ( -- ? ) f ; + +: test-case-2 ( -- ) + test-case-1 [ test-case-2 ] [ ] if ; inline recursive { [ ] @@ -49,6 +67,39 @@ kernel.private math ; [ "int" f "malloc" { "int" } alien-invoke ] [ "int" { "int" } "cdecl" alien-indirect ] [ "int" { "int" } "cdecl" [ ] alien-callback ] + [ swap - + * ] + [ swap slot ] + [ blahblah ] + [ 1000 [ dup [ reverse ] when ] times ] + [ 1array ] + [ 1 2 ? ] + [ { array } declare [ ] map ] + [ { array } declare dup 1 slot [ 1 slot ] when ] + [ [ dup more? ] [ dup ] produce ] + [ vector new over test-case-1 [ test-case-2 ] [ ] if ] + [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ] + [ + { fixnum sbuf } declare 2dup 3 slot fixnum> [ + over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot + ] [ ] if + ] + [ [ 2 fixnum* ] when 3 ] + [ [ 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 + ] } [ unit-test-cfg ] each diff --git a/basis/compiler/cfg/builder/builder.factor b/basis/compiler/cfg/builder/builder.factor index 2eff8b9e28..0c40b93ba6 100755 --- a/basis/compiler/cfg/builder/builder.factor +++ b/basis/compiler/cfg/builder/builder.factor @@ -10,30 +10,39 @@ compiler.tree.combinators compiler.tree.propagation.info compiler.cfg compiler.cfg.hats -compiler.cfg.stacks compiler.cfg.utilities compiler.cfg.registers compiler.cfg.intrinsics compiler.cfg.comparisons compiler.cfg.stack-frame compiler.cfg.instructions +compiler.cfg.predecessors +compiler.cfg.builder.blocks +compiler.cfg.stacks compiler.alien ; IN: compiler.cfg.builder -! Convert tree SSA IR to CFG SSA IR. +! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is +! constructed later by calling compiler.cfg.ssa.construction:construct-ssa. SYMBOL: procedures SYMBOL: loops -: begin-procedure ( word label -- ) - end-basic-block - begin-basic-block +: begin-cfg ( word label -- cfg ) + initial-basic-block H{ } clone loops set - [ basic-block get ] 2dip - procedures get push ; + [ basic-block get ] 2dip dup cfg set ; + +: begin-procedure ( word label -- ) + begin-cfg procedures get push ; : with-cfg-builder ( nodes word label quot -- ) - '[ begin-procedure @ ] with-scope ; inline + '[ + begin-stack-analysis + begin-procedure + @ + end-stack-analysis + ] with-scope ; inline GENERIC: emit-node ( node -- ) @@ -61,24 +70,26 @@ GENERIC: emit-node ( node -- ) : emit-loop-call ( basic-block -- ) ##branch basic-block get successors>> push - basic-block off ; + end-basic-block ; -: emit-call ( word -- ) - dup loops get key? - [ loops get at emit-loop-call ] - [ ##call ##branch begin-basic-block ] +: emit-call ( word height -- ) + over loops get key? + [ drop loops get at emit-loop-call ] + [ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ] if ; ! #recursive +: recursive-height ( #recursive -- n ) + [ label>> return>> in-d>> length ] [ in-d>> length ] bi - ; + : emit-recursive ( #recursive -- ) - [ label>> id>> emit-call ] + [ [ label>> id>> ] [ recursive-height ] bi emit-call ] [ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ; : remember-loop ( label -- ) basic-block get swap loops get set-at ; : emit-loop ( node -- ) - ##loop-entry ##branch begin-basic-block [ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ; @@ -93,9 +104,6 @@ M: #recursive emit-node : emit-if ( node -- ) children>> [ emit-branch ] map emit-conditional ; -: ##branch-t ( vreg -- ) - \ f tag-number cc/= ##compare-imm-branch ; - : trivial-branch? ( nodes -- value ? ) dup length 1 = [ first dup #push? [ literal>> t ] [ drop f f ] if @@ -119,24 +127,32 @@ M: #recursive emit-node : emit-trivial-not-if ( -- ) ds-pop \ f tag-number cc= ^^compare-imm ds-push ; +: emit-actual-if ( #if -- ) + ! Inputs to the final instruction need to be copied because of + ! loc>vreg sync + ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ; + M: #if emit-node { { [ dup trivial-if? ] [ drop emit-trivial-if ] } { [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] } - [ ds-pop ##branch-t emit-if ] + [ emit-actual-if ] } cond ; ! #dispatch M: #dispatch emit-node + ! Inputs to the final instruction need to be copied because of + ! loc>vreg sync. ^^offset>slot always returns a fresh vreg, + ! though. ds-pop ^^offset>slot i ##dispatch emit-if ; ! #call M: #call emit-node dup word>> dup "intrinsic" word-prop - [ emit-intrinsic ] [ nip emit-call ] if ; + [ emit-intrinsic ] [ swap call-height emit-call ] if ; ! #call-recursive -M: #call-recursive emit-node label>> id>> emit-call ; +M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ; ! #push M: #push emit-node @@ -153,15 +169,16 @@ M: #shuffle emit-node [ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ; ! #return -M: #return emit-node - drop ##epilogue ##return ; +: emit-return ( -- ) + ##branch begin-basic-block ##epilogue ##return ; + +M: #return emit-node drop emit-return ; M: #return-recursive emit-node - label>> id>> loops get key? - [ ##epilogue ##return ] unless ; + label>> id>> loops get key? [ emit-return ] unless ; ! #terminate -M: #terminate emit-node drop ##no-tco basic-block off ; +M: #terminate emit-node drop ##no-tco end-basic-block ; ! FFI : return-size ( ctype -- n ) @@ -178,12 +195,14 @@ M: #terminate emit-node drop ##no-tco basic-block off ; [ return>> return-size >>return ] [ alien-parameters parameter-sizes drop >>params ] bi ; -: alien-stack-frame ( params -- ) - ##stack-frame ; +: alien-node-height ( params -- ) + [ out-d>> length ] [ in-d>> length ] bi - adjust-d ; : emit-alien-node ( node quot -- ) - [ params>> ] dip [ drop alien-stack-frame ] [ call ] 2bi - ##branch begin-basic-block ; inline + [ + [ params>> dup dup ] dip call + alien-node-height + ] emit-trivial-block ; inline M: #alien-invoke emit-node [ ##alien-invoke ] emit-alien-node ; diff --git a/basis/compiler/cfg/checker/checker.factor b/basis/compiler/cfg/checker/checker.factor index 2f8077be99..07e6cc8cea 100644 --- a/basis/compiler/cfg/checker/checker.factor +++ b/basis/compiler/cfg/checker/checker.factor @@ -1,34 +1,44 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel compiler.cfg.instructions compiler.cfg.rpo -compiler.cfg.def-use compiler.cfg.linearization -combinators.short-circuit accessors math sequences sets assocs ; +compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities +compiler.cfg.mr combinators.short-circuit accessors math +sequences sets assocs ; IN: compiler.cfg.checker -ERROR: last-insn-not-a-jump insn ; +ERROR: bad-kill-block bb ; + +: check-kill-block ( bb -- ) + dup instructions>> first2 + swap ##epilogue? [ + { [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1|| + ] [ ##branch? ] if + [ drop ] [ bad-kill-block ] if ; + +ERROR: last-insn-not-a-jump bb ; : check-last-instruction ( bb -- ) - last dup { + dup instructions>> last { [ ##branch? ] [ ##dispatch? ] [ ##conditional-branch? ] [ ##compare-imm-branch? ] - [ ##return? ] - [ ##callback-return? ] - [ ##jump? ] [ ##fixnum-add? ] [ ##fixnum-sub? ] [ ##fixnum-mul? ] [ ##no-tco? ] } 1|| [ drop ] [ last-insn-not-a-jump ] if ; -ERROR: bad-loop-entry ; +ERROR: bad-kill-insn bb ; -: check-loop-entry ( bb -- ) - dup length 2 >= [ - 2 head* [ ##loop-entry? ] any? - [ bad-loop-entry ] when - ] [ drop ] if ; +: check-kill-instructions ( bb -- ) + dup instructions>> [ kill-vreg-insn? ] any? + [ bad-kill-insn ] [ drop ] if ; + +: check-normal-block ( bb -- ) + [ check-last-instruction ] + [ check-kill-instructions ] + bi ; ERROR: bad-successors ; @@ -37,10 +47,9 @@ ERROR: bad-successors ; [ bad-successors ] unless ; : check-basic-block ( bb -- ) - [ instructions>> check-last-instruction ] - [ instructions>> check-loop-entry ] + [ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ] [ check-successors ] - tri ; + bi ; ERROR: bad-live-in ; @@ -50,10 +59,10 @@ ERROR: undefined-values uses defs ; ! Check that every used register has a definition instructions>> [ [ uses-vregs ] map concat ] - [ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi + [ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi 2dup subset? [ 2drop ] [ undefined-values ] if ; : check-cfg ( cfg -- ) [ [ check-basic-block ] each-basic-block ] - [ flatten-cfg check-mr ] + [ build-mr check-mr ] bi ; diff --git a/basis/compiler/cfg/copy-prop/copy-prop.factor b/basis/compiler/cfg/copy-prop/copy-prop.factor index d526ea9c1d..1f2c75f28a 100644 --- a/basis/compiler/cfg/copy-prop/copy-prop.factor +++ b/basis/compiler/cfg/copy-prop/copy-prop.factor @@ -1,12 +1,62 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces assocs accessors ; +USING: kernel namespaces assocs accessors sequences grouping +compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ; IN: compiler.cfg.copy-prop +! The first three definitions are also used in compiler.cfg.alias-analysis. SYMBOL: copies : resolve ( vreg -- vreg ) - [ copies get at ] keep or ; + copies get ?at drop ; -: record-copy ( insn -- ) - [ src>> resolve ] [ dst>> ] bi copies get set-at ; inline +: (record-copy) ( dst src -- ) + swap copies get set-at ; inline + +: record-copy ( ##copy -- ) + [ dst>> ] [ src>> resolve ] bi (record-copy) ; inline + +> ] [ inputs>> values [ resolve ] map ] bi + dup all-equal? [ first (record-copy) ] [ 2drop ] if ; + +M: insn visit-insn drop ; + +: collect-copies ( cfg -- ) + H{ } clone copies set + [ + instructions>> + [ visit-insn ] each + ] each-basic-block ; + +GENERIC: update-insn ( insn -- keep? ) + +M: ##copy update-insn drop f ; + +M: ##phi update-insn + dup dst>> copies get key? [ drop f ] [ call-next-method ] if ; + +M: insn update-insn rename-insn-uses t ; + +: rename-copies ( cfg -- ) + copies get dup assoc-empty? [ 2drop ] [ + renamings set + [ + instructions>> + [ update-insn ] filter-here + ] each-basic-block + ] if ; + +PRIVATE> + +: copy-propagation ( cfg -- cfg' ) + [ collect-copies ] + [ rename-copies ] + [ ] + tri ; diff --git a/basis/compiler/cfg/critical-edges/critical-edges.factor b/basis/compiler/cfg/critical-edges/critical-edges.factor new file mode 100644 index 0000000000..1000c24752 --- /dev/null +++ b/basis/compiler/cfg/critical-edges/critical-edges.factor @@ -0,0 +1,21 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math accessors sequences +compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ; +IN: compiler.cfg.critical-edges + +: critical-edge? ( from to -- ? ) + [ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ; + +: split-critical-edge ( from to -- ) + f insert-basic-block ; + +: split-critical-edges ( cfg -- ) + dup [ + dup successors>> [ + 2dup critical-edge? + [ split-critical-edge ] [ 2drop ] if + ] with each + ] each-basic-block + cfg-changed + drop ; \ 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 index c38f43da8a..975adfa6cb 100644 --- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor +++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor @@ -20,7 +20,7 @@ MIXIN: dataflow-analysis GENERIC# compute-in-set 2 ( bb out-sets dfa -- set ) -! M: kill-block compute-in-set 3drop f ; +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 ; @@ -31,7 +31,7 @@ M:: basic-block compute-in-set ( bb out-sets dfa -- set ) GENERIC# compute-out-set 2 ( bb out-sets dfa -- set ) -! M: kill-block compute-out-set 3drop f ; +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 ; diff --git a/basis/compiler/cfg/debugger/debugger.factor b/basis/compiler/cfg/debugger/debugger.factor index 18f1b3be76..3c6ea1f0e4 100644 --- a/basis/compiler/cfg/debugger/debugger.factor +++ b/basis/compiler/cfg/debugger/debugger.factor @@ -14,9 +14,11 @@ IN: compiler.cfg.debugger GENERIC: test-cfg ( quot -- cfgs ) M: callable test-cfg + 0 vreg-counter set-global build-tree optimize-tree gensym build-cfg ; M: word test-cfg + 0 vreg-counter set-global [ build-tree optimize-tree ] keep build-cfg ; : test-mr ( quot -- mrs ) diff --git a/basis/compiler/cfg/def-use/def-use.factor b/basis/compiler/cfg/def-use/def-use.factor index d7bfc56b32..1c9ac90f78 100644 --- a/basis/compiler/cfg/def-use/def-use.factor +++ b/basis/compiler/cfg/def-use/def-use.factor @@ -1,16 +1,17 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays kernel assocs sequences -sets compiler.cfg.instructions ; +USING: accessors arrays kernel assocs sequences namespaces fry +sets compiler.cfg.rpo compiler.cfg.instructions ; IN: compiler.cfg.def-use -GENERIC: defs-vregs ( insn -- seq ) +GENERIC: defs-vreg ( insn -- vreg/f ) 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: ##flushable defs-vreg dst>> ; +M: ##fixnum-overflow defs-vreg dst>> ; +M: _fixnum-overflow defs-vreg dst>> ; +M: insn defs-vreg drop f ; M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ; M: ##unary/temp temp-vregs temp>> 1array ; @@ -49,26 +50,48 @@ M: _compare-imm-branch uses-vregs src1>> 1array ; M: _dispatch uses-vregs src>> 1array ; M: insn uses-vregs drop f ; -! Instructions that use vregs -UNION: vreg-insn -##flushable -##write-barrier -##dispatch -##effect -##fixnum-overflow -##conditional-branch -##compare-imm-branch -##phi -##gc -_conditional-branch -_compare-imm-branch -_dispatch ; +! Computing def-use chains. -: map-unique ( seq quot -- assoc ) - map concat unique ; inline +SYMBOLS: defs insns uses ; -: gen-set ( instructions -- seq ) - [ uses-vregs ] map-unique ; +: def-of ( vreg -- node ) defs get at ; +: uses-of ( vreg -- nodes ) uses get at ; +: insn-of ( vreg -- insn ) insns get at ; -: kill-set ( instructions -- seq ) - [ defs-vregs ] map-unique ; +: set-def-of ( obj insn assoc -- ) + swap defs-vreg dup [ swap set-at ] [ 3drop ] if ; + +: compute-defs ( cfg -- ) + H{ } clone [ + '[ + dup instructions>> [ + _ set-def-of + ] with each + ] each-basic-block + ] keep + defs set ; + +: compute-insns ( cfg -- ) + H{ } clone [ + '[ + instructions>> [ + dup _ set-def-of + ] each + ] each-basic-block + ] keep insns set ; + +: compute-uses ( cfg -- ) + H{ } clone [ + '[ + dup instructions>> [ + uses-vregs [ + _ conjoin-at + ] with each + ] with each + ] each-basic-block + ] keep + [ keys ] assoc-map + uses set ; + +: compute-def-use ( cfg -- ) + [ compute-defs ] [ compute-uses ] [ compute-insns ] tri ; \ No newline at end of file diff --git a/basis/compiler/cfg/dominance/dominance-tests.factor b/basis/compiler/cfg/dominance/dominance-tests.factor index e884e32d78..07bcd7bc84 100644 --- a/basis/compiler/cfg/dominance/dominance-tests.factor +++ b/basis/compiler/cfg/dominance/dominance-tests.factor @@ -33,10 +33,11 @@ V{ } 5 test-bb [ 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 +[ t ] [ 0 get 3 get dominates? ] unit-test +[ f ] [ 3 get 4 get dominates? ] unit-test +[ f ] [ 1 get 4 get dominates? ] unit-test +[ t ] [ 4 get 5 get dominates? ] unit-test +[ f ] [ 1 get 5 get dominates? ] unit-test ! Example from the paper V{ } 0 test-bb @@ -73,25 +74,3 @@ V{ } 5 test-bb [ ] [ test-dominance ] unit-test [ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test - -V{ } 0 test-bb -V{ } 1 test-bb -V{ } 2 test-bb -V{ } 3 test-bb -V{ } 4 test-bb -V{ } 5 test-bb -V{ } 6 test-bb - -0 get 1 get 5 get V{ } 2sequence >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 6 get 1vector >>successors drop -5 get 6 get 1vector >>successors drop - -[ ] [ test-dominance ] unit-test - -[ t ] [ - 2 get 3 get 2array iterated-dom-frontier - 4 get 6 get 2array set= -] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/dominance/dominance.factor b/basis/compiler/cfg/dominance/dominance.factor index 73d9f58eec..325bed74ff 100644 --- a/basis/compiler/cfg/dominance/dominance.factor +++ b/basis/compiler/cfg/dominance/dominance.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators sets math fry kernel math.order -dlists deques namespaces sequences sorting compiler.cfg.rpo ; +dlists deques vectors namespaces sequences sorting locals +compiler.cfg.rpo ; IN: compiler.cfg.dominance ! Reference: @@ -60,56 +61,42 @@ PRIVATE> [ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep dom-childrens set ; -! Maps bb -> DF(bb) -SYMBOL: dom-frontiers +SYMBOLS: preorder maxpreorder ; PRIVATE> -: dom-frontier ( bb -- set ) dom-frontiers get at keys ; +: pre-of ( bb -- n ) [ preorder get at ] [ -1/0. ] if* ; -> dup length 2 >= [ - [ compute-dom-frontier ] with each - ] [ 2drop ] if - ] each-basic-block ; - -PRIVATE> - -: compute-dominance ( cfg -- ) - [ compute-dom-parents compute-dom-children ] - [ compute-dom-frontiers ] - bi ; +: maxpre-of ( bb -- n ) [ maxpreorder get at ] [ 1/0. ] if* ; > (compute-dfs) drop ; PRIVATE> -: iterated-dom-frontier ( bbs -- bbs' ) - [ - work-list set - H{ } clone visited set - [ add-to-work-list ] each - work-list get [ iterated-dom-frontier-step ] slurp-deque - visited get keys - ] with-scope ; \ No newline at end of file +: compute-dominance ( cfg -- ) + [ compute-dom-parents compute-dom-children ] [ compute-dfs ] bi ; + +: dominates? ( bb1 bb2 -- ? ) + swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ; + +:: breadth-first-order ( cfg -- bfo ) + :> work-list + cfg post-order length :> accum + cfg entry>> work-list push-front + work-list [ + [ accum push ] + [ dom-children work-list push-all-front ] bi + ] slurp-deque + accum ; \ No newline at end of file diff --git a/basis/compiler/cfg/empty-blocks/empty-blocks.factor b/basis/compiler/cfg/empty-blocks/empty-blocks.factor new file mode 100644 index 0000000000..2a31a20b72 --- /dev/null +++ b/basis/compiler/cfg/empty-blocks/empty-blocks.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2008, 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel accessors sequences combinators combinators.short-circuit +classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; +IN: compiler.cfg.empty-blocks + +: update-predecessor ( bb -- ) + ! We have to replace occurrences of bb with bb's successor + ! in bb's predecessor's list of successors. + dup predecessors>> first [ + [ + 2dup eq? [ drop successors>> first ] [ nip ] if + ] with map + ] change-successors drop ; + +: update-successor ( bb -- ) + ! We have to replace occurrences of bb with bb's predecessor + ! in bb's sucessor's list of predecessors. + dup successors>> first [ + [ + 2dup eq? [ drop predecessors>> first ] [ nip ] if + ] with map + ] change-predecessors drop ; + +: delete-basic-block ( bb -- ) + [ update-predecessor ] [ update-successor ] bi ; + +: delete-basic-block? ( bb -- ? ) + { + [ instructions>> length 1 = ] + [ predecessors>> length 1 = ] + [ successors>> length 1 = ] + [ instructions>> first ##branch? ] + } 1&& ; + +: delete-empty-blocks ( cfg -- cfg' ) + dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block + cfg-changed ; \ No newline at end of file diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor index 287d0a6999..4c1999943f 100644 --- a/basis/compiler/cfg/hats/hats.factor +++ b/basis/compiler/cfg/hats/hats.factor @@ -18,7 +18,7 @@ IN: compiler.cfg.hats : ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline : ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline -: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline +: ^^copy ( src -- dst ) ^^i1 ##copy ; inline : ^^slot ( obj slot tag -- dst ) ^^i3 i ##slot ; inline : ^^slot-imm ( obj slot tag -- dst ) ^^i3 ##slot-imm ; inline : ^^set-slot ( src obj slot tag -- ) i ##set-slot ; inline @@ -74,7 +74,7 @@ IN: compiler.cfg.hats : ^^compare ( src1 src2 cc -- dst ) ^^i3 i ##compare ; inline : ^^compare-imm ( src1 src2 cc -- dst ) ^^i3 i ##compare-imm ; inline : ^^compare-float ( src1 src2 cc -- dst ) ^^i3 i ##compare-float ; inline -: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] when ; inline +: ^^offset>slot ( vreg -- vreg' ) cell 4 = [ 1 ^^shr-imm ] [ ^^copy ] if ; inline : ^^tag-fixnum ( src -- dst ) ^^i1 ##tag-fixnum ; inline : ^^untag-fixnum ( src -- dst ) ^^i1 ##untag-fixnum ; inline : ^^fixnum-add ( src1 src2 -- dst ) ^^i2 ##fixnum-add ; inline diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index d1b7592aaf..066d20ddec 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -52,7 +52,6 @@ INSN: ##inc-d { n integer } ; INSN: ##inc-r { n integer } ; ! Subroutine calls -INSN: ##stack-frame stack-frame ; INSN: ##call word ; INSN: ##jump word ; INSN: ##return ; @@ -160,9 +159,9 @@ INSN: ##write-barrier < ##effect card# table ; INSN: ##alien-global < ##flushable symbol library ; ! FFI -INSN: ##alien-invoke params ; -INSN: ##alien-indirect params ; -INSN: ##alien-callback params ; +INSN: ##alien-invoke params stack-frame ; +INSN: ##alien-indirect params stack-frame ; +INSN: ##alien-callback params stack-frame ; INSN: ##callback-return params ; ! Instructions used by CFG IR only. @@ -171,8 +170,6 @@ INSN: ##epilogue ; INSN: ##branch ; -INSN: ##loop-entry ; - INSN: ##phi < ##pure inputs ; ! Conditionals @@ -202,6 +199,7 @@ INSN: _epilogue stack-frame ; INSN: _label id ; INSN: _branch label ; +INSN: _loop-entry ; INSN: _dispatch src temp ; INSN: _dispatch-label label ; @@ -230,19 +228,33 @@ 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 use vregs +UNION: vreg-insn + ##flushable + ##write-barrier + ##dispatch + ##effect + ##fixnum-overflow + ##conditional-branch + ##compare-imm-branch + ##phi + ##gc + _conditional-branch + _compare-imm-branch + _dispatch ; ! Instructions that kill all live vregs UNION: kill-vreg-insn - poison-insn - ##stack-frame ##call ##prologue ##epilogue ##alien-invoke ##alien-indirect ##alien-callback ; + +! Instructions that have complex expansions and require that the +! output registers are not equal to any of the input registers +UNION: def-is-use-insn + ##integer>bignum + ##bignum>integer + ##unbox-any-c-ptr ; \ No newline at end of file diff --git a/basis/compiler/cfg/intrinsics/alien/alien.factor b/basis/compiler/cfg/intrinsics/alien/alien.factor index 42e23c29c9..04d841f2d1 100644 --- a/basis/compiler/cfg/intrinsics/alien/alien.factor +++ b/basis/compiler/cfg/intrinsics/alien/alien.factor @@ -1,10 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences alien math classes.algebra -fry locals combinators cpu.architecture -compiler.tree.propagation.info +USING: accessors kernel sequences alien math classes.algebra fry +locals combinators cpu.architecture compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions -compiler.cfg.utilities ; +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.alien : (prepare-alien-accessor-imm) ( class offset -- offset-vreg ) diff --git a/basis/compiler/cfg/intrinsics/allot/allot.factor b/basis/compiler/cfg/intrinsics/allot/allot.factor index 7b407c3ee4..8afd9f80ca 100644 --- a/basis/compiler/cfg/intrinsics/allot/allot.factor +++ b/basis/compiler/cfg/intrinsics/allot/allot.factor @@ -1,10 +1,10 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math math.order sequences accessors arrays byte-arrays layouts classes.tuple.private fry locals compiler.tree.propagation.info compiler.cfg.hats compiler.cfg.instructions compiler.cfg.stacks -compiler.cfg.utilities ; +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.allot : ##set-slots ( regs obj class -- ) diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor index 5dc04d47e1..d4b9db58c8 100644 --- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor +++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor @@ -7,6 +7,7 @@ compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions compiler.cfg.utilities +compiler.cfg.builder.blocks compiler.cfg.registers compiler.cfg.comparisons ; IN: compiler.cfg.intrinsics.fixnum @@ -31,7 +32,7 @@ IN: compiler.cfg.intrinsics.fixnum [ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ; : emit-fixnum-shift-general ( -- ) - D 0 ^^peek 0 cc> ##compare-imm-branch + ds-peek 0 cc> ##compare-imm-branch [ emit-fixnum-left-shift ] with-branch [ emit-fixnum-right-shift ] with-branch 2array emit-conditional ; @@ -62,13 +63,15 @@ IN: compiler.cfg.intrinsics.fixnum ds-pop ^^untag-fixnum ^^integer>bignum ds-push ; : emit-no-overflow-case ( dst -- final-bb ) - [ -2 ##inc-d ds-push ] with-branch ; + [ ds-drop ds-drop ds-push ] with-branch ; : emit-overflow-case ( word -- final-bb ) - [ ##call ] with-branch ; + [ ##call -1 adjust-d ] with-branch ; : emit-fixnum-overflow-op ( quot word -- ) - [ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip + ! Inputs to the final instruction need to be copied because + ! of loc>vreg sync + [ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip [ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array emit-conditional ; inline diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor index 2618db0904..c6642d8ad9 100644 --- a/basis/compiler/cfg/intrinsics/intrinsics.factor +++ b/basis/compiler/cfg/intrinsics/intrinsics.factor @@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics slots.private:set-slot strings.private:string-nth strings.private:set-string-nth-fast - classes.tuple.private: - arrays: - byte-arrays: - byte-arrays:(byte-array) - kernel: + ! classes.tuple.private: + ! arrays: + ! byte-arrays: + ! byte-arrays:(byte-array) + ! kernel: alien.accessors:alien-unsigned-1 alien.accessors:set-alien-unsigned-1 alien.accessors:alien-signed-1 @@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-unsigned-2 alien.accessors:alien-signed-2 alien.accessors:set-alien-signed-2 - alien.accessors:alien-cell + ! alien.accessors:alien-cell alien.accessors:set-alien-cell } [ t "intrinsic" set-word-prop ] each @@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics alien.accessors:set-alien-float alien.accessors:alien-double alien.accessors:set-alien-double - } [ t "intrinsic" set-word-prop ] each ; + } drop f [ t "intrinsic" set-word-prop ] each ; : enable-fixnum-log2 ( -- ) \ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ; diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor index 0cc6e6f5d0..93139a19a3 100644 --- a/basis/compiler/cfg/intrinsics/slots/slots.factor +++ b/basis/compiler/cfg/intrinsics/slots/slots.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: layouts namespaces kernel accessors sequences classes.algebra compiler.tree.propagation.info compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions -compiler.cfg.utilities ; +compiler.cfg.utilities compiler.cfg.builder.blocks ; IN: compiler.cfg.intrinsics.slots : value-tag ( info -- n ) class>> class-tag ; inline diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 8e21e7e3fb..3664f58b1e 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -9,7 +9,6 @@ compiler.cfg.def-use compiler.cfg.liveness compiler.cfg.registers compiler.cfg.instructions -compiler.cfg.linear-scan.mapping compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.live-intervals ; @@ -44,44 +43,25 @@ SYMBOL: register-live-outs H{ } clone register-live-outs set init-unhandled ; -: handle-spill ( live-interval -- ) - dup spill-to>> [ - [ reg>> ] [ spill-to>> ] [ vreg>> reg-class>> ] tri - register->memory - ] [ drop ] if ; - -: first-split ( live-interval -- live-interval' ) - dup split-before>> [ first-split ] [ ] ?if ; +: insert-spill ( live-interval -- ) + [ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ; -: next-interval ( live-interval -- live-interval' ) - split-next>> first-split ; - -: handle-copy ( live-interval -- ) - dup split-next>> [ - [ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri - register->register - ] [ drop ] if ; +: handle-spill ( live-interval -- ) + dup spill-to>> [ insert-spill ] [ 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 + dup heap-pop drop handle-spill (expire-old-intervals) ] if ] if ; : expire-old-intervals ( n -- ) - [ - pending-intervals get (expire-old-intervals) - ] { } make mapping-instructions % ; + pending-intervals get (expire-old-intervals) ; : insert-reload ( live-interval -- ) - { - [ reg>> ] - [ vreg>> reg-class>> ] - [ reload-from>> ] - [ start>> ] - } cleave f swap \ _reload boa , ; + [ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ; : handle-reload ( live-interval -- ) dup reload-from>> [ insert-reload ] [ drop ] if ; @@ -106,7 +86,9 @@ GENERIC: assign-registers-in-insn ( insn -- ) [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ; : all-vregs ( insn -- vregs ) - [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ; + [ [ temp-vregs ] [ uses-vregs ] bi append ] + [ defs-vreg ] bi + [ suffix ] when* ; SYMBOL: check-assignment? diff --git a/basis/compiler/cfg/linear-scan/linear-scan.factor b/basis/compiler/cfg/linear-scan/linear-scan.factor index b081f2ca6e..51b2f6db1b 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan.factor @@ -11,8 +11,7 @@ compiler.cfg.linear-scan.live-intervals compiler.cfg.linear-scan.allocation compiler.cfg.linear-scan.allocation.state compiler.cfg.linear-scan.assignment -compiler.cfg.linear-scan.resolve -compiler.cfg.linear-scan.mapping ; +compiler.cfg.linear-scan.resolve ; IN: compiler.cfg.linear-scan ! References: @@ -39,7 +38,6 @@ IN: compiler.cfg.linear-scan : linear-scan ( cfg -- cfg' ) [ - init-mapping dup machine-registers (linear-scan) spill-counts get >>spill-counts cfg-changed 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 8813a4e94e..77aae14503 100644 --- a/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor +++ b/basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor @@ -98,7 +98,7 @@ M: insn compute-live-intervals* drop ; M: vreg-insn compute-live-intervals* dup insn#>> live-intervals get - [ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ] + [ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ] [ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ] [ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ] 3tri ; diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor b/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor deleted file mode 100644 index d12167574a..0000000000 --- a/basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor +++ /dev/null @@ -1,145 +0,0 @@ -USING: compiler.cfg.instructions -compiler.cfg.linear-scan.allocation.state -compiler.cfg.linear-scan.mapping cpu.architecture kernel -namespaces tools.test ; -IN: compiler.cfg.linear-scan.mapping.tests - -H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set -init-mapping - -[ - { - T{ _copy { dst 5 } { src 4 } { class int-regs } } - T{ _spill { src 1 } { class int-regs } { n 10 } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n 10 } } - T{ _spill { src 1 } { class float-regs } { n 20 } } - T{ _copy { dst 1 } { src 0 } { class float-regs } } - T{ _reload { dst 0 } { class float-regs } { n 20 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 1 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 1 } { reg-class float-regs } } - T{ register->register { from 1 } { to 0 } { reg-class float-regs } } - T{ register->register { from 4 } { to 5 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _spill { src 2 } { class int-regs } { n 10 } } - T{ _copy { dst 2 } { src 1 } { class int-regs } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _reload { dst 0 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 1 } { to 2 } { reg-class int-regs } } - T{ register->register { from 2 } { to 0 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _spill { src 0 } { class int-regs } { n 10 } } - T{ _copy { dst 0 } { src 2 } { class int-regs } } - T{ _copy { dst 2 } { src 1 } { class int-regs } } - T{ _reload { dst 1 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 1 } { to 2 } { reg-class int-regs } } - T{ register->register { from 2 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { } -] [ - { - T{ register->register { from 4 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _spill { src 3 } { class int-regs } { n 4 } } - T{ _reload { dst 2 } { class int-regs } { n 1 } } - } -] [ - { - T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } } - T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _copy { dst 0 } { src 3 } { class int-regs } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _spill { src 4 } { class int-regs } { n 10 } } - T{ _copy { dst 4 } { src 0 } { class int-regs } } - T{ _copy { dst 0 } { src 3 } { class int-regs } } - T{ _reload { dst 3 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 4 } { to 3 } { reg-class int-regs } } - T{ register->register { from 0 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test - -[ - { - T{ _copy { dst 2 } { src 0 } { class int-regs } } - T{ _copy { dst 9 } { src 1 } { class int-regs } } - T{ _copy { dst 1 } { src 0 } { class int-regs } } - T{ _spill { src 4 } { class int-regs } { n 10 } } - T{ _copy { dst 4 } { src 0 } { class int-regs } } - T{ _copy { dst 0 } { src 3 } { class int-regs } } - T{ _reload { dst 3 } { class int-regs } { n 10 } } - } -] [ - { - T{ register->register { from 0 } { to 1 } { reg-class int-regs } } - T{ register->register { from 0 } { to 2 } { reg-class int-regs } } - T{ register->register { from 1 } { to 9 } { reg-class int-regs } } - T{ register->register { from 3 } { to 0 } { reg-class int-regs } } - T{ register->register { from 4 } { to 3 } { reg-class int-regs } } - T{ register->register { from 0 } { to 4 } { reg-class int-regs } } - } mapping-instructions -] unit-test diff --git a/basis/compiler/cfg/linear-scan/mapping/mapping.factor b/basis/compiler/cfg/linear-scan/mapping/mapping.factor deleted file mode 100644 index 5b47f33c64..0000000000 --- a/basis/compiler/cfg/linear-scan/mapping/mapping.factor +++ /dev/null @@ -1,148 +0,0 @@ -! Copyright (C) 2009 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs classes.parser classes.tuple -combinators compiler.cfg.instructions -compiler.cfg.linear-scan.allocation.state fry hashtables kernel -locals make namespaces parser sequences sets words ; -IN: compiler.cfg.linear-scan.mapping - -SYMBOL: spill-temps - -: spill-temp ( reg-class -- n ) - spill-temps get [ next-spill-slot ] cache ; - -<< - -TUPLE: operation from to reg-class ; - -SYNTAX: OPERATION: - CREATE-CLASS dup save-location - [ operation { } define-tuple-class ] - [ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ; - ->> - -OPERATION: register->memory -OPERATION: memory->register -OPERATION: register->register - -! This should never come up because of how spill slots are assigned, -! so make it an error. -: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ; - -GENERIC: >insn ( operation -- ) - -M: register->memory >insn - [ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ; - -M: memory->register >insn - [ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ; - -M: register->register >insn - [ to>> ] [ from>> ] [ reg-class>> ] tri _copy ; - -SYMBOL: froms -SYMBOL: tos - -SINGLETONS: memory register ; - -: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ; - -: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ; - -: from-reg ( operation -- seq ) - [ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ; - -: to-reg ( operation -- seq ) - [ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ; - -: start? ( operations -- pair ) - from-reg tos get key? not ; - -: independent-assignment? ( operations -- pair ) - to-reg froms get key? not ; - -: set-tos/froms ( operations -- ) - [ [ [ from-reg ] keep ] H{ } map>assoc froms set ] - [ [ [ to-reg ] keep ] H{ } map>assoc tos set ] - bi ; - -:: (trace-chain) ( obj hashtable -- ) - obj to-reg froms get at* [ - dup , - obj over hashtable clone [ maybe-set-at ] keep swap - [ (trace-chain) ] [ 2drop ] if - ] [ - drop - ] if ; - -: trace-chain ( obj -- seq ) - [ - dup , - dup dup associate (trace-chain) - ] { } make prune reverse ; - -: trace-chains ( seq -- seq' ) - [ trace-chain ] map concat ; - -ERROR: resolve-error ; - -: split-cycle ( operations -- chain spilled-operation ) - unclip [ - [ set-tos/froms ] - [ - [ start? ] find nip - [ resolve-error ] unless* trace-chain - ] bi - ] dip ; - -: break-cycle-n ( operations -- operations' ) - split-cycle [ - [ from>> ] - [ reg-class>> spill-temp ] - [ reg-class>> ] - tri \ register->memory boa - ] [ - [ reg-class>> spill-temp ] - [ to>> ] - [ reg-class>> ] - tri \ memory->register boa - ] bi [ 1array ] bi@ surround ; - -: break-cycle ( operations -- operations' ) - dup length { - { 1 [ ] } - [ drop break-cycle-n ] - } case ; - -: (group-cycles) ( seq -- ) - [ - dup set-tos/froms - unclip trace-chain - [ diff ] keep , (group-cycles) - ] unless-empty ; - -: group-cycles ( seq -- seqs ) - [ (group-cycles) ] { } make ; - -: remove-dead-mappings ( seq -- seq' ) - prune [ [ from-reg ] [ to-reg ] bi = not ] filter ; - -: parallel-mappings ( operations -- seq ) - [ - [ independent-assignment? not ] partition % - [ start? not ] partition - [ trace-chain ] map concat dup % - diff group-cycles [ break-cycle ] map concat % - ] { } make remove-dead-mappings ; - -: mapping-instructions ( mappings -- insns ) - [ { } ] [ - [ - [ set-tos/froms ] [ parallel-mappings ] bi - [ [ >insn ] each ] { } make - ] with-scope - ] if-empty ; - -: init-mapping ( -- ) - H{ } clone spill-temps set ; \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor new file mode 100644 index 0000000000..68f7544e8e --- /dev/null +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -0,0 +1,58 @@ +IN: compiler.cfg.linear-scan.resolve.tests +USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces +compiler.cfg.instructions cpu.architecture make +compiler.cfg.linear-scan.allocation.state ; + +[ + { + { { T{ spill-slot f 0 } int-regs } { 1 int-regs } } + } +] [ + [ + 0 1 int-regs add-mapping + ] { } make +] unit-test + +[ + { + T{ _reload { dst 1 } { class int-regs } { n 0 } } + } +] [ + [ + { T{ spill-slot f 0 } int-regs } { 1 int-regs } >insn + ] { } make +] unit-test + +[ + { + T{ _spill { src 1 } { class int-regs } { n 0 } } + } +] [ + [ + { 1 int-regs } { T{ spill-slot f 0 } int-regs } >insn + ] { } make +] unit-test + +[ + { + T{ _copy { src 1 } { dst 2 } { class int-regs } } + } +] [ + [ + { 1 int-regs } { 2 int-regs } >insn + ] { } make +] unit-test + +H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set +H{ } clone spill-temps set + +[ + { + T{ _spill { src 0 } { class int-regs } { n 10 } } + T{ _copy { dst 0 } { src 1 } { class int-regs } } + T{ _reload { dst 1 } { class int-regs } { n 10 } } + } +] [ + { { { 0 int-regs } { 1 int-regs } } { { 1 int-regs } { 0 int-regs } } } + mapping-instructions +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 56beaa5379..932e3dc6d6 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -1,31 +1,29 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs combinators -combinators.short-circuit fry kernel locals -make math sequences +combinators.short-circuit fry kernel locals namespaces +make math sequences hashtables compiler.cfg.rpo compiler.cfg.liveness compiler.cfg.utilities compiler.cfg.instructions +compiler.cfg.parallel-copy compiler.cfg.linear-scan.assignment -compiler.cfg.linear-scan.mapping ; +compiler.cfg.linear-scan.allocation.state ; IN: compiler.cfg.linear-scan.resolve +SYMBOL: spill-temps + +: spill-temp ( reg-class -- n ) + spill-temps get [ next-spill-slot ] cache ; + : add-mapping ( from to reg-class -- ) - over spill-slot? [ - pick spill-slot? - [ memory->memory ] - [ register->memory ] if - ] [ - pick spill-slot? - [ memory->register ] - [ register->register ] if - ] if ; + '[ _ 2array ] bi@ 2array , ; :: resolve-value-data-flow ( bb to vreg -- ) vreg bb vreg-at-end vreg to vreg-at-start - 2dup eq? [ 2drop ] [ vreg reg-class>> add-mapping ] if ; + 2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ; : compute-mappings ( bb to -- mappings ) [ @@ -33,6 +31,36 @@ IN: compiler.cfg.linear-scan.resolve [ resolve-value-data-flow ] with with each ] { } make ; +: memory->register ( from to -- ) + swap [ first2 ] [ first n>> ] bi* _reload ; + +: register->memory ( from to -- ) + [ first2 ] [ first n>> ] bi* _spill ; + +: temp->register ( from to -- ) + nip [ first ] [ second ] [ second spill-temp ] tri _reload ; + +: register->temp ( from to -- ) + drop [ first2 ] [ second spill-temp ] bi _spill ; + +: register->register ( from to -- ) + swap [ first ] [ first2 ] bi* _copy ; + +SYMBOL: temp + +: >insn ( from to -- ) + { + { [ over temp eq? ] [ temp->register ] } + { [ dup temp eq? ] [ register->temp ] } + { [ over first spill-slot? ] [ memory->register ] } + { [ dup first spill-slot? ] [ register->memory ] } + [ register->register ] + } cond ; + +: mapping-instructions ( alist -- insns ) + [ swap ] H{ } assoc-map-as + [ temp [ swap >insn ] parallel-mapping ] { } make ; + : perform-mappings ( bb to mappings -- ) dup empty? [ 3drop ] [ mapping-instructions @@ -46,4 +74,5 @@ IN: compiler.cfg.linear-scan.resolve dup successors>> [ resolve-edge-data-flow ] with each ; : resolve-data-flow ( cfg -- ) + H{ } clone spill-temps set [ resolve-block-data-flow ] each-basic-block ; diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor index c62d4b0208..cc148d34d8 100755 --- a/basis/compiler/cfg/linearization/linearization.factor +++ b/basis/compiler/cfg/linearization/linearization.factor @@ -6,7 +6,8 @@ compiler.cfg compiler.cfg.rpo compiler.cfg.comparisons compiler.cfg.stack-frame -compiler.cfg.instructions ; +compiler.cfg.instructions +compiler.cfg.utilities ; IN: compiler.cfg.linearization ! Convert CFG IR to machine IR. @@ -24,7 +25,11 @@ M: insn linearize-insn , drop ; #! don't need to branch. [ number>> ] bi@ 1 - = ; inline -: emit-branch ( basic-block successor -- ) +: emit-loop-entry? ( bb successor -- ? ) + [ back-edge? not ] [ nip loop-entry? ] 2bi and ; + +: emit-branch ( bb successor -- ) + 2dup emit-loop-entry? [ _loop-entry ] when 2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ; M: ##branch linearize-insn @@ -32,11 +37,11 @@ M: ##branch linearize-insn : successors ( bb -- first second ) successors>> first2 ; inline -: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc ) +: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc ) [ dup successors ] [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline -: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc ) +: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc ) [ (binary-conditional) ] [ drop dup successors>> second useless-branch? ] 2bi [ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ; @@ -53,7 +58,7 @@ 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 ) +: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 ) [ dup successors number>> ] [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline diff --git a/basis/compiler/cfg/liveness/liveness-tests.factor b/basis/compiler/cfg/liveness/liveness-tests.factor index 697a1f8a7b..eb497a9bae 100644 --- a/basis/compiler/cfg/liveness/liveness-tests.factor +++ b/basis/compiler/cfg/liveness/liveness-tests.factor @@ -1,9 +1,14 @@ USING: compiler.cfg.liveness compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.predecessors compiler.cfg.registers compiler.cfg cpu.architecture -accessors namespaces sequences kernel tools.test ; +accessors namespaces sequences kernel tools.test vectors ; IN: compiler.cfg.liveness.tests +: test-liveness ( -- ) + cfg new 1 get >>entry + compute-predecessors + compute-live-sets ; + ! Sanity check... V{ @@ -11,21 +16,22 @@ V{ T{ ##replace f V int-regs 0 D 0 } T{ ##replace f V int-regs 1 D 1 } T{ ##peek f V int-regs 1 D 1 } + T{ ##branch } } 1 test-bb V{ T{ ##replace f V int-regs 2 D 0 } + T{ ##branch } } 2 test-bb V{ T{ ##replace f V int-regs 3 D 0 } + T{ ##return } } 3 test-bb 1 get 2 get 3 get V{ } 2sequence >>successors drop -cfg new 1 get >>entry -compute-predecessors -compute-live-sets +test-liveness [ H{ @@ -35,4 +41,22 @@ compute-live-sets } ] [ 1 get live-in ] -unit-test \ No newline at end of file +unit-test + +! Tricky case; defs must be killed before uses + +V{ + T{ ##peek f V int-regs 0 D 0 } + T{ ##branch } +} 1 test-bb + +V{ + T{ ##add-imm f V int-regs 0 V int-regs 0 10 } + T{ ##return } +} 2 test-bb + +1 get 2 get 1vector >>successors drop + +test-liveness + +[ H{ { V int-regs 0 V int-regs 0 } } ] [ 2 get live-in ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/liveness/liveness.factor b/basis/compiler/cfg/liveness/liveness.factor index c1793842a2..6c67769a45 100644 --- a/basis/compiler/cfg/liveness/liveness.factor +++ b/basis/compiler/cfg/liveness/liveness.factor @@ -10,14 +10,19 @@ IN: compiler.cfg.liveness BACKWARD-ANALYSIS: live +GENERIC: insn-liveness ( live-set insn -- ) + +: kill-defs ( live-set insn -- live-set ) + defs-vreg [ over delete-at ] when* ; + +: gen-uses ( live-set insn -- live-set ) + dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ; + : transfer-liveness ( live-set instructions -- live-set' ) - [ clone ] [ ] bi* [ - [ uses-vregs [ over conjoin ] each ] - [ defs-vregs [ over delete-at ] each ] bi - ] each ; + [ clone ] [ ] bi* [ [ kill-defs ] [ gen-uses ] bi ] each ; : local-live-in ( instructions -- live-set ) - [ ##phi? not ] filter [ H{ } ] dip transfer-liveness keys ; + [ H{ } ] dip transfer-liveness keys ; M: live-analysis transfer-set drop instructions>> transfer-liveness ; diff --git a/basis/compiler/cfg/liveness/ssa/ssa.factor b/basis/compiler/cfg/liveness/ssa/ssa.factor new file mode 100644 index 0000000000..9fa22d22b1 --- /dev/null +++ b/basis/compiler/cfg/liveness/ssa/ssa.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces deques accessors sets sequences assocs fry +hashtables dlists compiler.cfg.def-use compiler.cfg.instructions +compiler.cfg.rpo compiler.cfg.liveness ; +IN: compiler.cfg.liveness.ssa + +! TODO: merge with compiler.cfg.liveness + +! Assoc mapping basic blocks to sequences of sets of vregs; each sequence +! is in conrrespondence with a predecessor +SYMBOL: phi-live-ins + +: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ; + +SYMBOL: work-list + +: add-to-work-list ( basic-blocks -- ) + work-list get '[ _ push-front ] each ; + +: compute-live-in ( basic-block -- live-in ) + [ live-out ] keep instructions>> transfer-liveness ; + +: compute-phi-live-in ( basic-block -- phi-live-in ) + instructions>> [ ##phi? ] filter [ f ] [ + H{ } clone [ + '[ inputs>> [ swap _ conjoin-at ] assoc-each ] each + ] keep + ] if-empty ; + +: update-live-in ( basic-block -- changed? ) + [ [ compute-live-in ] keep live-ins get maybe-set-at ] + [ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ] + bi and ; + +: compute-live-out ( basic-block -- live-out ) + [ successors>> [ live-in ] map ] + [ dup successors>> [ phi-live-in ] with map ] bi + append assoc-combine ; + +: update-live-out ( basic-block -- changed? ) + [ compute-live-out ] keep + live-outs get maybe-set-at ; + +: liveness-step ( basic-block -- ) + dup update-live-out [ + dup update-live-in + [ predecessors>> add-to-work-list ] [ drop ] if + ] [ drop ] if ; + +: compute-ssa-live-sets ( cfg -- cfg' ) + work-list set + H{ } clone live-ins set + H{ } clone phi-live-ins set + H{ } clone live-outs set + dup post-order add-to-work-list + work-list get [ liveness-step ] slurp-deque ; diff --git a/basis/compiler/cfg/optimizer/optimizer-tests.factor b/basis/compiler/cfg/optimizer/optimizer-tests.factor index 1eb1996da4..e69de29bb2 100755 --- a/basis/compiler/cfg/optimizer/optimizer-tests.factor +++ b/basis/compiler/cfg/optimizer/optimizer-tests.factor @@ -1,58 +0,0 @@ -USING: accessors arrays compiler.cfg.checker -compiler.cfg.debugger compiler.cfg.def-use -compiler.cfg.instructions fry kernel kernel.private math -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 - -: more? ( x -- ? ) ; - -: test-case-1 ( -- ? ) f ; - -: test-case-2 ( -- ) - test-case-1 [ test-case-2 ] [ ] if ; inline recursive - -{ - [ 1array ] - [ 1 2 ? ] - [ { array } declare [ ] map ] - [ { array } declare dup 1 slot [ 1 slot ] when ] - [ [ dup more? ] [ dup ] produce ] - [ vector new over test-case-1 [ test-case-2 ] [ ] if ] - [ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ] - [ - { fixnum sbuf } declare 2dup 3 slot fixnum> [ - over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot - ] [ ] if - ] - [ [ 2 fixnum* ] when 3 ] - [ [ 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 - -cell 8 = [ - [ t ] - [ - [ - 1 50 fixnum-shift-fast fixnum+fast - ] test-mr first instructions>> [ ##add? ] any? - ] unit-test -] when diff --git a/basis/compiler/cfg/optimizer/optimizer.factor b/basis/compiler/cfg/optimizer/optimizer.factor index 50148b73b2..8e2df04cca 100644 --- a/basis/compiler/cfg/optimizer/optimizer.factor +++ b/basis/compiler/cfg/optimizer/optimizer.factor @@ -2,17 +2,19 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences accessors combinators namespaces compiler.cfg.tco -compiler.cfg.predecessors compiler.cfg.useless-conditionals -compiler.cfg.stack-analysis compiler.cfg.branch-splitting compiler.cfg.block-joining +compiler.cfg.ssa.construction compiler.cfg.alias-analysis compiler.cfg.value-numbering +compiler.cfg.copy-prop compiler.cfg.dce compiler.cfg.write-barrier +compiler.cfg.ssa.destruction +compiler.cfg.empty-blocks +compiler.cfg.predecessors compiler.cfg.rpo -compiler.cfg.phi-elimination compiler.cfg.checker ; IN: compiler.cfg.optimizer @@ -33,12 +35,14 @@ SYMBOL: check-optimizer? split-branches join-blocks compute-predecessors - stack-analysis + construct-ssa alias-analysis value-numbering compute-predecessors + copy-propagation eliminate-dead-code eliminate-write-barriers - eliminate-phis + destruct-ssa + delete-empty-blocks ?check ] with-scope ; diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor b/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor new file mode 100644 index 0000000000..17b043c1b7 --- /dev/null +++ b/basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor @@ -0,0 +1,63 @@ +USING: compiler.cfg.parallel-copy tools.test make arrays +compiler.cfg.registers namespaces compiler.cfg.instructions +cpu.architecture ; +IN: compiler.cfg.parallel-copy.tests + +SYMBOL: temp + +: test-parallel-copy ( mapping -- seq ) + 3 vreg-counter set-global + [ parallel-copy ] { } make ; + +[ + { + T{ ##copy f V int-regs 4 V int-regs 2 } + T{ ##copy f V int-regs 2 V int-regs 1 } + T{ ##copy f V int-regs 1 V int-regs 4 } + } +] [ + H{ + { V int-regs 1 V int-regs 2 } + { V int-regs 2 V int-regs 1 } + } test-parallel-copy +] unit-test + +[ + { + T{ ##copy f V int-regs 1 V int-regs 2 } + T{ ##copy f V int-regs 3 V int-regs 4 } + } +] [ + H{ + { V int-regs 1 V int-regs 2 } + { V int-regs 3 V int-regs 4 } + } test-parallel-copy +] unit-test + +[ + { + T{ ##copy f V int-regs 1 V int-regs 3 } + T{ ##copy f V int-regs 2 V int-regs 1 } + } +] [ + H{ + { V int-regs 1 V int-regs 3 } + { V int-regs 2 V int-regs 3 } + } test-parallel-copy +] unit-test + +[ + { + T{ ##copy f V int-regs 4 V int-regs 3 } + T{ ##copy f V int-regs 3 V int-regs 2 } + T{ ##copy f V int-regs 2 V int-regs 1 } + T{ ##copy f V int-regs 1 V int-regs 4 } + } +] [ + { + { V int-regs 2 V int-regs 1 } + { V int-regs 3 V int-regs 2 } + { V int-regs 1 V int-regs 3 } + { V int-regs 4 V int-regs 3 } + } test-parallel-copy +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/parallel-copy/parallel-copy.factor b/basis/compiler/cfg/parallel-copy/parallel-copy.factor new file mode 100644 index 0000000000..5a1bfcd111 --- /dev/null +++ b/basis/compiler/cfg/parallel-copy/parallel-copy.factor @@ -0,0 +1,60 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs compiler.cfg.hats compiler.cfg.instructions +deques dlists fry kernel locals namespaces sequences +hashtables ; +IN: compiler.cfg.parallel-copy + +! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency +! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf, +! Algorithm 1 + + to-do set + ready set + [ preds set ] + [ [ nip dup ] H{ } assoc-map-as locs set ] + [ keys [ init-to-do ] [ init-ready ] bi ] tri ; + +:: process-ready ( b quot -- ) + b preds get at :> a + a locs get at :> c + b c quot call + b a locs get set-at + a c = a preds get at and [ a ready get push-front ] when ; inline + +:: process-to-do ( b quot -- ) + ! Note that we check if b = loc(b), not b = loc(pred(b)) as the + ! paper suggests. Confirmed by one of the authors at + ! http://www.reddit.com/comments/93253/some_lecture_notes_on_ssa_form/c0bco4f + b locs get at b = [ + temp get b quot call + temp get b locs get set-at + b ready get push-front + ] when ; inline + +PRIVATE> + +:: parallel-mapping ( mapping temp quot -- ) + [ + mapping temp init + to-do get [ + ready get [ + quot process-ready + ] slurp-deque + quot process-to-do + ] slurp-deque + ] with-scope ; inline + +: parallel-copy ( mapping -- ) i [ ##copy ] parallel-mapping ; \ No newline at end of file diff --git a/basis/compiler/cfg/phi-elimination/authors.txt b/basis/compiler/cfg/phi-elimination/authors.txt deleted file mode 100644 index a44f8d7f8d..0000000000 --- a/basis/compiler/cfg/phi-elimination/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -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 deleted file mode 100644 index 22afc0b32b..0000000000 --- a/basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor +++ /dev/null @@ -1,55 +0,0 @@ -! 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.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 - -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 - -3 vreg-counter set-global - -[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test - -[ 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 deleted file mode 100644 index 7e73f0b854..0000000000 --- a/basis/compiler/cfg/phi-elimination/phi-elimination.factor +++ /dev/null @@ -1,26 +0,0 @@ -! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -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 -- ##copy ) - i - [ [ inputs>> ] dip '[ _ insert-copy ] assoc-each ] - [ [ dst>> ] dip \ ##copy new-insn ] - 2bi ; - -: eliminate-phi-step ( bb -- ) - 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 - cfg-changed ; diff --git a/basis/compiler/cfg/renaming/functor/functor.factor b/basis/compiler/cfg/renaming/functor/functor.factor new file mode 100644 index 0000000000..2a9d8d4911 --- /dev/null +++ b/basis/compiler/cfg/renaming/functor/functor.factor @@ -0,0 +1,116 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: functors assocs kernel accessors compiler.cfg.instructions +lexer parser ; +IN: compiler.cfg.renaming.functor + +FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT -- ) + +rename-insn-defs DEFINES ${NAME}-insn-defs +rename-insn-uses DEFINES ${NAME}-insn-uses + +WHERE + +GENERIC: rename-insn-defs ( insn -- ) + +M: ##flushable rename-insn-defs + DEF-QUOT change-dst + drop ; + +M: ##fixnum-overflow rename-insn-defs + DEF-QUOT change-dst + drop ; + +M: _fixnum-overflow rename-insn-defs + DEF-QUOT change-dst + drop ; + +M: insn rename-insn-defs drop ; + +GENERIC: rename-insn-uses ( insn -- ) + +M: ##effect rename-insn-uses + USE-QUOT change-src + drop ; + +M: ##unary rename-insn-uses + USE-QUOT change-src + drop ; + +M: ##binary rename-insn-uses + USE-QUOT change-src1 + USE-QUOT change-src2 + drop ; + +M: ##binary-imm rename-insn-uses + USE-QUOT change-src1 + drop ; + +M: ##slot rename-insn-uses + USE-QUOT change-obj + USE-QUOT change-slot + drop ; + +M: ##slot-imm rename-insn-uses + USE-QUOT change-obj + drop ; + +M: ##set-slot rename-insn-uses + dup call-next-method + USE-QUOT change-obj + USE-QUOT change-slot + drop ; + +M: ##string-nth rename-insn-uses + USE-QUOT change-obj + USE-QUOT change-index + drop ; + +M: ##set-string-nth-fast rename-insn-uses + dup call-next-method + USE-QUOT change-obj + USE-QUOT change-index + drop ; + +M: ##set-slot-imm rename-insn-uses + dup call-next-method + USE-QUOT change-obj + drop ; + +M: ##alien-getter rename-insn-uses + dup call-next-method + USE-QUOT change-src + drop ; + +M: ##alien-setter rename-insn-uses + dup call-next-method + USE-QUOT change-value + drop ; + +M: ##conditional-branch rename-insn-uses + USE-QUOT change-src1 + USE-QUOT change-src2 + drop ; + +M: ##compare-imm-branch rename-insn-uses + USE-QUOT change-src1 + drop ; + +M: ##dispatch rename-insn-uses + USE-QUOT change-src + drop ; + +M: ##fixnum-overflow rename-insn-uses + USE-QUOT change-src1 + USE-QUOT change-src2 + drop ; + +M: ##phi rename-insn-uses + [ USE-QUOT assoc-map ] change-inputs + drop ; + +M: insn rename-insn-uses drop ; + +;FUNCTOR + +SYNTAX: RENAMING: scan scan-object scan-object define-renaming ; \ No newline at end of file diff --git a/basis/compiler/cfg/renaming/renaming.factor b/basis/compiler/cfg/renaming/renaming.factor index a2204fb36e..9de3fdd8d8 100644 --- a/basis/compiler/cfg/renaming/renaming.factor +++ b/basis/compiler/cfg/renaming/renaming.factor @@ -1,108 +1,16 @@ ! 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 ; +compiler.cfg.instructions compiler.cfg.registers +compiler.cfg.renaming.functor ; IN: compiler.cfg.renaming SYMBOL: renamings -: rename-value ( vreg -- vreg' ) renamings get ?at drop ; +: rename-value ( vreg -- vreg' ) + renamings get ?at drop ; -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 ; +RENAMING: rename [ rename-value ] [ rename-value ] : fresh-vreg ( vreg -- vreg' ) reg-class>> next-vreg ; diff --git a/basis/compiler/cfg/ssa/construction/construction-tests.factor b/basis/compiler/cfg/ssa/construction/construction-tests.factor new file mode 100644 index 0000000000..da0f320130 --- /dev/null +++ b/basis/compiler/cfg/ssa/construction/construction-tests.factor @@ -0,0 +1,113 @@ +USING: accessors compiler.cfg compiler.cfg.debugger +compiler.cfg.dominance compiler.cfg.instructions +compiler.cfg.predecessors compiler.cfg.ssa.construction assocs +compiler.cfg.registers cpu.architecture kernel namespaces sequences +tools.test vectors ; +IN: compiler.cfg.ssa.construction.tests + +: reset-counters ( -- ) + ! Reset counters so that results are deterministic w.r.t. hash order + 0 vreg-counter set-global + 0 basic-block set-global ; + +reset-counters + +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 + 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 + +: clean-up-phis ( insns -- insns' ) + [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ; + +[ + 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>> + clean-up-phis +] unit-test + +reset-counters + +V{ } 0 test-bb +V{ } 1 test-bb +V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb +V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb +V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb +V{ } 5 test-bb +V{ } 6 test-bb + +0 get 1 get 5 get V{ } 2sequence >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 6 get 1vector >>successors drop +5 get 6 get 1vector >>successors drop + +[ ] [ test-ssa ] unit-test + +[ + V{ + T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } } + T{ ##replace f V int-regs 3 D 0 } + } +] [ + 4 get instructions>> + clean-up-phis +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/construction.factor b/basis/compiler/cfg/ssa/construction/construction.factor new file mode 100644 index 0000000000..3bbbb887f0 --- /dev/null +++ b/basis/compiler/cfg/ssa/construction/construction.factor @@ -0,0 +1,140 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces kernel accessors sequences fry assocs +sets math combinators +compiler.cfg +compiler.cfg.rpo +compiler.cfg.def-use +compiler.cfg.liveness +compiler.cfg.registers +compiler.cfg.dominance +compiler.cfg.instructions +compiler.cfg.renaming.functor +compiler.cfg.ssa.construction.tdmsc ; +IN: compiler.cfg.ssa.construction + +! SSA construction. Predecessors must be computed first. + +! The phi placement algorithm is implemented in +! compiler.cfg.ssa.construction.tdmsc. + +! The renaming algorithm is based on "Practical Improvements to +! the Construction and Destruction of Static Single Assignment Form", +! however we construct pruned SSA, not semi-pruned SSA. + +! http://citeseerx.ist.psu.edu/viewdoc/summary?doi=10.1.1.49.9683 + + ] 2tri + [ defs-multi get conjoin ] [ drop ] if + ] [ 2drop ] if ; + +: compute-defs ( cfg -- ) + H{ } clone defs set + H{ } clone defs-multi set + [ + dup instructions>> [ + compute-insn-defs + ] with each + ] each-basic-block ; + +! Maps basic blocks to sequences of vregs +SYMBOL: inserting-phi-nodes + +: insert-phi-node-later ( vreg bb -- ) + 2dup live-in key? [ + [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep + inserting-phi-nodes get push-at + ] [ 2drop ] if ; + +: compute-phi-nodes-for ( vreg bbs -- ) + keys [ insert-phi-node-later ] with merge-set-each ; + +: compute-phi-nodes ( -- ) + H{ } clone inserting-phi-nodes set + defs-multi get defs get '[ _ at 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 pushed ; + +: init-renaming ( -- ) + H{ } clone stacks set ; + +: gen-name ( vreg -- vreg' ) + [ reg-class>> next-vreg dup ] keep + dup pushed get 2dup key? + [ 2drop stacks get at set-last ] + [ conjoin stacks get push-at ] + if ; + +: top-name ( vreg -- vreg' ) + stacks get at last ; + +RENAMING: ssa-rename [ gen-name ] [ top-name ] + +GENERIC: rename-insn ( insn -- ) + +M: insn rename-insn + [ ssa-rename-insn-uses ] + [ ssa-rename-insn-defs ] + bi ; + +M: ##phi rename-insn + ssa-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 ( -- ) + pushed get stacks get '[ drop _ at pop* ] assoc-each ; + +: rename-in-block ( bb -- ) + H{ } clone pushed set + [ rename-insns ] + [ rename-successors-phis ] + [ + pushed get + [ dom-children [ rename-in-block ] each ] dip + pushed set + ] tri + pop-stacks ; + +: rename ( cfg -- ) + init-renaming + entry>> rename-in-block ; + +PRIVATE> + +: construct-ssa ( cfg -- cfg' ) + { + [ ] + [ compute-live-sets ] + [ compute-dominance ] + [ compute-merge-sets ] + [ compute-defs compute-phi-nodes insert-phi-nodes ] + [ rename ] + } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor new file mode 100644 index 0000000000..7691d0e6ce --- /dev/null +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor @@ -0,0 +1,75 @@ +USING: accessors arrays compiler.cfg compiler.cfg.debugger +compiler.cfg.dominance compiler.cfg.predecessors +compiler.cfg.ssa.construction.tdmsc kernel namespaces sequences +tools.test vectors sets ; +IN: compiler.cfg.ssa.construction.tdmsc.tests + +: test-tdmsc ( -- ) + cfg new 0 get >>entry + compute-predecessors + dup compute-dominance + compute-merge-sets ; + +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-tdmsc ] unit-test + +[ V{ 4 } ] [ 1 get 1array merge-set [ number>> ] map ] unit-test +[ V{ 4 } ] [ 2 get 1array merge-set [ number>> ] map ] unit-test +[ V{ } ] [ 0 get 1array merge-set ] unit-test +[ V{ } ] [ 4 get 1array merge-set ] unit-test + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb +V{ } 6 test-bb + +0 get 1 get 5 get V{ } 2sequence >>successors drop +1 get 2 get 3 get V{ } 2sequence >>successors drop +2 get 4 get 1vector >>successors drop +3 get 4 get 1vector >>successors drop +4 get 6 get 1vector >>successors drop +5 get 6 get 1vector >>successors drop + +[ ] [ test-tdmsc ] unit-test + +[ t ] [ + 2 get 3 get 2array merge-set + 4 get 6 get 2array set= +] unit-test + +V{ } 0 test-bb +V{ } 1 test-bb +V{ } 2 test-bb +V{ } 3 test-bb +V{ } 4 test-bb +V{ } 5 test-bb +V{ } 6 test-bb +V{ } 7 test-bb + +0 get 1 get 1vector >>successors drop +1 get 2 get 1vector >>successors drop +2 get 3 get 6 get V{ } 2sequence >>successors drop +3 get 4 get 1vector >>successors drop +6 get 7 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop +5 get 2 get 1vector >>successors drop + +[ ] [ test-tdmsc ] unit-test + +[ V{ 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test +[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor new file mode 100644 index 0000000000..1c1abefe1b --- /dev/null +++ b/basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor @@ -0,0 +1,109 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs bit-arrays bit-sets fry +hashtables hints kernel locals math namespaces sequences sets +compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ; +IN: compiler.cfg.ssa.construction.tdmsc + +! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for +! Phi-Function Computation Using DJ Graphs" + +! http://portal.acm.org/citation.cfm?id=1065887.1065890 + + ] H{ } map>assoc merge-sets set ; + +: compute-levels ( cfg -- ) + 0 over entry>> associate [ + '[ + _ [ [ dom-parent ] dip at 1 + ] 2keep set-at + ] each-basic-block + ] keep levels set ; + +: j-edge? ( from to -- ? ) + 2dup eq? [ 2drop f ] [ dominates? not ] if ; + +: level ( bb -- n ) levels get at ; inline + +: set-bit ( bit-array n -- ) + [ t ] 2dip swap set-nth ; + +: update-merge-set ( tmp to -- ) + [ merge-sets get ] dip + '[ + _ + [ merge-sets get at bit-set-union ] + [ dupd number>> set-bit ] + bi + ] change-at ; + +:: walk ( tmp to lnode -- lnode ) + tmp level to level >= [ + tmp to update-merge-set + tmp dom-parent to tmp walk + ] [ lnode ] if ; + +: each-incoming-j-edge ( bb quot: ( from to -- ) -- ) + [ [ predecessors>> ] keep ] dip + '[ _ 2dup j-edge? _ [ 2drop ] if ] each ; inline + +: visited? ( pair -- ? ) visited get key? ; + +: consistent? ( snode lnode -- ? ) + [ merge-sets get at ] bi@ swap bit-set-subset? ; + +: (process-edge) ( from to -- ) + f walk [ + 2dup 2array visited? [ + consistent? [ again? on ] unless + ] [ 2drop ] if + ] each-incoming-j-edge ; + +: process-edge ( from to -- ) + 2dup 2array dup visited? [ 3drop ] [ + visited get conjoin + (process-edge) + ] if ; + +: process-block ( bb -- ) + [ process-edge ] each-incoming-j-edge ; + +: compute-merge-set-step ( bfo -- ) + visited get clear-assoc + [ process-block ] each ; + +: compute-merge-set-loop ( cfg -- ) + breadth-first-order + '[ again? off _ compute-merge-set-step again? get ] + loop ; + +: (merge-set) ( bbs -- flags rpo ) + merge-sets get '[ _ at ] [ bit-set-union ] map-reduce + cfg get reverse-post-order ; inline + +: filter-by ( flags seq -- seq' ) + [ drop ] pusher [ 2each ] dip ; + +HINTS: filter-by { bit-array object } ; + +PRIVATE> + +: compute-merge-sets ( cfg -- ) + dup cfg set + H{ } clone visited set + [ compute-levels ] + [ init-merge-sets ] + [ compute-merge-set-loop ] + tri ; + +: merge-set-each ( bbs quot: ( bb -- ) -- ) + [ (merge-set) ] dip '[ + swap _ [ drop ] if + ] 2each ; inline + +: merge-set ( bbs -- bbs' ) + (merge-set) filter-by ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/destruction/copies/copies.factor b/basis/compiler/cfg/ssa/destruction/copies/copies.factor new file mode 100644 index 0000000000..063704e0f6 --- /dev/null +++ b/basis/compiler/cfg/ssa/destruction/copies/copies.factor @@ -0,0 +1,28 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs hashtables fry kernel make namespaces +sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ; +IN: compiler.cfg.ssa.destruction.copies + +ERROR: bad-copy ; + +: compute-copies ( assoc -- assoc' ) + dup assoc-size [ + '[ + [ + 2dup eq? [ 2drop ] [ + _ 2dup key? + [ bad-copy ] [ set-at ] if + ] if + ] with each + ] assoc-each + ] keep ; + +: insert-copies ( -- ) + waiting get [ + [ instructions>> building ] dip '[ + building get pop + _ compute-copies parallel-copy + , + ] with-variable + ] assoc-each ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/destruction/destruction.factor b/basis/compiler/cfg/ssa/destruction/destruction.factor new file mode 100644 index 0000000000..c650782582 --- /dev/null +++ b/basis/compiler/cfg/ssa/destruction/destruction.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel locals math math.order +sequences namespaces sets +compiler.cfg.rpo +compiler.cfg.def-use +compiler.cfg.utilities +compiler.cfg.dominance +compiler.cfg.instructions +compiler.cfg.liveness.ssa +compiler.cfg.critical-edges +compiler.cfg.ssa.destruction.state +compiler.cfg.ssa.destruction.forest +compiler.cfg.ssa.destruction.copies +compiler.cfg.ssa.destruction.renaming +compiler.cfg.ssa.destruction.live-ranges +compiler.cfg.ssa.destruction.process-blocks ; +IN: compiler.cfg.ssa.destruction + +! Based on "Fast Copy Coalescing and Live-Range Identification" +! http://www.cs.ucsd.edu/classes/sp02/cse231/kenpldi.pdf + +! Dominance, liveness and def-use need to be computed + +: process-blocks ( cfg -- ) + [ [ process-block ] if-has-phis ] each-basic-block ; + +SYMBOL: seen + +:: visit-renaming ( dst assoc src bb -- ) + src seen get key? [ + src dst bb waiting-for push-at + src assoc delete-at + ] [ src seen get conjoin ] if ; + +:: break-interferences ( -- ) + V{ } clone seen set + renaming-sets get [| dst assoc | + assoc [| src bb | + dst assoc src bb visit-renaming + ] assoc-each + ] assoc-each ; + +: remove-phis-from-block ( bb -- ) + instructions>> [ ##phi? not ] filter-here ; + +: remove-phis ( cfg -- ) + [ [ remove-phis-from-block ] if-has-phis ] each-basic-block ; + +: destruct-ssa ( cfg -- cfg' ) + dup cfg-has-phis? [ + init-coalescing + compute-ssa-live-sets + dup split-critical-edges + dup compute-def-use + dup compute-dominance + dup compute-live-ranges + dup process-blocks + break-interferences + dup perform-renaming + insert-copies + dup remove-phis + ] when ; \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor b/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor new file mode 100644 index 0000000000..64c04b79f2 --- /dev/null +++ b/basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor @@ -0,0 +1,86 @@ +USING: accessors compiler.cfg compiler.cfg.ssa.destruction.forest +compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions +compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.def-use +cpu.architecture kernel namespaces sequences tools.test vectors sorting +math.order ; +IN: compiler.cfg.ssa.destruction.forest.tests + +V{ T{ ##peek f V int-regs 0 D 0 } } clone 0 test-bb +V{ T{ ##peek f V int-regs 1 D 0 } } clone 1 test-bb +V{ T{ ##peek f V int-regs 2 D 0 } } clone 2 test-bb +V{ T{ ##peek f V int-regs 3 D 0 } } clone 3 test-bb +V{ T{ ##peek f V int-regs 4 D 0 } } clone 4 test-bb +V{ T{ ##peek f V int-regs 5 D 0 } } clone 5 test-bb +V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb + +0 get 1 get 2 get V{ } 2sequence >>successors drop +2 get 3 get 4 get V{ } 2sequence >>successors drop +3 get 5 get 1vector >>successors drop +4 get 5 get 1vector >>successors drop +1 get 6 get 1vector >>successors drop +5 get 6 get 1vector >>successors drop + +: clean-up-forest ( forest -- forest' ) + [ [ vreg>> n>> ] compare ] sort + [ + [ clean-up-forest ] change-children + [ number>> ] change-bb + ] V{ } map-as ; + +: test-dom-forest ( vregs -- forest ) + cfg new 0 get >>entry + compute-predecessors + dup compute-dominance + compute-def-use + compute-dom-forest + clean-up-forest ; + +[ V{ } ] [ { } test-dom-forest ] unit-test + +[ V{ T{ dom-forest-node f V int-regs 0 0 V{ } } } ] +[ { V int-regs 0 } test-dom-forest ] +unit-test + +[ + V{ + T{ dom-forest-node + f + V int-regs 0 + 0 + V{ T{ dom-forest-node f V int-regs 1 1 V{ } } } + } + } +] +[ { V int-regs 0 V int-regs 1 } test-dom-forest ] +unit-test + +[ + V{ + T{ dom-forest-node + f + V int-regs 1 + 1 + V{ } + } + T{ dom-forest-node + f + V int-regs 2 + 2 + V{ + T{ dom-forest-node f V int-regs 3 3 V{ } } + T{ dom-forest-node f V int-regs 4 4 V{ } } + T{ dom-forest-node f V int-regs 5 5 V{ } } + } + } + T{ dom-forest-node + f + V int-regs 6 + 6 + V{ } + } + } +] +[ + { V int-regs 1 V int-regs 6 V int-regs 2 V int-regs 3 V int-regs 4 V int-regs 5 } + test-dom-forest +] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/destruction/forest/forest.factor b/basis/compiler/cfg/ssa/destruction/forest/forest.factor new file mode 100644 index 0000000000..a196be13cb --- /dev/null +++ b/basis/compiler/cfg/ssa/destruction/forest/forest.factor @@ -0,0 +1,38 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel math math.order +namespaces sequences sorting vectors compiler.cfg.def-use +compiler.cfg.dominance compiler.cfg.registers ; +IN: compiler.cfg.ssa.destruction.forest + +TUPLE: dom-forest-node vreg bb children ; + +assoc + [ [ second pre-of ] compare ] sort ; + +: ( vreg bb parent -- node ) + [ V{ } clone dom-forest-node boa dup ] dip children>> push ; + +: ( -- node ) + f f V{ } clone dom-forest-node boa ; + +: find-parent ( pre stack -- parent ) + 2dup last vreg>> def-of maxpre-of > [ + dup pop* find-parent + ] [ nip last ] if ; + +: (compute-dom-forest) ( vreg bb stack -- ) + [ dup pre-of ] dip [ find-parent ] keep push ; + +PRIVATE> + +: compute-dom-forest ( vregs -- forest ) + [ + 1vector + [ sort-vregs-by-bb ] dip + '[ _ (compute-dom-forest) ] assoc-each + ] keep children>> ; diff --git a/basis/compiler/cfg/ssa/destruction/interference/interference.factor b/basis/compiler/cfg/ssa/destruction/interference/interference.factor new file mode 100644 index 0000000000..4bb55a00aa --- /dev/null +++ b/basis/compiler/cfg/ssa/destruction/interference/interference.factor @@ -0,0 +1,44 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs combinators combinators.short-circuit +kernel math namespaces sequences locals compiler.cfg.def-use +compiler.cfg.dominance compiler.cfg.ssa.destruction.live-ranges ; +IN: compiler.cfg.ssa.destruction.interference + + ; + +: interferes-same-block? ( vreg1 vreg2 bb1 bb2 -- ? ) + ! If both are defined in the same basic block, they interfere if their + ! local live ranges intersect. + drop + { [ kill-after-def? ] [ swapd kill-after-def? ] } 3|| ; + +: interferes-first-dominates? ( vreg1 vreg2 bb1 bb2 -- ? ) + ! If vreg1 dominates vreg2, then they interfere if vreg2's definition + ! occurs before vreg1 is killed. + nip + kill-after-def? ; + +: interferes-second-dominates? ( vreg1 vreg2 bb1 bb2 -- ? ) + ! If vreg2 dominates vreg1, then they interfere if vreg1's definition + ! occurs before vreg2 is killed. + drop + swapd kill-after-def? ; + +PRIVATE> + +: interferes? ( vreg1 vreg2 -- ? ) + 2dup [ def-of ] bi@ { + { [ 2dup eq? ] [ interferes-same-block? ] } + { [ 2dup dominates? ] [ interferes-first-dominates? ] } + { [ 2dup swap dominates? ] [ interferes-second-dominates? ] } + [ 2drop 2drop f ] + } cond ; diff --git a/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor b/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor new file mode 100644 index 0000000000..536f5e1e68 --- /dev/null +++ b/basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor @@ -0,0 +1,60 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel namespaces sequences math +arrays compiler.cfg.def-use compiler.cfg.instructions +compiler.cfg.liveness compiler.cfg.rpo ; +IN: compiler.cfg.ssa.destruction.live-ranges + +! Live ranges for interference testing + +> [ visit-insn ] each-index ] + [ [ local-def-indices get ] dip def-indices get set-at ] + [ [ local-kill-indices get ] dip kill-indices get set-at ] + tri ; + +PRIVATE> + +: compute-live-ranges ( cfg -- ) + H{ } clone def-indices set + H{ } clone kill-indices set + [ compute-local-live-ranges ] each-basic-block ; + +: def-index ( vreg bb -- n ) + def-indices get at at ; + +ERROR: bad-kill-index vreg bb ; + +: kill-index ( vreg bb -- n ) + 2dup live-out key? [ 2drop 1/0. ] [ + 2dup kill-indices get at at* [ 2nip ] [ + drop 2dup live-in key? + [ bad-kill-index ] [ 2drop -1/0. ] if + ] if + ] if ; diff --git a/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor b/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor new file mode 100644 index 0000000000..f8c8a4d8b2 --- /dev/null +++ b/basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor @@ -0,0 +1,138 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel locals math math.order arrays +namespaces sequences sorting sets combinators combinators.short-circuit make +compiler.cfg.def-use +compiler.cfg.instructions +compiler.cfg.liveness +compiler.cfg.dominance +compiler.cfg.ssa.destruction.state +compiler.cfg.ssa.destruction.forest +compiler.cfg.ssa.destruction.interference ; +IN: compiler.cfg.ssa.destruction.process-blocks + +! phi-union maps a vreg to the predecessor block +! that carries it to the phi node's block + +! unioned-blocks is a set of bb's which defined +! the source vregs above +SYMBOLS: phi-union unioned-blocks ; + +:: operand-live-into-phi-node's-block? ( bb src dst -- ? ) + src bb live-in key? ; + +:: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? ) + dst src def-of live-out key? ; + +:: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? ) + { [ src insn-of ##phi? ] [ src src def-of live-in key? ] } 0&& ; + +:: operand-being-renamed? ( bb src dst -- ? ) + src processed-names get key? ; + +:: two-operands-in-same-block? ( bb src dst -- ? ) + src def-of unioned-blocks get key? ; + +: trivial-interference? ( bb src dst -- ? ) + { + [ operand-live-into-phi-node's-block? ] + [ phi-node-is-live-out-of-operand's-block? ] + [ operand-is-phi-node-and-live-into-operand's-block? ] + [ operand-being-renamed? ] + [ two-operands-in-same-block? ] + } 3|| ; + +: don't-coalesce ( bb src dst -- ) + 2nip processed-name ; + +:: trivial-interference ( bb src dst -- ) + dst src bb waiting-for push-at + src used-by-another get push ; + +:: add-to-renaming-set ( bb src dst -- ) + bb src phi-union get set-at + src def-of unioned-blocks get conjoin ; + +: process-phi-operand ( bb src dst -- ) + { + { [ 2dup eq? ] [ don't-coalesce ] } + { [ 3dup trivial-interference? ] [ trivial-interference ] } + [ add-to-renaming-set ] + } cond ; + +: node-is-live-in-of-child? ( node child -- ? ) + [ vreg>> ] [ bb>> live-in ] bi* key? ; + +: node-is-live-out-of-child? ( node child -- ? ) + [ vreg>> ] [ bb>> live-out ] bi* key? ; + +:: insert-copy ( bb src dst -- ) + bb src dst trivial-interference + src phi-union get delete-at ; + +:: insert-copy-for-parent ( bb src node dst -- ) + src node vreg>> eq? [ bb src dst insert-copy ] when ; + +: insert-copies-for-parent ( ##phi node child -- ) + drop + [ [ inputs>> ] [ dst>> ] bi ] dip + '[ _ _ insert-copy-for-parent ] assoc-each ; + +: defined-in-same-block? ( node child -- ? ) [ bb>> ] bi@ eq? ; + +: add-interference ( ##phi node child -- ) + [ vreg>> ] bi@ 2array , drop ; + +: process-df-child ( ##phi node child -- ) + { + { [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] } + { [ 2dup node-is-live-in-of-child? ] [ add-interference ] } + { [ 2dup defined-in-same-block? ] [ add-interference ] } + [ 3drop ] + } cond ; + +: process-df-node ( ##phi node -- ) + dup children>> + [ [ process-df-child ] with with each ] + [ nip [ process-df-node ] with each ] + 3bi ; + +: process-phi-union ( ##phi dom-forest -- ) + [ process-df-node ] with each ; + +: add-local-interferences ( ##phi -- ) + [ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ; + +: compute-local-interferences ( ##phi -- pairs ) + [ + [ phi-union get keys compute-dom-forest process-phi-union ] + [ add-local-interferences ] + bi + ] { } make ; + +:: insert-copies-for-interference ( ##phi src -- ) + ##phi inputs>> [| bb src' | + src src' eq? [ bb src ##phi dst>> insert-copy ] when + ] assoc-each ; + +: process-local-interferences ( ##phi pairs -- ) + [ + first2 2dup interferes? + [ drop insert-copies-for-interference ] [ 3drop ] if + ] with each ; + +: add-renaming-set ( ##phi -- ) + [ phi-union get ] dip dst>> renaming-sets get set-at + phi-union get [ drop processed-name ] assoc-each ; + +: process-phi ( ##phi -- ) + H{ } clone phi-union set + H{ } clone unioned-blocks set + [ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ] + [ dup compute-local-interferences process-local-interferences ] + [ add-renaming-set ] + tri ; + +: process-block ( bb -- ) + instructions>> + [ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ; diff --git a/basis/compiler/cfg/ssa/destruction/renaming/renaming.factor b/basis/compiler/cfg/ssa/destruction/renaming/renaming.factor new file mode 100644 index 0000000000..e5c547f96b --- /dev/null +++ b/basis/compiler/cfg/ssa/destruction/renaming/renaming.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel namespaces sequences +compiler.cfg.ssa.destruction.state compiler.cfg.renaming compiler.cfg.rpo +disjoint-sets ; +IN: compiler.cfg.ssa.destruction.renaming + +: build-disjoint-set ( assoc -- disjoint-set ) + dup [ + '[ + [ _ add-atom ] + [ [ drop _ add-atom ] assoc-each ] + bi* + ] assoc-each + ] keep ; + +: update-congruence-class ( dst assoc disjoint-set -- ) + [ keys swap ] dip equate-all-with ; + +: build-congruence-classes ( -- disjoint-set ) + renaming-sets get + dup build-disjoint-set + [ '[ _ update-congruence-class ] assoc-each ] keep ; + +: compute-renaming ( disjoint-set -- assoc ) + [ parents>> ] keep + '[ drop dup _ representative ] assoc-map ; + +: rename-blocks ( cfg -- ) + [ + instructions>> [ + [ rename-insn-defs ] + [ rename-insn-uses ] bi + ] each + ] each-basic-block ; + +: rename-copies ( -- ) + waiting renamings get '[ + [ + [ _ [ ?at drop ] [ '[ _ ?at drop ] map ] bi-curry bi* ] assoc-map + ] assoc-map + ] change ; + +: perform-renaming ( cfg -- ) + build-congruence-classes compute-renaming renamings set + rename-blocks + rename-copies ; diff --git a/basis/compiler/cfg/ssa/destruction/state/state.factor b/basis/compiler/cfg/ssa/destruction/state/state.factor new file mode 100644 index 0000000000..30e69521b9 --- /dev/null +++ b/basis/compiler/cfg/ssa/destruction/state/state.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces sets kernel assocs ; +IN: compiler.cfg.ssa.destruction.state + +SYMBOLS: processed-names waiting used-by-another renaming-sets ; + +: init-coalescing ( -- ) + H{ } clone renaming-sets set + H{ } clone processed-names set + H{ } clone waiting set + V{ } clone used-by-another set ; + +: processed-name ( vreg -- ) processed-names get conjoin ; + +: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ; diff --git a/basis/compiler/cfg/ssa/ssa-tests.factor b/basis/compiler/cfg/ssa/ssa-tests.factor deleted file mode 100644 index 6a3a014f78..0000000000 --- a/basis/compiler/cfg/ssa/ssa-tests.factor +++ /dev/null @@ -1,113 +0,0 @@ -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 ( -- ) - ! Reset counters so that results are deterministic w.r.t. hash order - 0 vreg-counter set-global - 0 basic-block set-global ; - -reset-counters - -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 - 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 - -: clean-up-phis ( insns -- insns' ) - [ dup ##phi? [ [ [ [ number>> ] dip ] assoc-map ] change-inputs ] when ] map ; - -[ - 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>> - clean-up-phis -] unit-test - -reset-counters - -V{ } 0 test-bb -V{ } 1 test-bb -V{ T{ ##peek f V int-regs 0 D 0 } } 2 test-bb -V{ T{ ##peek f V int-regs 0 D 0 } } 3 test-bb -V{ T{ ##replace f V int-regs 0 D 0 } } 4 test-bb -V{ } 5 test-bb -V{ } 6 test-bb - -0 get 1 get 5 get V{ } 2sequence >>successors drop -1 get 2 get 3 get V{ } 2sequence >>successors drop -2 get 4 get 1vector >>successors drop -3 get 4 get 1vector >>successors drop -4 get 6 get 1vector >>successors drop -5 get 6 get 1vector >>successors drop - -[ ] [ test-ssa ] unit-test - -[ - V{ - T{ ##phi f V int-regs 3 H{ { 2 V int-regs 1 } { 3 V int-regs 2 } } } - T{ ##replace f V int-regs 3 D 0 } - } -] [ - 4 get instructions>> - clean-up-phis -] unit-test \ No newline at end of file diff --git a/basis/compiler/cfg/ssa/ssa.factor b/basis/compiler/cfg/ssa/ssa.factor deleted file mode 100644 index 2e76ba35a1..0000000000 --- a/basis/compiler/cfg/ssa/ssa.factor +++ /dev/null @@ -1,131 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: namespaces kernel accessors sequences fry assocs -sets math combinators -compiler.cfg -compiler.cfg.rpo -compiler.cfg.def-use -compiler.cfg.renaming -compiler.cfg.liveness -compiler.cfg.registers -compiler.cfg.dominance -compiler.cfg.instructions ; -IN: compiler.cfg.ssa - -! SSA construction. Predecessors must be computed first. - -! This is the classical algorithm based on dominance frontiers, except -! we consult liveness information to build pruned SSA: -! 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 [ - _ conjoin-at - ] with each - ] with each - ] each-basic-block ; - -: insert-phi-node-later ( vreg bb -- ) - 2dup live-in key? [ - [ predecessors>> over '[ _ ] H{ } map>assoc \ ##phi new-insn ] keep - inserting-phi-nodes get push-at - ] [ 2drop ] if ; - -: compute-phi-nodes-for ( vreg bbs -- ) - keys dup length 2 >= [ - iterated-dom-frontier [ - insert-phi-node-later - ] with each - ] [ 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' ) - { - [ ] - [ compute-live-sets ] - [ compute-dominance ] - [ compute-defs compute-phi-nodes insert-phi-nodes ] - [ rename ] - } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/stack-analysis/authors.txt b/basis/compiler/cfg/stack-analysis/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/compiler/cfg/stack-analysis/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ 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 deleted file mode 100644 index 5883777861..0000000000 --- a/basis/compiler/cfg/stack-analysis/merge/merge-tests.factor +++ /dev/null @@ -1,104 +0,0 @@ -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.utilities compiler.cfg compiler.cfg.registers -compiler.cfg.debugger cpu.architecture make assocs namespaces -sequences kernel classes ; - -[ - { D 0 } - { V int-regs 0 V int-regs 1 } -] [ - - - 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 - - H{ } clone added-instructions set - V{ } clone added-phis set - merge-locs locs>vregs>> keys added-phis get values first -] unit-test - -[ - { D 0 } - ##peek -] [ - - - 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{ } 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 - -[ - 0 ##inc-d -] [ - - - V{ T{ ##branch } } >>instructions dup 1 set - V{ T{ ##branch } } >>instructions dup 2 set 2array - - H{ } clone added-instructions set - V{ } clone added-phis set - - -1 >>ds-height - 2array - - [ merge-ds-heights ds-height>> ] { } make drop - 1 get added-instructions get at first class -] unit-test - -[ - 0 - { D 0 } - { 1 1 } -] [ - - - 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 - - [ merge-locs [ ds-height>> ] [ locs>vregs>> keys ] bi ] { } make drop - ] keep - [ instructions>> length ] map -] unit-test - -[ - -1 - { D -1 } - { 1 1 } -] [ - - - 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 - - [ [ merge-ds-heights ] [ merge-locs ] 2bi ] { } make drop - [ ds-height>> ] [ locs>vregs>> keys ] bi - ] keep - [ instructions>> length ] map -] unit-test diff --git a/basis/compiler/cfg/stack-analysis/merge/merge.factor b/basis/compiler/cfg/stack-analysis/merge/merge.factor deleted file mode 100644 index a53fd7494e..0000000000 --- a/basis/compiler/cfg/stack-analysis/merge/merge.factor +++ /dev/null @@ -1,117 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -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 - -: initial-state ( bb states -- state ) 2drop ; - -: single-predecessor ( bb states -- state ) nip first clone ; - -: save-ds-height ( n -- ) - dup 0 = [ drop ] [ ##inc-d ] if ; - -: merge-ds-heights ( state predecessors states -- state ) - [ ds-height>> ] map dup all-equal? - [ nip first >>ds-height ] - [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ; - -: save-rs-height ( n -- ) - dup 0 = [ drop ] [ ##inc-r ] if ; - -: merge-rs-heights ( state predecessors states -- state ) - [ rs-height>> ] map dup all-equal? - [ nip first >>rs-height ] - [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ; - -: assoc-map-keys ( assoc quot -- assoc' ) - '[ _ dip ] assoc-map ; inline - -: translate-locs ( assoc state -- assoc' ) - '[ _ translate-loc ] assoc-map-keys ; - -: untranslate-locs ( assoc state -- assoc' ) - '[ _ untranslate-loc ] assoc-map-keys ; - -: collect-locs ( loc-maps states -- assoc ) - ! assoc maps locs to sequences - [ untranslate-locs ] 2map - [ [ keys ] map concat prune ] keep - '[ dup _ [ at ] with map ] H{ } map>assoc ; - -: 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 - '[ [ ] [ _ _ insert-peek ] ?if ] 2map - dup all-equal? [ first ] [ add-phi-later ] if ; - -:: merge-locs ( state predecessors states -- state ) - states [ locs>vregs>> ] map states collect-locs - [| key value | - key - predecessors value key state merge-loc - ] assoc-map - state translate-locs - state (>>locs>vregs) - state ; - -: merge-actual-loc ( vregs -- vreg/f ) - dup all-equal? [ first ] [ drop f ] if ; - -:: merge-actual-locs ( state states -- state ) - states [ actual-locs>vregs>> ] map states collect-locs - [ merge-actual-loc ] assoc-map [ nip ] assoc-filter - state translate-locs - state (>>actual-locs>vregs) - state ; - -: merge-changed-locs ( state states -- state ) - [ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine - over translate-locs - >>changed-locs ; - -:: 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 ) - states [ not ] any? [ - - bb add-to-work-list - ] [ - [ - 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 ) - dup length { - { 0 [ initial-state ] } - { 1 [ single-predecessor ] } - [ drop multiple-predecessors ] - } case ; diff --git a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor b/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor deleted file mode 100644 index 9fbf7acf78..0000000000 --- a/basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor +++ /dev/null @@ -1,204 +0,0 @@ -USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization -compiler.cfg.predecessors compiler.cfg.stack-analysis -compiler.cfg.instructions sequences kernel tools.test accessors -sequences.private alien math combinators.private compiler.cfg -compiler.cfg.checker compiler.cfg.rpo -compiler.cfg.dce compiler.cfg.registers -sets namespaces arrays cpu.architecture ; -IN: compiler.cfg.stack-analysis.tests - -! Fundamental invariant: a basic block should not load or store a value more than once -: test-stack-analysis ( quot -- cfg ) - dup cfg? [ test-cfg first ] unless - compute-predecessors - stack-analysis - dup check-cfg ; - -: linearize ( cfg -- mr ) - flatten-cfg instructions>> ; - -[ ] [ [ ] test-stack-analysis drop ] unit-test - -! Only peek once -[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test - -! Redundant replace is redundant -[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test -[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Replace required here -[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test -[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Only one replace, at the end -[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test - -! Do we support the full language? -[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test -[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test -[ ] [ - [ "int" { "int" "int" } "cdecl" [ + ] alien-callback ] - test-cfg second test-stack-analysis drop -] unit-test - -! Test loops -[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test -[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test - -! Make sure that peeks are inserted in the right place -[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test - -! This should be a total no-op -[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test - -! Don't insert inc-d/inc-r; that's wrong! -[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test - -! Bug in height tracking -[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test -[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test -[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test - -! Bugs with code that throws -[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test -[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test -[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test -[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test - -! Make sure the replace stores a value with the right height -[ ] [ - [ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize - [ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi -] unit-test - -! translate-loc was the wrong way round -[ ] [ - [ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize - [ [ ##load-immediate? ] count 2 assert= ] - [ [ ##peek? ] count 1 assert= ] - [ [ ##replace? ] count 3 assert= ] - tri -] unit-test - -[ ] [ - [ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize - [ [ ##load-immediate? ] count 2 assert= ] - [ [ ##peek? ] count 1 assert= ] - [ [ ##replace? ] count 1 assert= ] - tri -] unit-test - -! Sync before a back-edge, not after -! ##peeks should be inserted before a ##loop-entry -! Don't optimize out the constants -[ t ] [ - [ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize - [ ##load-immediate? ] any? -] unit-test - -! Correct height tracking -[ t ] [ - [ pick [ ] [ drop ] if swap ] test-stack-analysis eliminate-dead-code - reverse-post-order 4 swap nth - instructions>> [ ##peek? ] filter first2 [ loc>> ] [ loc>> ] bi* - 2array { D 1 D 0 } set= -] unit-test - -[ D 1 ] [ - V{ T{ ##branch } } 0 test-bb - - V{ T{ ##peek f V int-regs 0 D 2 } T{ ##branch } } 1 test-bb - - V{ - T{ ##peek f V int-regs 1 D 2 } - T{ ##inc-d f -1 } - T{ ##branch } - } 2 test-bb - - V{ T{ ##call f \ + -1 } T{ ##branch } } 3 test-bb - - V{ T{ ##return } } 4 test-bb - - test-diamond - - cfg new 0 get >>entry - compute-predecessors - stack-analysis - drop - - 3 get successors>> first instructions>> first loc>> -] unit-test - -! Do inserted ##peeks reference the correct stack location if -! an ##inc-d/r was also inserted? -[ D 0 ] [ - V{ T{ ##branch } } 0 test-bb - - V{ T{ ##branch } } 1 test-bb - - V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##branch } - } 2 test-bb - - V{ - T{ ##call f \ + -1 } - T{ ##inc-d f 1 } - T{ ##branch } - } 3 test-bb - - V{ T{ ##return } } 4 test-bb - - test-diamond - - cfg new 0 get >>entry - compute-predecessors - stack-analysis - drop - - 3 get successors>> first instructions>> [ ##peek? ] find nip loc>> -] unit-test - -! Missing ##replace -[ t ] [ - [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis - reverse-post-order last - instructions>> [ ##replace? ] filter [ loc>> ] map - { D 0 D 1 D 2 } set= -] unit-test - -! Inserted ##peeks reference the wrong stack location -[ t ] [ - [ [ "B" ] 2dip dup [ [ /mod ] dip ] when ] test-stack-analysis - eliminate-dead-code reverse-post-order 4 swap nth - instructions>> [ ##peek? ] filter [ loc>> ] map - { D 0 D 1 } set= -] unit-test - -[ D 0 ] [ - V{ T{ ##branch } } 0 test-bb - - V{ T{ ##branch } } 1 test-bb - - V{ - T{ ##peek f V int-regs 1 D 0 } - T{ ##inc-d f 1 } - T{ ##branch } - } 2 test-bb - - V{ - T{ ##inc-d f 1 } - T{ ##branch } - } 3 test-bb - - V{ T{ ##return } } 4 test-bb - - test-diamond - - cfg new 0 get >>entry - compute-predecessors - stack-analysis - drop - - 3 get 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 deleted file mode 100644 index cf15c0a312..0000000000 --- a/basis/compiler/cfg/stack-analysis/stack-analysis.factor +++ /dev/null @@ -1,125 +0,0 @@ -! 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 dlists deques -compiler.cfg -compiler.cfg.copy-prop -compiler.cfg.def-use -compiler.cfg.instructions -compiler.cfg.registers -compiler.cfg.rpo -compiler.cfg.hats -compiler.cfg.stack-analysis.state -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 ; - -: save-changed-locs ( state -- ) - [ changed-locs>> keys ] [ locs>vregs>> ] bi '[ - dup _ at swap 2dup redundant-replace? - [ 2drop ] [ state get untranslate-loc ##replace ] if - ] each ; - -ERROR: poisoned-state state ; - -: sync-state ( -- ) - state get { - [ dup poisoned?>> [ poisoned-state ] [ drop ] if ] - [ ds-height>> save-ds-height ] - [ rs-height>> save-rs-height ] - [ save-changed-locs ] - [ clear-state ] - } cleave ; - -: poison-state ( -- ) state get t >>poisoned? drop ; - -! Abstract interpretation -GENERIC: visit ( insn -- ) - -M: ##inc-d visit - n>> state get [ + ] change-ds-height drop ; - -M: ##inc-r visit - n>> state get [ + ] change-rs-height drop ; - -! Instructions which don't have any effect on the stack -UNION: neutral-insn - ##effect - ##flushable - ##no-tco ; - -M: neutral-insn visit , ; - -UNION: sync-if-back-edge - ##branch - ##conditional-branch - ##compare-imm-branch - ##dispatch - ##loop-entry - ##fixnum-overflow ; - -: sync-state? ( -- ? ) - basic-block get successors>> - [ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ; - -M: sync-if-back-edge visit - global-optimization? get [ sync-state? [ sync-state ] when ] unless - , ; - -: eliminate-peek ( dst src -- ) - ! the requested stack location is already in 'src' - [ ##copy ] [ swap copies get set-at ] 2bi ; - -M: ##peek visit - [ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg - [ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ; - -M: ##replace visit - [ src>> resolve ] [ loc>> state get translate-loc ] bi - record-replace ; - -M: ##copy visit - [ call-next-method ] [ record-copy ] bi ; - -M: poison-insn visit call-next-method poison-state ; - -M: kill-vreg-insn visit sync-state , ; - -! Maps basic-blocks to states -SYMBOL: state-out - -: block-in-state ( bb -- states ) - dup predecessors>> state-out get '[ _ at ] map merge-states ; - -: set-block-out-state ( state bb -- ) - [ clone ] dip state-out get set-at ; - -: visit-block ( bb -- ) - ! block-in-state may add phi nodes at the start of the basic block - ! so we wrap the whole thing with a 'make' - [ - dup basic-block set - dup block-in-state - 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-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 deleted file mode 100644 index 25fa249853..0000000000 --- a/basis/compiler/cfg/stack-analysis/state/state.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2009 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces assocs sets math deques -compiler.cfg.registers ; -IN: compiler.cfg.stack-analysis.state - -TUPLE: state -locs>vregs actual-locs>vregs changed-locs -{ ds-height integer } -{ rs-height integer } -poisoned? ; - -: ( -- state ) - state new - H{ } clone >>locs>vregs - H{ } clone >>actual-locs>vregs - H{ } clone >>changed-locs - 0 >>ds-height - 0 >>rs-height ; - -M: state clone - call-next-method - [ clone ] change-locs>vregs - [ clone ] change-actual-locs>vregs - [ clone ] change-changed-locs ; - -: loc>vreg ( loc -- vreg ) state get locs>vregs>> at ; - -: record-peek ( dst loc -- ) - state get [ locs>vregs>> set-at ] [ actual-locs>vregs>> set-at ] 3bi ; - -: changed-loc ( loc -- ) - state get changed-locs>> conjoin ; - -: record-replace ( src loc -- ) - dup changed-loc state get locs>vregs>> set-at ; - -: clear-state ( state -- ) - 0 >>ds-height 0 >>rs-height - [ locs>vregs>> ] [ actual-locs>vregs>> ] [ changed-locs>> ] tri - [ clear-assoc ] tri@ ; - -GENERIC# translate-loc 1 ( loc state -- loc' ) -M: ds-loc translate-loc [ n>> ] [ ds-height>> ] bi* - ; -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/stacks/finalize/finalize.factor b/basis/compiler/cfg/stacks/finalize/finalize.factor new file mode 100644 index 0000000000..5c8c1343d0 --- /dev/null +++ b/basis/compiler/cfg/stacks/finalize/finalize.factor @@ -0,0 +1,41 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: namespaces assocs kernel fry accessors sequences make math +combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions +compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local +compiler.cfg.stacks.global compiler.cfg.stacks.height ; +IN: compiler.cfg.stacks.finalize + +! This pass inserts peeks and replaces. + +: inserting-peeks ( from to -- assoc ) + peek-in swap [ peek-out ] [ avail-out ] bi + assoc-union assoc-diff ; + +: inserting-replaces ( from to -- assoc ) + [ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi* + assoc-union assoc-diff ; + +: each-insertion ( assoc bb quot: ( vreg loc -- ) -- ) + '[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline + +ERROR: bad-peek dst loc ; + +: insert-peeks ( from to -- ) + [ inserting-peeks ] keep + [ dup n>> 0 < [ bad-peek ] [ ##peek ] if ] each-insertion ; + +: insert-replaces ( from to -- ) + [ inserting-replaces ] keep + [ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ; + +: visit-edge ( from to -- ) + 2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make + [ 2drop ] [ insert-basic-block ] if-empty ; + +: visit-block ( bb -- ) + [ predecessors>> ] keep '[ _ visit-edge ] each ; + +: finalize-stack-shuffling ( cfg -- cfg' ) + dup [ visit-block ] each-basic-block + cfg-changed ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/global/global.factor b/basis/compiler/cfg/stacks/global/global.factor new file mode 100644 index 0000000000..129d7e74cd --- /dev/null +++ b/basis/compiler/cfg/stacks/global/global.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel combinators compiler.cfg.dataflow-analysis +compiler.cfg.stacks.local ; +IN: compiler.cfg.stacks.global + +! Peek analysis. Peek-in is the set of all locations anticipated at +! the start of a basic block. +BACKWARD-ANALYSIS: peek + +M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ; + +! Replace analysis. Replace-in is the set of all locations which +! will be overwritten at some point after the start of a basic block. +FORWARD-ANALYSIS: replace + +M: replace-analysis transfer-set drop replace-set assoc-union ; + +! Availability analysis. Avail-out is the set of all locations +! in registers at the end of a basic block. +FORWARD-ANALYSIS: avail + +M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ; + +! Kill analysis. Kill-in is the set of all locations +! which are going to be overwritten. +BACKWARD-ANALYSIS: kill + +M: kill-analysis transfer-set drop replace-set assoc-union ; + +! Main word +: compute-global-sets ( cfg -- cfg' ) + { + [ compute-peek-sets ] + [ compute-replace-sets ] + [ compute-avail-sets ] + [ compute-kill-sets ] + [ ] + } cleave ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/height/height.factor b/basis/compiler/cfg/stacks/height/height.factor new file mode 100644 index 0000000000..4d91dc614a --- /dev/null +++ b/basis/compiler/cfg/stacks/height/height.factor @@ -0,0 +1,27 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs fry kernel math +namespaces compiler.cfg.registers ; +IN: compiler.cfg.stacks.height + +! Global stack height tracking done while constructing CFG. +SYMBOLS: ds-heights rs-heights ; + +: record-stack-heights ( ds-height rs-height bb -- ) + [ ds-heights get set-at ] [ rs-heights get set-at ] bi-curry bi* ; + +GENERIC# translate-loc 1 ( loc bb -- loc' ) + +M: ds-loc translate-loc [ n>> ] [ ds-heights get at ] bi* - ; +M: rs-loc translate-loc [ n>> ] [ rs-heights get at ] bi* - ; + +: translate-locs ( assoc bb -- assoc' ) + '[ [ _ translate-loc ] dip ] assoc-map ; + +GENERIC# untranslate-loc 1 ( loc bb -- loc' ) + +M: ds-loc untranslate-loc [ n>> ] [ ds-heights get at ] bi* + ; +M: rs-loc untranslate-loc [ n>> ] [ rs-heights get at ] bi* + ; + +: untranslate-locs ( assoc bb -- assoc' ) + '[ [ _ untranslate-loc ] dip ] assoc-map ; \ No newline at end of file diff --git a/basis/compiler/cfg/stacks/local/local.factor b/basis/compiler/cfg/stacks/local/local.factor new file mode 100644 index 0000000000..754789042a --- /dev/null +++ b/basis/compiler/cfg/stacks/local/local.factor @@ -0,0 +1,91 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel math namespaces sets make sequences +compiler.cfg +compiler.cfg.hats +compiler.cfg.instructions +compiler.cfg.registers +compiler.cfg.stacks.height +compiler.cfg.parallel-copy ; +IN: compiler.cfg.stacks.local + +! Local stack analysis. We build local peek and replace sets for every basic +! block while constructing the CFG. + +SYMBOLS: peek-sets replace-sets ; + +SYMBOL: locs>vregs + +: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ; +: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ; + +TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ; + +SYMBOLS: local-peek-set local-replace-set replace-mapping ; + +GENERIC: translate-local-loc ( loc -- loc' ) +M: ds-loc translate-local-loc n>> current-height get d>> - ; +M: rs-loc translate-local-loc n>> current-height get r>> - ; + +: emit-stack-changes ( -- ) + replace-mapping get dup assoc-empty? [ drop ] [ + [ [ loc>vreg ] dip ] assoc-map parallel-copy + ] if ; + +: emit-height-changes ( -- ) + current-height get + [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ] + [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ; + +: emit-changes ( -- ) + ! Insert height and stack changes prior to the last instruction + building get pop + emit-stack-changes + emit-height-changes + , ; + +! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later +: inc-d ( n -- ) + current-height get + [ [ + ] change-emit-d drop ] + [ [ + ] change-d drop ] + 2bi ; + +: inc-r ( n -- ) + current-height get + [ [ + ] change-emit-r drop ] + [ [ + ] change-r drop ] + 2bi ; + +: peek-loc ( loc -- vreg ) + translate-local-loc + dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless + dup replace-mapping get at [ ] [ loc>vreg ] ?if ; + +: replace-loc ( vreg loc -- ) + translate-local-loc + 2dup loc>vreg = + [ nip replace-mapping get delete-at ] + [ + [ local-replace-set get conjoin ] + [ replace-mapping get set-at ] + bi + ] if ; + +: begin-local-analysis ( -- ) + H{ } clone local-peek-set set + H{ } clone local-replace-set set + H{ } clone replace-mapping set + current-height get 0 >>emit-d 0 >>emit-r drop + current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ; + +: end-local-analysis ( -- ) + emit-changes + local-peek-set get basic-block get peek-sets get set-at + local-replace-set get basic-block get replace-sets get set-at ; + +: clone-current-height ( -- ) + current-height [ clone ] change ; + +: peek-set ( bb -- assoc ) peek-sets get at ; +: replace-set ( bb -- assoc ) replace-sets get at ; diff --git a/basis/compiler/cfg/stacks/stacks.factor b/basis/compiler/cfg/stacks/stacks.factor index c8fcae87c0..2683222fb8 100755 --- a/basis/compiler/cfg/stacks/stacks.factor +++ b/basis/compiler/cfg/stacks/stacks.factor @@ -1,45 +1,76 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math sequences kernel cpu.architecture -compiler.cfg.instructions compiler.cfg.registers -compiler.cfg.hats ; +USING: math sequences kernel namespaces accessors biassocs compiler.cfg +compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats +compiler.cfg.predecessors compiler.cfg.stacks.local +compiler.cfg.stacks.height compiler.cfg.stacks.global +compiler.cfg.stacks.finalize ; IN: compiler.cfg.stacks -: ds-drop ( -- ) - -1 ##inc-d ; +: begin-stack-analysis ( -- ) + locs>vregs set + H{ } clone ds-heights set + H{ } clone rs-heights set + H{ } clone peek-sets set + H{ } clone replace-sets set + current-height new current-height set ; -: ds-pop ( -- vreg ) - D 0 ^^peek -1 ##inc-d ; +: end-stack-analysis ( -- ) + cfg get + compute-predecessors + compute-global-sets + finalize-stack-shuffling + drop ; -: ds-push ( vreg -- ) - 1 ##inc-d D 0 ##replace ; +: ds-drop ( -- ) -1 inc-d ; + +: ds-peek ( -- vreg ) D 0 peek-loc ; + +: ds-pop ( -- vreg ) ds-peek ds-drop ; + +: ds-push ( vreg -- ) 1 inc-d D 0 replace-loc ; : ds-load ( n -- vregs ) dup 0 = [ drop f ] - [ [ [ ^^peek ] map ] [ neg ##inc-d ] bi ] if ; + [ [ [ peek-loc ] map ] [ neg inc-d ] bi ] if ; : ds-store ( vregs -- ) [ - [ length ##inc-d ] - [ [ ##replace ] each-index ] bi + [ length inc-d ] + [ [ replace-loc ] each-index ] bi ] unless-empty ; +: rs-drop ( -- ) -1 inc-r ; + : rs-load ( n -- vregs ) dup 0 = [ drop f ] - [ [ [ ^^peek ] map ] [ neg ##inc-r ] bi ] if ; + [ [ [ peek-loc ] map ] [ neg inc-r ] bi ] if ; : rs-store ( vregs -- ) [ - [ length ##inc-r ] - [ [ ##replace ] each-index ] bi + [ length inc-r ] + [ [ replace-loc ] each-index ] bi ] unless-empty ; +: (2inputs) ( -- vreg1 vreg2 ) + D 1 peek-loc D 0 peek-loc ; + : 2inputs ( -- vreg1 vreg2 ) - D 1 ^^peek D 0 ^^peek -2 ##inc-d ; + (2inputs) -2 inc-d ; + +: (3inputs) ( -- vreg1 vreg2 vreg3 ) + D 2 peek-loc D 1 peek-loc D 0 peek-loc ; : 3inputs ( -- vreg1 vreg2 vreg3 ) - D 2 ^^peek D 1 ^^peek D 0 ^^peek -3 ##inc-d ; + (3inputs) -3 inc-d ; + +! adjust-d/adjust-r: these are called when other instructions which +! internally adjust the stack height are emitted, such as ##call and +! ##alien-invoke +: adjust-d ( n -- ) current-height get [ + ] change-d drop ; +: adjust-r ( n -- ) current-height get [ + ] change-r drop ; + diff --git a/basis/compiler/cfg/two-operand/two-operand-tests.factor b/basis/compiler/cfg/two-operand/two-operand-tests.factor new file mode 100644 index 0000000000..0d0c57e0f7 --- /dev/null +++ b/basis/compiler/cfg/two-operand/two-operand-tests.factor @@ -0,0 +1,45 @@ +IN: compiler.cfg.two-operand.tests +USING: compiler.cfg.two-operand compiler.cfg.instructions +compiler.cfg.registers cpu.architecture namespaces tools.test ; + +3 vreg-counter set-global + +[ + V{ + T{ ##copy f V int-regs 1 V int-regs 2 } + T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 3 } + } +] [ + { + T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 3 } + } (convert-two-operand) +] unit-test + +[ + V{ + T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 } + } +] [ + { + T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 } + } (convert-two-operand) +] unit-test + +[ + V{ + T{ ##copy f V int-regs 4 V int-regs 2 } + T{ ##sub f V int-regs 4 V int-regs 4 V int-regs 1 } + T{ ##copy f V int-regs 1 V int-regs 4 } + } +] [ + { + T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 } + } (convert-two-operand) +] unit-test + +! This should never come up after coalescing +[ + V{ + T{ ##fixnum-add f V int-regs 2 V int-regs 4 V int-regs 2 } + } (convert-two-operand) +] must-fail diff --git a/basis/compiler/cfg/two-operand/two-operand.factor b/basis/compiler/cfg/two-operand/two-operand.factor index 0a52aa7c1a..db3462bf0d 100644 --- a/basis/compiler/cfg/two-operand/two-operand.factor +++ b/basis/compiler/cfg/two-operand/two-operand.factor @@ -1,59 +1,104 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel sequences make compiler.cfg.instructions +USING: accessors kernel sequences make combinators +compiler.cfg.registers compiler.cfg.instructions compiler.cfg.rpo cpu.architecture ; IN: compiler.cfg.two-operand -! On x86, instructions take the form x = x op y -! Our SSA IR is x = y op z +! This pass runs after SSA coalescing and normalizes instructions +! to fit the x86 two-address scheme. Possibilities are: + +! 1) x = x op y +! 2) x = y op x +! 3) x = y op z + +! In case 1, there is nothing to do. + +! In case 2, we convert to +! z = y +! z = z op x +! x = z + +! In case 3, we convert to +! x = y +! x = x op z + +! In case 2 and case 3, linear scan coalescing will eliminate a +! copy if the value y is never used again. ! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm ! since x86 has LEA and IMUL instructions which are effectively ! three-operand addition and multiplication, respectively. -: convert-two-operand/integer ( insn -- ) - [ [ dst>> ] [ src1>> ] bi ##copy ] - [ dup dst>> >>src1 , ] - bi ; inline +UNION: two-operand-insn + ##sub + ##mul + ##and + ##and-imm + ##or + ##or-imm + ##xor + ##xor-imm + ##shl + ##shl-imm + ##shr + ##shr-imm + ##sar + ##sar-imm + ##fixnum-overflow + ##add-float + ##sub-float + ##mul-float + ##div-float ; + +GENERIC: convert-two-operand* ( insn -- ) -: convert-two-operand/float ( insn -- ) - [ [ dst>> ] [ src1>> ] bi ##copy-float ] +: emit-copy ( dst src -- ) + dup reg-class>> { + { int-regs [ ##copy ] } + { double-float-regs [ ##copy-float ] } + } case ; inline + +: case-1? ( insn -- ? ) [ dst>> ] [ src1>> ] bi = ; inline + +: case-1 ( insn -- ) , ; inline + +: case-2? ( insn -- ? ) [ dst>> ] [ src2>> ] bi = ; inline + +ERROR: bad-case-2 insn ; + +: case-2 ( insn -- ) + ! This can't work with a ##fixnum-overflow since it branches + dup ##fixnum-overflow? [ bad-case-2 ] when + dup dst>> reg-class>> next-vreg + [ swap src1>> emit-copy ] + [ [ >>src1 ] [ >>dst ] bi , ] + [ [ src2>> ] dip emit-copy ] + 2tri ; inline + +: case-3 ( insn -- ) + [ [ dst>> ] [ src1>> ] bi emit-copy ] [ dup dst>> >>src1 , ] bi ; inline -GENERIC: convert-two-operand* ( insn -- ) +M: two-operand-insn convert-two-operand* + { + { [ dup case-1? ] [ case-1 ] } + { [ dup case-2? ] [ case-2 ] } + [ case-3 ] + } cond ; inline M: ##not convert-two-operand* - [ [ dst>> ] [ src>> ] bi ##copy ] - [ dup dst>> >>src , ] - bi ; - -M: ##sub convert-two-operand* convert-two-operand/integer ; -M: ##mul convert-two-operand* convert-two-operand/integer ; -M: ##and convert-two-operand* convert-two-operand/integer ; -M: ##and-imm convert-two-operand* convert-two-operand/integer ; -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 ; -M: ##div-float convert-two-operand* convert-two-operand/float ; + dup [ dst>> ] [ src>> ] bi = [ + [ [ dst>> ] [ src>> ] bi ##copy ] + [ dup dst>> >>src ] + bi + ] unless , ; M: insn convert-two-operand* , ; +: (convert-two-operand) ( cfg -- cfg' ) + [ [ convert-two-operand* ] each ] V{ } make ; + : convert-two-operand ( cfg -- cfg' ) - two-operand? [ - [ [ [ convert-two-operand* ] each ] V{ } make ] - local-optimization - ] when ; + two-operand? [ [ (convert-two-operand) ] local-optimization ] when ; \ No newline at end of file diff --git a/basis/compiler/cfg/utilities/utilities.factor b/basis/compiler/cfg/utilities/utilities.factor index 9cb8bf26f9..d242d5d90d 100644 --- a/basis/compiler/cfg/utilities/utilities.factor +++ b/basis/compiler/cfg/utilities/utilities.factor @@ -1,56 +1,23 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators combinators.short-circuit -compiler.cfg compiler.cfg.instructions cpu.architecture kernel -layouts locals make math namespaces sequences sets vectors fry ; +cpu.architecture kernel layouts locals make math namespaces sequences +sets vectors fry compiler.cfg compiler.cfg.instructions +compiler.cfg.rpo ; IN: compiler.cfg.utilities -: value-info-small-fixnum? ( value-info -- ? ) - literal>> { - { [ dup fixnum? ] [ tag-fixnum small-enough? ] } - [ drop f ] - } cond ; - -: value-info-small-tagged? ( value-info -- ? ) - dup literal?>> [ - literal>> { - { [ dup fixnum? ] [ tag-fixnum small-enough? ] } - { [ dup not ] [ drop t ] } - [ drop f ] - } cond - ] [ drop f ] if ; - -: set-basic-block ( basic-block -- ) - [ basic-block set ] [ instructions>> building set ] bi ; - -: begin-basic-block ( -- ) - basic-block get [ - dupd successors>> push - ] when* - set-basic-block ; - -: end-basic-block ( -- ) - building off - basic-block off ; - -: 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 ; +PREDICATE: kill-block < basic-block + instructions>> { + [ length 2 = ] + [ first kill-vreg-insn? ] + } 1&& ; : back-edge? ( from to -- ? ) [ number>> ] bi@ >= ; +: loop-entry? ( bb -- ? ) + dup predecessors>> [ swap back-edge? ] with any? ; + : empty-block? ( bb -- ? ) instructions>> { [ length 1 = ] @@ -70,16 +37,6 @@ SYMBOL: visited : 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 @@ -92,6 +49,11 @@ SYMBOL: added-instructions \ ##branch new-insn over push >>instructions ; -: insert-basic-blocks ( bb -- ) - [ added-instructions get ] dip - '[ [ _ ] dip insert-basic-block ] assoc-each ; +: has-phis? ( bb -- ? ) + instructions>> first ##phi? ; + +: cfg-has-phis? ( cfg -- ? ) + post-order [ has-phis? ] any? ; + +: if-has-phis ( bb quot: ( bb -- ) -- ) + [ dup has-phis? ] dip [ drop ] if ; inline diff --git a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor index fcd1b1c9ac..4b8ee2a1ae 100755 --- a/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor +++ b/basis/compiler/cfg/value-numbering/rewrite/rewrite.factor @@ -20,13 +20,9 @@ IN: compiler.cfg.value-numbering.rewrite ! Outputs f to mean no change -GENERIC: rewrite* ( insn -- insn/f ) +GENERIC: rewrite ( insn -- insn/f ) -: rewrite ( insn -- insn' ) - dup [ number-values ] [ rewrite* ] bi - [ rewrite ] [ ] ?if ; - -M: insn rewrite* drop f ; +M: insn rewrite drop f ; : ##branch-t? ( insn -- ? ) dup ##compare-imm-branch? [ @@ -123,7 +119,7 @@ ERROR: bad-comparison ; : fold-compare-imm-branch ( insn -- insn/f ) (fold-compare-imm) fold-branch ; -M: ##compare-imm-branch rewrite* +M: ##compare-imm-branch rewrite { { [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] } { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } @@ -154,7 +150,7 @@ M: ##compare-imm-branch rewrite* : rewrite-self-compare-branch ( insn -- insn' ) (rewrite-self-compare) fold-branch ; -M: ##compare-branch rewrite* +M: ##compare-branch rewrite { { [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] } { [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] } @@ -185,7 +181,7 @@ M: ##compare-branch rewrite* : rewrite-self-compare ( insn -- insn' ) dup (rewrite-self-compare) >boolean-insn ; -M: ##compare rewrite* +M: ##compare rewrite { { [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] } { [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] } @@ -196,7 +192,7 @@ M: ##compare rewrite* : fold-compare-imm ( insn -- insn' ) dup (fold-compare-imm) >boolean-insn ; -M: ##compare-imm rewrite* +M: ##compare-imm rewrite { { [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] } { [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] } @@ -238,7 +234,7 @@ M: ##shl-imm constant-fold* drop shift ; ] dip over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline -M: ##add-imm rewrite* +M: ##add-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##add-imm reassociate ] } @@ -249,7 +245,7 @@ M: ##add-imm rewrite* [ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough? [ \ ##add-imm new-insn ] [ 3drop f ] if ; -M: ##sub-imm rewrite* +M: ##sub-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ sub-imm>add-imm ] @@ -261,7 +257,7 @@ M: ##sub-imm rewrite* : strength-reduce-mul? ( insn -- ? ) src2>> power-of-2? ; -M: ##mul-imm rewrite* +M: ##mul-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup strength-reduce-mul? ] [ strength-reduce-mul ] } @@ -269,40 +265,40 @@ M: ##mul-imm rewrite* [ drop f ] } cond ; -M: ##and-imm rewrite* +M: ##and-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##and-imm reassociate ] } [ drop f ] } cond ; -M: ##or-imm rewrite* +M: ##or-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##or-imm reassociate ] } [ drop f ] } cond ; -M: ##xor-imm rewrite* +M: ##xor-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } { [ dup reassociate? ] [ \ ##xor-imm reassociate ] } [ drop f ] } cond ; -M: ##shl-imm rewrite* +M: ##shl-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ drop f ] } cond ; -M: ##shr-imm rewrite* +M: ##shr-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ drop f ] } cond ; -M: ##sar-imm rewrite* +M: ##sar-imm rewrite { { [ dup constant-fold? ] [ constant-fold ] } [ drop f ] @@ -327,7 +323,7 @@ M: ##sar-imm rewrite* [ 2drop f ] } cond ; inline -M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ; +M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ; : subtraction-identity? ( insn -- ? ) [ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ; @@ -335,22 +331,22 @@ M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ; : rewrite-subtraction-identity ( insn -- insn' ) dst>> 0 \ ##load-immediate new-insn ; -M: ##sub rewrite* +M: ##sub rewrite { { [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] } [ \ ##sub-imm rewrite-arithmetic ] } cond ; -M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ; +M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ; -M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ; +M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ; -M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ; +M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ; -M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ; +M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ; -M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ; +M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ; -M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ; +M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ; -M: ##sar rewrite* \ ##sar-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 5934643acc..6bd84021b3 100644 --- a/basis/compiler/cfg/value-numbering/simplify/simplify.factor +++ b/basis/compiler/cfg/value-numbering/simplify/simplify.factor @@ -127,7 +127,5 @@ M: expr simplify* drop f ; { [ dup integer? ] [ nip ] } } cond ; -GENERIC: number-values ( insn -- ) - -M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ; -M: insn number-values drop ; +: number-values ( insn -- ) + [ >expr simplify ] [ dst>> ] bi set-vn ; diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor index 9063947ae1..087b73e2c0 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor @@ -3,7 +3,7 @@ USING: compiler.cfg.value-numbering compiler.cfg.instructions 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.dce compiler.cfg.ssa.destruction compiler.cfg assocs vectors arrays layouts namespaces ; : trim-temps ( insns -- insns ) @@ -35,9 +35,9 @@ compiler.cfg assocs vectors arrays layouts namespaces ; [ { T{ ##load-reference f V int-regs 0 0.0 } - T{ ##load-reference f V int-regs 1 0.0 } + T{ ##copy f V int-regs 1 V int-regs 0 } T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 0 D 1 } + T{ ##replace f V int-regs 1 D 1 } } ] [ { @@ -51,9 +51,9 @@ compiler.cfg assocs vectors arrays layouts namespaces ; [ { T{ ##load-reference f V int-regs 0 t } - T{ ##load-reference f V int-regs 1 t } + T{ ##copy f V int-regs 1 V int-regs 0 } T{ ##replace f V int-regs 0 D 0 } - T{ ##replace f V int-regs 0 D 1 } + T{ ##replace f V int-regs 1 D 1 } } ] [ { @@ -64,29 +64,14 @@ compiler.cfg assocs vectors arrays layouts namespaces ; } value-numbering-step ] unit-test -! Copy propagation -[ - { - T{ ##peek f V int-regs 45 D 1 } - 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 45 D 1 } - 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 -] unit-test - ! Compare propagation [ { T{ ##load-reference f V int-regs 1 + } T{ ##peek f V int-regs 2 D 0 } T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> } - T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> } - T{ ##replace f V int-regs 4 D 0 } + T{ ##copy f V int-regs 6 V int-regs 4 } + T{ ##replace f V int-regs 6 D 0 } } ] [ { @@ -612,8 +597,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; 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{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -630,8 +615,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; 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{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -648,8 +633,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; 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{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -666,8 +651,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; 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{ ##copy f V int-regs 3 V int-regs 0 } + T{ ##replace f V int-regs 3 D 0 } } ] [ { @@ -683,8 +668,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ; { 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{ ##copy f V int-regs 2 V int-regs 0 } + T{ ##replace f V int-regs 2 D 0 } } ] [ { @@ -1206,14 +1191,14 @@ test-diamond cfg new 0 get >>entry value-numbering compute-predecessors - eliminate-phis drop + destruct-ssa 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 +[ 2 ] [ 4 get instructions>> length ] unit-test V{ T{ ##peek f V int-regs 0 D 0 } diff --git a/basis/compiler/cfg/value-numbering/value-numbering.factor b/basis/compiler/cfg/value-numbering/value-numbering.factor index 0c9616b4e5..a249f71c02 100644 --- a/basis/compiler/cfg/value-numbering/value-numbering.factor +++ b/basis/compiler/cfg/value-numbering/value-numbering.factor @@ -1,10 +1,10 @@ ! 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 fry +USING: namespaces assocs kernel accessors +sorting sets sequences compiler.cfg compiler.cfg.rpo -compiler.cfg.renaming +compiler.cfg.instructions compiler.cfg.value-numbering.graph compiler.cfg.value-numbering.expressions compiler.cfg.value-numbering.simplify @@ -12,20 +12,28 @@ compiler.cfg.value-numbering.rewrite ; IN: compiler.cfg.value-numbering ! Local value numbering. Predecessors must be recomputed after this -: vreg>vreg-mapping ( -- assoc ) - vregs>vns get [ keys ] keep - '[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ; +: >copy ( insn -- insn/##copy ) + dup dst>> dup vreg>vn vn>vreg + 2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ; -: rename-uses ( insns -- ) - vreg>vreg-mapping renamings [ - [ rename-insn-uses ] each - ] with-variable ; +: rewrite-loop ( insn -- insn' ) + dup rewrite [ rewrite-loop ] [ ] ?if ; + +GENERIC: process-instruction ( insn -- insn' ) + +M: ##flushable process-instruction + dup rewrite + [ process-instruction ] + [ dup number-values >copy ] ?if ; + +M: insn process-instruction + dup rewrite + [ process-instruction ] [ ] ?if ; : value-numbering-step ( insns -- insns' ) init-value-graph init-expressions - [ rewrite ] map - dup rename-uses ; + [ process-instruction ] map ; : value-numbering ( cfg -- cfg' ) [ value-numbering-step ] local-optimization cfg-changed ; diff --git a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor index c1a667c004..14197bc3f7 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier-tests.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier-tests.factor @@ -1,42 +1,43 @@ USING: compiler.cfg.write-barrier compiler.cfg.instructions compiler.cfg.registers compiler.cfg.debugger cpu.architecture -arrays tools.test vectors compiler.cfg kernel accessors ; +arrays tools.test vectors compiler.cfg kernel accessors +compiler.cfg.utilities ; IN: compiler.cfg.write-barrier.tests : test-write-barrier ( insns -- insns ) - write-barriers-step ; + dup write-barriers-step instructions>> ; [ - { + V{ T{ ##peek f V int-regs 4 D 0 f } - T{ ##copy f V int-regs 6 V int-regs 4 f } T{ ##allot f V int-regs 7 24 array V int-regs 8 f } T{ ##load-immediate f V int-regs 9 8 f } T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 f } - T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 f } + T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 f } T{ ##replace f V int-regs 7 D 0 f } + T{ ##branch } } ] [ { T{ ##peek f V int-regs 4 D 0 } - T{ ##copy f V int-regs 6 V int-regs 4 } T{ ##allot f V int-regs 7 24 array V int-regs 8 } T{ ##load-immediate f V int-regs 9 8 } T{ ##set-slot-imm f V int-regs 9 V int-regs 7 1 3 } T{ ##write-barrier f V int-regs 7 V int-regs 10 V int-regs 11 } - T{ ##set-slot-imm f V int-regs 6 V int-regs 7 2 3 } + T{ ##set-slot-imm f V int-regs 4 V int-regs 7 2 3 } T{ ##write-barrier f V int-regs 7 V int-regs 12 V int-regs 13 } T{ ##replace f V int-regs 7 D 0 } } test-write-barrier ] unit-test [ - { + V{ T{ ##load-immediate f V int-regs 4 24 } T{ ##peek f V int-regs 5 D -1 } T{ ##peek f V int-regs 6 D -2 } T{ ##set-slot-imm f V int-regs 5 V int-regs 6 3 2 } T{ ##write-barrier f V int-regs 6 V int-regs 7 V int-regs 8 } + T{ ##branch } } ] [ { @@ -49,28 +50,23 @@ IN: compiler.cfg.write-barrier.tests ] unit-test [ - { + V{ T{ ##peek f V int-regs 19 D -3 } T{ ##peek f V int-regs 22 D -2 } - T{ ##copy f V int-regs 23 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 } - T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 } - T{ ##copy f V int-regs 26 V int-regs 19 } + T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 } + T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 } T{ ##peek f V int-regs 28 D -1 } - T{ ##copy f V int-regs 29 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } + T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 } + T{ ##branch } } ] [ { T{ ##peek f V int-regs 19 D -3 } T{ ##peek f V int-regs 22 D -2 } - T{ ##copy f V int-regs 23 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 } - T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 } - T{ ##copy f V int-regs 26 V int-regs 19 } + T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 } + T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 } T{ ##peek f V int-regs 28 D -1 } - T{ ##copy f V int-regs 29 V int-regs 19 } - T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 } - T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 } + T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 } + T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 } } test-write-barrier ] unit-test diff --git a/basis/compiler/cfg/write-barrier/write-barrier.factor b/basis/compiler/cfg/write-barrier/write-barrier.factor index bcec542501..2f32a4ca81 100644 --- a/basis/compiler/cfg/write-barrier/write-barrier.factor +++ b/basis/compiler/cfg/write-barrier/write-barrier.factor @@ -1,8 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors namespaces assocs sets sequences locals -compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop -compiler.cfg.rpo ; +USING: kernel accessors namespaces assocs sets sequences +compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ; IN: compiler.cfg.write-barrier ! Eliminate redundant write barrier hits. @@ -14,33 +13,27 @@ SYMBOL: safe ! Objects which have been mutated SYMBOL: mutated -GENERIC: eliminate-write-barrier ( insn -- insn' ) +GENERIC: eliminate-write-barrier ( insn -- ? ) M: ##allot eliminate-write-barrier - dup dst>> safe get conjoin ; + dst>> safe get conjoin t ; M: ##write-barrier eliminate-write-barrier - dup src>> resolve dup - [ safe get key? not ] - [ mutated get key? ] bi and - [ safe get conjoin ] [ 2drop f ] if ; - -M: ##copy eliminate-write-barrier - dup record-copy ; + src>> dup [ safe get key? not ] [ mutated get key? ] bi and + [ safe get conjoin t ] [ drop f ] if ; M: ##set-slot eliminate-write-barrier - dup obj>> resolve mutated get conjoin ; + obj>> mutated get conjoin t ; M: ##set-slot-imm eliminate-write-barrier - dup obj>> resolve mutated get conjoin ; + obj>> mutated get conjoin t ; -M: insn eliminate-write-barrier ; +M: insn eliminate-write-barrier drop t ; -: write-barriers-step ( insns -- insns' ) +: write-barriers-step ( bb -- ) H{ } clone safe set H{ } clone mutated set - H{ } clone copies set - [ eliminate-write-barrier ] map sift ; + instructions>> [ eliminate-write-barrier ] filter-here ; : eliminate-write-barriers ( cfg -- cfg' ) - [ write-barriers-step ] local-optimization ; + dup [ write-barriers-step ] each-basic-block ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 5df0114244..993edbf812 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -4,7 +4,7 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs alien.strings alien.arrays alien.complex alien.libraries sets libc -continuations.private fry cpu.architecture +continuations.private fry cpu.architecture classes source-files.errors compiler.errors compiler.alien @@ -18,6 +18,10 @@ compiler.codegen.fixup compiler.utilities ; IN: compiler.codegen +SYMBOL: insn-counts + +H{ } clone insn-counts set-global + GENERIC: generate-insn ( insn -- ) SYMBOL: registers @@ -54,7 +58,12 @@ SYMBOL: labels [ word>> init-generator ] [ instructions>> - [ [ regs>> registers set ] [ generate-insn ] bi ] each + [ + [ class insn-counts get inc-at ] + [ regs>> registers set ] + [ generate-insn ] + tri + ] each ] bi ] with-fixup ; @@ -245,7 +254,7 @@ M: _gc generate-insn [ gc-root-count>> ] } cleave %gc ; -M: ##loop-entry generate-insn drop %loop-entry ; +M: _loop-entry generate-insn drop %loop-entry ; M: ##alien-global generate-insn [ dst>> register ] [ symbol>> ] [ library>> ] tri diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 9f573019c2..f1d17fe4a2 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -286,7 +286,7 @@ M: cucumber equal? "The cucumber has no equal" throw ; [ 4294967295 B{ 255 255 255 255 } -1 ] [ -1 -1 - [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ] + [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ] compile-call ] unit-test @@ -321,4 +321,28 @@ cell 4 = [ ] 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 +[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test + +! Bug with ##return node construction +: return-recursive-bug ( nodes -- ? ) + { fixnum } declare [ + dup 3 bitand 1 = [ drop t ] [ + dup 3 bitand 2 = [ + return-recursive-bug + ] [ drop f ] if + ] if + ] any? ; inline recursive + +[ t ] [ 3 [ return-recursive-bug ] compile-call ] unit-test + +! Coalescing reductions +[ f ] [ V{ } 0 [ [ vector? ] both? ] compile-call ] unit-test +[ f ] [ 0 V{ } [ [ vector? ] both? ] compile-call ] unit-test + +[ f ] [ + f vector [ + [ dup [ \ vector eq? ] [ drop f ] if ] dip + dup [ \ vector eq? ] [ drop f ] if + over rot [ drop ] [ nip ] if + ] compile-call +] unit-test \ No newline at end of file diff --git a/basis/compiler/tests/low-level-ir.factor b/basis/compiler/tests/low-level-ir.factor new file mode 100644 index 0000000000..649a72cd20 --- /dev/null +++ b/basis/compiler/tests/low-level-ir.factor @@ -0,0 +1,140 @@ +USING: accessors assocs compiler compiler.cfg +compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr +compiler.cfg.registers compiler.codegen compiler.units +cpu.architecture hashtables kernel namespaces sequences +tools.test vectors words layouts literals math arrays +alien.syntax ; +IN: compiler.tests.low-level-ir + +: compile-cfg ( cfg -- word ) + gensym + [ build-mr generate code>> ] dip + [ associate >alist modify-code-heap ] keep ; + +: compile-test-cfg ( -- word ) + cfg new + 0 get >>entry + compile-cfg ; + +: compile-test-bb ( insns -- result ) + V{ T{ ##prologue } T{ ##branch } } 0 test-bb + V{ + T{ ##inc-d f 1 } + T{ ##replace f V int-regs 0 D 0 } + T{ ##branch } + } append 1 test-bb + V{ + T{ ##epilogue } + T{ ##return } + } 2 test-bb + 0 get 1 get 1vector >>successors drop + 1 get 2 get 1vector >>successors drop + compile-test-cfg + execute( -- result ) ; + +! loading immediates +[ f ] [ + V{ + T{ ##load-immediate f V int-regs 0 5 } + } compile-test-bb +] unit-test + +[ "hello" ] [ + V{ + T{ ##load-reference f V int-regs 0 "hello" } + } compile-test-bb +] unit-test + +! make sure slot access works when the destination is +! one of the sources +[ t ] [ + V{ + T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] } + T{ ##load-reference f V int-regs 0 { t f t } } + T{ ##slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 } + } compile-test-bb +] unit-test + +[ t ] [ + V{ + T{ ##load-reference f V int-regs 0 { t f t } } + T{ ##slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] V int-regs 2 } + } compile-test-bb +] unit-test + +[ t ] [ + V{ + T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] } + T{ ##load-reference f V int-regs 0 { t f t } } + T{ ##set-slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 } + } compile-test-bb + dup first eq? +] unit-test + +[ t ] [ + V{ + T{ ##load-reference f V int-regs 0 { t f t } } + T{ ##set-slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] } + } compile-test-bb + dup first eq? +] unit-test + +[ 8 ] [ + V{ + T{ ##load-immediate f V int-regs 0 4 } + T{ ##shl f V int-regs 0 V int-regs 0 V int-regs 0 } + } compile-test-bb +] unit-test + +[ 4 ] [ + V{ + T{ ##load-immediate f V int-regs 0 4 } + T{ ##shl-imm f V int-regs 0 V int-regs 0 3 } + } compile-test-bb +] unit-test + +[ 31 ] [ + V{ + T{ ##load-reference f V int-regs 1 B{ 31 67 52 } } + T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 1 V int-regs 2 } + T{ ##alien-unsigned-1 f V int-regs 0 V int-regs 0 } + T{ ##shl-imm f V int-regs 0 V int-regs 0 3 } + } compile-test-bb +] unit-test + +[ CHAR: l ] [ + V{ + T{ ##load-reference f V int-regs 0 "hello world" } + T{ ##load-immediate f V int-regs 1 3 } + T{ ##string-nth f V int-regs 0 V int-regs 0 V int-regs 1 V int-regs 2 } + T{ ##shl-imm f V int-regs 0 V int-regs 0 3 } + } compile-test-bb +] unit-test + +[ 1 ] [ + V{ + T{ ##load-immediate f V int-regs 0 16 } + T{ ##add-imm f V int-regs 0 V int-regs 0 -8 } + } compile-test-bb +] unit-test + +! These are def-is-use-insns +USE: multiline + +/* + +[ 100 ] [ + V{ + T{ ##load-immediate f V int-regs 0 100 } + T{ ##integer>bignum f V int-regs 0 V int-regs 0 V int-regs 1 } + } compile-test-bb +] unit-test + +[ 1 ] [ + V{ + T{ ##load-reference f V int-regs 0 ALIEN: 8 } + T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 0 V int-regs 1 } + } compile-test-bb +] unit-test + +*/ \ No newline at end of file diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 816368466f..a2dec12279 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -3,7 +3,7 @@ USING: assocs classes classes.algebra classes.tuple classes.tuple.private kernel accessors math math.intervals namespaces sequences words combinators byte-arrays strings -arrays compiler.tree.propagation.copy ; +arrays layouts cpu.architecture compiler.tree.propagation.copy ; IN: compiler.tree.propagation.info : false-class? ( class -- ? ) \ f class<= ; @@ -306,3 +306,18 @@ SYMBOL: value-infos dup in-d>> last node-value-info literal>> first immutable-tuple-class? ] [ drop f ] if ; + +: value-info-small-fixnum? ( value-info -- ? ) + literal>> { + { [ dup fixnum? ] [ tag-fixnum small-enough? ] } + [ drop f ] + } cond ; + +: value-info-small-tagged? ( value-info -- ? ) + dup literal?>> [ + literal>> { + { [ dup fixnum? ] [ tag-fixnum small-enough? ] } + { [ dup not ] [ drop t ] } + [ drop f ] + } cond + ] [ drop f ] if ; diff --git a/basis/cpu/x86/assembler/assembler-tests.factor b/basis/cpu/x86/assembler/assembler-tests.factor index a8c54fa65e..66adee6bf6 100644 --- a/basis/cpu/x86/assembler/assembler-tests.factor +++ b/basis/cpu/x86/assembler/assembler-tests.factor @@ -8,6 +8,33 @@ IN: cpu.x86.assembler.tests [ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test [ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test +! r-rm / m-r sse instruction +[ { HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVUPS ] { } make ] unit-test +[ { HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVUPS ] { } make ] unit-test +[ { HEX: 0f HEX: 11 HEX: 08 } ] [ [ EAX [] XMM1 MOVUPS ] { } make ] unit-test + +[ { HEX: f3 HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVSS ] { } make ] unit-test +[ { HEX: f3 HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVSS ] { } make ] unit-test +[ { HEX: f3 HEX: 0f HEX: 11 HEX: 08 } ] [ [ EAX [] XMM1 MOVSS ] { } make ] unit-test + +[ { HEX: 66 HEX: 0f HEX: 6f HEX: c1 } ] [ [ XMM0 XMM1 MOVDQA ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 6f HEX: 01 } ] [ [ XMM0 ECX [] MOVDQA ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 7f HEX: 08 } ] [ [ EAX [] XMM1 MOVDQA ] { } make ] unit-test + +! r-rm only sse instruction +[ { HEX: 66 HEX: 0f HEX: 2e HEX: c1 } ] [ [ XMM0 XMM1 UCOMISD ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 2e HEX: 01 } ] [ [ XMM0 ECX [] UCOMISD ] { } make ] unit-test +[ [ EAX [] XMM1 UCOMISD ] { } make ] must-fail +[ { HEX: 66 HEX: 0f HEX: 38 HEX: 2a HEX: 01 } ] [ [ XMM0 ECX [] MOVNTDQA ] { } make ] unit-test + +! rm-r only sse instructions +[ { HEX: 0f HEX: 2b HEX: 08 } ] [ [ EAX [] XMM1 MOVNTPS ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: e7 HEX: 08 } ] [ [ EAX [] XMM1 MOVNTDQ ] { } make ] unit-test + +! three-byte-opcode ssse3 instruction +[ { HEX: 66 HEX: 0f HEX: 38 HEX: 02 HEX: c1 } ] [ [ XMM0 XMM1 PHADDD ] { } make ] unit-test + +! int/sse conversion instruction [ { HEX: f2 HEX: 0f HEX: 2c HEX: c0 } ] [ [ EAX XMM0 CVTTSD2SI ] { } make ] unit-test [ { HEX: f2 HEX: 48 HEX: 0f HEX: 2c HEX: c0 } ] [ [ RAX XMM0 CVTTSD2SI ] { } make ] unit-test [ { HEX: f2 HEX: 4c HEX: 0f HEX: 2c HEX: e0 } ] [ [ R12 XMM0 CVTTSD2SI ] { } make ] unit-test @@ -25,6 +52,50 @@ IN: cpu.x86.assembler.tests ! [ { HEX: f2 HEX: 0f HEX: 11 HEX: 00 } ] [ [ RAX [] XMM0 MOVSD ] { } make ] unit-test ! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test +! 3-operand r-rm-imm sse instructions +[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test +[ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test + +! scalar register insert/extract sse instructions +[ { HEX: 66 HEX: 0f HEX: c4 HEX: c1 HEX: 02 } ] [ [ XMM0 ECX 2 PINSRW ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: c4 HEX: 04 HEX: 11 HEX: 03 } ] [ [ XMM0 ECX EDX [+] 3 PINSRW ] { } make ] unit-test + +[ { HEX: 66 HEX: 0f HEX: c5 HEX: c1 HEX: 02 } ] [ [ EAX XMM1 2 PEXTRW ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 3a HEX: 15 HEX: 08 HEX: 02 } ] [ [ EAX [] XMM1 2 PEXTRW ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 3a HEX: 15 HEX: 14 HEX: 08 HEX: 03 } ] [ [ EAX ECX [+] XMM2 3 PEXTRW ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 3a HEX: 14 HEX: c8 HEX: 02 } ] [ [ EAX XMM1 2 PEXTRB ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 3a HEX: 14 HEX: 08 HEX: 02 } ] [ [ EAX [] XMM1 2 PEXTRB ] { } make ] unit-test + +! sse shift instructions +[ { HEX: 66 HEX: 0f HEX: 71 HEX: d0 HEX: 05 } ] [ [ XMM0 5 PSRLW ] { } make ] unit-test + +! sse comparison instructions +[ { HEX: 66 HEX: 0f HEX: c2 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 CMPLEPD ] { } make ] unit-test + +! unique sse instructions +[ { HEX: 0f HEX: 18 HEX: 00 } ] [ [ EAX [] PREFETCHNTA ] { } make ] unit-test +[ { HEX: 0f HEX: 18 HEX: 08 } ] [ [ EAX [] PREFETCHT0 ] { } make ] unit-test +[ { HEX: 0f HEX: 18 HEX: 10 } ] [ [ EAX [] PREFETCHT1 ] { } make ] unit-test +[ { HEX: 0f HEX: 18 HEX: 18 } ] [ [ EAX [] PREFETCHT2 ] { } make ] unit-test +[ { HEX: 0f HEX: ae HEX: 10 } ] [ [ EAX [] LDMXCSR ] { } make ] unit-test +[ { HEX: 0f HEX: ae HEX: 18 } ] [ [ EAX [] STMXCSR ] { } make ] unit-test + +[ { HEX: 0f HEX: c3 HEX: 08 } ] [ [ EAX [] ECX MOVNTI ] { } make ] unit-test + +[ { HEX: 0f HEX: 50 HEX: c1 } ] [ [ EAX XMM1 MOVMSKPS ] { } make ] unit-test +[ { HEX: 66 HEX: 0f HEX: 50 HEX: c1 } ] [ [ EAX XMM1 MOVMSKPD ] { } make ] unit-test + +[ { HEX: f3 HEX: 0f HEX: b8 HEX: c1 } ] [ [ EAX ECX POPCNT ] { } make ] unit-test +[ { HEX: f3 HEX: 48 HEX: 0f HEX: b8 HEX: c1 } ] [ [ RAX RCX POPCNT ] { } make ] unit-test +[ { HEX: f3 HEX: 0f HEX: b8 HEX: 01 } ] [ [ EAX ECX [] POPCNT ] { } make ] unit-test +[ { HEX: f3 HEX: 0f HEX: b8 HEX: 04 HEX: 11 } ] [ [ EAX ECX EDX [+] POPCNT ] { } make ] unit-test + +[ { HEX: f2 HEX: 0f HEX: 38 HEX: f0 HEX: c1 } ] [ [ EAX CL CRC32B ] { } make ] unit-test +[ { HEX: f2 HEX: 0f HEX: 38 HEX: f0 HEX: 01 } ] [ [ EAX ECX [] CRC32B ] { } make ] unit-test +[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: c1 } ] [ [ EAX ECX CRC32 ] { } make ] unit-test +[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: 01 } ] [ [ EAX ECX [] CRC32 ] { } make ] unit-test + +! memory address modes [ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test [ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test [ { HEX: 8b HEX: 18 } ] [ [ EBX RAX [] MOV ] { } make ] unit-test @@ -72,3 +143,4 @@ IN: cpu.x86.assembler.tests [ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } make ] unit-test [ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test + diff --git a/basis/cpu/x86/assembler/assembler.factor b/basis/cpu/x86/assembler/assembler.factor index 95b85ac2dd..e91ebdcb1a 100644 --- a/basis/cpu/x86/assembler/assembler.factor +++ b/basis/cpu/x86/assembler/assembler.factor @@ -3,6 +3,7 @@ USING: arrays io.binary kernel combinators kernel.private math namespaces make sequences words system layouts math.order accessors cpu.x86.assembler.syntax ; +QUALIFIED: sequences IN: cpu.x86.assembler ! A postfix assembler for x86-32 and x86-64. @@ -12,11 +13,16 @@ IN: cpu.x86.assembler ! Beware! ! Register operands -- eg, ECX -REGISTERS: 8 AL CL DL BL ; +REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ; -REGISTERS: 16 AX CX DX BX SP BP SI DI ; +ALIAS: AH SPL +ALIAS: CH BPL +ALIAS: DH SIL +ALIAS: BH DIL -REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ; +REGISTERS: 16 AX CX DX BX SP BP SI DI R8W R9W R10W R11W R12W R13W R14W R15W ; + +REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI R8D R9D R10D R11D R12D R13D R14D R15D ; REGISTERS: 64 RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ; @@ -212,7 +218,8 @@ M: object operand-64? drop f ; : opcode, ( opcode -- ) dup array? [ % ] [ , ] if ; -: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ; +: extended-opcode ( opcode -- opcode' ) + dup array? [ OCT: 17 sequences:prefix ] [ OCT: 17 swap 2array ] if ; : extended-opcode, ( opcode -- ) extended-opcode opcode, ; @@ -451,6 +458,9 @@ M: operand TEST OCT: 204 2-operand ; ! Misc : NOP ( -- ) HEX: 90 , ; +: PAUSE ( -- ) HEX: f3 , HEX: 90 , ; + +: RDPMC ( -- ) HEX: 0f , HEX: 33 , ; ! x87 Floating Point Unit @@ -468,26 +478,313 @@ M: operand TEST OCT: 204 2-operand ; pick register-128? [ swapd ] [ BIN: 1 bitor ] if ; : 2-operand-sse ( dst src op1 op2 -- ) - , direction-bit-sse extended-opcode (2-operand) ; + [ , ] when* direction-bit-sse extended-opcode (2-operand) ; + +: direction-op-sse ( dst src op1s -- dst' src' op1' ) + pick register-128? [ swapd first ] [ second ] if ; + +: 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- ) + [ , ] when* direction-op-sse extended-opcode (2-operand) ; + +: 2-operand-rm-sse ( dst src op1 op2 -- ) + [ , ] when* swapd extended-opcode (2-operand) ; + +: 2-operand-mr-sse ( dst src op1 op2 -- ) + [ , ] when* extended-opcode (2-operand) ; : 2-operand-int/sse ( dst src op1 op2 -- ) - , swapd extended-opcode (2-operand) ; + [ , ] when* swapd extended-opcode (2-operand) ; + +: 3-operand-rm-sse ( dst src imm op1 op2 -- ) + rot [ 2-operand-rm-sse ] dip , ; + +: 3-operand-mr-sse ( dst src imm op1 op2 -- ) + rot [ 2-operand-mr-sse ] dip , ; +: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- ) + rot [ 2-operand-rm-mr-sse ] dip , ; + +: 2-operand-sse-cmp ( dst src cmp op1 op2 -- ) + 3-operand-rm-sse ; inline + +: 2-operand-sse-shift ( dst imm reg op1 op2 -- ) + [ , ] when* + [ f HEX: 0f ] dip 2array 3array + swapd 1-operand , ; + +PRIVATE> + +: MOVUPS ( dest src -- ) HEX: 10 f 2-operand-sse ; +: MOVUPD ( dest src -- ) HEX: 10 HEX: 66 2-operand-sse ; +: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ; +: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ; +: MOVLPS ( dest src -- ) HEX: 12 f 2-operand-sse ; +: MOVLPD ( dest src -- ) HEX: 12 HEX: 66 2-operand-sse ; +: MOVDDUP ( dest src -- ) HEX: 12 HEX: f2 2-operand-rm-sse ; +: MOVSLDUP ( dest src -- ) HEX: 12 HEX: f3 2-operand-rm-sse ; +: UNPCKLPS ( dest src -- ) HEX: 14 f 2-operand-rm-sse ; +: UNPCKLPD ( dest src -- ) HEX: 14 HEX: 66 2-operand-rm-sse ; +: UNPCKHPS ( dest src -- ) HEX: 15 f 2-operand-rm-sse ; +: UNPCKHPD ( dest src -- ) HEX: 15 HEX: 66 2-operand-rm-sse ; +: MOVHPS ( dest src -- ) HEX: 16 f 2-operand-sse ; +: MOVHPD ( dest src -- ) HEX: 16 HEX: 66 2-operand-sse ; +: MOVSHDUP ( dest src -- ) HEX: 16 HEX: f3 2-operand-rm-sse ; + +: PREFETCHNTA ( mem -- ) { BIN: 000 f { HEX: 0f HEX: 18 } } 1-operand ; +: PREFETCHT0 ( mem -- ) { BIN: 001 f { HEX: 0f HEX: 18 } } 1-operand ; +: PREFETCHT1 ( mem -- ) { BIN: 010 f { HEX: 0f HEX: 18 } } 1-operand ; +: PREFETCHT2 ( mem -- ) { BIN: 011 f { HEX: 0f HEX: 18 } } 1-operand ; + +: MOVAPS ( dest src -- ) HEX: 28 f 2-operand-sse ; +: MOVAPD ( dest src -- ) HEX: 28 HEX: 66 2-operand-sse ; +: CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ; +: CVTSI2SS ( dest src -- ) HEX: 2a HEX: f3 2-operand-int/sse ; +: MOVNTPS ( dest src -- ) HEX: 2b f 2-operand-mr-sse ; +: MOVNTPD ( dest src -- ) HEX: 2b HEX: 66 2-operand-mr-sse ; +: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ; +: CVTTSS2SI ( dest src -- ) HEX: 2c HEX: f3 2-operand-int/sse ; +: CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ; +: CVTSS2SI ( dest src -- ) HEX: 2d HEX: f3 2-operand-int/sse ; +: UCOMISS ( dest src -- ) HEX: 2e f 2-operand-rm-sse ; +: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-rm-sse ; +: COMISS ( dest src -- ) HEX: 2f f 2-operand-rm-sse ; +: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-rm-sse ; + +: PSHUFB ( dest src -- ) { HEX: 38 HEX: 00 } HEX: 66 2-operand-rm-sse ; +: PHADDW ( dest src -- ) { HEX: 38 HEX: 01 } HEX: 66 2-operand-rm-sse ; +: PHADDD ( dest src -- ) { HEX: 38 HEX: 02 } HEX: 66 2-operand-rm-sse ; +: PHADDSW ( dest src -- ) { HEX: 38 HEX: 03 } HEX: 66 2-operand-rm-sse ; +: PMADDUBSW ( dest src -- ) { HEX: 38 HEX: 04 } HEX: 66 2-operand-rm-sse ; +: PHSUBW ( dest src -- ) { HEX: 38 HEX: 05 } HEX: 66 2-operand-rm-sse ; +: PHSUBD ( dest src -- ) { HEX: 38 HEX: 06 } HEX: 66 2-operand-rm-sse ; +: PHSUBSW ( dest src -- ) { HEX: 38 HEX: 07 } HEX: 66 2-operand-rm-sse ; +: PSIGNB ( dest src -- ) { HEX: 38 HEX: 08 } HEX: 66 2-operand-rm-sse ; +: PSIGNW ( dest src -- ) { HEX: 38 HEX: 09 } HEX: 66 2-operand-rm-sse ; +: PSIGND ( dest src -- ) { HEX: 38 HEX: 0a } HEX: 66 2-operand-rm-sse ; +: PMULHRSW ( dest src -- ) { HEX: 38 HEX: 0b } HEX: 66 2-operand-rm-sse ; +: PBLENDVB ( dest src -- ) { HEX: 38 HEX: 10 } HEX: 66 2-operand-rm-sse ; +: BLENDVPS ( dest src -- ) { HEX: 38 HEX: 14 } HEX: 66 2-operand-rm-sse ; +: BLENDVPD ( dest src -- ) { HEX: 38 HEX: 15 } HEX: 66 2-operand-rm-sse ; +: PTEST ( dest src -- ) { HEX: 38 HEX: 17 } HEX: 66 2-operand-rm-sse ; +: PABSB ( dest src -- ) { HEX: 38 HEX: 1c } HEX: 66 2-operand-rm-sse ; +: PABSW ( dest src -- ) { HEX: 38 HEX: 1d } HEX: 66 2-operand-rm-sse ; +: PABSD ( dest src -- ) { HEX: 38 HEX: 1e } HEX: 66 2-operand-rm-sse ; +: PMOVSXBW ( dest src -- ) { HEX: 38 HEX: 20 } HEX: 66 2-operand-rm-sse ; +: PMOVSXBD ( dest src -- ) { HEX: 38 HEX: 21 } HEX: 66 2-operand-rm-sse ; +: PMOVSXBQ ( dest src -- ) { HEX: 38 HEX: 22 } HEX: 66 2-operand-rm-sse ; +: PMOVSXWD ( dest src -- ) { HEX: 38 HEX: 23 } HEX: 66 2-operand-rm-sse ; +: PMOVSXWQ ( dest src -- ) { HEX: 38 HEX: 24 } HEX: 66 2-operand-rm-sse ; +: PMOVSXDQ ( dest src -- ) { HEX: 38 HEX: 25 } HEX: 66 2-operand-rm-sse ; +: PMULDQ ( dest src -- ) { HEX: 38 HEX: 28 } HEX: 66 2-operand-rm-sse ; +: PCMPEQQ ( dest src -- ) { HEX: 38 HEX: 29 } HEX: 66 2-operand-rm-sse ; +: MOVNTDQA ( dest src -- ) { HEX: 38 HEX: 2a } HEX: 66 2-operand-rm-sse ; +: PACKUSDW ( dest src -- ) { HEX: 38 HEX: 2b } HEX: 66 2-operand-rm-sse ; +: PMOVZXBW ( dest src -- ) { HEX: 38 HEX: 30 } HEX: 66 2-operand-rm-sse ; +: PMOVZXBD ( dest src -- ) { HEX: 38 HEX: 31 } HEX: 66 2-operand-rm-sse ; +: PMOVZXBQ ( dest src -- ) { HEX: 38 HEX: 32 } HEX: 66 2-operand-rm-sse ; +: PMOVZXWD ( dest src -- ) { HEX: 38 HEX: 33 } HEX: 66 2-operand-rm-sse ; +: PMOVZXWQ ( dest src -- ) { HEX: 38 HEX: 34 } HEX: 66 2-operand-rm-sse ; +: PMOVZXDQ ( dest src -- ) { HEX: 38 HEX: 35 } HEX: 66 2-operand-rm-sse ; +: PCMPGTQ ( dest src -- ) { HEX: 38 HEX: 37 } HEX: 66 2-operand-rm-sse ; +: PMINSB ( dest src -- ) { HEX: 38 HEX: 38 } HEX: 66 2-operand-rm-sse ; +: PMINSD ( dest src -- ) { HEX: 38 HEX: 39 } HEX: 66 2-operand-rm-sse ; +: PMINUW ( dest src -- ) { HEX: 38 HEX: 3a } HEX: 66 2-operand-rm-sse ; +: PMINUD ( dest src -- ) { HEX: 38 HEX: 3b } HEX: 66 2-operand-rm-sse ; +: PMAXSB ( dest src -- ) { HEX: 38 HEX: 3c } HEX: 66 2-operand-rm-sse ; +: PMAXSD ( dest src -- ) { HEX: 38 HEX: 3d } HEX: 66 2-operand-rm-sse ; +: PMAXUW ( dest src -- ) { HEX: 38 HEX: 3e } HEX: 66 2-operand-rm-sse ; +: PMAXUD ( dest src -- ) { HEX: 38 HEX: 3f } HEX: 66 2-operand-rm-sse ; +: PMULLD ( dest src -- ) { HEX: 38 HEX: 40 } HEX: 66 2-operand-rm-sse ; +: PHMINPOSUW ( dest src -- ) { HEX: 38 HEX: 41 } HEX: 66 2-operand-rm-sse ; +: CRC32B ( dest src -- ) { HEX: 38 HEX: f0 } HEX: f2 2-operand-rm-sse ; +: CRC32 ( dest src -- ) { HEX: 38 HEX: f1 } HEX: f2 2-operand-rm-sse ; + +: ROUNDPS ( dest src imm -- ) { HEX: 3a HEX: 08 } HEX: 66 3-operand-rm-sse ; +: ROUNDPD ( dest src imm -- ) { HEX: 3a HEX: 09 } HEX: 66 3-operand-rm-sse ; +: ROUNDSS ( dest src imm -- ) { HEX: 3a HEX: 0a } HEX: 66 3-operand-rm-sse ; +: ROUNDSD ( dest src imm -- ) { HEX: 3a HEX: 0b } HEX: 66 3-operand-rm-sse ; +: BLENDPS ( dest src imm -- ) { HEX: 3a HEX: 0c } HEX: 66 3-operand-rm-sse ; +: BLENDPD ( dest src imm -- ) { HEX: 3a HEX: 0d } HEX: 66 3-operand-rm-sse ; +: PBLENDW ( dest src imm -- ) { HEX: 3a HEX: 0e } HEX: 66 3-operand-rm-sse ; +: PALIGNR ( dest src imm -- ) { HEX: 3a HEX: 0f } HEX: 66 3-operand-rm-sse ; + +: PEXTRB ( dest src imm -- ) { HEX: 3a HEX: 14 } HEX: 66 3-operand-mr-sse ; + + -: MOVSS ( dest src -- ) HEX: 10 HEX: f3 2-operand-sse ; -: MOVSD ( dest src -- ) HEX: 10 HEX: f2 2-operand-sse ; -: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-sse ; -: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-sse ; -: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-sse ; -: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-sse ; -: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-sse ; -: UCOMISD ( dest src -- ) HEX: 2e HEX: 66 2-operand-sse ; -: COMISD ( dest src -- ) HEX: 2f HEX: 66 2-operand-sse ; - -: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ; -: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-sse ; - -: CVTSI2SD ( dest src -- ) HEX: 2a HEX: f2 2-operand-int/sse ; -: CVTSD2SI ( dest src -- ) HEX: 2d HEX: f2 2-operand-int/sse ; -: CVTTSD2SI ( dest src -- ) HEX: 2c HEX: f2 2-operand-int/sse ; +: PEXTRW ( dest src imm -- ) pick indirect? [ (PEXTRW-sse4) ] [ (PEXTRW-sse1) ] if ; +: PEXTRD ( dest src imm -- ) { HEX: 3a HEX: 16 } HEX: 66 3-operand-mr-sse ; +ALIAS: PEXTRQ PEXTRD +: EXTRACTPS ( dest src imm -- ) { HEX: 3a HEX: 17 } HEX: 66 3-operand-mr-sse ; + +: PINSRB ( dest src imm -- ) { HEX: 3a HEX: 20 } HEX: 66 3-operand-rm-sse ; +: INSERTPS ( dest src imm -- ) { HEX: 3a HEX: 21 } HEX: 66 3-operand-rm-sse ; +: PINSRD ( dest src imm -- ) { HEX: 3a HEX: 22 } HEX: 66 3-operand-rm-sse ; +ALIAS: PINSRQ PINSRD +: DPPS ( dest src imm -- ) { HEX: 3a HEX: 40 } HEX: 66 3-operand-rm-sse ; +: DPPD ( dest src imm -- ) { HEX: 3a HEX: 41 } HEX: 66 3-operand-rm-sse ; +: MPSADBW ( dest src imm -- ) { HEX: 3a HEX: 42 } HEX: 66 3-operand-rm-sse ; +: PCMPESTRM ( dest src imm -- ) { HEX: 3a HEX: 60 } HEX: 66 3-operand-rm-sse ; +: PCMPESTRI ( dest src imm -- ) { HEX: 3a HEX: 61 } HEX: 66 3-operand-rm-sse ; +: PCMPISTRM ( dest src imm -- ) { HEX: 3a HEX: 62 } HEX: 66 3-operand-rm-sse ; +: PCMPISTRI ( dest src imm -- ) { HEX: 3a HEX: 63 } HEX: 66 3-operand-rm-sse ; + +: MOVMSKPS ( dest src -- ) HEX: 50 f 2-operand-int/sse ; +: MOVMSKPD ( dest src -- ) HEX: 50 HEX: 66 2-operand-int/sse ; +: SQRTPS ( dest src -- ) HEX: 51 f 2-operand-rm-sse ; +: SQRTPD ( dest src -- ) HEX: 51 HEX: 66 2-operand-rm-sse ; +: SQRTSD ( dest src -- ) HEX: 51 HEX: f2 2-operand-rm-sse ; +: SQRTSS ( dest src -- ) HEX: 51 HEX: f3 2-operand-rm-sse ; +: RSQRTPS ( dest src -- ) HEX: 52 f 2-operand-rm-sse ; +: RSQRTSS ( dest src -- ) HEX: 52 HEX: f3 2-operand-rm-sse ; +: RCPPS ( dest src -- ) HEX: 53 f 2-operand-rm-sse ; +: RCPSS ( dest src -- ) HEX: 53 HEX: f3 2-operand-rm-sse ; +: ANDPS ( dest src -- ) HEX: 54 f 2-operand-rm-sse ; +: ANDPD ( dest src -- ) HEX: 54 HEX: 66 2-operand-rm-sse ; +: ANDNPS ( dest src -- ) HEX: 55 f 2-operand-rm-sse ; +: ANDNPD ( dest src -- ) HEX: 55 HEX: 66 2-operand-rm-sse ; +: ORPS ( dest src -- ) HEX: 56 f 2-operand-rm-sse ; +: ORPD ( dest src -- ) HEX: 56 HEX: 66 2-operand-rm-sse ; +: XORPS ( dest src -- ) HEX: 57 f 2-operand-rm-sse ; +: XORPD ( dest src -- ) HEX: 57 HEX: 66 2-operand-rm-sse ; +: ADDPS ( dest src -- ) HEX: 58 f 2-operand-rm-sse ; +: ADDPD ( dest src -- ) HEX: 58 HEX: 66 2-operand-rm-sse ; +: ADDSD ( dest src -- ) HEX: 58 HEX: f2 2-operand-rm-sse ; +: ADDSS ( dest src -- ) HEX: 58 HEX: f3 2-operand-rm-sse ; +: MULPS ( dest src -- ) HEX: 59 f 2-operand-rm-sse ; +: MULPD ( dest src -- ) HEX: 59 HEX: 66 2-operand-rm-sse ; +: MULSD ( dest src -- ) HEX: 59 HEX: f2 2-operand-rm-sse ; +: MULSS ( dest src -- ) HEX: 59 HEX: f3 2-operand-rm-sse ; +: CVTPS2PD ( dest src -- ) HEX: 5a f 2-operand-rm-sse ; +: CVTPD2PS ( dest src -- ) HEX: 5a HEX: 66 2-operand-rm-sse ; +: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-rm-sse ; +: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-rm-sse ; +: CVTDQ2PS ( dest src -- ) HEX: 5b f 2-operand-rm-sse ; +: CVTPS2DQ ( dest src -- ) HEX: 5b HEX: 66 2-operand-rm-sse ; +: CVTTPS2DQ ( dest src -- ) HEX: 5b HEX: f3 2-operand-rm-sse ; +: SUBPS ( dest src -- ) HEX: 5c f 2-operand-rm-sse ; +: SUBPD ( dest src -- ) HEX: 5c HEX: 66 2-operand-rm-sse ; +: SUBSD ( dest src -- ) HEX: 5c HEX: f2 2-operand-rm-sse ; +: SUBSS ( dest src -- ) HEX: 5c HEX: f3 2-operand-rm-sse ; +: MINPS ( dest src -- ) HEX: 5d f 2-operand-rm-sse ; +: MINPD ( dest src -- ) HEX: 5d HEX: 66 2-operand-rm-sse ; +: MINSD ( dest src -- ) HEX: 5d HEX: f2 2-operand-rm-sse ; +: MINSS ( dest src -- ) HEX: 5d HEX: f3 2-operand-rm-sse ; +: DIVPS ( dest src -- ) HEX: 5e f 2-operand-rm-sse ; +: DIVPD ( dest src -- ) HEX: 5e HEX: 66 2-operand-rm-sse ; +: DIVSD ( dest src -- ) HEX: 5e HEX: f2 2-operand-rm-sse ; +: DIVSS ( dest src -- ) HEX: 5e HEX: f3 2-operand-rm-sse ; +: MAXPS ( dest src -- ) HEX: 5f f 2-operand-rm-sse ; +: MAXPD ( dest src -- ) HEX: 5f HEX: 66 2-operand-rm-sse ; +: MAXSD ( dest src -- ) HEX: 5f HEX: f2 2-operand-rm-sse ; +: MAXSS ( dest src -- ) HEX: 5f HEX: f3 2-operand-rm-sse ; +: PUNPCKLQDQ ( dest src -- ) HEX: 6c HEX: 66 2-operand-rm-sse ; +: PUNPCKHQDQ ( dest src -- ) HEX: 6d HEX: 66 2-operand-rm-sse ; + +: MOVDQA ( dest src -- ) { HEX: 6f HEX: 7f } HEX: 66 2-operand-rm-mr-sse ; +: MOVDQU ( dest src -- ) { HEX: 6f HEX: 7f } HEX: f3 2-operand-rm-mr-sse ; + +: PSHUFD ( dest src imm -- ) HEX: 70 HEX: 66 3-operand-rm-sse ; +: PSHUFLW ( dest src imm -- ) HEX: 70 HEX: f2 3-operand-rm-sse ; +: PSHUFHW ( dest src imm -- ) HEX: 70 HEX: f3 3-operand-rm-sse ; +: PSRLW ( dest imm -- ) BIN: 010 HEX: 71 HEX: 66 2-operand-sse-shift ; +: PSRAW ( dest imm -- ) BIN: 100 HEX: 71 HEX: 66 2-operand-sse-shift ; +: PSLLW ( dest imm -- ) BIN: 110 HEX: 71 HEX: 66 2-operand-sse-shift ; +: PSRLD ( dest imm -- ) BIN: 010 HEX: 72 HEX: 66 2-operand-sse-shift ; +: PSRAD ( dest imm -- ) BIN: 100 HEX: 72 HEX: 66 2-operand-sse-shift ; +: PSLLD ( dest imm -- ) BIN: 110 HEX: 72 HEX: 66 2-operand-sse-shift ; +: PSRLQ ( dest imm -- ) BIN: 010 HEX: 73 HEX: 66 2-operand-sse-shift ; +: PSRLDQ ( dest imm -- ) BIN: 011 HEX: 73 HEX: 66 2-operand-sse-shift ; +: PSLLQ ( dest imm -- ) BIN: 110 HEX: 73 HEX: 66 2-operand-sse-shift ; +: PSLLDQ ( dest imm -- ) BIN: 111 HEX: 73 HEX: 66 2-operand-sse-shift ; + +: PCMPEQB ( dest src -- ) HEX: 74 HEX: 66 2-operand-rm-sse ; +: PCMPEQW ( dest src -- ) HEX: 75 HEX: 66 2-operand-rm-sse ; +: PCMPEQD ( dest src -- ) HEX: 76 HEX: 66 2-operand-rm-sse ; +: HADDPD ( dest src -- ) HEX: 7c HEX: 66 2-operand-rm-sse ; +: HADDPS ( dest src -- ) HEX: 7c HEX: f2 2-operand-rm-sse ; +: HSUBPD ( dest src -- ) HEX: 7d HEX: 66 2-operand-rm-sse ; +: HSUBPS ( dest src -- ) HEX: 7d HEX: f2 2-operand-rm-sse ; + +: LDMXCSR ( src -- ) { BIN: 010 f { HEX: 0f HEX: ae } } 1-operand ; +: STMXCSR ( dest -- ) { BIN: 011 f { HEX: 0f HEX: ae } } 1-operand ; +: LFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 350 , ; +: MFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 360 , ; +: SFENCE ( -- ) HEX: 0f , HEX: ae , OCT: 370 , ; + +: POPCNT ( dest src -- ) HEX: b8 HEX: f3 2-operand-rm-sse ; + +: CMPEQPS ( dest src -- ) 0 HEX: c2 f 2-operand-sse-cmp ; +: CMPLTPS ( dest src -- ) 1 HEX: c2 f 2-operand-sse-cmp ; +: CMPLEPS ( dest src -- ) 2 HEX: c2 f 2-operand-sse-cmp ; +: CMPUNORDPS ( dest src -- ) 3 HEX: c2 f 2-operand-sse-cmp ; +: CMPNEQPS ( dest src -- ) 4 HEX: c2 f 2-operand-sse-cmp ; +: CMPNLTPS ( dest src -- ) 5 HEX: c2 f 2-operand-sse-cmp ; +: CMPNLEPS ( dest src -- ) 6 HEX: c2 f 2-operand-sse-cmp ; +: CMPORDPS ( dest src -- ) 7 HEX: c2 f 2-operand-sse-cmp ; + +: CMPEQPD ( dest src -- ) 0 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPLTPD ( dest src -- ) 1 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPLEPD ( dest src -- ) 2 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPUNORDPD ( dest src -- ) 3 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPNEQPD ( dest src -- ) 4 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPNLTPD ( dest src -- ) 5 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPNLEPD ( dest src -- ) 6 HEX: c2 HEX: 66 2-operand-sse-cmp ; +: CMPORDPD ( dest src -- ) 7 HEX: c2 HEX: 66 2-operand-sse-cmp ; + +: CMPEQSD ( dest src -- ) 0 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPLTSD ( dest src -- ) 1 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPLESD ( dest src -- ) 2 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPUNORDSD ( dest src -- ) 3 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPNEQSD ( dest src -- ) 4 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPNLTSD ( dest src -- ) 5 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPNLESD ( dest src -- ) 6 HEX: c2 HEX: f2 2-operand-sse-cmp ; +: CMPORDSD ( dest src -- ) 7 HEX: c2 HEX: f2 2-operand-sse-cmp ; + +: CMPEQSS ( dest src -- ) 0 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPLTSS ( dest src -- ) 1 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPLESS ( dest src -- ) 2 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPUNORDSS ( dest src -- ) 3 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPNEQSS ( dest src -- ) 4 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPNLTSS ( dest src -- ) 5 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPNLESS ( dest src -- ) 6 HEX: c2 HEX: f3 2-operand-sse-cmp ; +: CMPORDSS ( dest src -- ) 7 HEX: c2 HEX: f3 2-operand-sse-cmp ; + +: MOVNTI ( dest src -- ) { HEX: 0f HEX: c3 } (2-operand) ; + +: PINSRW ( dest src imm -- ) HEX: c4 HEX: 66 3-operand-rm-sse ; +: SHUFPS ( dest src imm -- ) HEX: c6 f 3-operand-rm-sse ; +: SHUFPD ( dest src imm -- ) HEX: c6 HEX: 66 3-operand-rm-sse ; + +: ADDSUBPD ( dest src -- ) HEX: d0 HEX: 66 2-operand-rm-sse ; +: ADDSUBPS ( dest src -- ) HEX: d0 HEX: f2 2-operand-rm-sse ; +: PADDQ ( dest src -- ) HEX: d4 HEX: 66 2-operand-rm-sse ; +: PMINUB ( dest src -- ) HEX: da HEX: 66 2-operand-rm-sse ; +: PMAXUB ( dest src -- ) HEX: de HEX: 66 2-operand-rm-sse ; +: PAVGB ( dest src -- ) HEX: e0 HEX: 66 2-operand-rm-sse ; +: PAVGW ( dest src -- ) HEX: e3 HEX: 66 2-operand-rm-sse ; +: PMULHUW ( dest src -- ) HEX: e4 HEX: 66 2-operand-rm-sse ; +: CVTTPD2DQ ( dest src -- ) HEX: e6 HEX: 66 2-operand-rm-sse ; +: CVTPD2DQ ( dest src -- ) HEX: e6 HEX: f2 2-operand-rm-sse ; +: CVTDQ2PD ( dest src -- ) HEX: e6 HEX: f3 2-operand-rm-sse ; + +: MOVNTDQ ( dest src -- ) HEX: e7 HEX: 66 2-operand-mr-sse ; + +: PMINSW ( dest src -- ) HEX: ea HEX: 66 2-operand-rm-sse ; +: PMAXSW ( dest src -- ) HEX: ee HEX: 66 2-operand-rm-sse ; +: LDDQU ( dest src -- ) HEX: f0 HEX: f2 2-operand-rm-sse ; +: PMULUDQ ( dest src -- ) HEX: f4 HEX: 66 2-operand-rm-sse ; +: PSADBW ( dest src -- ) HEX: f6 HEX: 66 2-operand-rm-sse ; + +: MASKMOVDQU ( dest src -- ) HEX: f7 HEX: 66 2-operand-rm-sse ; + +: PSUBQ ( dest src -- ) HEX: fb HEX: 66 2-operand-rm-sse ; + +! x86-64 branch prediction hints + +: HWNT ( -- ) HEX: 2e , ; ! Hint branch Weakly Not Taken +: HST ( -- ) HEX: 3e , ; ! Hint branch Strongly Taken + diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 6b4a93885c..258f842598 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -56,7 +56,7 @@ HOOK: param-reg-2 cpu ( -- reg ) HOOK: pic-tail-reg cpu ( -- reg ) -M: x86 %load-immediate MOV ; +M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ; M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ; @@ -108,10 +108,10 @@ M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ; M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ; M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ; -M: x86 %add [+] LEA ; -M: x86 %add-imm [+] LEA ; +M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ; +M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ; M: x86 %sub nip SUB ; -M: x86 %sub-imm neg [+] LEA ; +M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ; M: x86 %mul nip swap IMUL2 ; M: x86 %mul-imm IMUL3 ; M: x86 %and nip AND ; diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor index a3e5c7ceb7..80ab2f58bf 100644 --- a/basis/disjoint-sets/disjoint-sets.factor +++ b/basis/disjoint-sets/disjoint-sets.factor @@ -35,6 +35,8 @@ TUPLE: disjoint-set : representative? ( a disjoint-set -- ? ) dupd parent = ; inline +PRIVATE> + GENERIC: representative ( a disjoint-set -- p ) M: disjoint-set representative @@ -42,6 +44,8 @@ M: disjoint-set representative [ [ parent ] keep representative dup ] 2keep set-parent ] if ; +spaces "\t" "\s" ; +M: byte-array disassemble + [ + [ malloc-byte-array &free alien-address dup ] + [ length + ] bi + 2array disassemble + ] with-destructors ; + M: pair disassemble first2 disassemble* [ tabs>spaces print ] each ; M: word disassemble word-xt 2array disassemble ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 3c39848d02..6d221c1380 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -106,7 +106,7 @@ PREDICATE: empty-union < anonymous-union members>> empty? ; PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; -: (class<=) ( first second -- -1/0/1 ) +: (class<=) ( first second -- ? ) 2dup eq? [ 2drop t ] [ 2dup superclass<= [ 2drop t ] [ [ normalize-class ] bi@ { diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 6eea872343..55d4bc9be9 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -633,6 +633,8 @@ PRIVATE> : last ( seq -- elt ) [ length 1 - ] [ nth ] bi ; +: set-last ( elt seq -- ) [ length 1 - ] keep set-nth ; + : pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ; > number>string ] bi@ " -> " glue write ";" print ] assoc-each + "}" print + ] with-file-writer + ] + [ { "dot" "-Tpng" "-O" } swap suffix try-process ] + [ ".png" append { "open" } swap suffix try-process ] + tri ; + +: cfg-edges ( cfg -- edges ) + [ + [ + dup successors>> [ + 2array , + ] with each + ] each-basic-block + ] { } make ; + +: render-cfg ( cfg -- ) cfg-edges render-graph ; + +: dom-edges ( cfg -- edges ) + [ + compute-predecessors + compute-dominance + dom-childrens get [ + [ + 2array , + ] with each + ] assoc-each + ] { } make ; + +: render-dom ( cfg -- ) dom-edges render-graph ; \ No newline at end of file