steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Sam Anklesaria 2009-07-28 16:42:38 -05:00
parent 0c104ca126 f63b322859
commit fe86d9f56e
95 changed files with 2897 additions and 1742 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/bit-arrays/bit-arrays.factor
View File

@ -61,7 +61,7 @@ M: bit-array like drop dup bit-array? [ >bit-array ] unless ;
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 ] [

4
basis/bit-sets/bit-sets.factor
View File

@ -26,4 +26,6 @@ HINTS: bit-set-intersect bit-array bit-array ;
: bit-set-diff ( seq1 seq2 -- seq ) [ bitnot bitand ] bit-set-map ;
HINTS: bit-set-diff bit-array bit-array ;
HINTS: bit-set-diff bit-array bit-array ;
: bit-set-subset? ( seq1 seq2 -- ? ) dupd bit-set-intersect = ;

2
basis/byte-arrays/hex/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Maxim Savchenko
Slava Pestov

8
basis/byte-arrays/hex/hex-docs.factor Normal file
View File

@ -0,0 +1,8 @@
! Copyright (C) 2009 Maxim Savchenko, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: byte-arrays.hex
USING: byte-arrays help.markup help.syntax ;
HELP: HEX{
{ $syntax "HEX{ 0123 45 67 89abcdef }" }
{ $description "Constructs a " { $link byte-array } " from data specified in hexadecimal format. Whitespace between the curly braces is ignored." } ;

11
basis/byte-arrays/hex/hex.factor Normal file
View File

@ -0,0 +1,11 @@
! Copyright (C) 2009 Maxim Savchenko, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: grouping lexer ascii parser sequences kernel math.parser ;
IN: byte-arrays.hex
SYNTAX: HEX{
"}" parse-tokens "" join
[ blank? not ] filter
2 group [ hex> ] B{ } map-as
parsed ;

3
basis/circular/circular.factor
View File

@ -43,11 +43,10 @@ TUPLE: growing-circular < circular length ;
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 -- )

10
basis/compiler/cfg/block-joining/block-joining.factor
View File

@ -8,20 +8,14 @@ IN: compiler.cfg.block-joining
! Joining blocks that are not calls and are connected by a single CFG edge.
! Predecessors must be recomputed after this. Also this pass does not
! update ##phi nodes and should therefore only run before stack analysis.
: kill-vreg-block? ( bb -- ? )
instructions>> {
[ length 2 >= ]
[ penultimate kill-vreg-insn? ]
} 1&& ;
: predecessor ( bb -- pred )
predecessors>> first ; inline
: join-block? ( bb -- ? )
{
[ kill-block? not ]
[ predecessors>> length 1 = ]
[ predecessor kill-vreg-block? not ]
[ predecessor kill-block? not ]
[ predecessor successors>> length 1 = ]
[ [ predecessor ] keep back-edge? not ]
} 1&& ;

45
basis/compiler/cfg/branch-splitting/branch-splitting.factor
View File

@ -6,18 +6,8 @@ compiler.cfg.def-use compiler.cfg compiler.cfg.rpo
compiler.cfg.renaming compiler.cfg.instructions compiler.cfg.utilities ;
IN: compiler.cfg.branch-splitting
: clone-renamings ( insns -- assoc )
[ defs-vregs ] map concat [ dup fresh-vreg ] H{ } map>assoc ;
: clone-instructions ( insns -- insns' )
dup clone-renamings renamings [
[
clone
dup rename-insn-defs
dup rename-insn-uses
dup fresh-insn-temps
] map
] with-variable ;
[ clone dup fresh-insn-temps ] map ;
: clone-basic-block ( bb -- bb' )
! The new block gets the same RPO number as the old one.
@ -62,17 +52,32 @@ IN: compiler.cfg.branch-splitting
UNION: irrelevant ##peek ##replace ##inc-d ##inc-r ;
: split-instructions? ( insns -- ? )
[ [ irrelevant? not ] count 5 <= ]
[ last ##fixnum-overflow? not ]
bi and ;
: split-instructions? ( insns -- ? ) [ irrelevant? not ] count 5 <= ;
: 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 -- ? )
{
[ predecessors>> length 2 = ]
[ successors>> length 2 = ]
[ instructions>> length 20 <= ]
} 1&& ;
: split-branch? ( bb -- ? )
{
[ dup successors>> [ back-edge? ] with any? not ]
[ predecessors>> length 2 4 between? ]
[ instructions>> split-instructions? ]
} 1&& ;
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 [

12
basis/compiler/cfg/build-stack-frame/build-stack-frame.factor
View File

@ -13,10 +13,16 @@ SYMBOL: spill-counts
GENERIC: compute-stack-frame* ( insn -- )
: request-stack-frame ( stack-frame -- )
frame-required? on
stack-frame [ max-stack-frame ] change ;
M: ##stack-frame compute-stack-frame*
frame-required? on
M: ##alien-invoke compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##alien-indirect compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##alien-callback compute-stack-frame*
stack-frame>> request-stack-frame ;
M: ##call compute-stack-frame*
@ -45,8 +51,6 @@ M: insn compute-stack-frame*
GENERIC: insert-pro/epilogues* ( insn -- )
M: ##stack-frame insert-pro/epilogues* drop ;
M: ##prologue insert-pro/epilogues*
drop frame-required? get [ stack-frame get _prologue ] when ;

74
basis/compiler/cfg/builder/blocks/blocks.factor Normal file
View File

@ -0,0 +1,74 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays fry kernel make math namespaces sequences
compiler.cfg compiler.cfg.instructions compiler.cfg.stacks
compiler.cfg.stacks.local ;
IN: compiler.cfg.builder.blocks
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi
begin-local-analysis ;
: initial-basic-block ( -- )
<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 ;

63
basis/compiler/cfg/builder/builder-tests.factor
View File

@ -1,12 +1,30 @@
IN: compiler.cfg.builder.tests
USING: tools.test kernel sequences
words sequences.private fry prettyprint alien alien.accessors
math.private compiler.tree.builder compiler.tree.optimizer
compiler.cfg.builder compiler.cfg.debugger arrays locals byte-arrays
kernel.private math ;
USING: tools.test kernel sequences words sequences.private fry
prettyprint alien alien.accessors math.private compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder compiler.cfg.debugger
compiler.cfg.optimizer compiler.cfg.predecessors compiler.cfg.checker
arrays locals byte-arrays kernel.private math slots.private vectors sbufs
strings math.partial-dispatch strings.private ;
! Just ensure that various CFGs build correctly.
: unit-test-cfg ( quot -- ) '[ _ test-cfg drop ] [ ] swap unit-test ;
: unit-test-cfg ( quot -- )
'[ _ test-cfg [ optimize-cfg check-cfg ] each ] [ ] swap unit-test ;
: blahblah ( nodes -- ? )
{ fixnum } declare [
dup 3 bitand 1 = [ drop t ] [
dup 3 bitand 2 = [
blahblah
] [ drop f ] if
] if
] any? ; inline recursive
: more? ( x -- ? ) ;
: test-case-1 ( -- ? ) f ;
: test-case-2 ( -- )
test-case-1 [ test-case-2 ] [ ] if ; inline recursive
{
[ ]
@ -49,6 +67,39 @@ kernel.private math ;
[ "int" f "malloc" { "int" } alien-invoke ]
[ "int" { "int" } "cdecl" alien-indirect ]
[ "int" { "int" } "cdecl" [ ] alien-callback ]
[ swap - + * ]
[ swap slot ]
[ blahblah ]
[ 1000 [ dup [ reverse ] when ] times ]
[ 1array ]
[ 1 2 ? ]
[ { array } declare [ ] map ]
[ { array } declare dup 1 slot [ 1 slot ] when ]
[ [ dup more? ] [ dup ] produce ]
[ vector new over test-case-1 [ test-case-2 ] [ ] if ]
[ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
[
{ fixnum sbuf } declare 2dup 3 slot fixnum> [
over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
] [ ] if
]
[ [ 2 fixnum* ] when 3 ]
[ [ 2 fixnum+ ] when 3 ]
[ [ 2 fixnum- ] when 3 ]
[ 10000 [ ] times ]
[
over integer? [
over dup 16 <-integer-fixnum
[ 0 >=-integer-fixnum ] [ drop f ] if [
nip dup
[ ] [ ] if
] [ 2drop f ] if
] [ 2drop f ] if
]
[
pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
set-string-nth-fast
]
} [
unit-test-cfg
] each

79
basis/compiler/cfg/builder/builder.factor
View File

@ -10,30 +10,39 @@ compiler.tree.combinators
compiler.tree.propagation.info
compiler.cfg
compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.utilities
compiler.cfg.registers
compiler.cfg.intrinsics
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.instructions
compiler.cfg.predecessors
compiler.cfg.builder.blocks
compiler.cfg.stacks
compiler.alien ;
IN: compiler.cfg.builder
! Convert tree SSA IR to CFG SSA IR.
! Convert tree SSA IR to CFG IR. The result is not in SSA form; this is
! constructed later by calling compiler.cfg.ssa.construction:construct-ssa.
SYMBOL: procedures
SYMBOL: loops
: begin-procedure ( word label -- )
end-basic-block
begin-basic-block
: begin-cfg ( word label -- cfg )
initial-basic-block
H{ } clone loops set
[ basic-block get ] 2dip
<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 -- )
@ -61,24 +70,26 @@ GENERIC: emit-node ( node -- )
: emit-loop-call ( basic-block -- )
##branch
basic-block get successors>> push
basic-block off ;
end-basic-block ;
: emit-call ( word -- )
dup loops get key?
[ loops get at emit-loop-call ]
[ ##call ##branch begin-basic-block ]
: emit-call ( word height -- )
over loops get key?
[ drop loops get at emit-loop-call ]
[ [ [ ##call ] [ adjust-d ] bi* ] emit-trivial-block ]
if ;
! #recursive
: recursive-height ( #recursive -- n )
[ label>> return>> in-d>> length ] [ in-d>> length ] bi - ;
: emit-recursive ( #recursive -- )
[ label>> id>> emit-call ]
[ [ label>> id>> ] [ recursive-height ] bi emit-call ]
[ [ child>> ] [ label>> word>> ] [ label>> id>> ] tri (build-cfg) ] bi ;
: remember-loop ( label -- )
basic-block get swap loops get set-at ;
: emit-loop ( node -- )
##loop-entry
##branch
begin-basic-block
[ label>> id>> remember-loop ] [ child>> emit-nodes ] bi ;
@ -93,9 +104,6 @@ M: #recursive emit-node
: emit-if ( node -- )
children>> [ emit-branch ] map emit-conditional ;
: ##branch-t ( vreg -- )
\ f tag-number cc/= ##compare-imm-branch ;
: trivial-branch? ( nodes -- value ? )
dup length 1 = [
first dup #push? [ literal>> t ] [ drop f f ] if
@ -119,24 +127,32 @@ M: #recursive emit-node
: emit-trivial-not-if ( -- )
ds-pop \ f tag-number cc= ^^compare-imm ds-push ;
: emit-actual-if ( #if -- )
! Inputs to the final instruction need to be copied because of
! loc>vreg sync
ds-pop ^^copy \ f tag-number cc/= ##compare-imm-branch emit-if ;
M: #if emit-node
{
{ [ dup trivial-if? ] [ drop emit-trivial-if ] }
{ [ dup trivial-not-if? ] [ drop emit-trivial-not-if ] }
[ ds-pop ##branch-t emit-if ]
[ emit-actual-if ]
} cond ;
! #dispatch
M: #dispatch emit-node
! Inputs to the final instruction need to be copied because of
! loc>vreg sync. ^^offset>slot always returns a fresh vreg,
! though.
ds-pop ^^offset>slot i ##dispatch emit-if ;
! #call
M: #call emit-node
dup word>> dup "intrinsic" word-prop
[ emit-intrinsic ] [ nip emit-call ] if ;
[ emit-intrinsic ] [ swap call-height emit-call ] if ;
! #call-recursive
M: #call-recursive emit-node label>> id>> emit-call ;
M: #call-recursive emit-node [ label>> id>> ] [ call-height ] bi emit-call ;
! #push
M: #push emit-node
@ -153,15 +169,16 @@ M: #shuffle emit-node
[ [ [ out-r>> ] [ mapping>> ] bi ] dip '[ _ at _ at ] map rs-store ] 2bi ;
! #return
M: #return emit-node
drop ##epilogue ##return ;
: emit-return ( -- )
##branch begin-basic-block ##epilogue ##return ;
M: #return emit-node drop emit-return ;
M: #return-recursive emit-node
label>> id>> loops get key?
[ ##epilogue ##return ] unless ;
label>> id>> loops get key? [ emit-return ] unless ;
! #terminate
M: #terminate emit-node drop ##no-tco basic-block off ;
M: #terminate emit-node drop ##no-tco end-basic-block ;
! FFI
: return-size ( ctype -- n )
@ -178,12 +195,14 @@ M: #terminate emit-node drop ##no-tco basic-block off ;
[ return>> return-size >>return ]
[ alien-parameters parameter-sizes drop >>params ] bi ;
: alien-stack-frame ( params -- )
<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 ;

45
basis/compiler/cfg/checker/checker.factor
View File

@ -1,34 +1,44 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.def-use compiler.cfg.linearization
combinators.short-circuit accessors math sequences sets assocs ;
compiler.cfg.def-use compiler.cfg.linearization compiler.cfg.utilities
compiler.cfg.mr combinators.short-circuit accessors math
sequences sets assocs ;
IN: compiler.cfg.checker
ERROR: last-insn-not-a-jump insn ;
ERROR: bad-kill-block bb ;
: check-kill-block ( bb -- )
dup instructions>> first2
swap ##epilogue? [
{ [ ##return? ] [ ##callback-return? ] [ ##jump? ] } 1||
] [ ##branch? ] if
[ drop ] [ bad-kill-block ] if ;
ERROR: last-insn-not-a-jump bb ;
: check-last-instruction ( bb -- )
last dup {
dup instructions>> last {
[ ##branch? ]
[ ##dispatch? ]
[ ##conditional-branch? ]
[ ##compare-imm-branch? ]
[ ##return? ]
[ ##callback-return? ]
[ ##jump? ]
[ ##fixnum-add? ]
[ ##fixnum-sub? ]
[ ##fixnum-mul? ]
[ ##no-tco? ]
} 1|| [ drop ] [ last-insn-not-a-jump ] if ;
ERROR: bad-loop-entry ;
ERROR: bad-kill-insn bb ;
: check-loop-entry ( bb -- )
dup length 2 >= [
2 head* [ ##loop-entry? ] any?
[ bad-loop-entry ] when
] [ drop ] if ;
: check-kill-instructions ( bb -- )
dup instructions>> [ kill-vreg-insn? ] any?
[ bad-kill-insn ] [ drop ] if ;
: check-normal-block ( bb -- )
[ check-last-instruction ]
[ check-kill-instructions ]
bi ;
ERROR: bad-successors ;
@ -37,10 +47,9 @@ ERROR: bad-successors ;
[ bad-successors ] unless ;
: check-basic-block ( bb -- )
[ instructions>> check-last-instruction ]
[ instructions>> check-loop-entry ]
[ dup kill-block? [ check-kill-block ] [ check-normal-block ] if ]
[ check-successors ]
tri ;
bi ;
ERROR: bad-live-in ;
@ -50,10 +59,10 @@ ERROR: undefined-values uses defs ;
! Check that every used register has a definition
instructions>>
[ [ uses-vregs ] map concat ]
[ [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat ] bi
[ [ [ temp-vregs ] [ defs-vreg ] bi [ suffix ] when* ] map concat ] bi
2dup subset? [ 2drop ] [ undefined-values ] if ;
: check-cfg ( cfg -- )
[ [ check-basic-block ] each-basic-block ]
[ flatten-cfg check-mr ]
[ build-mr check-mr ]
bi ;

60
basis/compiler/cfg/copy-prop/copy-prop.factor
View File

@ -1,12 +1,62 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces assocs accessors ;
USING: kernel namespaces assocs accessors sequences grouping
compiler.cfg.rpo compiler.cfg.renaming compiler.cfg.instructions ;
IN: compiler.cfg.copy-prop
! The first three definitions are also used in compiler.cfg.alias-analysis.
SYMBOL: copies
: resolve ( vreg -- vreg )
[ copies get at ] keep or ;
copies get ?at drop ;
: record-copy ( insn -- )
[ src>> resolve ] [ dst>> ] bi copies get set-at ; inline
: (record-copy) ( dst src -- )
swap copies get set-at ; inline
: record-copy ( ##copy -- )
[ dst>> ] [ src>> resolve ] bi (record-copy) ; inline
<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 ;

21
basis/compiler/cfg/critical-edges/critical-edges.factor Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math accessors sequences
compiler.cfg compiler.cfg.rpo compiler.cfg.utilities ;
IN: compiler.cfg.critical-edges
: critical-edge? ( from to -- ? )
[ successors>> length 1 > ] [ predecessors>> length 1 > ] bi* and ;
: split-critical-edge ( from to -- )
f <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 ;

4
basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor
View File

@ -20,7 +20,7 @@ MIXIN: dataflow-analysis
GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
! M: kill-block compute-in-set 3drop f ;
M: kill-block compute-in-set 3drop f ;
M:: basic-block compute-in-set ( bb out-sets dfa -- set )
bb dfa predecessors [ out-sets at ] map dfa join-sets ;
@ -31,7 +31,7 @@ M:: basic-block compute-in-set ( bb out-sets dfa -- set )
GENERIC# compute-out-set 2 ( bb out-sets dfa -- set )
! M: kill-block compute-out-set 3drop f ;
M: kill-block compute-out-set 3drop f ;
M:: basic-block compute-out-set ( bb in-sets dfa -- set )
bb in-sets at bb dfa transfer-set ;

2
basis/compiler/cfg/debugger/debugger.factor
View File

@ -14,9 +14,11 @@ IN: compiler.cfg.debugger
GENERIC: test-cfg ( quot -- cfgs )
M: callable test-cfg
0 vreg-counter set-global
build-tree optimize-tree gensym build-cfg ;
M: word test-cfg
0 vreg-counter set-global
[ build-tree optimize-tree ] keep build-cfg ;
: test-mr ( quot -- mrs )

75
basis/compiler/cfg/def-use/def-use.factor
View File

@ -1,16 +1,17 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel assocs sequences
sets compiler.cfg.instructions ;
USING: accessors arrays kernel assocs sequences namespaces fry
sets compiler.cfg.rpo compiler.cfg.instructions ;
IN: compiler.cfg.def-use
GENERIC: defs-vregs ( insn -- seq )
GENERIC: defs-vreg ( insn -- vreg/f )
GENERIC: temp-vregs ( insn -- seq )
GENERIC: uses-vregs ( insn -- seq )
M: ##flushable defs-vregs dst>> 1array ;
M: ##fixnum-overflow defs-vregs dst>> 1array ;
M: insn defs-vregs drop f ;
M: ##flushable defs-vreg dst>> ;
M: ##fixnum-overflow defs-vreg dst>> ;
M: _fixnum-overflow defs-vreg dst>> ;
M: insn defs-vreg drop f ;
M: ##write-barrier temp-vregs [ card#>> ] [ table>> ] bi 2array ;
M: ##unary/temp temp-vregs temp>> 1array ;
@ -49,26 +50,48 @@ M: _compare-imm-branch uses-vregs src1>> 1array ;
M: _dispatch uses-vregs src>> 1array ;
M: insn uses-vregs drop f ;
! Instructions that use vregs
UNION: vreg-insn
##flushable
##write-barrier
##dispatch
##effect
##fixnum-overflow
##conditional-branch
##compare-imm-branch
##phi
##gc
_conditional-branch
_compare-imm-branch
_dispatch ;
! Computing def-use chains.
: map-unique ( seq quot -- assoc )
map concat unique ; inline
SYMBOLS: defs insns uses ;
: gen-set ( instructions -- seq )
[ uses-vregs ] map-unique ;
: def-of ( vreg -- node ) defs get at ;
: uses-of ( vreg -- nodes ) uses get at ;
: insn-of ( vreg -- insn ) insns get at ;
: kill-set ( instructions -- seq )
[ defs-vregs ] map-unique ;
: set-def-of ( obj insn assoc -- )
swap defs-vreg dup [ swap set-at ] [ 3drop ] if ;
: compute-defs ( cfg -- )
H{ } clone [
'[
dup instructions>> [
_ set-def-of
] with each
] each-basic-block
] keep
defs set ;
: compute-insns ( cfg -- )
H{ } clone [
'[
instructions>> [
dup _ set-def-of
] each
] each-basic-block
] keep insns set ;
: compute-uses ( cfg -- )
H{ } clone [
'[
dup instructions>> [
uses-vregs [
_ conjoin-at
] with each
] with each
] each-basic-block
] keep
[ keys ] assoc-map
uses set ;
: compute-def-use ( cfg -- )
[ compute-defs ] [ compute-uses ] [ compute-insns ] tri ;

31
basis/compiler/cfg/dominance/dominance-tests.factor
View File

@ -33,10 +33,11 @@ V{ } 5 test-bb
[ t ] [ 0 get dom-children 1 get 2 get 4 get 3array set= ] unit-test
[ { 4 } ] [ 1 get dom-frontier [ number>> ] map ] unit-test
[ { 4 } ] [ 2 get dom-frontier [ number>> ] map ] unit-test
[ { } ] [ 0 get dom-frontier ] unit-test
[ { } ] [ 4 get dom-frontier ] unit-test
[ t ] [ 0 get 3 get dominates? ] unit-test
[ f ] [ 3 get 4 get dominates? ] unit-test
[ f ] [ 1 get 4 get dominates? ] unit-test
[ t ] [ 4 get 5 get dominates? ] unit-test
[ f ] [ 1 get 5 get dominates? ] unit-test
! Example from the paper
V{ } 0 test-bb
@ -73,25 +74,3 @@ V{ } 5 test-bb
[ ] [ test-dominance ] unit-test
[ t ] [ 0 5 [a,b] [ get dom-parent 0 get eq? ] all? ] unit-test
V{ } 0 test-bb
V{ } 1 test-bb
V{ } 2 test-bb
V{ } 3 test-bb
V{ } 4 test-bb
V{ } 5 test-bb
V{ } 6 test-bb
0 get 1 get 5 get V{ } 2sequence >>successors drop
1 get 2 get 3 get V{ } 2sequence >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
[ ] [ test-dominance ] unit-test
[ t ] [
2 get 3 get 2array iterated-dom-frontier
4 get 6 get 2array set=
] unit-test

69
basis/compiler/cfg/dominance/dominance.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators sets math fry kernel math.order
dlists deques namespaces sequences sorting compiler.cfg.rpo ;
dlists deques vectors namespaces sequences sorting locals
compiler.cfg.rpo ;
IN: compiler.cfg.dominance
! Reference:
@ -60,56 +61,42 @@ PRIVATE>
[ '[ 2dup eq? [ 2drop ] [ _ push-at ] if ] assoc-each ] keep
dom-childrens set ;
! Maps bb -> DF(bb)
SYMBOL: dom-frontiers
SYMBOLS: preorder maxpreorder ;
PRIVATE>
: dom-frontier ( bb -- set ) dom-frontiers get at keys ;
: pre-of ( bb -- n ) [ preorder get at ] [ -1/0. ] if* ;
: maxpre-of ( bb -- n ) [ maxpreorder 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-dfs) ( n bb -- n )
[ 1 + ] dip
[ dupd preorder get set-at ]
[ dom-children [ (compute-dfs) ] each ]
[ dupd maxpreorder get set-at ]
tri ;
: compute-dom-frontiers ( cfg -- )
H{ } clone dom-frontiers set
[
dup predecessors>> dup length 2 >= [
[ compute-dom-frontier ] with each
] [ 2drop ] if
] each-basic-block ;
: compute-dfs ( cfg -- )
H{ } clone preorder set
H{ } clone maxpreorder set
[ 0 ] dip entry>> (compute-dfs) drop ;
PRIVATE>
: compute-dominance ( cfg -- )
[ compute-dom-parents compute-dom-children ]
[ compute-dom-frontiers ]
bi ;
[ compute-dom-parents compute-dom-children ] [ compute-dfs ] bi ;
<PRIVATE
: dominates? ( bb1 bb2 -- ? )
swap [ pre-of ] [ [ pre-of ] [ maxpre-of ] bi ] bi* between? ;
SYMBOLS: work-list visited ;
: 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 ;
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 ;
:: 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 ;

38
basis/compiler/cfg/empty-blocks/empty-blocks.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences combinators combinators.short-circuit
classes vectors compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.empty-blocks
: update-predecessor ( bb -- )
! We have to replace occurrences of bb with bb's successor
! in bb's predecessor's list of successors.
dup predecessors>> first [
[
2dup eq? [ drop successors>> first ] [ nip ] if
] with map
] change-successors drop ;
: update-successor ( bb -- )
! We have to replace occurrences of bb with bb's predecessor
! in bb's sucessor's list of predecessors.
dup successors>> first [
[
2dup eq? [ drop predecessors>> first ] [ nip ] if
] with map
] change-predecessors drop ;
: delete-basic-block ( bb -- )
[ update-predecessor ] [ update-successor ] bi ;
: delete-basic-block? ( bb -- ? )
{
[ instructions>> length 1 = ]
[ predecessors>> length 1 = ]
[ successors>> length 1 = ]
[ instructions>> first ##branch? ]
} 1&& ;
: delete-empty-blocks ( cfg -- cfg' )
dup [ dup delete-basic-block? [ delete-basic-block ] [ drop ] if ] each-basic-block
cfg-changed ;

4
basis/compiler/cfg/hats/hats.factor
View File

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

38
basis/compiler/cfg/instructions/instructions.factor
View File

@ -52,7 +52,6 @@ INSN: ##inc-d { n integer } ;
INSN: ##inc-r { n integer } ;
! Subroutine calls
INSN: ##stack-frame stack-frame ;
INSN: ##call word ;
INSN: ##jump word ;
INSN: ##return ;
@ -160,9 +159,9 @@ INSN: ##write-barrier < ##effect card# table ;
INSN: ##alien-global < ##flushable symbol library ;
! FFI
INSN: ##alien-invoke params ;
INSN: ##alien-indirect params ;
INSN: ##alien-callback params ;
INSN: ##alien-invoke params stack-frame ;
INSN: ##alien-indirect params stack-frame ;
INSN: ##alien-callback params stack-frame ;
INSN: ##callback-return params ;
! Instructions used by CFG IR only.
@ -171,8 +170,6 @@ INSN: ##epilogue ;
INSN: ##branch ;
INSN: ##loop-entry ;
INSN: ##phi < ##pure inputs ;
! Conditionals
@ -202,6 +199,7 @@ INSN: _epilogue stack-frame ;
INSN: _label id ;
INSN: _branch label ;
INSN: _loop-entry ;
INSN: _dispatch src temp ;
INSN: _dispatch-label label ;
@ -230,19 +228,33 @@ INSN: _reload dst class n ;
INSN: _copy dst src class ;
INSN: _spill-counts counts ;
! Instructions that poison the stack state
UNION: poison-insn
##jump
##return
##callback-return ;
! Instructions that use vregs
UNION: vreg-insn
##flushable
##write-barrier
##dispatch
##effect
##fixnum-overflow
##conditional-branch
##compare-imm-branch
##phi
##gc
_conditional-branch
_compare-imm-branch
_dispatch ;
! Instructions that kill all live vregs
UNION: kill-vreg-insn
poison-insn
##stack-frame
##call
##prologue
##epilogue
##alien-invoke
##alien-indirect
##alien-callback ;
! Instructions that have complex expansions and require that the
! output registers are not equal to any of the input registers
UNION: def-is-use-insn
##integer>bignum
##bignum>integer
##unbox-any-c-ptr ;

9
basis/compiler/cfg/intrinsics/alien/alien.factor
View File

@ -1,10 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences alien math classes.algebra
fry locals combinators cpu.architecture
compiler.tree.propagation.info
USING: accessors kernel sequences alien math classes.algebra fry
locals combinators cpu.architecture compiler.tree.propagation.info
compiler.cfg.hats compiler.cfg.stacks compiler.cfg.instructions
compiler.cfg.utilities ;
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.alien
: (prepare-alien-accessor-imm) ( class offset -- offset-vreg )

4
basis/compiler/cfg/intrinsics/allot/allot.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order sequences accessors arrays
byte-arrays layouts classes.tuple.private fry locals
compiler.tree.propagation.info compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stacks
compiler.cfg.utilities ;
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.allot
: ##set-slots ( regs obj class -- )

11
basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
View File

@ -7,6 +7,7 @@ compiler.cfg.hats
compiler.cfg.stacks
compiler.cfg.instructions
compiler.cfg.utilities
compiler.cfg.builder.blocks
compiler.cfg.registers
compiler.cfg.comparisons ;
IN: compiler.cfg.intrinsics.fixnum
@ -31,7 +32,7 @@ IN: compiler.cfg.intrinsics.fixnum
[ ^^untag-fixnum ^^neg ^^sar dup tag-mask get ^^and-imm ^^xor ] emit-fixnum-op ;
: emit-fixnum-shift-general ( -- )
D 0 ^^peek 0 cc> ##compare-imm-branch
ds-peek 0 cc> ##compare-imm-branch
[ emit-fixnum-left-shift ] with-branch
[ emit-fixnum-right-shift ] with-branch
2array emit-conditional ;
@ -62,13 +63,15 @@ IN: compiler.cfg.intrinsics.fixnum
ds-pop ^^untag-fixnum ^^integer>bignum ds-push ;
: emit-no-overflow-case ( dst -- final-bb )
[ -2 ##inc-d ds-push ] with-branch ;
[ ds-drop ds-drop ds-push ] with-branch ;
: emit-overflow-case ( word -- final-bb )
[ ##call ] with-branch ;
[ ##call -1 adjust-d ] with-branch ;
: emit-fixnum-overflow-op ( quot word -- )
[ [ D 1 ^^peek D 0 ^^peek ] dip call ] dip
! Inputs to the final instruction need to be copied because
! of loc>vreg sync
[ [ (2inputs) [ ^^copy ] bi@ ] dip call ] dip
[ emit-no-overflow-case ] [ emit-overflow-case ] bi* 2array
emit-conditional ; inline

14
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -48,11 +48,11 @@ IN: compiler.cfg.intrinsics
slots.private:set-slot
strings.private:string-nth
strings.private:set-string-nth-fast
classes.tuple.private:<tuple-boa>
arrays:<array>
byte-arrays:<byte-array>
byte-arrays:(byte-array)
kernel:<wrapper>
! classes.tuple.private:<tuple-boa>
! arrays:<array>
! 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
@ -61,7 +61,7 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-unsigned-2
alien.accessors:alien-signed-2
alien.accessors:set-alien-signed-2
alien.accessors:alien-cell
! alien.accessors:alien-cell
alien.accessors:set-alien-cell
} [ t "intrinsic" set-word-prop ] each
@ -90,7 +90,7 @@ IN: compiler.cfg.intrinsics
alien.accessors:set-alien-float
alien.accessors:alien-double
alien.accessors:set-alien-double
} [ t "intrinsic" set-word-prop ] each ;
} drop f [ t "intrinsic" set-word-prop ] each ;
: enable-fixnum-log2 ( -- )
\ math.integers.private:fixnum-log2 t "intrinsic" set-word-prop ;

4
basis/compiler/cfg/intrinsics/slots/slots.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: layouts namespaces kernel accessors sequences
classes.algebra compiler.tree.propagation.info
compiler.cfg.stacks compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities ;
compiler.cfg.utilities compiler.cfg.builder.blocks ;
IN: compiler.cfg.intrinsics.slots
: value-tag ( info -- n ) class>> class-tag ; inline

38
basis/compiler/cfg/linear-scan/assignment/assignment.factor
View File

@ -9,7 +9,6 @@ compiler.cfg.def-use
compiler.cfg.liveness
compiler.cfg.registers
compiler.cfg.instructions
compiler.cfg.linear-scan.mapping
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.live-intervals ;
@ -44,44 +43,25 @@ SYMBOL: register-live-outs
H{ } clone register-live-outs set
init-unhandled ;
: insert-spill ( live-interval -- )
[ reg>> ] [ vreg>> reg-class>> ] [ spill-to>> ] tri _spill ;
: 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 ;
: 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 ;
dup spill-to>> [ insert-spill ] [ drop ] if ;
: (expire-old-intervals) ( n heap -- )
dup heap-empty? [ 2drop ] [
2dup heap-peek nip <= [ 2drop ] [
dup heap-pop drop [ handle-spill ] [ handle-copy ] bi
dup heap-pop drop handle-spill
(expire-old-intervals)
] if
] if ;
: expire-old-intervals ( n -- )
[
pending-intervals get (expire-old-intervals)
] { } make mapping-instructions % ;
pending-intervals get (expire-old-intervals) ;
: insert-reload ( live-interval -- )
{
[ reg>> ]
[ vreg>> reg-class>> ]
[ reload-from>> ]
[ start>> ]
} cleave f swap \ _reload boa , ;
[ reg>> ] [ vreg>> reg-class>> ] [ reload-from>> ] tri _reload ;
: handle-reload ( live-interval -- )
dup reload-from>> [ insert-reload ] [ drop ] if ;
@ -106,7 +86,9 @@ GENERIC: assign-registers-in-insn ( insn -- )
[ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ;
: all-vregs ( insn -- vregs )
[ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
[ [ temp-vregs ] [ uses-vregs ] bi append ]
[ defs-vreg ] bi
[ suffix ] when* ;
SYMBOL: check-assignment?

4
basis/compiler/cfg/linear-scan/linear-scan.factor
View File

@ -11,8 +11,7 @@ compiler.cfg.linear-scan.live-intervals
compiler.cfg.linear-scan.allocation
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.resolve
compiler.cfg.linear-scan.mapping ;
compiler.cfg.linear-scan.resolve ;
IN: compiler.cfg.linear-scan
! References:
@ -39,7 +38,6 @@ IN: compiler.cfg.linear-scan
: linear-scan ( cfg -- cfg' )
[
init-mapping
dup machine-registers (linear-scan)
spill-counts get >>spill-counts
cfg-changed

2
basis/compiler/cfg/linear-scan/live-intervals/live-intervals.factor
View File

@ -98,7 +98,7 @@ M: insn compute-live-intervals* drop ;
M: vreg-insn compute-live-intervals*
dup insn#>>
live-intervals get
[ [ defs-vregs ] 2dip '[ [ _ ] dip _ handle-output ] each ]
[ [ defs-vreg ] 2dip '[ [ _ ] dip _ handle-output ] when* ]
[ [ uses-vregs ] 2dip '[ [ _ ] dip _ handle-input ] each ]
[ [ temp-vregs ] 2dip '[ [ _ ] dip _ handle-temp ] each ]
3tri ;

145
basis/compiler/cfg/linear-scan/mapping/mapping-tests.factor
View File

@ -1,145 +0,0 @@
USING: compiler.cfg.instructions
compiler.cfg.linear-scan.allocation.state
compiler.cfg.linear-scan.mapping cpu.architecture kernel
namespaces tools.test ;
IN: compiler.cfg.linear-scan.mapping.tests
H{ { int-regs 10 } { float-regs 20 } } clone spill-counts set
init-mapping
[
{
T{ _copy { dst 5 } { src 4 } { class int-regs } }
T{ _spill { src 1 } { class int-regs } { n 10 } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _reload { dst 0 } { class int-regs } { n 10 } }
T{ _spill { src 1 } { class float-regs } { n 20 } }
T{ _copy { dst 1 } { src 0 } { class float-regs } }
T{ _reload { dst 0 } { class float-regs } { n 20 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class float-regs } }
T{ register->register { from 1 } { to 0 } { reg-class float-regs } }
T{ register->register { from 4 } { to 5 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 2 } { class int-regs } { n 10 } }
T{ _copy { dst 2 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _reload { dst 0 } { class int-regs } { n 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 0 } { class int-regs } { n 10 } }
T{ _copy { dst 0 } { src 2 } { class int-regs } }
T{ _copy { dst 2 } { src 1 } { class int-regs } }
T{ _reload { dst 1 } { class int-regs } { n 10 } }
}
] [
{
T{ register->register { from 1 } { to 2 } { reg-class int-regs } }
T{ register->register { from 2 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{ }
] [
{
T{ register->register { from 4 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _spill { src 3 } { class int-regs } { n 4 } }
T{ _reload { dst 2 } { class int-regs } { n 1 } }
}
] [
{
T{ register->memory { from 3 } { to T{ spill-slot f 4 } } { reg-class int-regs } }
T{ memory->register { from T{ spill-slot f 1 } } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _spill { src 4 } { class int-regs } { n 10 } }
T{ _copy { dst 4 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
T{ _reload { dst 3 } { class int-regs } { n 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test
[
{
T{ _copy { dst 2 } { src 0 } { class int-regs } }
T{ _copy { dst 9 } { src 1 } { class int-regs } }
T{ _copy { dst 1 } { src 0 } { class int-regs } }
T{ _spill { src 4 } { class int-regs } { n 10 } }
T{ _copy { dst 4 } { src 0 } { class int-regs } }
T{ _copy { dst 0 } { src 3 } { class int-regs } }
T{ _reload { dst 3 } { class int-regs } { n 10 } }
}
] [
{
T{ register->register { from 0 } { to 1 } { reg-class int-regs } }
T{ register->register { from 0 } { to 2 } { reg-class int-regs } }
T{ register->register { from 1 } { to 9 } { reg-class int-regs } }
T{ register->register { from 3 } { to 0 } { reg-class int-regs } }
T{ register->register { from 4 } { to 3 } { reg-class int-regs } }
T{ register->register { from 0 } { to 4 } { reg-class int-regs } }
} mapping-instructions
] unit-test

148
basis/compiler/cfg/linear-scan/mapping/mapping.factor
View File

@ -1,148 +0,0 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.parser classes.tuple
combinators compiler.cfg.instructions
compiler.cfg.linear-scan.allocation.state fry hashtables kernel
locals make namespaces parser sequences sets words ;
IN: compiler.cfg.linear-scan.mapping
SYMBOL: spill-temps
: spill-temp ( reg-class -- n )
spill-temps get [ next-spill-slot ] cache ;
<<
TUPLE: operation from to reg-class ;
SYNTAX: OPERATION:
CREATE-CLASS dup save-location
[ operation { } define-tuple-class ]
[ dup '[ _ boa , ] (( from to reg-class -- )) define-declared ] bi ;
>>
OPERATION: register->memory
OPERATION: memory->register
OPERATION: register->register
! This should never come up because of how spill slots are assigned,
! so make it an error.
: memory->memory ( from to reg-class -- ) drop [ n>> ] bi@ assert= ;
GENERIC: >insn ( operation -- )
M: register->memory >insn
[ from>> ] [ reg-class>> ] [ to>> n>> ] tri _spill ;
M: memory->register >insn
[ to>> ] [ reg-class>> ] [ from>> n>> ] tri _reload ;
M: register->register >insn
[ to>> ] [ from>> ] [ reg-class>> ] tri _copy ;
SYMBOL: froms
SYMBOL: tos
SINGLETONS: memory register ;
: from-loc ( operation -- obj ) from>> spill-slot? memory register ? ;
: to-loc ( operation -- obj ) to>> spill-slot? memory register ? ;
: from-reg ( operation -- seq )
[ from-loc ] [ from>> ] [ reg-class>> ] tri 3array ;
: to-reg ( operation -- seq )
[ to-loc ] [ to>> ] [ reg-class>> ] tri 3array ;
: start? ( operations -- pair )
from-reg tos get key? not ;
: independent-assignment? ( operations -- pair )
to-reg froms get key? not ;
: set-tos/froms ( operations -- )
[ [ [ from-reg ] keep ] H{ } map>assoc froms set ]
[ [ [ to-reg ] keep ] H{ } map>assoc tos set ]
bi ;
:: (trace-chain) ( obj hashtable -- )
obj to-reg froms get at* [
dup ,
obj over hashtable clone [ maybe-set-at ] keep swap
[ (trace-chain) ] [ 2drop ] if
] [
drop
] if ;
: trace-chain ( obj -- seq )
[
dup ,
dup dup associate (trace-chain)
] { } make prune reverse ;
: trace-chains ( seq -- seq' )
[ trace-chain ] map concat ;
ERROR: resolve-error ;
: split-cycle ( operations -- chain spilled-operation )
unclip [
[ set-tos/froms ]
[
[ start? ] find nip
[ resolve-error ] unless* trace-chain
] bi
] dip ;
: break-cycle-n ( operations -- operations' )
split-cycle [
[ from>> ]
[ reg-class>> spill-temp <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 ;

58
basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor Normal file
View File

@ -0,0 +1,58 @@
IN: compiler.cfg.linear-scan.resolve.tests
USING: compiler.cfg.linear-scan.resolve tools.test kernel namespaces
compiler.cfg.instructions cpu.architecture make
compiler.cfg.linear-scan.allocation.state ;
[
{
{ { T{ spill-slot f 0 } int-regs } { 1 int-regs } }
}
] [
[
0 <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

55
basis/compiler/cfg/linear-scan/resolve/resolve.factor
View File

@ -1,31 +1,29 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs combinators
combinators.short-circuit fry kernel locals
make math sequences
combinators.short-circuit fry kernel locals namespaces
make math sequences hashtables
compiler.cfg.rpo
compiler.cfg.liveness
compiler.cfg.utilities
compiler.cfg.instructions
compiler.cfg.parallel-copy
compiler.cfg.linear-scan.assignment
compiler.cfg.linear-scan.mapping ;
compiler.cfg.linear-scan.allocation.state ;
IN: compiler.cfg.linear-scan.resolve
SYMBOL: spill-temps
: spill-temp ( reg-class -- n )
spill-temps get [ next-spill-slot ] cache ;
: add-mapping ( from to reg-class -- )
over spill-slot? [
pick spill-slot?
[ memory->memory ]
[ register->memory ] if
] [
pick spill-slot?
[ memory->register ]
[ register->register ] if
] if ;
'[ _ 2array ] bi@ 2array , ;
:: resolve-value-data-flow ( bb to vreg -- )
vreg bb vreg-at-end
vreg to vreg-at-start
2dup eq? [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
2dup = [ 2drop ] [ vreg reg-class>> add-mapping ] if ;
: compute-mappings ( bb to -- mappings )
[
@ -33,6 +31,36 @@ IN: compiler.cfg.linear-scan.resolve
[ resolve-value-data-flow ] with with each
] { } make ;
: memory->register ( from to -- )
swap [ first2 ] [ first n>> ] bi* _reload ;
: register->memory ( from to -- )
[ first2 ] [ first n>> ] bi* _spill ;
: temp->register ( from to -- )
nip [ first ] [ second ] [ second spill-temp ] tri _reload ;
: register->temp ( from to -- )
drop [ first2 ] [ second spill-temp ] bi _spill ;
: register->register ( from to -- )
swap [ first ] [ first2 ] bi* _copy ;
SYMBOL: temp
: >insn ( from to -- )
{
{ [ over temp eq? ] [ temp->register ] }
{ [ dup temp eq? ] [ register->temp ] }
{ [ over first spill-slot? ] [ memory->register ] }
{ [ dup first spill-slot? ] [ register->memory ] }
[ register->register ]
} cond ;
: mapping-instructions ( alist -- insns )
[ swap ] H{ } assoc-map-as
[ temp [ swap >insn ] parallel-mapping ] { } make ;
: perform-mappings ( bb to mappings -- )
dup empty? [ 3drop ] [
mapping-instructions <simple-block>
@ -46,4 +74,5 @@ IN: compiler.cfg.linear-scan.resolve
dup successors>> [ resolve-edge-data-flow ] with each ;
: resolve-data-flow ( cfg -- )
H{ } clone spill-temps set
[ resolve-block-data-flow ] each-basic-block ;

15
basis/compiler/cfg/linearization/linearization.factor
View File

@ -6,7 +6,8 @@ compiler.cfg
compiler.cfg.rpo
compiler.cfg.comparisons
compiler.cfg.stack-frame
compiler.cfg.instructions ;
compiler.cfg.instructions
compiler.cfg.utilities ;
IN: compiler.cfg.linearization
! Convert CFG IR to machine IR.
@ -24,7 +25,11 @@ M: insn linearize-insn , drop ;
#! don't need to branch.
[ number>> ] bi@ 1 - = ; inline
: emit-branch ( basic-block successor -- )
: emit-loop-entry? ( bb successor -- ? )
[ back-edge? not ] [ nip loop-entry? ] 2bi and ;
: emit-branch ( bb successor -- )
2dup emit-loop-entry? [ _loop-entry ] when
2dup useless-branch? [ 2drop ] [ nip number>> _branch ] if ;
M: ##branch linearize-insn
@ -32,11 +37,11 @@ M: ##branch linearize-insn
: successors ( bb -- first second ) successors>> first2 ; inline
: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
: (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
[ dup successors ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
: binary-conditional ( basic-block insn -- basic-block successor label2 src1 src2 cc )
: binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
[ (binary-conditional) ]
[ drop dup successors>> second useless-branch? ] 2bi
[ [ swap number>> ] 3dip ] [ [ number>> ] 3dip negate-cc ] if ;
@ -53,7 +58,7 @@ M: ##compare-imm-branch linearize-insn
M: ##compare-float-branch linearize-insn
[ binary-conditional _compare-float-branch ] with-regs emit-branch ;
: overflow-conditional ( basic-block insn -- basic-block successor label2 dst src1 src2 )
: overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
[ dup successors number>> ]
[ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline

34
basis/compiler/cfg/liveness/liveness-tests.factor
View File

@ -1,9 +1,14 @@
USING: compiler.cfg.liveness compiler.cfg.debugger
compiler.cfg.instructions compiler.cfg.predecessors
compiler.cfg.registers compiler.cfg cpu.architecture
accessors namespaces sequences kernel tools.test ;
accessors namespaces sequences kernel tools.test vectors ;
IN: compiler.cfg.liveness.tests
: test-liveness ( -- )
cfg new 1 get >>entry
compute-predecessors
compute-live-sets ;
! Sanity check...
V{
@ -11,21 +16,22 @@ V{
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 1 D 1 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##branch }
} 1 test-bb
V{
T{ ##replace f V int-regs 2 D 0 }
T{ ##branch }
} 2 test-bb
V{
T{ ##replace f V int-regs 3 D 0 }
T{ ##return }
} 3 test-bb
1 get 2 get 3 get V{ } 2sequence >>successors drop
cfg new 1 get >>entry
compute-predecessors
compute-live-sets
test-liveness
[
H{
@ -35,4 +41,22 @@ compute-live-sets
}
]
[ 1 get live-in ]
unit-test
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

15
basis/compiler/cfg/liveness/liveness.factor
View File

@ -10,14 +10,19 @@ IN: compiler.cfg.liveness
BACKWARD-ANALYSIS: live
GENERIC: insn-liveness ( live-set insn -- )
: kill-defs ( live-set insn -- live-set )
defs-vreg [ over delete-at ] when* ;
: gen-uses ( live-set insn -- live-set )
dup ##phi? [ drop ] [ uses-vregs [ over conjoin ] each ] if ;
: transfer-liveness ( live-set instructions -- live-set' )
[ clone ] [ <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 ;

57
basis/compiler/cfg/liveness/ssa/ssa.factor Normal file
View File

@ -0,0 +1,57 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces deques accessors sets sequences assocs fry
hashtables dlists compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.rpo compiler.cfg.liveness ;
IN: compiler.cfg.liveness.ssa
! TODO: merge with compiler.cfg.liveness
! Assoc mapping basic blocks to sequences of sets of vregs; each sequence
! is in conrrespondence with a predecessor
SYMBOL: phi-live-ins
: phi-live-in ( predecessor basic-block -- set ) phi-live-ins get at at ;
SYMBOL: work-list
: add-to-work-list ( basic-blocks -- )
work-list get '[ _ push-front ] each ;
: compute-live-in ( basic-block -- live-in )
[ live-out ] keep instructions>> transfer-liveness ;
: compute-phi-live-in ( basic-block -- phi-live-in )
instructions>> [ ##phi? ] filter [ f ] [
H{ } clone [
'[ inputs>> [ swap _ conjoin-at ] assoc-each ] each
] keep
] if-empty ;
: update-live-in ( basic-block -- changed? )
[ [ compute-live-in ] keep live-ins get maybe-set-at ]
[ [ compute-phi-live-in ] keep phi-live-ins get maybe-set-at ]
bi and ;
: compute-live-out ( basic-block -- live-out )
[ successors>> [ live-in ] map ]
[ dup successors>> [ phi-live-in ] with map ] bi
append assoc-combine ;
: update-live-out ( basic-block -- changed? )
[ compute-live-out ] keep
live-outs get maybe-set-at ;
: liveness-step ( basic-block -- )
dup update-live-out [
dup update-live-in
[ predecessors>> add-to-work-list ] [ drop ] if
] [ drop ] if ;
: compute-ssa-live-sets ( cfg -- cfg' )
<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 ;

58
basis/compiler/cfg/optimizer/optimizer-tests.factor
View File

@ -1,58 +0,0 @@
USING: accessors arrays compiler.cfg.checker
compiler.cfg.debugger compiler.cfg.def-use
compiler.cfg.instructions fry kernel kernel.private math
math.partial-dispatch math.private sbufs sequences sequences.private sets
slots.private strings strings.private tools.test vectors layouts ;
IN: compiler.cfg.optimizer.tests
! Miscellaneous tests
: more? ( x -- ? ) ;
: test-case-1 ( -- ? ) f ;
: test-case-2 ( -- )
test-case-1 [ test-case-2 ] [ ] if ; inline recursive
{
[ 1array ]
[ 1 2 ? ]
[ { array } declare [ ] map ]
[ { array } declare dup 1 slot [ 1 slot ] when ]
[ [ dup more? ] [ dup ] produce ]
[ vector new over test-case-1 [ test-case-2 ] [ ] if ]
[ [ [ nth-unsafe ".." = 0 ] dip set-nth-unsafe ] 2curry (each-integer) ]
[
{ fixnum sbuf } declare 2dup 3 slot fixnum> [
over 3 fixnum* over dup [ 2 slot resize-string ] dip 2 set-slot
] [ ] if
]
[ [ 2 fixnum* ] when 3 ]
[ [ 2 fixnum+ ] when 3 ]
[ [ 2 fixnum- ] when 3 ]
[ 10000 [ ] times ]
[
over integer? [
over dup 16 <-integer-fixnum
[ 0 >=-integer-fixnum ] [ drop f ] if [
nip dup
[ ] [ ] if
] [ 2drop f ] if
] [ 2drop f ] if
]
[
pick 10 fixnum>= [ [ 123 fixnum-bitand ] 2dip ] [ ] if
set-string-nth-fast
]
} [
[ [ ] ] dip '[ _ test-mr first check-mr ] unit-test
] each
cell 8 = [
[ t ]
[
[
1 50 fixnum-shift-fast fixnum+fast
] test-mr first instructions>> [ ##add? ] any?
] unit-test
] when

14
basis/compiler/cfg/optimizer/optimizer.factor
View File

@ -2,17 +2,19 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors combinators namespaces
compiler.cfg.tco
compiler.cfg.predecessors
compiler.cfg.useless-conditionals
compiler.cfg.stack-analysis
compiler.cfg.branch-splitting
compiler.cfg.block-joining
compiler.cfg.ssa.construction
compiler.cfg.alias-analysis
compiler.cfg.value-numbering
compiler.cfg.copy-prop
compiler.cfg.dce
compiler.cfg.write-barrier
compiler.cfg.ssa.destruction
compiler.cfg.empty-blocks
compiler.cfg.predecessors
compiler.cfg.rpo
compiler.cfg.phi-elimination
compiler.cfg.checker ;
IN: compiler.cfg.optimizer
@ -33,12 +35,14 @@ SYMBOL: check-optimizer?
split-branches
join-blocks
compute-predecessors
stack-analysis
construct-ssa
alias-analysis
value-numbering
compute-predecessors
copy-propagation
eliminate-dead-code
eliminate-write-barriers
eliminate-phis
destruct-ssa
delete-empty-blocks
?check
] with-scope ;

63
basis/compiler/cfg/parallel-copy/parallel-copy-tests.factor Normal file
View File

@ -0,0 +1,63 @@
USING: compiler.cfg.parallel-copy tools.test make arrays
compiler.cfg.registers namespaces compiler.cfg.instructions
cpu.architecture ;
IN: compiler.cfg.parallel-copy.tests
SYMBOL: temp
: test-parallel-copy ( mapping -- seq )
3 vreg-counter set-global
[ parallel-copy ] { } make ;
[
{
T{ ##copy f V int-regs 4 V int-regs 2 }
T{ ##copy f V int-regs 2 V int-regs 1 }
T{ ##copy f V int-regs 1 V int-regs 4 }
}
] [
H{
{ V int-regs 1 V int-regs 2 }
{ V int-regs 2 V int-regs 1 }
} test-parallel-copy
] unit-test
[
{
T{ ##copy f V int-regs 1 V int-regs 2 }
T{ ##copy f V int-regs 3 V int-regs 4 }
}
] [
H{
{ V int-regs 1 V int-regs 2 }
{ V int-regs 3 V int-regs 4 }
} test-parallel-copy
] unit-test
[
{
T{ ##copy f V int-regs 1 V int-regs 3 }
T{ ##copy f V int-regs 2 V int-regs 1 }
}
] [
H{
{ V int-regs 1 V int-regs 3 }
{ V int-regs 2 V int-regs 3 }
} test-parallel-copy
] unit-test
[
{
T{ ##copy f V int-regs 4 V int-regs 3 }
T{ ##copy f V int-regs 3 V int-regs 2 }
T{ ##copy f V int-regs 2 V int-regs 1 }
T{ ##copy f V int-regs 1 V int-regs 4 }
}
] [
{
{ V int-regs 2 V int-regs 1 }
{ V int-regs 3 V int-regs 2 }
{ V int-regs 1 V int-regs 3 }
{ V int-regs 4 V int-regs 3 }
} test-parallel-copy
] unit-test

60
basis/compiler/cfg/parallel-copy/parallel-copy.factor Normal file
View File

@ -0,0 +1,60 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs compiler.cfg.hats compiler.cfg.instructions
deques dlists fry kernel locals namespaces sequences
hashtables ;
IN: compiler.cfg.parallel-copy
! Revisiting Out-of-SSA Translation for Correctness, Code Quality, and Efficiency
! http://hal.archives-ouvertes.fr/docs/00/34/99/25/PDF/OutSSA-RR.pdf,
! Algorithm 1
<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 ;

2
basis/compiler/cfg/phi-elimination/authors.txt
View File

@ -1,2 +0,0 @@
Slava Pestov
Daniel Ehrenberg

55
basis/compiler/cfg/phi-elimination/phi-elimination-tests.factor
View File

@ -1,55 +0,0 @@
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.cfg.instructions compiler.cfg compiler.cfg.registers
compiler.cfg.comparisons compiler.cfg.debugger locals
compiler.cfg.phi-elimination kernel accessors sequences classes
namespaces tools.test cpu.architecture arrays ;
IN: compiler.cfg.phi-elimination.tests
V{ T{ ##branch } } 0 test-bb
V{
T{ ##peek f V int-regs 0 D 0 }
T{ ##compare-branch f V int-regs 0 V int-regs 0 cc< }
} 1 test-bb
V{
T{ ##load-immediate f V int-regs 1 1 }
T{ ##branch }
} 2 test-bb
V{
T{ ##load-immediate f V int-regs 2 2 }
T{ ##branch }
} 3 test-bb
V{
T{ ##phi f V int-regs 3 { } }
T{ ##replace f V int-regs 3 D 0 }
T{ ##return }
} 4 test-bb
4 get instructions>> first
2 get V int-regs 1 2array
3 get V int-regs 2 2array 2array
>>inputs drop
test-diamond
3 vreg-counter set-global
[ ] [ cfg new 0 get >>entry eliminate-phis drop ] unit-test
[ T{ ##copy f V int-regs 4 V int-regs 1 } ] [
2 get successors>> first instructions>> first
] unit-test
[ T{ ##copy f V int-regs 4 V int-regs 2 } ] [
3 get successors>> first instructions>> first
] unit-test
[ T{ ##copy f V int-regs 3 V int-regs 4 } ] [
4 get instructions>> first
] unit-test
[ 3 ] [ 4 get instructions>> length ] unit-test

26
basis/compiler/cfg/phi-elimination/phi-elimination.factor
View File

@ -1,26 +0,0 @@
! Copyright (C) 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel sequences namespaces
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
compiler.cfg.utilities compiler.cfg.hats make
locals ;
IN: compiler.cfg.phi-elimination
: insert-copy ( predecessor input output -- )
'[ _ _ swap ##copy ] add-instructions ;
: eliminate-phi ( ##phi -- ##copy )
i
[ [ inputs>> ] dip '[ _ insert-copy ] assoc-each ]
[ [ dst>> ] dip \ ##copy new-insn ]
2bi ;
: eliminate-phi-step ( bb -- )
H{ } clone added-instructions set
[ instructions>> [ dup ##phi? [ eliminate-phi ] when ] change-each ]
[ insert-basic-blocks ]
bi ;
: eliminate-phis ( cfg -- cfg' )
dup [ eliminate-phi-step ] each-basic-block
cfg-changed ;

116
basis/compiler/cfg/renaming/functor/functor.factor Normal file
View File

@ -0,0 +1,116 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: functors assocs kernel accessors compiler.cfg.instructions
lexer parser ;
IN: compiler.cfg.renaming.functor
FUNCTOR: define-renaming ( NAME DEF-QUOT USE-QUOT -- )
rename-insn-defs DEFINES ${NAME}-insn-defs
rename-insn-uses DEFINES ${NAME}-insn-uses
WHERE
GENERIC: rename-insn-defs ( insn -- )
M: ##flushable rename-insn-defs
DEF-QUOT change-dst
drop ;
M: ##fixnum-overflow rename-insn-defs
DEF-QUOT change-dst
drop ;
M: _fixnum-overflow rename-insn-defs
DEF-QUOT change-dst
drop ;
M: insn rename-insn-defs drop ;
GENERIC: rename-insn-uses ( insn -- )
M: ##effect rename-insn-uses
USE-QUOT change-src
drop ;
M: ##unary rename-insn-uses
USE-QUOT change-src
drop ;
M: ##binary rename-insn-uses
USE-QUOT change-src1
USE-QUOT change-src2
drop ;
M: ##binary-imm rename-insn-uses
USE-QUOT change-src1
drop ;
M: ##slot rename-insn-uses
USE-QUOT change-obj
USE-QUOT change-slot
drop ;
M: ##slot-imm rename-insn-uses
USE-QUOT change-obj
drop ;
M: ##set-slot rename-insn-uses
dup call-next-method
USE-QUOT change-obj
USE-QUOT change-slot
drop ;
M: ##string-nth rename-insn-uses
USE-QUOT change-obj
USE-QUOT change-index
drop ;
M: ##set-string-nth-fast rename-insn-uses
dup call-next-method
USE-QUOT change-obj
USE-QUOT change-index
drop ;
M: ##set-slot-imm rename-insn-uses
dup call-next-method
USE-QUOT change-obj
drop ;
M: ##alien-getter rename-insn-uses
dup call-next-method
USE-QUOT change-src
drop ;
M: ##alien-setter rename-insn-uses
dup call-next-method
USE-QUOT change-value
drop ;
M: ##conditional-branch rename-insn-uses
USE-QUOT change-src1
USE-QUOT change-src2
drop ;
M: ##compare-imm-branch rename-insn-uses
USE-QUOT change-src1
drop ;
M: ##dispatch rename-insn-uses
USE-QUOT change-src
drop ;
M: ##fixnum-overflow rename-insn-uses
USE-QUOT change-src1
USE-QUOT change-src2
drop ;
M: ##phi rename-insn-uses
[ USE-QUOT assoc-map ] change-inputs
drop ;
M: insn rename-insn-uses drop ;
;FUNCTOR
SYNTAX: RENAMING: scan scan-object scan-object define-renaming ;

102
basis/compiler/cfg/renaming/renaming.factor
View File

@ -1,108 +1,16 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces sequences
compiler.cfg.instructions compiler.cfg.registers ;
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.renaming.functor ;
IN: compiler.cfg.renaming
SYMBOL: renamings
: rename-value ( vreg -- vreg' ) renamings get ?at drop ;
: rename-value ( vreg -- vreg' )
renamings get ?at drop ;
GENERIC: rename-insn-defs ( insn -- )
M: ##flushable rename-insn-defs
[ rename-value ] change-dst
drop ;
M: ##fixnum-overflow rename-insn-defs
[ rename-value ] change-dst
drop ;
M: _fixnum-overflow rename-insn-defs
[ rename-value ] change-dst
drop ;
M: insn rename-insn-defs drop ;
GENERIC: rename-insn-uses ( insn -- )
M: ##effect rename-insn-uses
[ rename-value ] change-src
drop ;
M: ##unary rename-insn-uses
[ rename-value ] change-src
drop ;
M: ##binary rename-insn-uses
[ rename-value ] change-src1
[ rename-value ] change-src2
drop ;
M: ##binary-imm rename-insn-uses
[ rename-value ] change-src1
drop ;
M: ##slot rename-insn-uses
[ rename-value ] change-obj
[ rename-value ] change-slot
drop ;
M: ##slot-imm rename-insn-uses
[ rename-value ] change-obj
drop ;
M: ##set-slot rename-insn-uses
dup call-next-method
[ rename-value ] change-obj
[ rename-value ] change-slot
drop ;
M: ##string-nth rename-insn-uses
[ rename-value ] change-obj
[ rename-value ] change-index
drop ;
M: ##set-string-nth-fast rename-insn-uses
dup call-next-method
[ rename-value ] change-obj
[ rename-value ] change-index
drop ;
M: ##set-slot-imm rename-insn-uses
dup call-next-method
[ rename-value ] change-obj
drop ;
M: ##alien-getter rename-insn-uses
dup call-next-method
[ rename-value ] change-src
drop ;
M: ##alien-setter rename-insn-uses
dup call-next-method
[ rename-value ] change-value
drop ;
M: ##conditional-branch rename-insn-uses
[ rename-value ] change-src1
[ rename-value ] change-src2
drop ;
M: ##compare-imm-branch rename-insn-uses
[ rename-value ] change-src1
drop ;
M: ##dispatch rename-insn-uses
[ rename-value ] change-src
drop ;
M: ##fixnum-overflow rename-insn-uses
[ rename-value ] change-src1
[ rename-value ] change-src2
drop ;
M: insn rename-insn-uses drop ;
RENAMING: rename [ rename-value ] [ rename-value ]
: fresh-vreg ( vreg -- vreg' )
reg-class>> next-vreg ;

4
basis/compiler/cfg/ssa/ssa-tests.factor → basis/compiler/cfg/ssa/construction/construction-tests.factor
View File

@ -1,9 +1,9 @@
USING: accessors compiler.cfg compiler.cfg.debugger
compiler.cfg.dominance compiler.cfg.instructions
compiler.cfg.predecessors compiler.cfg.ssa assocs
compiler.cfg.predecessors compiler.cfg.ssa.construction assocs
compiler.cfg.registers cpu.architecture kernel namespaces sequences
tools.test vectors ;
IN: compiler.cfg.ssa.tests
IN: compiler.cfg.ssa.construction.tests
: reset-counters ( -- )
! Reset counters so that results are deterministic w.r.t. hash order

103
basis/compiler/cfg/ssa/ssa.factor → basis/compiler/cfg/ssa/construction/construction.factor
View File

@ -5,40 +5,51 @@ 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
compiler.cfg.instructions
compiler.cfg.renaming.functor
compiler.cfg.ssa.construction.tdmsc ;
IN: compiler.cfg.ssa.construction
! 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
! The phi placement algorithm is implemented in
! compiler.cfg.ssa.construction.tdmsc.
! Eventually might be worth trying something fancier:
! http://portal.acm.org/citation.cfm?id=1065887.1065890
! 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 vreg to sequence of basic blocks
! 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
: 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
@ -46,15 +57,11 @@ SYMBOL: inserting-phi-nodes
] [ 2drop ] if ;
: compute-phi-nodes-for ( vreg bbs -- )
keys dup length 2 >= [
iterated-dom-frontier [
insert-phi-node-later
] with each
] [ 2drop ] if ;
keys [ insert-phi-node-later ] with merge-set-each ;
: compute-phi-nodes ( -- )
H{ } clone inserting-phi-nodes set
defs get [ compute-phi-nodes-for ] assoc-each ;
defs-multi get defs get '[ _ at compute-phi-nodes-for ] assoc-each ;
: insert-phi-nodes-in ( phis bb -- )
[ append ] change-instructions drop ;
@ -62,31 +69,32 @@ SYMBOL: inserting-phi-nodes
: insert-phi-nodes ( -- )
inserting-phi-nodes get [ swap insert-phi-nodes-in ] assoc-each ;
SYMBOLS: stacks originals ;
SYMBOLS: stacks pushed ;
: init-renaming ( -- )
H{ } clone stacks set
H{ } clone originals set ;
H{ } clone stacks set ;
: gen-name ( vreg -- vreg' )
[ reg-class>> next-vreg ] keep
[ stacks get push-at ]
[ swap originals get set-at ]
[ drop ]
2tri ;
[ 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
[ 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 ]
[ ssa-rename-insn-uses ]
[ ssa-rename-insn-defs ]
bi ;
M: ##phi rename-insn
dup defs-vregs [ dup gen-name ] { } map>assoc renamings set rename-insn-defs ;
ssa-rename-insn-defs ;
: rename-insns ( bb -- )
instructions>> [ rename-insn ] each ;
@ -101,19 +109,19 @@ M: ##phi rename-insn
: 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 ;
: pop-stacks ( -- )
pushed get stacks get '[ drop _ at pop* ] assoc-each ;
: rename-in-block ( bb -- )
{
[ rename-insns ]
[ rename-successors-phis ]
[ dom-children [ rename-in-block ] each ]
[ pop-stacks ]
} cleave ;
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
@ -126,6 +134,7 @@ PRIVATE>
[ ]
[ compute-live-sets ]
[ compute-dominance ]
[ compute-merge-sets ]
[ compute-defs compute-phi-nodes insert-phi-nodes ]
[ rename ]
} cleave ;

75
basis/compiler/cfg/ssa/construction/tdmsc/tdmsc-tests.factor Normal file
View File

@ -0,0 +1,75 @@
USING: accessors arrays compiler.cfg compiler.cfg.debugger
compiler.cfg.dominance compiler.cfg.predecessors
compiler.cfg.ssa.construction.tdmsc kernel namespaces sequences
tools.test vectors sets ;
IN: compiler.cfg.ssa.construction.tdmsc.tests
: test-tdmsc ( -- )
cfg new 0 get >>entry
compute-predecessors
dup compute-dominance
compute-merge-sets ;
V{ } 0 test-bb
V{ } 1 test-bb
V{ } 2 test-bb
V{ } 3 test-bb
V{ } 4 test-bb
V{ } 5 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
1 get 3 get 1vector >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
[ ] [ test-tdmsc ] unit-test
[ V{ 4 } ] [ 1 get 1array merge-set [ number>> ] map ] unit-test
[ V{ 4 } ] [ 2 get 1array merge-set [ number>> ] map ] unit-test
[ V{ } ] [ 0 get 1array merge-set ] unit-test
[ V{ } ] [ 4 get 1array merge-set ] unit-test
V{ } 0 test-bb
V{ } 1 test-bb
V{ } 2 test-bb
V{ } 3 test-bb
V{ } 4 test-bb
V{ } 5 test-bb
V{ } 6 test-bb
0 get 1 get 5 get V{ } 2sequence >>successors drop
1 get 2 get 3 get V{ } 2sequence >>successors drop
2 get 4 get 1vector >>successors drop
3 get 4 get 1vector >>successors drop
4 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
[ ] [ test-tdmsc ] unit-test
[ t ] [
2 get 3 get 2array merge-set
4 get 6 get 2array set=
] unit-test
V{ } 0 test-bb
V{ } 1 test-bb
V{ } 2 test-bb
V{ } 3 test-bb
V{ } 4 test-bb
V{ } 5 test-bb
V{ } 6 test-bb
V{ } 7 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
2 get 3 get 6 get V{ } 2sequence >>successors drop
3 get 4 get 1vector >>successors drop
6 get 7 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
5 get 2 get 1vector >>successors drop
[ ] [ test-tdmsc ] unit-test
[ V{ 2 } ] [ { 2 3 4 5 } [ get ] map merge-set [ number>> ] map ] unit-test
[ V{ } ] [ { 0 1 6 7 } [ get ] map merge-set ] unit-test

109
basis/compiler/cfg/ssa/construction/tdmsc/tdmsc.factor Normal file
View File

@ -0,0 +1,109 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs bit-arrays bit-sets fry
hashtables hints kernel locals math namespaces sequences sets
compiler.cfg compiler.cfg.dominance compiler.cfg.rpo ;
IN: compiler.cfg.ssa.construction.tdmsc
! TDMSC-I algorithm from "A Practical and Fast Iterative Algorithm for
! Phi-Function Computation Using DJ Graphs"
! http://portal.acm.org/citation.cfm?id=1065887.1065890
<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 ;

28
basis/compiler/cfg/ssa/destruction/copies/copies.factor Normal file
View File

@ -0,0 +1,28 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs hashtables fry kernel make namespaces
sequences compiler.cfg.ssa.destruction.state compiler.cfg.parallel-copy ;
IN: compiler.cfg.ssa.destruction.copies
ERROR: bad-copy ;
: compute-copies ( assoc -- assoc' )
dup assoc-size <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 ;

63
basis/compiler/cfg/ssa/destruction/destruction.factor Normal file
View File

@ -0,0 +1,63 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel locals math math.order
sequences namespaces sets
compiler.cfg.rpo
compiler.cfg.def-use
compiler.cfg.utilities
compiler.cfg.dominance
compiler.cfg.instructions
compiler.cfg.liveness.ssa
compiler.cfg.critical-edges
compiler.cfg.ssa.destruction.state
compiler.cfg.ssa.destruction.forest
compiler.cfg.ssa.destruction.copies
compiler.cfg.ssa.destruction.renaming
compiler.cfg.ssa.destruction.live-ranges
compiler.cfg.ssa.destruction.process-blocks ;
IN: compiler.cfg.ssa.destruction
! Based on "Fast Copy Coalescing and Live-Range Identification"
! http://www.cs.ucsd.edu/classes/sp02/cse231/kenpldi.pdf
! Dominance, liveness and def-use need to be computed
: process-blocks ( cfg -- )
[ [ process-block ] if-has-phis ] each-basic-block ;
SYMBOL: seen
:: visit-renaming ( dst assoc src bb -- )
src seen get key? [
src dst bb waiting-for push-at
src assoc delete-at
] [ src seen get conjoin ] if ;
:: break-interferences ( -- )
V{ } clone seen set
renaming-sets get [| dst assoc |
assoc [| src bb |
dst assoc src bb visit-renaming
] assoc-each
] assoc-each ;
: remove-phis-from-block ( bb -- )
instructions>> [ ##phi? not ] filter-here ;
: remove-phis ( cfg -- )
[ [ remove-phis-from-block ] if-has-phis ] each-basic-block ;
: destruct-ssa ( cfg -- cfg' )
dup cfg-has-phis? [
init-coalescing
compute-ssa-live-sets
dup split-critical-edges
dup compute-def-use
dup compute-dominance
dup compute-live-ranges
dup process-blocks
break-interferences
dup perform-renaming
insert-copies
dup remove-phis
] when ;

86
basis/compiler/cfg/ssa/destruction/forest/forest-tests.factor Normal file
View File

@ -0,0 +1,86 @@
USING: accessors compiler.cfg compiler.cfg.ssa.destruction.forest
compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions
compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.def-use
cpu.architecture kernel namespaces sequences tools.test vectors sorting
math.order ;
IN: compiler.cfg.ssa.destruction.forest.tests
V{ T{ ##peek f V int-regs 0 D 0 } } clone 0 test-bb
V{ T{ ##peek f V int-regs 1 D 0 } } clone 1 test-bb
V{ T{ ##peek f V int-regs 2 D 0 } } clone 2 test-bb
V{ T{ ##peek f V int-regs 3 D 0 } } clone 3 test-bb
V{ T{ ##peek f V int-regs 4 D 0 } } clone 4 test-bb
V{ T{ ##peek f V int-regs 5 D 0 } } clone 5 test-bb
V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb
0 get 1 get 2 get V{ } 2sequence >>successors drop
2 get 3 get 4 get V{ } 2sequence >>successors drop
3 get 5 get 1vector >>successors drop
4 get 5 get 1vector >>successors drop
1 get 6 get 1vector >>successors drop
5 get 6 get 1vector >>successors drop
: clean-up-forest ( forest -- forest' )
[ [ vreg>> n>> ] compare ] sort
[
[ clean-up-forest ] change-children
[ number>> ] change-bb
] V{ } map-as ;
: test-dom-forest ( vregs -- forest )
cfg new 0 get >>entry
compute-predecessors
dup compute-dominance
compute-def-use
compute-dom-forest
clean-up-forest ;
[ V{ } ] [ { } test-dom-forest ] unit-test
[ V{ T{ dom-forest-node f V int-regs 0 0 V{ } } } ]
[ { V int-regs 0 } test-dom-forest ]
unit-test
[
V{
T{ dom-forest-node
f
V int-regs 0
0
V{ T{ dom-forest-node f V int-regs 1 1 V{ } } }
}
}
]
[ { V int-regs 0 V int-regs 1 } test-dom-forest ]
unit-test
[
V{
T{ dom-forest-node
f
V int-regs 1
1
V{ }
}
T{ dom-forest-node
f
V int-regs 2
2
V{
T{ dom-forest-node f V int-regs 3 3 V{ } }
T{ dom-forest-node f V int-regs 4 4 V{ } }
T{ dom-forest-node f V int-regs 5 5 V{ } }
}
}
T{ dom-forest-node
f
V int-regs 6
6
V{ }
}
}
]
[
{ V int-regs 1 V int-regs 6 V int-regs 2 V int-regs 3 V int-regs 4 V int-regs 5 }
test-dom-forest
] unit-test

38
basis/compiler/cfg/ssa/destruction/forest/forest.factor Normal file
View File

@ -0,0 +1,38 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel math math.order
namespaces sequences sorting vectors compiler.cfg.def-use
compiler.cfg.dominance compiler.cfg.registers ;
IN: compiler.cfg.ssa.destruction.forest
TUPLE: dom-forest-node vreg bb children ;
<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>> ;

44
basis/compiler/cfg/ssa/destruction/interference/interference.factor Normal file
View File

@ -0,0 +1,44 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.short-circuit
kernel math namespaces sequences locals compiler.cfg.def-use
compiler.cfg.dominance compiler.cfg.ssa.destruction.live-ranges ;
IN: compiler.cfg.ssa.destruction.interference
<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 ;

60
basis/compiler/cfg/ssa/destruction/live-ranges/live-ranges.factor Normal file
View File

@ -0,0 +1,60 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel namespaces sequences math
arrays compiler.cfg.def-use compiler.cfg.instructions
compiler.cfg.liveness compiler.cfg.rpo ;
IN: compiler.cfg.ssa.destruction.live-ranges
! Live ranges for interference testing
<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 ;

138
basis/compiler/cfg/ssa/destruction/process-blocks/process-blocks.factor Normal file
View File

@ -0,0 +1,138 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel locals math math.order arrays
namespaces sequences sorting sets combinators combinators.short-circuit make
compiler.cfg.def-use
compiler.cfg.instructions
compiler.cfg.liveness
compiler.cfg.dominance
compiler.cfg.ssa.destruction.state
compiler.cfg.ssa.destruction.forest
compiler.cfg.ssa.destruction.interference ;
IN: compiler.cfg.ssa.destruction.process-blocks
! phi-union maps a vreg to the predecessor block
! that carries it to the phi node's block
! unioned-blocks is a set of bb's which defined
! the source vregs above
SYMBOLS: phi-union unioned-blocks ;
:: operand-live-into-phi-node's-block? ( bb src dst -- ? )
src bb live-in key? ;
:: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? )
dst src def-of live-out key? ;
:: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? )
{ [ src insn-of ##phi? ] [ src src def-of live-in key? ] } 0&& ;
:: operand-being-renamed? ( bb src dst -- ? )
src processed-names get key? ;
:: two-operands-in-same-block? ( bb src dst -- ? )
src def-of unioned-blocks get key? ;
: trivial-interference? ( bb src dst -- ? )
{
[ operand-live-into-phi-node's-block? ]
[ phi-node-is-live-out-of-operand's-block? ]
[ operand-is-phi-node-and-live-into-operand's-block? ]
[ operand-being-renamed? ]
[ two-operands-in-same-block? ]
} 3|| ;
: don't-coalesce ( bb src dst -- )
2nip processed-name ;
:: trivial-interference ( bb src dst -- )
dst src bb waiting-for push-at
src used-by-another get push ;
:: add-to-renaming-set ( bb src dst -- )
bb src phi-union get set-at
src def-of unioned-blocks get conjoin ;
: process-phi-operand ( bb src dst -- )
{
{ [ 2dup eq? ] [ don't-coalesce ] }
{ [ 3dup trivial-interference? ] [ trivial-interference ] }
[ add-to-renaming-set ]
} cond ;
: node-is-live-in-of-child? ( node child -- ? )
[ vreg>> ] [ bb>> live-in ] bi* key? ;
: node-is-live-out-of-child? ( node child -- ? )
[ vreg>> ] [ bb>> live-out ] bi* key? ;
:: insert-copy ( bb src dst -- )
bb src dst trivial-interference
src phi-union get delete-at ;
:: insert-copy-for-parent ( bb src node dst -- )
src node vreg>> eq? [ bb src dst insert-copy ] when ;
: insert-copies-for-parent ( ##phi node child -- )
drop
[ [ inputs>> ] [ dst>> ] bi ] dip
'[ _ _ insert-copy-for-parent ] assoc-each ;
: defined-in-same-block? ( node child -- ? ) [ bb>> ] bi@ eq? ;
: add-interference ( ##phi node child -- )
[ vreg>> ] bi@ 2array , drop ;
: process-df-child ( ##phi node child -- )
{
{ [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] }
{ [ 2dup node-is-live-in-of-child? ] [ add-interference ] }
{ [ 2dup defined-in-same-block? ] [ add-interference ] }
[ 3drop ]
} cond ;
: process-df-node ( ##phi node -- )
dup children>>
[ [ process-df-child ] with with each ]
[ nip [ process-df-node ] with each ]
3bi ;
: process-phi-union ( ##phi dom-forest -- )
[ process-df-node ] with each ;
: add-local-interferences ( ##phi -- )
[ phi-union get ] dip dst>> '[ drop _ 2array , ] assoc-each ;
: compute-local-interferences ( ##phi -- pairs )
[
[ phi-union get keys compute-dom-forest process-phi-union ]
[ add-local-interferences ]
bi
] { } make ;
:: insert-copies-for-interference ( ##phi src -- )
##phi inputs>> [| bb src' |
src src' eq? [ bb src ##phi dst>> insert-copy ] when
] assoc-each ;
: process-local-interferences ( ##phi pairs -- )
[
first2 2dup interferes?
[ drop insert-copies-for-interference ] [ 3drop ] if
] with each ;
: add-renaming-set ( ##phi -- )
[ phi-union get ] dip dst>> renaming-sets get set-at
phi-union get [ drop processed-name ] assoc-each ;
: process-phi ( ##phi -- )
H{ } clone phi-union set
H{ } clone unioned-blocks set
[ [ inputs>> ] [ dst>> ] bi '[ _ process-phi-operand ] assoc-each ]
[ dup compute-local-interferences process-local-interferences ]
[ add-renaming-set ]
tri ;
: process-block ( bb -- )
instructions>>
[ dup ##phi? [ process-phi t ] [ drop f ] if ] all? drop ;

47
basis/compiler/cfg/ssa/destruction/renaming/renaming.factor Normal file
View File

@ -0,0 +1,47 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel namespaces sequences
compiler.cfg.ssa.destruction.state compiler.cfg.renaming compiler.cfg.rpo
disjoint-sets ;
IN: compiler.cfg.ssa.destruction.renaming
: build-disjoint-set ( assoc -- disjoint-set )
<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 ;

16
basis/compiler/cfg/ssa/destruction/state/state.factor Normal file
View File

@ -0,0 +1,16 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sets kernel assocs ;
IN: compiler.cfg.ssa.destruction.state
SYMBOLS: processed-names waiting used-by-another renaming-sets ;
: init-coalescing ( -- )
H{ } clone renaming-sets set
H{ } clone processed-names set
H{ } clone waiting set
V{ } clone used-by-another set ;
: processed-name ( vreg -- ) processed-names get conjoin ;
: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ;

1
basis/compiler/cfg/stack-analysis/authors.txt
View File

@ -1 +0,0 @@
Slava Pestov

104
basis/compiler/cfg/stack-analysis/merge/merge-tests.factor
View File

@ -1,104 +0,0 @@
IN: compiler.cfg.stack-analysis.merge.tests
USING: compiler.cfg.stack-analysis.merge tools.test arrays accessors
compiler.cfg.instructions compiler.cfg.stack-analysis.state
compiler.cfg.utilities compiler.cfg compiler.cfg.registers
compiler.cfg.debugger cpu.architecture make assocs namespaces
sequences kernel classes ;
[
{ D 0 }
{ V int-regs 0 V int-regs 1 }
] [
<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

117
basis/compiler/cfg/stack-analysis/merge/merge.factor
View File

@ -1,117 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel assocs sequences accessors fry combinators grouping sets
arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.stack-analysis.state
compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
IN: compiler.cfg.stack-analysis.merge
: initial-state ( bb states -- state ) 2drop <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 ;

204
basis/compiler/cfg/stack-analysis/stack-analysis-tests.factor
View File

@ -1,204 +0,0 @@
USING: prettyprint compiler.cfg.debugger compiler.cfg.linearization
compiler.cfg.predecessors compiler.cfg.stack-analysis
compiler.cfg.instructions sequences kernel tools.test accessors
sequences.private alien math combinators.private compiler.cfg
compiler.cfg.checker compiler.cfg.rpo
compiler.cfg.dce compiler.cfg.registers
sets namespaces arrays cpu.architecture ;
IN: compiler.cfg.stack-analysis.tests
! Fundamental invariant: a basic block should not load or store a value more than once
: test-stack-analysis ( quot -- cfg )
dup cfg? [ test-cfg first ] unless
compute-predecessors
stack-analysis
dup check-cfg ;
: linearize ( cfg -- mr )
flatten-cfg instructions>> ;
[ ] [ [ ] test-stack-analysis drop ] unit-test
! Only peek once
[ 1 ] [ [ dup drop dup ] test-stack-analysis linearize [ ##peek? ] count ] unit-test
! Redundant replace is redundant
[ f ] [ [ dup drop ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
[ f ] [ [ swap swap ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
! Replace required here
[ t ] [ [ dup ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
[ t ] [ [ [ drop 1 ] when ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
! Only one replace, at the end
[ 1 ] [ [ [ 1 ] [ 2 ] if ] test-stack-analysis linearize [ ##replace? ] count ] unit-test
! Do we support the full language?
[ ] [ [ { [ ] [ ] } dispatch ] test-stack-analysis drop ] unit-test
[ ] [ [ { [ ] [ ] } dispatch dup ] test-stack-analysis drop ] unit-test
[ ] [
[ "int" { "int" "int" } "cdecl" [ + ] alien-callback ]
test-cfg second test-stack-analysis drop
] unit-test
! Test loops
[ ] [ [ [ t ] loop ] test-stack-analysis drop ] unit-test
[ ] [ [ [ dup ] loop ] test-stack-analysis drop ] unit-test
! Make sure that peeks are inserted in the right place
[ ] [ [ [ drop 1 ] when ] test-stack-analysis drop ] unit-test
! This should be a total no-op
[ f ] [ [ [ ] dip ] test-stack-analysis linearize [ ##replace? ] any? ] unit-test
! Don't insert inc-d/inc-r; that's wrong!
[ 1 ] [ [ dup ] test-stack-analysis linearize [ ##inc-d? ] count ] unit-test
! Bug in height tracking
[ ] [ [ dup [ ] [ reverse ] if ] test-stack-analysis drop ] unit-test
[ ] [ [ dup [ ] [ dup reverse drop ] if ] test-stack-analysis drop ] unit-test
[ ] [ [ [ drop dup 4.0 > ] find-last-integer ] test-stack-analysis drop ] unit-test
! Bugs with code that throws
[ ] [ [ [ "Oops" throw ] unless ] test-stack-analysis drop ] unit-test
[ ] [ [ [ ] (( -- * )) call-effect-unsafe ] test-stack-analysis drop ] unit-test
[ ] [ [ dup [ "Oops" throw ] when dup ] test-stack-analysis drop ] unit-test
[ ] [ [ B{ 1 2 3 4 } over [ "Oops" throw ] when swap ] test-stack-analysis drop ] unit-test
! Make sure the replace stores a value with the right height
[ ] [
[ [ . ] [ 2drop 1 ] if ] test-stack-analysis eliminate-dead-code linearize
[ ##replace? ] filter [ length 1 assert= ] [ first loc>> D 0 assert= ] bi
] unit-test
! translate-loc was the wrong way round
[ ] [
[ 1 2 rot ] test-stack-analysis eliminate-dead-code linearize
[ [ ##load-immediate? ] count 2 assert= ]
[ [ ##peek? ] count 1 assert= ]
[ [ ##replace? ] count 3 assert= ]
tri
] unit-test
[ ] [
[ 1 2 ? ] test-stack-analysis eliminate-dead-code linearize
[ [ ##load-immediate? ] count 2 assert= ]
[ [ ##peek? ] count 1 assert= ]
[ [ ##replace? ] count 1 assert= ]
tri
] unit-test
! Sync before a back-edge, not after
! ##peeks should be inserted before a ##loop-entry
! Don't optimize out the constants
[ t ] [
[ 1000 [ ] times ] test-stack-analysis eliminate-dead-code linearize
[ ##load-immediate? ] any?
] unit-test
! Correct height tracking
[ t ] [
[ pick [ <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

125
basis/compiler/cfg/stack-analysis/stack-analysis.factor
View File

@ -1,125 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel namespaces math sequences fry grouping
sets make combinators dlists deques
compiler.cfg
compiler.cfg.copy-prop
compiler.cfg.def-use
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.rpo
compiler.cfg.hats
compiler.cfg.stack-analysis.state
compiler.cfg.stack-analysis.merge
compiler.cfg.utilities ;
IN: compiler.cfg.stack-analysis
SYMBOL: global-optimization?
: redundant-replace? ( vreg loc -- ? )
dup state get untranslate-loc n>> 0 <
[ 2drop t ] [ state get actual-locs>vregs>> at = ] if ;
: save-changed-locs ( state -- )
[ changed-locs>> keys ] [ locs>vregs>> ] bi '[
dup _ at swap 2dup redundant-replace?
[ 2drop ] [ state get untranslate-loc ##replace ] if
] each ;
ERROR: poisoned-state state ;
: sync-state ( -- )
state get {
[ dup poisoned?>> [ poisoned-state ] [ drop ] if ]
[ ds-height>> save-ds-height ]
[ rs-height>> save-rs-height ]
[ save-changed-locs ]
[ clear-state ]
} cleave ;
: poison-state ( -- ) state get t >>poisoned? drop ;
! Abstract interpretation
GENERIC: visit ( insn -- )
M: ##inc-d visit
n>> state get [ + ] change-ds-height drop ;
M: ##inc-r visit
n>> state get [ + ] change-rs-height drop ;
! Instructions which don't have any effect on the stack
UNION: neutral-insn
##effect
##flushable
##no-tco ;
M: neutral-insn visit , ;
UNION: sync-if-back-edge
##branch
##conditional-branch
##compare-imm-branch
##dispatch
##loop-entry
##fixnum-overflow ;
: sync-state? ( -- ? )
basic-block get successors>>
[ [ predecessors>> ] keep '[ _ back-edge? ] any? ] any? ;
M: sync-if-back-edge visit
global-optimization? get [ sync-state? [ sync-state ] when ] unless
, ;
: eliminate-peek ( dst src -- )
! the requested stack location is already in 'src'
[ ##copy ] [ swap copies get set-at ] 2bi ;
M: ##peek visit
[ dst>> ] [ loc>> state get translate-loc ] bi dup loc>vreg
[ eliminate-peek ] [ [ record-peek ] [ ##peek ] 2bi ] ?if ;
M: ##replace visit
[ src>> resolve ] [ loc>> state get translate-loc ] bi
record-replace ;
M: ##copy visit
[ call-next-method ] [ record-copy ] bi ;
M: poison-insn visit call-next-method poison-state ;
M: kill-vreg-insn visit sync-state , ;
! Maps basic-blocks to states
SYMBOL: state-out
: block-in-state ( bb -- states )
dup predecessors>> state-out get '[ _ at ] map merge-states ;
: set-block-out-state ( state bb -- )
[ clone ] dip state-out get set-at ;
: visit-block ( bb -- )
! block-in-state may add phi nodes at the start of the basic block
! so we wrap the whole thing with a 'make'
[
dup basic-block set
dup block-in-state
state [
[ instructions>> [ visit ] each ]
[ [ state get ] dip set-block-out-state ]
[ ]
tri
] with-variable
] V{ } make >>instructions drop ;
: stack-analysis ( cfg -- cfg' )
[
<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 ;

53
basis/compiler/cfg/stack-analysis/state/state.factor
View File

@ -1,53 +0,0 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets math deques
compiler.cfg.registers ;
IN: compiler.cfg.stack-analysis.state
TUPLE: state
locs>vregs actual-locs>vregs changed-locs
{ ds-height integer }
{ rs-height integer }
poisoned? ;
: <state> ( -- state )
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 ;

41
basis/compiler/cfg/stacks/finalize/finalize.factor Normal file
View File

@ -0,0 +1,41 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs kernel fry accessors sequences make math
combinators compiler.cfg compiler.cfg.hats compiler.cfg.instructions
compiler.cfg.utilities compiler.cfg.rpo compiler.cfg.stacks.local
compiler.cfg.stacks.global compiler.cfg.stacks.height ;
IN: compiler.cfg.stacks.finalize
! This pass inserts peeks and replaces.
: inserting-peeks ( from to -- assoc )
peek-in swap [ peek-out ] [ avail-out ] bi
assoc-union assoc-diff ;
: inserting-replaces ( from to -- assoc )
[ replace-out ] [ [ kill-in ] [ replace-in ] bi ] bi*
assoc-union assoc-diff ;
: each-insertion ( assoc bb quot: ( vreg loc -- ) -- )
'[ drop [ loc>vreg ] [ _ untranslate-loc ] bi @ ] assoc-each ; inline
ERROR: bad-peek dst loc ;
: insert-peeks ( from to -- )
[ inserting-peeks ] keep
[ dup n>> 0 < [ bad-peek ] [ ##peek ] if ] each-insertion ;
: insert-replaces ( from to -- )
[ inserting-replaces ] keep
[ dup n>> 0 < [ 2drop ] [ ##replace ] if ] each-insertion ;
: visit-edge ( from to -- )
2dup [ [ insert-peeks ] [ insert-replaces ] 2bi ] V{ } make
[ 2drop ] [ <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 ;

39
basis/compiler/cfg/stacks/global/global.factor Normal file
View File

@ -0,0 +1,39 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel combinators compiler.cfg.dataflow-analysis
compiler.cfg.stacks.local ;
IN: compiler.cfg.stacks.global
! Peek analysis. Peek-in is the set of all locations anticipated at
! the start of a basic block.
BACKWARD-ANALYSIS: peek
M: peek-analysis transfer-set drop [ replace-set assoc-diff ] keep peek-set assoc-union ;
! Replace analysis. Replace-in is the set of all locations which
! will be overwritten at some point after the start of a basic block.
FORWARD-ANALYSIS: replace
M: replace-analysis transfer-set drop replace-set assoc-union ;
! Availability analysis. Avail-out is the set of all locations
! in registers at the end of a basic block.
FORWARD-ANALYSIS: avail
M: avail-analysis transfer-set drop [ peek-set ] [ replace-set ] bi assoc-union assoc-union ;
! Kill analysis. Kill-in is the set of all locations
! which are going to be overwritten.
BACKWARD-ANALYSIS: kill
M: kill-analysis transfer-set drop replace-set assoc-union ;
! Main word
: compute-global-sets ( cfg -- cfg' )
{
[ compute-peek-sets ]
[ compute-replace-sets ]
[ compute-avail-sets ]
[ compute-kill-sets ]
[ ]
} cleave ;

27
basis/compiler/cfg/stacks/height/height.factor Normal file
View File

@ -0,0 +1,27 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs fry kernel math
namespaces compiler.cfg.registers ;
IN: compiler.cfg.stacks.height
! Global stack height tracking done while constructing CFG.
SYMBOLS: ds-heights rs-heights ;
: record-stack-heights ( ds-height rs-height bb -- )
[ ds-heights get set-at ] [ rs-heights get set-at ] bi-curry bi* ;
GENERIC# translate-loc 1 ( loc bb -- loc' )
M: ds-loc translate-loc [ n>> ] [ ds-heights get at ] bi* - <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 ;

91
basis/compiler/cfg/stacks/local/local.factor Normal file
View File

@ -0,0 +1,91 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs kernel math namespaces sets make sequences
compiler.cfg
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.stacks.height
compiler.cfg.parallel-copy ;
IN: compiler.cfg.stacks.local
! Local stack analysis. We build local peek and replace sets for every basic
! block while constructing the CFG.
SYMBOLS: peek-sets replace-sets ;
SYMBOL: locs>vregs
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
SYMBOLS: local-peek-set local-replace-set replace-mapping ;
GENERIC: translate-local-loc ( loc -- loc' )
M: ds-loc translate-local-loc n>> current-height get d>> - <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 ;

67
basis/compiler/cfg/stacks/stacks.factor
View File

@ -1,45 +1,76 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: math sequences kernel cpu.architecture
compiler.cfg.instructions compiler.cfg.registers
compiler.cfg.hats ;
USING: math sequences kernel namespaces accessors biassocs compiler.cfg
compiler.cfg.instructions compiler.cfg.registers compiler.cfg.hats
compiler.cfg.predecessors compiler.cfg.stacks.local
compiler.cfg.stacks.height compiler.cfg.stacks.global
compiler.cfg.stacks.finalize ;
IN: compiler.cfg.stacks
: ds-drop ( -- )
-1 ##inc-d ;
: begin-stack-analysis ( -- )
<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 ;

45
basis/compiler/cfg/two-operand/two-operand-tests.factor Normal file
View File

@ -0,0 +1,45 @@
IN: compiler.cfg.two-operand.tests
USING: compiler.cfg.two-operand compiler.cfg.instructions
compiler.cfg.registers cpu.architecture namespaces tools.test ;
3 vreg-counter set-global
[
V{
T{ ##copy f V int-regs 1 V int-regs 2 }
T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 3 }
}
] [
{
T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 3 }
} (convert-two-operand)
] unit-test
[
V{
T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 }
}
] [
{
T{ ##sub f V int-regs 1 V int-regs 1 V int-regs 2 }
} (convert-two-operand)
] unit-test
[
V{
T{ ##copy f V int-regs 4 V int-regs 2 }
T{ ##sub f V int-regs 4 V int-regs 4 V int-regs 1 }
T{ ##copy f V int-regs 1 V int-regs 4 }
}
] [
{
T{ ##sub f V int-regs 1 V int-regs 2 V int-regs 1 }
} (convert-two-operand)
] unit-test
! This should never come up after coalescing
[
V{
T{ ##fixnum-add f V int-regs 2 V int-regs 4 V int-regs 2 }
} (convert-two-operand)
] must-fail

127
basis/compiler/cfg/two-operand/two-operand.factor
View File

@ -1,59 +1,104 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sequences make compiler.cfg.instructions
USING: accessors kernel sequences make combinators
compiler.cfg.registers compiler.cfg.instructions
compiler.cfg.rpo cpu.architecture ;
IN: compiler.cfg.two-operand
! On x86, instructions take the form x = x op y
! Our SSA IR is x = y op z
! This pass runs after SSA coalescing and normalizes instructions
! to fit the x86 two-address scheme. Possibilities are:
! 1) x = x op y
! 2) x = y op x
! 3) x = y op z
! In case 1, there is nothing to do.
! In case 2, we convert to
! z = y
! z = z op x
! x = z
! In case 3, we convert to
! x = y
! x = x op z
! In case 2 and case 3, linear scan coalescing will eliminate a
! copy if the value y is never used again.
! We don't bother with ##add, ##add-imm, ##sub-imm or ##mul-imm
! since x86 has LEA and IMUL instructions which are effectively
! three-operand addition and multiplication, respectively.
: convert-two-operand/integer ( insn -- )
[ [ dst>> ] [ src1>> ] bi ##copy ]
[ dup dst>> >>src1 , ]
bi ; inline
: convert-two-operand/float ( insn -- )
[ [ dst>> ] [ src1>> ] bi ##copy-float ]
[ 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 -- )
: 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
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 ;

76
basis/compiler/cfg/utilities/utilities.factor
View File

@ -1,56 +1,23 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.short-circuit
compiler.cfg compiler.cfg.instructions cpu.architecture kernel
layouts locals make math namespaces sequences sets vectors fry ;
cpu.architecture kernel layouts locals make math namespaces sequences
sets vectors fry compiler.cfg compiler.cfg.instructions
compiler.cfg.rpo ;
IN: compiler.cfg.utilities
: value-info-small-fixnum? ( value-info -- ? )
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
[ drop f ]
} cond ;
: value-info-small-tagged? ( value-info -- ? )
dup literal?>> [
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
{ [ dup not ] [ drop t ] }
[ drop f ]
} cond
] [ drop f ] if ;
: set-basic-block ( basic-block -- )
[ basic-block set ] [ instructions>> building set ] bi ;
: begin-basic-block ( -- )
<basic-block> basic-block get [
dupd successors>> push
] when*
set-basic-block ;
: end-basic-block ( -- )
building off
basic-block off ;
: emit-primitive ( node -- )
word>> ##call ##branch begin-basic-block ;
: with-branch ( quot -- final-bb )
[
begin-basic-block
call
basic-block get dup [ ##branch ] when
] with-scope ; inline
: emit-conditional ( branches -- )
end-basic-block
begin-basic-block
basic-block get '[ [ _ swap successors>> push ] when* ] each ;
PREDICATE: kill-block < basic-block
instructions>> {
[ length 2 = ]
[ first kill-vreg-insn? ]
} 1&& ;
: back-edge? ( from to -- ? )
[ number>> ] bi@ >= ;
: loop-entry? ( bb -- ? )
dup predecessors>> [ swap back-edge? ] with any? ;
: empty-block? ( bb -- ? )
instructions>> {
[ length 1 = ]
@ -70,16 +37,6 @@ SYMBOL: visited
: skip-empty-blocks ( bb -- bb' )
H{ } clone visited [ (skip-empty-blocks) ] with-variable ;
! assoc mapping predecessors to sequences
SYMBOL: added-instructions
: add-instructions ( predecessor quot -- )
[
added-instructions get
[ drop V{ } clone ] cache
building
] dip with-variable ; inline
:: insert-basic-block ( from to bb -- )
bb from 1vector >>predecessors drop
bb to 1vector >>successors drop
@ -92,6 +49,11 @@ SYMBOL: added-instructions
\ ##branch new-insn over push
>>instructions ;
: insert-basic-blocks ( bb -- )
[ added-instructions get ] dip
'[ [ _ ] dip <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

52
basis/compiler/cfg/value-numbering/rewrite/rewrite.factor
View File

@ -20,13 +20,9 @@ IN: compiler.cfg.value-numbering.rewrite
! Outputs f to mean no change
GENERIC: rewrite* ( insn -- insn/f )
GENERIC: rewrite ( insn -- insn/f )
: rewrite ( insn -- insn' )
dup [ number-values ] [ rewrite* ] bi
[ rewrite ] [ ] ?if ;
M: insn rewrite* drop f ;
M: insn rewrite drop f ;
: ##branch-t? ( insn -- ? )
dup ##compare-imm-branch? [
@ -123,7 +119,7 @@ ERROR: bad-comparison ;
: fold-compare-imm-branch ( insn -- insn/f )
(fold-compare-imm) fold-branch ;
M: ##compare-imm-branch rewrite*
M: ##compare-imm-branch rewrite
{
{ [ dup rewrite-boolean-comparison? ] [ rewrite-boolean-comparison ] }
{ [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
@ -154,7 +150,7 @@ M: ##compare-imm-branch rewrite*
: rewrite-self-compare-branch ( insn -- insn' )
(rewrite-self-compare) fold-branch ;
M: ##compare-branch rewrite*
M: ##compare-branch rewrite
{
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm-branch ] }
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm-branch ] }
@ -185,7 +181,7 @@ M: ##compare-branch rewrite*
: rewrite-self-compare ( insn -- insn' )
dup (rewrite-self-compare) >boolean-insn ;
M: ##compare rewrite*
M: ##compare rewrite
{
{ [ dup src1>> vreg-small-constant? ] [ t >compare-imm ] }
{ [ dup src2>> vreg-small-constant? ] [ f >compare-imm ] }
@ -196,7 +192,7 @@ M: ##compare rewrite*
: fold-compare-imm ( insn -- insn' )
dup (fold-compare-imm) >boolean-insn ;
M: ##compare-imm rewrite*
M: ##compare-imm rewrite
{
{ [ dup rewrite-redundant-comparison? ] [ rewrite-redundant-comparison ] }
{ [ dup rewrite-tagged-comparison? ] [ rewrite-tagged-comparison ] }
@ -238,7 +234,7 @@ M: ##shl-imm constant-fold* drop shift ;
] dip
over small-enough? [ new-insn ] [ 2drop 2drop f ] if ; inline
M: ##add-imm rewrite*
M: ##add-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##add-imm reassociate ] }
@ -249,7 +245,7 @@ M: ##add-imm rewrite*
[ dst>> ] [ src1>> ] [ src2>> neg ] tri dup small-enough?
[ \ ##add-imm new-insn ] [ 3drop f ] if ;
M: ##sub-imm rewrite*
M: ##sub-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ sub-imm>add-imm ]
@ -261,7 +257,7 @@ M: ##sub-imm rewrite*
: strength-reduce-mul? ( insn -- ? )
src2>> power-of-2? ;
M: ##mul-imm rewrite*
M: ##mul-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup strength-reduce-mul? ] [ strength-reduce-mul ] }
@ -269,40 +265,40 @@ M: ##mul-imm rewrite*
[ drop f ]
} cond ;
M: ##and-imm rewrite*
M: ##and-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##and-imm reassociate ] }
[ drop f ]
} cond ;
M: ##or-imm rewrite*
M: ##or-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##or-imm reassociate ] }
[ drop f ]
} cond ;
M: ##xor-imm rewrite*
M: ##xor-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
{ [ dup reassociate? ] [ \ ##xor-imm reassociate ] }
[ drop f ]
} cond ;
M: ##shl-imm rewrite*
M: ##shl-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ drop f ]
} cond ;
M: ##shr-imm rewrite*
M: ##shr-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ drop f ]
} cond ;
M: ##sar-imm rewrite*
M: ##sar-imm rewrite
{
{ [ dup constant-fold? ] [ constant-fold ] }
[ drop f ]
@ -327,7 +323,7 @@ M: ##sar-imm rewrite*
[ 2drop f ]
} cond ; inline
M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
M: ##add rewrite \ ##add-imm rewrite-arithmetic-commutative ;
: subtraction-identity? ( insn -- ? )
[ src1>> ] [ src2>> ] bi [ vreg>vn ] bi@ eq? ;
@ -335,22 +331,22 @@ M: ##add rewrite* \ ##add-imm rewrite-arithmetic-commutative ;
: rewrite-subtraction-identity ( insn -- insn' )
dst>> 0 \ ##load-immediate new-insn ;
M: ##sub rewrite*
M: ##sub rewrite
{
{ [ dup subtraction-identity? ] [ rewrite-subtraction-identity ] }
[ \ ##sub-imm rewrite-arithmetic ]
} cond ;
M: ##mul rewrite* \ ##mul-imm rewrite-arithmetic-commutative ;
M: ##mul rewrite \ ##mul-imm rewrite-arithmetic-commutative ;
M: ##and rewrite* \ ##and-imm rewrite-arithmetic-commutative ;
M: ##and rewrite \ ##and-imm rewrite-arithmetic-commutative ;
M: ##or rewrite* \ ##or-imm rewrite-arithmetic-commutative ;
M: ##or rewrite \ ##or-imm rewrite-arithmetic-commutative ;
M: ##xor rewrite* \ ##xor-imm rewrite-arithmetic-commutative ;
M: ##xor rewrite \ ##xor-imm rewrite-arithmetic-commutative ;
M: ##shl rewrite* \ ##shl-imm rewrite-arithmetic ;
M: ##shl rewrite \ ##shl-imm rewrite-arithmetic ;
M: ##shr rewrite* \ ##shr-imm rewrite-arithmetic ;
M: ##shr rewrite \ ##shr-imm rewrite-arithmetic ;
M: ##sar rewrite* \ ##sar-imm rewrite-arithmetic ;
M: ##sar rewrite \ ##sar-imm rewrite-arithmetic ;

6
basis/compiler/cfg/value-numbering/simplify/simplify.factor
View File

@ -127,7 +127,5 @@ M: expr simplify* drop f ;
{ [ dup integer? ] [ nip ] }
} cond ;
GENERIC: number-values ( insn -- )
M: ##flushable number-values [ >expr simplify ] [ dst>> ] bi set-vn ;
M: insn number-values drop ;
: number-values ( insn -- )
[ >expr simplify ] [ dst>> ] bi set-vn ;

53
basis/compiler/cfg/value-numbering/value-numbering-tests.factor
View File

@ -3,7 +3,7 @@ USING: compiler.cfg.value-numbering compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger compiler.cfg.comparisons
cpu.architecture tools.test kernel math combinators.short-circuit
accessors sequences compiler.cfg.predecessors locals
compiler.cfg.phi-elimination compiler.cfg.dce
compiler.cfg.dce compiler.cfg.ssa.destruction
compiler.cfg assocs vectors arrays layouts namespaces ;
: trim-temps ( insns -- insns )
@ -35,9 +35,9 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
[
{
T{ ##load-reference f V int-regs 0 0.0 }
T{ ##load-reference f V int-regs 1 0.0 }
T{ ##copy f V int-regs 1 V int-regs 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 0 D 1 }
T{ ##replace f V int-regs 1 D 1 }
}
] [
{
@ -51,9 +51,9 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
[
{
T{ ##load-reference f V int-regs 0 t }
T{ ##load-reference f V int-regs 1 t }
T{ ##copy f V int-regs 1 V int-regs 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##replace f V int-regs 0 D 1 }
T{ ##replace f V int-regs 1 D 1 }
}
] [
{
@ -64,29 +64,14 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
} value-numbering-step
] unit-test
! Copy propagation
[
{
T{ ##peek f V int-regs 45 D 1 }
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 45 7 cc/= }
}
] [
{
T{ ##peek f V int-regs 45 D 1 }
T{ ##copy f V int-regs 48 V int-regs 45 }
T{ ##compare-imm-branch f V int-regs 48 7 cc/= }
} value-numbering-step
] unit-test
! Compare propagation
[
{
T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
T{ ##replace f V int-regs 4 D 0 }
T{ ##copy f V int-regs 6 V int-regs 4 }
T{ ##replace f V int-regs 6 D 0 }
}
] [
{
@ -612,8 +597,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##load-immediate f V int-regs 2 0 }
T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##copy f V int-regs 3 V int-regs 0 }
T{ ##replace f V int-regs 3 D 0 }
}
] [
{
@ -630,8 +615,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##load-immediate f V int-regs 2 0 }
T{ ##add-imm f V int-regs 3 V int-regs 0 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##copy f V int-regs 3 V int-regs 0 }
T{ ##replace f V int-regs 3 D 0 }
}
] [
{
@ -648,8 +633,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##load-immediate f V int-regs 2 0 }
T{ ##or-imm f V int-regs 3 V int-regs 0 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##copy f V int-regs 3 V int-regs 0 }
T{ ##replace f V int-regs 3 D 0 }
}
] [
{
@ -666,8 +651,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
T{ ##peek f V int-regs 0 D 0 }
T{ ##peek f V int-regs 1 D 1 }
T{ ##load-immediate f V int-regs 2 0 }
T{ ##xor-imm f V int-regs 3 V int-regs 0 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##copy f V int-regs 3 V int-regs 0 }
T{ ##replace f V int-regs 3 D 0 }
}
] [
{
@ -683,8 +668,8 @@ compiler.cfg assocs vectors arrays layouts namespaces ;
{
T{ ##peek f V int-regs 0 D 0 }
T{ ##load-immediate f V int-regs 1 1 }
T{ ##shl-imm f V int-regs 2 V int-regs 0 0 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##copy f V int-regs 2 V int-regs 0 }
T{ ##replace f V int-regs 2 D 0 }
}
] [
{
@ -1206,14 +1191,14 @@ test-diamond
cfg new 0 get >>entry
value-numbering
compute-predecessors
eliminate-phis drop
destruct-ssa drop
] unit-test
[ 1 ] [ 1 get successors>> length ] unit-test
[ t ] [ 1 get successors>> first 3 get eq? ] unit-test
[ 3 ] [ 4 get instructions>> length ] unit-test
[ 2 ] [ 4 get instructions>> length ] unit-test
V{
T{ ##peek f V int-regs 0 D 0 }

32
basis/compiler/cfg/value-numbering/value-numbering.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces assocs biassocs classes kernel math accessors
sorting sets sequences fry
USING: namespaces assocs kernel accessors
sorting sets sequences
compiler.cfg
compiler.cfg.rpo
compiler.cfg.renaming
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions
compiler.cfg.value-numbering.simplify
@ -12,20 +12,28 @@ compiler.cfg.value-numbering.rewrite ;
IN: compiler.cfg.value-numbering
! Local value numbering. Predecessors must be recomputed after this
: vreg>vreg-mapping ( -- assoc )
vregs>vns get [ keys ] keep
'[ dup _ [ at ] [ value-at ] bi ] H{ } map>assoc ;
: >copy ( insn -- insn/##copy )
dup dst>> dup vreg>vn vn>vreg
2dup eq? [ 2drop ] [ \ ##copy new-insn nip ] if ;
: rename-uses ( insns -- )
vreg>vreg-mapping renamings [
[ rename-insn-uses ] each
] with-variable ;
: rewrite-loop ( insn -- insn' )
dup rewrite [ rewrite-loop ] [ ] ?if ;
GENERIC: process-instruction ( insn -- insn' )
M: ##flushable process-instruction
dup rewrite
[ process-instruction ]
[ dup number-values >copy ] ?if ;
M: insn process-instruction
dup rewrite
[ process-instruction ] [ ] ?if ;
: value-numbering-step ( insns -- insns' )
init-value-graph
init-expressions
[ rewrite ] map
dup rename-uses ;
[ process-instruction ] map ;
: value-numbering ( cfg -- cfg' )
[ value-numbering-step ] local-optimization cfg-changed ;

40
basis/compiler/cfg/write-barrier/write-barrier-tests.factor
View File

@ -1,42 +1,43 @@
USING: compiler.cfg.write-barrier compiler.cfg.instructions
compiler.cfg.registers compiler.cfg.debugger cpu.architecture
arrays tools.test vectors compiler.cfg kernel accessors ;
arrays tools.test vectors compiler.cfg kernel accessors
compiler.cfg.utilities ;
IN: compiler.cfg.write-barrier.tests
: test-write-barrier ( insns -- insns )
write-barriers-step ;
<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 }
}
] [
{
@ -49,28 +50,23 @@ IN: compiler.cfg.write-barrier.tests
] unit-test
[
{
V{
T{ ##peek f V int-regs 19 D -3 }
T{ ##peek f V int-regs 22 D -2 }
T{ ##copy f V int-regs 23 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
T{ ##copy f V int-regs 26 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
T{ ##peek f V int-regs 28 D -1 }
T{ ##copy f V int-regs 29 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
T{ ##branch }
}
] [
{
T{ ##peek f V int-regs 19 D -3 }
T{ ##peek f V int-regs 22 D -2 }
T{ ##copy f V int-regs 23 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 23 3 2 }
T{ ##write-barrier f V int-regs 23 V int-regs 24 V int-regs 25 }
T{ ##copy f V int-regs 26 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 22 V int-regs 19 3 2 }
T{ ##write-barrier f V int-regs 19 V int-regs 24 V int-regs 25 }
T{ ##peek f V int-regs 28 D -1 }
T{ ##copy f V int-regs 29 V int-regs 19 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 29 4 2 }
T{ ##write-barrier f V int-regs 29 V int-regs 30 V int-regs 3 }
T{ ##set-slot-imm f V int-regs 28 V int-regs 19 4 2 }
T{ ##write-barrier f V int-regs 19 V int-regs 30 V int-regs 3 }
} test-write-barrier
] unit-test

31
basis/compiler/cfg/write-barrier/write-barrier.factor
View File

@ -1,8 +1,7 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors namespaces assocs sets sequences locals
compiler.cfg compiler.cfg.instructions compiler.cfg.copy-prop
compiler.cfg.rpo ;
USING: kernel accessors namespaces assocs sets sequences
compiler.cfg compiler.cfg.instructions compiler.cfg.rpo ;
IN: compiler.cfg.write-barrier
! Eliminate redundant write barrier hits.
@ -14,33 +13,27 @@ SYMBOL: safe
! Objects which have been mutated
SYMBOL: mutated
GENERIC: eliminate-write-barrier ( insn -- insn' )
GENERIC: eliminate-write-barrier ( insn -- ? )
M: ##allot eliminate-write-barrier
dup dst>> safe get conjoin ;
dst>> safe get conjoin t ;
M: ##write-barrier eliminate-write-barrier
dup src>> resolve dup
[ safe get key? not ]
[ mutated get key? ] bi and
[ safe get conjoin ] [ 2drop f ] if ;
M: ##copy eliminate-write-barrier
dup record-copy ;
src>> dup [ safe get key? not ] [ mutated get key? ] bi and
[ safe get conjoin t ] [ drop f ] if ;
M: ##set-slot eliminate-write-barrier
dup obj>> resolve mutated get conjoin ;
obj>> mutated get conjoin t ;
M: ##set-slot-imm eliminate-write-barrier
dup obj>> resolve mutated get conjoin ;
obj>> mutated get conjoin t ;
M: insn eliminate-write-barrier ;
M: insn eliminate-write-barrier drop t ;
: write-barriers-step ( insns -- insns' )
: write-barriers-step ( bb -- )
H{ } clone safe set
H{ } clone mutated set
H{ } clone copies set
[ eliminate-write-barrier ] map sift ;
instructions>> [ eliminate-write-barrier ] filter-here ;
: eliminate-write-barriers ( cfg -- cfg' )
[ write-barriers-step ] local-optimization ;
dup [ write-barriers-step ] each-basic-block ;

15
basis/compiler/codegen/codegen.factor
View File

@ -4,7 +4,7 @@ USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex alien.libraries sets libc
continuations.private fry cpu.architecture
continuations.private fry cpu.architecture classes
source-files.errors
compiler.errors
compiler.alien
@ -18,6 +18,10 @@ compiler.codegen.fixup
compiler.utilities ;
IN: compiler.codegen
SYMBOL: insn-counts
H{ } clone insn-counts set-global
GENERIC: generate-insn ( insn -- )
SYMBOL: registers
@ -54,7 +58,12 @@ SYMBOL: labels
[ word>> init-generator ]
[
instructions>>
[ [ regs>> registers set ] [ generate-insn ] bi ] each
[
[ class insn-counts get inc-at ]
[ regs>> registers set ]
[ generate-insn ]
tri
] each
] bi
] with-fixup ;
@ -245,7 +254,7 @@ M: _gc generate-insn
[ gc-root-count>> ]
} cleave %gc ;
M: ##loop-entry generate-insn drop %loop-entry ;
M: _loop-entry generate-insn drop %loop-entry ;
M: ##alien-global generate-insn
[ dst>> register ] [ symbol>> ] [ library>> ] tri

28
basis/compiler/tests/codegen.factor
View File

@ -286,7 +286,7 @@ M: cucumber equal? "The cucumber has no equal" throw ;
[ 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
@ -321,4 +321,28 @@ cell 4 = [
] when
! Regression from Slava's value numbering changes
[ 1 ] [ 31337 [ dup fixnum<= [ 1 ] [ 2 ] if ] compile-call ] unit-test
[ 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

140
basis/compiler/tests/low-level-ir.factor Normal file
View File

@ -0,0 +1,140 @@
USING: accessors assocs compiler compiler.cfg
compiler.cfg.debugger compiler.cfg.instructions compiler.cfg.mr
compiler.cfg.registers compiler.codegen compiler.units
cpu.architecture hashtables kernel namespaces sequences
tools.test vectors words layouts literals math arrays
alien.syntax ;
IN: compiler.tests.low-level-ir
: compile-cfg ( cfg -- word )
gensym
[ build-mr generate code>> ] dip
[ associate >alist modify-code-heap ] keep ;
: compile-test-cfg ( -- word )
cfg new
0 get >>entry
compile-cfg ;
: compile-test-bb ( insns -- result )
V{ T{ ##prologue } T{ ##branch } } 0 test-bb
V{
T{ ##inc-d f 1 }
T{ ##replace f V int-regs 0 D 0 }
T{ ##branch }
} append 1 test-bb
V{
T{ ##epilogue }
T{ ##return }
} 2 test-bb
0 get 1 get 1vector >>successors drop
1 get 2 get 1vector >>successors drop
compile-test-cfg
execute( -- result ) ;
! loading immediates
[ f ] [
V{
T{ ##load-immediate f V int-regs 0 5 }
} compile-test-bb
] unit-test
[ "hello" ] [
V{
T{ ##load-reference f V int-regs 0 "hello" }
} compile-test-bb
] unit-test
! make sure slot access works when the destination is
! one of the sources
[ t ] [
V{
T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] }
T{ ##load-reference f V int-regs 0 { t f t } }
T{ ##slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 }
} compile-test-bb
] unit-test
[ t ] [
V{
T{ ##load-reference f V int-regs 0 { t f t } }
T{ ##slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] V int-regs 2 }
} compile-test-bb
] unit-test
[ t ] [
V{
T{ ##load-immediate f V int-regs 1 $[ 2 cell log2 shift ] }
T{ ##load-reference f V int-regs 0 { t f t } }
T{ ##set-slot f V int-regs 0 V int-regs 0 V int-regs 1 $[ array tag-number ] V int-regs 2 }
} compile-test-bb
dup first eq?
] unit-test
[ t ] [
V{
T{ ##load-reference f V int-regs 0 { t f t } }
T{ ##set-slot-imm f V int-regs 0 V int-regs 0 2 $[ array tag-number ] }
} compile-test-bb
dup first eq?
] unit-test
[ 8 ] [
V{
T{ ##load-immediate f V int-regs 0 4 }
T{ ##shl f V int-regs 0 V int-regs 0 V int-regs 0 }
} compile-test-bb
] unit-test
[ 4 ] [
V{
T{ ##load-immediate f V int-regs 0 4 }
T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
} compile-test-bb
] unit-test
[ 31 ] [
V{
T{ ##load-reference f V int-regs 1 B{ 31 67 52 } }
T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 1 V int-regs 2 }
T{ ##alien-unsigned-1 f V int-regs 0 V int-regs 0 }
T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
} compile-test-bb
] unit-test
[ CHAR: l ] [
V{
T{ ##load-reference f V int-regs 0 "hello world" }
T{ ##load-immediate f V int-regs 1 3 }
T{ ##string-nth f V int-regs 0 V int-regs 0 V int-regs 1 V int-regs 2 }
T{ ##shl-imm f V int-regs 0 V int-regs 0 3 }
} compile-test-bb
] unit-test
[ 1 ] [
V{
T{ ##load-immediate f V int-regs 0 16 }
T{ ##add-imm f V int-regs 0 V int-regs 0 -8 }
} compile-test-bb
] unit-test
! These are def-is-use-insns
USE: multiline
/*
[ 100 ] [
V{
T{ ##load-immediate f V int-regs 0 100 }
T{ ##integer>bignum f V int-regs 0 V int-regs 0 V int-regs 1 }
} compile-test-bb
] unit-test
[ 1 ] [
V{
T{ ##load-reference f V int-regs 0 ALIEN: 8 }
T{ ##unbox-any-c-ptr f V int-regs 0 V int-regs 0 V int-regs 1 }
} compile-test-bb
] unit-test
*/

17
basis/compiler/tree/propagation/info/info.factor
View File

@ -3,7 +3,7 @@
USING: assocs classes classes.algebra classes.tuple
classes.tuple.private kernel accessors math math.intervals
namespaces sequences words combinators byte-arrays strings
arrays compiler.tree.propagation.copy ;
arrays layouts cpu.architecture compiler.tree.propagation.copy ;
IN: compiler.tree.propagation.info
: false-class? ( class -- ? ) \ f class<= ;
@ -306,3 +306,18 @@ SYMBOL: value-infos
dup in-d>> last node-value-info
literal>> first immutable-tuple-class?
] [ drop f ] if ;
: value-info-small-fixnum? ( value-info -- ? )
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
[ drop f ]
} cond ;
: value-info-small-tagged? ( value-info -- ? )
dup literal?>> [
literal>> {
{ [ dup fixnum? ] [ tag-fixnum small-enough? ] }
{ [ dup not ] [ drop t ] }
[ drop f ]
} cond
] [ drop f ] if ;

72
basis/cpu/x86/assembler/assembler-tests.factor
View File

@ -8,6 +8,33 @@ IN: cpu.x86.assembler.tests
[ { HEX: 4c HEX: 89 HEX: e2 } ] [ [ RDX R12 MOV ] { } make ] unit-test
[ { HEX: 49 HEX: 89 HEX: d4 } ] [ [ R12 RDX MOV ] { } make ] unit-test
! r-rm / m-r sse instruction
[ { HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVUPS ] { } make ] unit-test
[ { HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVUPS ] { } make ] unit-test
[ { HEX: 0f HEX: 11 HEX: 08 } ] [ [ EAX [] XMM1 MOVUPS ] { } make ] unit-test
[ { HEX: f3 HEX: 0f HEX: 10 HEX: c1 } ] [ [ XMM0 XMM1 MOVSS ] { } make ] unit-test
[ { HEX: f3 HEX: 0f HEX: 10 HEX: 01 } ] [ [ XMM0 ECX [] MOVSS ] { } make ] unit-test
[ { HEX: f3 HEX: 0f HEX: 11 HEX: 08 } ] [ [ EAX [] XMM1 MOVSS ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: 6f HEX: c1 } ] [ [ XMM0 XMM1 MOVDQA ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: 6f HEX: 01 } ] [ [ XMM0 ECX [] MOVDQA ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: 7f HEX: 08 } ] [ [ EAX [] XMM1 MOVDQA ] { } make ] unit-test
! r-rm only sse instruction
[ { HEX: 66 HEX: 0f HEX: 2e HEX: c1 } ] [ [ XMM0 XMM1 UCOMISD ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: 2e HEX: 01 } ] [ [ XMM0 ECX [] UCOMISD ] { } make ] unit-test
[ [ EAX [] XMM1 UCOMISD ] { } make ] must-fail
[ { HEX: 66 HEX: 0f HEX: 38 HEX: 2a HEX: 01 } ] [ [ XMM0 ECX [] MOVNTDQA ] { } make ] unit-test
! rm-r only sse instructions
[ { HEX: 0f HEX: 2b HEX: 08 } ] [ [ EAX [] XMM1 MOVNTPS ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: e7 HEX: 08 } ] [ [ EAX [] XMM1 MOVNTDQ ] { } make ] unit-test
! three-byte-opcode ssse3 instruction
[ { HEX: 66 HEX: 0f HEX: 38 HEX: 02 HEX: c1 } ] [ [ XMM0 XMM1 PHADDD ] { } make ] unit-test
! int/sse conversion instruction
[ { HEX: f2 HEX: 0f HEX: 2c HEX: c0 } ] [ [ EAX XMM0 CVTTSD2SI ] { } make ] unit-test
[ { HEX: f2 HEX: 48 HEX: 0f HEX: 2c HEX: c0 } ] [ [ RAX XMM0 CVTTSD2SI ] { } make ] unit-test
[ { HEX: f2 HEX: 4c HEX: 0f HEX: 2c HEX: e0 } ] [ [ R12 XMM0 CVTTSD2SI ] { } make ] unit-test
@ -25,6 +52,50 @@ IN: cpu.x86.assembler.tests
! [ { HEX: f2 HEX: 0f HEX: 11 HEX: 00 } ] [ [ RAX [] XMM0 MOVSD ] { } make ] unit-test
! [ { HEX: f2 HEX: 41 HEX: 0f HEX: 11 HEX: 04 HEX: 24 } ] [ [ R12 [] XMM0 MOVSD ] { } make ] unit-test
! 3-operand r-rm-imm sse instructions
[ { HEX: 66 HEX: 0f HEX: 70 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 PSHUFD ] { } make ] unit-test
[ { HEX: 0f HEX: c6 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 2 SHUFPS ] { } make ] unit-test
! scalar register insert/extract sse instructions
[ { HEX: 66 HEX: 0f HEX: c4 HEX: c1 HEX: 02 } ] [ [ XMM0 ECX 2 PINSRW ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: c4 HEX: 04 HEX: 11 HEX: 03 } ] [ [ XMM0 ECX EDX [+] 3 PINSRW ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: c5 HEX: c1 HEX: 02 } ] [ [ EAX XMM1 2 PEXTRW ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: 3a HEX: 15 HEX: 08 HEX: 02 } ] [ [ EAX [] XMM1 2 PEXTRW ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: 3a HEX: 15 HEX: 14 HEX: 08 HEX: 03 } ] [ [ EAX ECX [+] XMM2 3 PEXTRW ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: 3a HEX: 14 HEX: c8 HEX: 02 } ] [ [ EAX XMM1 2 PEXTRB ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: 3a HEX: 14 HEX: 08 HEX: 02 } ] [ [ EAX [] XMM1 2 PEXTRB ] { } make ] unit-test
! sse shift instructions
[ { HEX: 66 HEX: 0f HEX: 71 HEX: d0 HEX: 05 } ] [ [ XMM0 5 PSRLW ] { } make ] unit-test
! sse comparison instructions
[ { HEX: 66 HEX: 0f HEX: c2 HEX: c1 HEX: 02 } ] [ [ XMM0 XMM1 CMPLEPD ] { } make ] unit-test
! unique sse instructions
[ { HEX: 0f HEX: 18 HEX: 00 } ] [ [ EAX [] PREFETCHNTA ] { } make ] unit-test
[ { HEX: 0f HEX: 18 HEX: 08 } ] [ [ EAX [] PREFETCHT0 ] { } make ] unit-test
[ { HEX: 0f HEX: 18 HEX: 10 } ] [ [ EAX [] PREFETCHT1 ] { } make ] unit-test
[ { HEX: 0f HEX: 18 HEX: 18 } ] [ [ EAX [] PREFETCHT2 ] { } make ] unit-test
[ { HEX: 0f HEX: ae HEX: 10 } ] [ [ EAX [] LDMXCSR ] { } make ] unit-test
[ { HEX: 0f HEX: ae HEX: 18 } ] [ [ EAX [] STMXCSR ] { } make ] unit-test
[ { HEX: 0f HEX: c3 HEX: 08 } ] [ [ EAX [] ECX MOVNTI ] { } make ] unit-test
[ { HEX: 0f HEX: 50 HEX: c1 } ] [ [ EAX XMM1 MOVMSKPS ] { } make ] unit-test
[ { HEX: 66 HEX: 0f HEX: 50 HEX: c1 } ] [ [ EAX XMM1 MOVMSKPD ] { } make ] unit-test
[ { HEX: f3 HEX: 0f HEX: b8 HEX: c1 } ] [ [ EAX ECX POPCNT ] { } make ] unit-test
[ { HEX: f3 HEX: 48 HEX: 0f HEX: b8 HEX: c1 } ] [ [ RAX RCX POPCNT ] { } make ] unit-test
[ { HEX: f3 HEX: 0f HEX: b8 HEX: 01 } ] [ [ EAX ECX [] POPCNT ] { } make ] unit-test
[ { HEX: f3 HEX: 0f HEX: b8 HEX: 04 HEX: 11 } ] [ [ EAX ECX EDX [+] POPCNT ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 38 HEX: f0 HEX: c1 } ] [ [ EAX CL CRC32B ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 38 HEX: f0 HEX: 01 } ] [ [ EAX ECX [] CRC32B ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: c1 } ] [ [ EAX ECX CRC32 ] { } make ] unit-test
[ { HEX: f2 HEX: 0f HEX: 38 HEX: f1 HEX: 01 } ] [ [ EAX ECX [] CRC32 ] { } make ] unit-test
! memory address modes
[ { HEX: 8a HEX: 18 } ] [ [ BL RAX [] MOV ] { } make ] unit-test
[ { HEX: 66 HEX: 8b HEX: 18 } ] [ [ BX RAX [] MOV ] { } make ] unit-test
[ { HEX: 8b HEX: 18 } ] [ [ EBX RAX [] MOV ] { } make ] unit-test
@ -72,3 +143,4 @@ IN: cpu.x86.assembler.tests
[ { HEX: 48 HEX: 69 HEX: c1 HEX: 44 HEX: 03 HEX: 00 HEX: 00 } ] [ [ RAX RCX HEX: 344 IMUL3 ] { } make ] unit-test
[ { 15 183 195 } ] [ [ EAX BX MOVZX ] { } make ] unit-test

337
basis/cpu/x86/assembler/assembler.factor
View File

@ -3,6 +3,7 @@
USING: arrays io.binary kernel combinators kernel.private math
namespaces make sequences words system layouts math.order accessors
cpu.x86.assembler.syntax ;
QUALIFIED: sequences
IN: cpu.x86.assembler
! A postfix assembler for x86-32 and x86-64.
@ -12,11 +13,16 @@ IN: cpu.x86.assembler
! Beware!
! Register operands -- eg, ECX
REGISTERS: 8 AL CL DL BL ;
REGISTERS: 8 AL CL DL BL SPL BPL SIL DIL R8B R9B R10B R11B R12B R13B R14B R15B ;
REGISTERS: 16 AX CX DX BX SP BP SI DI ;
ALIAS: AH SPL
ALIAS: CH BPL
ALIAS: DH SIL
ALIAS: BH DIL
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI ;
REGISTERS: 16 AX CX DX BX SP BP SI DI R8W R9W R10W R11W R12W R13W R14W R15W ;
REGISTERS: 32 EAX ECX EDX EBX ESP EBP ESI EDI R8D R9D R10D R11D R12D R13D R14D R15D ;
REGISTERS: 64
RAX RCX RDX RBX RSP RBP RSI RDI R8 R9 R10 R11 R12 R13 R14 R15 ;
@ -212,7 +218,8 @@ M: object operand-64? drop f ;
: opcode, ( opcode -- ) dup array? [ % ] [ , ] if ;
: extended-opcode ( opcode -- opcode' ) OCT: 17 swap 2array ;
: extended-opcode ( opcode -- opcode' )
dup array? [ OCT: 17 sequences:prefix ] [ OCT: 17 swap 2array ] if ;
: extended-opcode, ( opcode -- ) extended-opcode opcode, ;
@ -451,6 +458,9 @@ M: operand TEST OCT: 204 2-operand ;
! Misc
: NOP ( -- ) HEX: 90 , ;
: PAUSE ( -- ) HEX: f3 , HEX: 90 , ;
: RDPMC ( -- ) HEX: 0f , HEX: 33 , ;
! x87 Floating Point Unit
@ -468,26 +478,313 @@ M: operand TEST OCT: 204 2-operand ;
pick register-128? [ swapd ] [ BIN: 1 bitor ] if ;
: 2-operand-sse ( dst src op1 op2 -- )
, direction-bit-sse extended-opcode (2-operand) ;
[ , ] when* direction-bit-sse extended-opcode (2-operand) ;
: direction-op-sse ( dst src op1s -- dst' src' op1' )
pick register-128? [ swapd first ] [ second ] if ;
: 2-operand-rm-mr-sse ( dst src op1{rm,mr} op2 -- )
[ , ] when* direction-op-sse extended-opcode (2-operand) ;
: 2-operand-rm-sse ( dst src op1 op2 -- )
[ , ] when* swapd extended-opcode (2-operand) ;
: 2-operand-mr-sse ( dst src op1 op2 -- )
[ , ] when* extended-opcode (2-operand) ;
: 2-operand-int/sse ( dst src op1 op2 -- )
, swapd extended-opcode (2-operand) ;
[ , ] when* swapd extended-opcode (2-operand) ;
: 3-operand-rm-sse ( dst src imm op1 op2 -- )
rot [ 2-operand-rm-sse ] dip , ;
: 3-operand-mr-sse ( dst src imm op1 op2 -- )
rot [ 2-operand-mr-sse ] dip , ;
: 3-operand-rm-mr-sse ( dst src imm op1 op2 -- )
rot [ 2-operand-rm-mr-sse ] dip , ;
: 2-operand-sse-cmp ( dst src cmp op1 op2 -- )
3-operand-rm-sse ; inline
: 2-operand-sse-shift ( dst imm reg op1 op2 -- )
[ , ] when*
[ f HEX: 0f ] dip 2array 3array
swapd 1-operand , ;
PRIVATE>
: 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 ;
: 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 ;
: CVTSS2SD ( dest src -- ) HEX: 5a HEX: f3 2-operand-sse ;
: CVTSD2SS ( dest src -- ) HEX: 5a HEX: f2 2-operand-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>
: 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
: 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 ;

8
basis/cpu/x86/x86.factor
View File

@ -56,7 +56,7 @@ HOOK: param-reg-2 cpu ( -- reg )
HOOK: pic-tail-reg cpu ( -- reg )
M: x86 %load-immediate MOV ;
M: x86 %load-immediate dup 0 = [ drop dup XOR ] [ MOV ] if ;
M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
@ -108,10 +108,10 @@ M: x86 %slot-imm ( dst obj slot tag -- ) (%slot-imm) MOV ;
M: x86 %set-slot ( src obj slot tag temp -- ) (%slot) swap MOV ;
M: x86 %set-slot-imm ( src obj slot tag -- ) (%slot-imm) swap MOV ;
M: x86 %add [+] LEA ;
M: x86 %add-imm [+] LEA ;
M: x86 %add 2over eq? [ nip ADD ] [ [+] LEA ] if ;
M: x86 %add-imm 2over eq? [ nip ADD ] [ [+] LEA ] if ;
M: x86 %sub nip SUB ;
M: x86 %sub-imm neg [+] LEA ;
M: x86 %sub-imm 2over eq? [ nip SUB ] [ neg [+] LEA ] if ;
M: x86 %mul nip swap IMUL2 ;
M: x86 %mul-imm IMUL3 ;
M: x86 %and nip AND ;

4
basis/disjoint-sets/disjoint-sets.factor
View File

@ -35,6 +35,8 @@ TUPLE: disjoint-set
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
PRIVATE>
GENERIC: representative ( a disjoint-set -- p )
M: disjoint-set representative
@ -42,6 +44,8 @@ M: disjoint-set representative
[ [ parent ] keep representative dup ] 2keep set-parent
] if ;
<PRIVATE
: representatives ( a b disjoint-set -- r r )
[ representative ] curry bi@ ; inline

4
basis/hints/hints.factor
View File

@ -83,6 +83,10 @@ SYNTAX: HINTS:
\ 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

3
basis/tools/annotations/annotations-docs.factor
View File

@ -60,3 +60,6 @@ HELP: reset-word-timing
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." } ;

12
basis/tools/disassembler/disassembler.factor
View File

@ -1,7 +1,8 @@
! 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 -- )
@ -12,6 +13,13 @@ HOOK: disassemble* disassembler-backend ( from to -- lines )
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 ;

2
core/classes/algebra/algebra.factor
View File

@ -106,7 +106,7 @@ PREDICATE: empty-union < anonymous-union members>> empty? ;
PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
: (class<=) ( first second -- -1/0/1 )
: (class<=) ( first second -- ? )
2dup eq? [ 2drop t ] [
2dup superclass<= [ 2drop t ] [
[ normalize-class ] bi@ {

2
core/sequences/sequences.factor
View File

@ -633,6 +633,8 @@ PRIVATE>
: last ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
: set-last ( elt seq -- ) [ length 1 - ] keep set-nth ;
: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
<PRIVATE

44
extra/compiler/cfg/graphviz/graphviz.factor Normal file
View File

@ -0,0 +1,44 @@
! 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 ;