M: bit-array new-sequence drop <bit-array> ;
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 ] [
: 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
--- /dev/null
+Maxim Savchenko
+Slava Pestov
--- /dev/null
+! 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." } ;
--- /dev/null
+! 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 ;
+
M: growing-circular length length>> ;
<PRIVATE
+
: full? ( circular -- ? )
[ length ] [ seq>> length ] bi = ;
-: set-last ( elt seq -- )
- [ length 1- ] keep set-nth ;
PRIVATE>
: push-growing-circular ( elt circular -- )
! 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&& ;
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.
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
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*
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 ;
--- /dev/null
+! 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 ( -- )
+ <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>
+ 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 ;
+
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
{
[ ]
[ "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
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
- <cfg> procedures get push ;
+ [ basic-block get ] 2dip <cfg> 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 -- )
: 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 ;
: 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
: 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
[ [ [ 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 )
[ return>> return-size >>return ]
[ alien-parameters parameter-sizes drop >>params ] bi ;
-: alien-stack-frame ( params -- )
- <alien-stack-frame> ##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 <alien-stack-frame> ] dip call
+ alien-node-height
+ ] emit-trivial-block ; inline
M: #alien-invoke emit-node
[ ##alien-invoke ] emit-alien-node ;
! 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 ;
[ 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 ;
! 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 ;
-! 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
+
+<PRIVATE
+
+GENERIC: visit-insn ( insn -- )
+
+M: ##copy visit-insn record-copy ;
+
+M: ##phi visit-insn
+ [ dst>> ] [ 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 ;
--- /dev/null
+! 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 <simple-block> 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
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 ;
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 ;
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 )
! 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 ;
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
[ 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
[ ] [ 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
! 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:
[ '[ 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* ;
-<PRIVATE
-
-: compute-dom-frontier ( bb pred -- )
- 2dup [ dom-parent ] dip eq? [ 2drop ] [
- [ dom-frontiers get conjoin-at ]
- [ dom-parent compute-dom-frontier ] 2bi
- ] if ;
-
-: compute-dom-frontiers ( cfg -- )
- H{ } clone dom-frontiers set
- [
- dup predecessors>> 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* ;
<PRIVATE
-SYMBOLS: work-list visited ;
+: (compute-dfs) ( n bb -- n )
+ [ 1 + ] dip
+ [ dupd preorder get set-at ]
+ [ dom-children [ (compute-dfs) ] each ]
+ [ dupd maxpreorder get set-at ]
+ tri ;
-: add-to-work-list ( bb -- )
- dom-frontier work-list get push-all-front ;
-
-: iterated-dom-frontier-step ( bb -- )
- dup visited get key? [ drop ] [
- [ visited get conjoin ]
- [ add-to-work-list ] bi
- ] if ;
+: compute-dfs ( cfg -- )
+ H{ } clone preorder set
+ H{ } clone maxpreorder set
+ [ 0 ] dip entry>> (compute-dfs) drop ;
PRIVATE>
-: iterated-dom-frontier ( bbs -- bbs' )
- [
- <dlist> 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 )
+ <dlist> :> work-list
+ cfg post-order length <vector> :> 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
--- /dev/null
+! 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
: ^^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
: ^^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
INSN: ##inc-r { n integer } ;
! Subroutine calls
-INSN: ##stack-frame stack-frame ;
INSN: ##call word ;
INSN: ##jump word ;
INSN: ##return ;
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.
INSN: ##branch ;
-INSN: ##loop-entry ;
-
INSN: ##phi < ##pure inputs ;
! Conditionals
INSN: _label id ;
INSN: _branch label ;
+INSN: _loop-entry ;
INSN: _dispatch src temp ;
INSN: _dispatch-label label ;
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
-! 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 )
-! 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 -- )
compiler.cfg.stacks
compiler.cfg.instructions
compiler.cfg.utilities
+compiler.cfg.builder.blocks
compiler.cfg.registers
compiler.cfg.comparisons ;
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 ;
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
slots.private:set-slot
strings.private:string-nth
strings.private:set-string-nth-fast
- classes.tuple.private:<tuple-boa>
- arrays:<array>
- byte-arrays:<byte-array>
- byte-arrays:(byte-array)
- kernel:<wrapper>
+ ! classes.tuple.private:<tuple-boa>
+ ! byte-arrays:<byte-array>
+ ! byte-arrays:(byte-array)
+ ! kernel:<wrapper>
alien.accessors:alien-unsigned-1
alien.accessors:set-alien-unsigned-1
alien.accessors:alien-signed-1
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
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 ;
-! 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
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 ;
H{ } clone register-live-outs set
init-unhandled ;
-: handle-spill ( live-interval -- )
- dup spill-to>> [
- [ reg>> ] [ spill-to>> <spill-slot> ] [ 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 ;
[ [ 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?
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:
: linear-scan ( cfg -- cfg' )
[
- init-mapping
dup machine-registers (linear-scan)
spill-counts get >>spill-counts
cfg-changed
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 ;
+++ /dev/null
-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
+++ /dev/null
-! 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 <spill-slot> ]
- [ reg-class>> ]
- tri \ register->memory boa
- ] [
- [ reg-class>> spill-temp <spill-slot> ]
- [ 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
--- /dev/null
+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 <spill-slot> 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
! 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 )
[
[ 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 <simple-block>
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( cfg -- )
+ H{ } clone spill-temps set
[ resolve-block-data-flow ] each-basic-block ;
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.
#! 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
: 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 ;
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
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{
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{
}
]
[ 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
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 ] [ <reversed> ] bi* [
- [ uses-vregs [ over conjoin ] each ]
- [ defs-vregs [ over delete-at ] each ] bi
- ] each ;
+ [ clone ] [ <reversed> ] 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 ;
--- /dev/null
+! 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' )
+ <hashed-dlist> 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 ;
-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
! 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
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 ;
--- /dev/null
+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
--- /dev/null
+! 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
+
+<PRIVATE
+
+SYMBOLS: temp locs preds to-do ready ;
+
+: init-to-do ( bs -- )
+ to-do get push-all-back ;
+
+: init-ready ( bs -- )
+ locs get '[ _ key? not ] filter ready get push-all-front ;
+
+: init ( mapping temp -- )
+ temp set
+ <dlist> to-do set
+ <dlist> 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
+++ /dev/null
-Slava Pestov
-Daniel Ehrenberg
+++ /dev/null
-! 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
+++ /dev/null
-! 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 ;
--- /dev/null
+! 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
! 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 ;
--- /dev/null
+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
--- /dev/null
+! 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
+
+<PRIVATE
+
+! Maps vregs to sets of basic blocks
+SYMBOL: defs
+
+! Set of vregs defined in more than one basic block
+SYMBOL: defs-multi
+
+: compute-insn-defs ( bb insn -- )
+ defs-vreg dup [
+ defs get [ conjoin-at ] [ drop ] [ at assoc-size 1 > ] 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
--- /dev/null
+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
--- /dev/null
+! 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
+
+<PRIVATE
+
+SYMBOLS: visited merge-sets levels again? ;
+
+: init-merge-sets ( cfg -- )
+ post-order dup length '[ _ <bit-array> ] 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
--- /dev/null
+! 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 <hashtable> [
+ '[
+ [
+ 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
--- /dev/null
+! 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
--- /dev/null
+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
--- /dev/null
+! 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 ;
+
+<PRIVATE
+
+: sort-vregs-by-bb ( vregs -- alist )
+ defs get
+ '[ dup _ at ] { } map>assoc
+ [ [ second pre-of ] compare ] sort ;
+
+: <dom-forest-node> ( vreg bb parent -- node )
+ [ V{ } clone dom-forest-node boa dup ] dip children>> push ;
+
+: <virtual-root> ( -- 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 <dom-forest-node> ] keep push ;
+
+PRIVATE>
+
+: compute-dom-forest ( vregs -- forest )
+ <virtual-root> [
+ 1vector
+ [ sort-vregs-by-bb ] dip
+ '[ _ (compute-dom-forest) ] assoc-each
+ ] keep children>> ;
--- /dev/null
+! 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
+
+<PRIVATE
+
+: kill-after-def? ( vreg1 vreg2 bb -- ? )
+ ! If first register is used after second one is defined, they interfere.
+ ! If they are used in the same instruction, no interference. If the
+ ! instruction is a def-is-use-insn, then there will be a use at +1
+ ! (instructions are 2 apart) and so outputs will interfere with
+ ! inputs.
+ [ kill-index ] [ def-index ] bi-curry bi* > ;
+
+: 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 ;
--- /dev/null
+! 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
+
+<PRIVATE
+
+SYMBOLS: local-def-indices local-kill-indices ;
+
+: record-def ( n vregs -- )
+ dup [ local-def-indices get set-at ] [ 2drop ] if ;
+
+: record-uses ( n vregs -- )
+ local-kill-indices get '[ _ set-at ] with each ;
+
+: visit-insn ( insn n -- )
+ ! Instructions are numbered 2 apart. If the instruction requires
+ ! that outputs are in different registers than the inputs, then
+ ! a use will be registered for every output immediately after
+ ! this instruction and before the next one, ensuring that outputs
+ ! interfere with inputs.
+ 2 *
+ [ swap defs-vreg record-def ]
+ [ swap uses-vregs record-uses ]
+ [ over def-is-use-insn? [ 1 + swap defs-vreg 1array record-uses ] [ 2drop ] if ]
+ 2tri ;
+
+SYMBOLS: def-indices kill-indices ;
+
+: compute-local-live-ranges ( bb -- )
+ H{ } clone local-def-indices set
+ H{ } clone local-kill-indices set
+ [ instructions>> [ 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 ;
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 )
+ <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 ;
--- /dev/null
+! 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 ;
+++ /dev/null
-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
+++ /dev/null
-! 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
-
-<PRIVATE
-
-! Maps vreg to sequence of basic blocks
-SYMBOL: defs
-
-! Maps basic blocks to sequences of vregs
-SYMBOL: inserting-phi-nodes
-
-: compute-defs ( cfg -- )
- H{ } clone dup defs set
- '[
- dup instructions>> [
- 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
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-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 }
-] [
- <state>
-
- <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
- <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
-
- <state> H{ { D 0 V int-regs 0 } } >>locs>vregs
- <state> 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
-] [
- <state>
-
- <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
- <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
-
- <state>
- <state> 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
-] [
- <state>
-
- <basic-block> V{ T{ ##branch } } >>instructions dup 1 set
- <basic-block> V{ T{ ##branch } } >>instructions dup 2 set 2array
-
- H{ } clone added-instructions set
- V{ } clone added-phis set
-
- <state> -1 >>ds-height
- <state> 2array
-
- [ merge-ds-heights ds-height>> ] { } make drop
- 1 get added-instructions get at first class
-] unit-test
-
-[
- 0
- { D 0 }
- { 1 1 }
-] [
- <state>
-
- <basic-block> V{ T{ ##branch } } >>instructions
- <basic-block> V{ T{ ##branch } } >>instructions 2array
-
- H{ } clone added-instructions set
- V{ } clone added-phis set
-
- [
- <state> -1 >>ds-height H{ { D 1 V int-regs 0 } } >>locs>vregs
- <state> 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 }
-] [
- <state>
-
- <basic-block> V{ T{ ##branch } } >>instructions
- <basic-block> V{ T{ ##branch } } >>instructions 2array
-
- H{ } clone added-instructions set
- V{ } clone added-phis set
-
- [
- <state> -1 >>ds-height H{ { D -1 V int-regs 0 } } >>locs>vregs
- <state> -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
+++ /dev/null
-! 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 <state> ;
-
-: 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? [
- <state>
- 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 ;
+++ /dev/null
-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 [ <array> ] [ 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
+++ /dev/null
-! 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' )
- [
- <hashed-dlist> 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 ;
+++ /dev/null
-! 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 )
- 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* - <ds-loc> ;
-M: rs-loc translate-loc [ n>> ] [ rs-height>> ] bi* - <rs-loc> ;
-
-GENERIC# untranslate-loc 1 ( loc state -- loc' )
-M: ds-loc untranslate-loc [ n>> ] [ ds-height>> ] bi* + <ds-loc> ;
-M: rs-loc untranslate-loc [ n>> ] [ rs-height>> ] bi* + <rs-loc> ;
-
-SYMBOL: work-list
-
-: add-to-work-list ( bb -- ) work-list get push-front ;
--- /dev/null
+! 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 ] [ <simple-block> 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
--- /dev/null
+! 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
--- /dev/null
+! 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* - <ds-loc> ;
+M: rs-loc translate-loc [ n>> ] [ rs-heights get at ] bi* - <rs-loc> ;
+
+: 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* + <ds-loc> ;
+M: rs-loc untranslate-loc [ n>> ] [ rs-heights get at ] bi* + <rs-loc> ;
+
+: untranslate-locs ( assoc bb -- assoc' )
+ '[ [ _ untranslate-loc ] dip ] assoc-map ;
\ No newline at end of file
--- /dev/null
+! 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>> - <ds-loc> ;
+M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
+
+: emit-stack-changes ( -- )
+ replace-mapping get dup assoc-empty? [ drop ] [
+ [ [ loc>vreg ] dip ] assoc-map parallel-copy
+ ] if ;
+
+: emit-height-changes ( -- )
+ 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 ;
-! 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 ( -- )
+ <bihash> 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 ]
- [ [ <reversed> [ <ds-loc> ^^peek ] map ] [ neg ##inc-d ] bi ] if ;
+ [ [ <reversed> [ <ds-loc> peek-loc ] map ] [ neg inc-d ] bi ] if ;
: ds-store ( vregs -- )
[
<reversed>
- [ length ##inc-d ]
- [ [ <ds-loc> ##replace ] each-index ] bi
+ [ length inc-d ]
+ [ [ <ds-loc> replace-loc ] each-index ] bi
] unless-empty ;
+: rs-drop ( -- ) -1 inc-r ;
+
: rs-load ( n -- vregs )
dup 0 =
[ drop f ]
- [ [ <reversed> [ <rs-loc> ^^peek ] map ] [ neg ##inc-r ] bi ] if ;
+ [ [ <reversed> [ <rs-loc> peek-loc ] map ] [ neg inc-r ] bi ] if ;
: rs-store ( vregs -- )
[
<reversed>
- [ length ##inc-r ]
- [ [ <rs-loc> ##replace ] each-index ] bi
+ [ length inc-r ]
+ [ [ <rs-loc> 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 ;
+
--- /dev/null
+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
! 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
! 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> 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 = ]
: 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
\ ##branch new-insn over push
>>instructions ;
-: insert-basic-blocks ( bb -- )
- [ added-instructions get ] dip
- '[ [ _ ] dip <simple-block> 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
! 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? [
: 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 ] }
: 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 ] }
: 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 ] }
: 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 ] }
] 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 ] }
[ 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 ]
: 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 ] }
[ 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 ]
[ 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? ;
: 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 ;
{ [ 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 ;
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 )
[
{
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 }
}
] [
{
[
{
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 }
}
] [
{
} 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 }
}
] [
{
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 }
}
] [
{
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 }
}
] [
{
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 }
}
] [
{
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 }
}
] [
{
{
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 }
}
] [
{
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 }
! 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
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 ;
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 ;
+ <simple-block> 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 }
}
] [
{
] 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
! 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.
! 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 ;
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
compiler.utilities ;
IN: compiler.codegen
+SYMBOL: insn-counts
+
+H{ } clone insn-counts set-global
+
GENERIC: generate-insn ( insn -- )
SYMBOL: registers
[ 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 ;
[ 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
[ 4294967295 B{ 255 255 255 255 } -1 ]
[
-1 <int> -1 <int>
- [ [ 0 alien-unsigned-cell swap ] [ 0 alien-signed-2 ] bi ]
+ [ [ 0 alien-unsigned-4 swap ] [ 0 alien-signed-2 ] bi ]
compile-call
] unit-test
] when
! Regression from Slava's value numbering changes
-[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
\ No newline at end of file
+[ 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
--- /dev/null
+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
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<= ;
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 ;
[ { 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
! [ { 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
[ { 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
+
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.
! 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 ;
: 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, ;
! Misc
: NOP ( -- ) HEX: 90 , ;
+: PAUSE ( -- ) HEX: f3 , HEX: 90 , ;
+
+: RDPMC ( -- ) HEX: 0f , HEX: 33 , ;
! x87 Floating Point Unit
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 ;
+
+<PRIVATE
+: (PEXTRW-sse1) ( dest src imm -- ) HEX: c5 HEX: 66 3-operand-rm-sse ;
+: (PEXTRW-sse4) ( dest src imm -- ) { HEX: 3a HEX: 15 } HEX: 66 3-operand-mr-sse ;
PRIVATE>
-: 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
+
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 ;
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 ;
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
+PRIVATE>
+
GENERIC: representative ( a disjoint-set -- p )
M: disjoint-set representative
[ [ parent ] keep representative dup ] 2keep set-parent
] if ;
+<PRIVATE
+
: representatives ( a b disjoint-set -- r r )
[ representative ] curry bi@ ; inline
\ push { { vector } { sbuf } } "specializer" set-word-prop
+\ last { { vector } } "specializer" set-word-prop
+
+\ set-last { { object vector } } "specializer" set-word-prop
+
\ push-all
{ { string sbuf } { array vector } { byte-array byte-vector } }
"specializer" set-word-prop
HELP: word-timing.
{ $description "Prints the word timing table." } ;
+
+HELP: cannot-annotate-twice
+{ $error-description "Thrown when attempting to annotate a word that's already been annotated. If a word already has an annotation such as a watch or a breakpoint, you must first " { $link reset } " the word before adding another annotation." } ;
\ No newline at end of file
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tr arrays sequences io words generic system combinators
-vocabs.loader kernel ;
+USING: alien alien.c-types arrays byte-arrays combinators
+destructors generic io kernel libc math sequences system tr
+vocabs.loader words ;
IN: tools.disassembler
GENERIC: disassemble ( obj -- )
TR: tabs>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 ;
\r
PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;\r
\r
-: (class<=) ( first second -- -1/0/1 )\r
+: (class<=) ( first second -- ? )\r
2dup eq? [ 2drop t ] [\r
2dup superclass<= [ 2drop t ] [\r
[ normalize-class ] bi@ {\r
: last ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
+: set-last ( elt seq -- ) [ length 1 - ] keep set-nth ;
+
: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
<PRIVATE
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license
+USING: accessors compiler.cfg.rpo compiler.cfg.dominance
+compiler.cfg.dominance.private compiler.cfg.predecessors images.viewer
+io io.encodings.ascii io.files io.files.unique io.launcher kernel
+math.parser sequences assocs arrays make namespaces ;
+IN: compiler.cfg.graphviz
+
+: render-graph ( edges -- )
+ "cfg" "dot" make-unique-file
+ [
+ ascii [
+ "digraph CFG {" print
+ [ [ number>> 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
projects / factor.git / commitdiff