Merge branch 's3' of git://github.com/littledan/Factor into s3
Daniel Ehrenberg
commit
12db8a6c77
|
|
@ -0,0 +1,183 @@
|
|||
! Copyright (C) 2009, 2010 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators compiler.cfg.def-use
|
||||
compiler.cfg.instructions compiler.cfg.registers fry kernel
|
||||
locals namespaces sequences sets sorting math.vectors
|
||||
make math combinators.short-circuit vectors ;
|
||||
IN: compiler.cfg.dependence
|
||||
|
||||
! Dependence graph construction
|
||||
|
||||
SYMBOL: roots
|
||||
SYMBOL: node-number
|
||||
SYMBOL: nodes
|
||||
|
||||
SYMBOL: +data+
|
||||
SYMBOL: +control+
|
||||
|
||||
! Nodes in the dependency graph
|
||||
! These need to be numbered so that the same instruction
|
||||
! will get distinct nodes if it occurs multiple times
|
||||
TUPLE: node
|
||||
number insn precedes follows
|
||||
children parent
|
||||
registers parent-index ;
|
||||
|
||||
M: node equal? [ number>> ] bi@ = ;
|
||||
|
||||
M: node hashcode* nip number>> ;
|
||||
|
||||
: <node> ( insn -- node )
|
||||
node new
|
||||
node-number counter >>number
|
||||
swap >>insn
|
||||
H{ } clone >>precedes
|
||||
H{ } clone >>follows ;
|
||||
|
||||
: ready? ( node -- ? ) precedes>> assoc-empty? ;
|
||||
|
||||
: spin ( a b c -- c b a )
|
||||
[ 2nip ] [ drop nip ] [ 2drop ] 3tri ;
|
||||
|
||||
: precedes ( first second how -- )
|
||||
spin precedes>> set-at ;
|
||||
|
||||
:: add-data-edges ( nodes -- )
|
||||
! This builds up def-use information on the fly, since
|
||||
! we only care about local def-use
|
||||
H{ } clone :> definers
|
||||
nodes [| node |
|
||||
node insn>> defs-vreg [ node swap definers set-at ] when*
|
||||
node insn>> uses-vregs [ definers at [ node +data+ precedes ] when* ] each
|
||||
] each ;
|
||||
|
||||
UNION: stack-read-write ##peek ##replace ;
|
||||
|
||||
UNION: ##alien-read
|
||||
##alien-double ##alien-float ##alien-cell ##alien-vector
|
||||
##alien-signed-1 ##alien-signed-2 ##alien-signed-4
|
||||
##alien-unsigned-1 ##alien-unsigned-2 ##alien-unsigned-4 ;
|
||||
|
||||
UNION: ##alien-write
|
||||
##set-alien-double ##set-alien-float ##set-alien-cell ##set-alien-vector
|
||||
##set-alien-integer-1 ##set-alien-integer-2 ##set-alien-integer-4 ;
|
||||
|
||||
UNION: slot-memory-insn
|
||||
##read ##write ;
|
||||
|
||||
UNION: alien-memory-insn
|
||||
##alien-read ##alien-write ;
|
||||
|
||||
UNION: string-memory-insn
|
||||
##string-nth ##set-string-nth-fast ;
|
||||
|
||||
UNION: alien-call-insn
|
||||
##save-context ##alien-invoke ##alien-indirect ##alien-callback ;
|
||||
|
||||
: chain ( node var -- )
|
||||
dup get [
|
||||
pick +control+ precedes
|
||||
] when*
|
||||
set ;
|
||||
|
||||
GENERIC: add-control-edge ( node insn -- )
|
||||
|
||||
M: stack-read-write add-control-edge
|
||||
loc>> chain ;
|
||||
|
||||
M: alien-memory-insn add-control-edge
|
||||
drop alien-memory-insn chain ;
|
||||
|
||||
M: slot-memory-insn add-control-edge
|
||||
drop slot-memory-insn chain ;
|
||||
|
||||
M: string-memory-insn add-control-edge
|
||||
drop string-memory-insn chain ;
|
||||
|
||||
M: alien-call-insn add-control-edge
|
||||
drop alien-call-insn chain ;
|
||||
|
||||
M: object add-control-edge 2drop ;
|
||||
|
||||
: add-control-edges ( nodes -- )
|
||||
[
|
||||
[ dup insn>> add-control-edge ] each
|
||||
] with-scope ;
|
||||
|
||||
: set-follows ( nodes -- )
|
||||
[
|
||||
dup precedes>> keys [
|
||||
follows>> conjoin
|
||||
] with each
|
||||
] each ;
|
||||
|
||||
: set-roots ( nodes -- )
|
||||
[ ready? ] filter V{ } like roots set ;
|
||||
|
||||
: build-dependence-graph ( instructions -- )
|
||||
[ <node> ] map {
|
||||
[ add-control-edges ]
|
||||
[ add-data-edges ]
|
||||
[ set-follows ]
|
||||
[ set-roots ]
|
||||
[ nodes set ]
|
||||
} cleave ;
|
||||
|
||||
! Sethi-Ulmann numbering
|
||||
:: calculate-registers ( node -- registers )
|
||||
node children>> [ 0 ] [
|
||||
[ [ calculate-registers ] map natural-sort ]
|
||||
[ length iota ]
|
||||
bi v+ supremum
|
||||
] if-empty
|
||||
node insn>> temp-vregs length +
|
||||
dup node (>>registers) ;
|
||||
|
||||
! Constructing fan-in trees
|
||||
|
||||
: attach-parent ( node parent -- )
|
||||
[ >>parent drop ]
|
||||
[ [ ?push ] change-children drop ] 2bi ;
|
||||
|
||||
: keys-for ( assoc value -- keys )
|
||||
'[ nip _ = ] assoc-filter keys ;
|
||||
|
||||
: choose-parent ( node -- )
|
||||
! If a node has control dependences, it has to be a root
|
||||
! Otherwise, choose one of the data dependences for a parent
|
||||
dup precedes>> +control+ keys-for empty? [
|
||||
dup precedes>> +data+ keys-for [ drop ] [
|
||||
first attach-parent
|
||||
] if-empty
|
||||
] [ drop ] if ;
|
||||
|
||||
: make-trees ( -- trees )
|
||||
nodes get
|
||||
[ [ choose-parent ] each ]
|
||||
[ [ parent>> not ] filter ] bi ;
|
||||
|
||||
ERROR: node-missing-parent trees nodes ;
|
||||
ERROR: node-missing-children trees nodes ;
|
||||
|
||||
: flatten-tree ( node -- nodes )
|
||||
[ children>> [ flatten-tree ] map concat ] keep
|
||||
suffix ;
|
||||
|
||||
: verify-parents ( trees -- trees )
|
||||
nodes get over '[ [ parent>> ] [ _ member? ] bi or ] all?
|
||||
[ nodes get node-missing-parent ] unless ;
|
||||
|
||||
: verify-children ( trees -- trees )
|
||||
dup [ flatten-tree ] map concat
|
||||
nodes get
|
||||
{ [ [ length ] bi@ = ] [ set= ] } 2&&
|
||||
[ nodes get node-missing-children ] unless ;
|
||||
|
||||
: verify-trees ( trees -- trees )
|
||||
verify-parents verify-children ;
|
||||
|
||||
: build-fan-in-trees ( -- )
|
||||
make-trees verify-trees [
|
||||
-1/0. >>parent-index
|
||||
calculate-registers drop
|
||||
] each ;
|
||||
|
|
@ -0,0 +1,55 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors math namespaces sequences kernel fry
|
||||
compiler.cfg compiler.cfg.registers compiler.cfg.instructions
|
||||
compiler.cfg.rpo ;
|
||||
IN: compiler.cfg.height
|
||||
|
||||
! Combine multiple stack height changes into one at the
|
||||
! start of the basic block.
|
||||
|
||||
SYMBOL: ds-height
|
||||
SYMBOL: rs-height
|
||||
|
||||
GENERIC: compute-heights ( insn -- )
|
||||
|
||||
M: ##inc-d compute-heights n>> ds-height [ + ] change ;
|
||||
M: ##inc-r compute-heights n>> rs-height [ + ] change ;
|
||||
M: insn compute-heights drop ;
|
||||
|
||||
GENERIC: normalize-height* ( insn -- insn' )
|
||||
|
||||
: normalize-inc-d/r ( insn stack -- insn' )
|
||||
swap n>> '[ _ - ] change f ; inline
|
||||
|
||||
M: ##inc-d normalize-height* ds-height normalize-inc-d/r ;
|
||||
M: ##inc-r normalize-height* rs-height normalize-inc-d/r ;
|
||||
|
||||
GENERIC: loc-stack ( loc -- stack )
|
||||
|
||||
M: ds-loc loc-stack drop ds-height ;
|
||||
M: rs-loc loc-stack drop rs-height ;
|
||||
|
||||
GENERIC: <loc> ( n stack -- loc )
|
||||
|
||||
M: ds-loc <loc> drop <ds-loc> ;
|
||||
M: rs-loc <loc> drop <rs-loc> ;
|
||||
|
||||
: normalize-peek/replace ( insn -- insn' )
|
||||
[ [ [ n>> ] [ loc-stack get ] bi + ] keep <loc> ] change-loc ; inline
|
||||
|
||||
M: ##peek normalize-height* normalize-peek/replace ;
|
||||
M: ##replace normalize-height* normalize-peek/replace ;
|
||||
|
||||
M: insn normalize-height* ;
|
||||
|
||||
: height-step ( insns -- insns' )
|
||||
0 ds-height set
|
||||
0 rs-height set
|
||||
[ [ compute-heights ] each ]
|
||||
[ [ [ normalize-height* ] map sift ] with-scope ] bi
|
||||
ds-height get dup 0 = [ drop ] [ \ ##inc-d new-insn prefix ] if
|
||||
rs-height get dup 0 = [ drop ] [ \ ##inc-r new-insn prefix ] if ;
|
||||
|
||||
: normalize-height ( cfg -- cfg' )
|
||||
[ height-step ] local-optimization ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Stack height normalization coalesces height changes at start of basic block
|
||||
|
|
@ -5,12 +5,14 @@ compiler.cfg.tco
|
|||
compiler.cfg.useless-conditionals
|
||||
compiler.cfg.branch-splitting
|
||||
compiler.cfg.block-joining
|
||||
compiler.cfg.height
|
||||
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.scheduling
|
||||
compiler.cfg.representations
|
||||
compiler.cfg.ssa.destruction
|
||||
compiler.cfg.empty-blocks
|
||||
|
|
@ -29,12 +31,14 @@ SYMBOL: check-optimizer?
|
|||
delete-useless-conditionals
|
||||
split-branches
|
||||
join-blocks
|
||||
normalize-height
|
||||
construct-ssa
|
||||
alias-analysis
|
||||
value-numbering
|
||||
copy-propagation
|
||||
eliminate-dead-code
|
||||
eliminate-write-barriers
|
||||
schedule-instructions
|
||||
select-representations
|
||||
destruct-ssa
|
||||
delete-empty-blocks
|
||||
|
|
|
|||
|
|
@ -0,0 +1,138 @@
|
|||
! Copyright (C) 2009, 2010 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs combinators compiler.cfg.def-use
|
||||
compiler.cfg.dependence compiler.cfg.instructions
|
||||
compiler.cfg.registers compiler.cfg.rpo continuations
|
||||
cpu.architecture fry hashtables kernel locals math math.order
|
||||
namespaces random sequences sets vectors literals make
|
||||
arrays
|
||||
compiler.cfg.liveness
|
||||
compiler.cfg.liveness.ssa ;
|
||||
IN: compiler.cfg.scheduling
|
||||
|
||||
! Instruction scheduling to reduce register pressure, from:
|
||||
! "Register-sensitive selection, duplication, and
|
||||
! sequencing of instructions"
|
||||
! by Vivek Sarkar, et al.
|
||||
! http://portal.acm.org/citation.cfm?id=377849
|
||||
|
||||
ERROR: bad-delete-at key assoc ;
|
||||
|
||||
: check-delete-at ( key assoc -- )
|
||||
2dup key? [ delete-at ] [ bad-delete-at ] if ;
|
||||
|
||||
: set-parent-indices ( node -- )
|
||||
children>> building get length
|
||||
'[ _ >>parent-index drop ] each ;
|
||||
|
||||
: remove-node ( node -- )
|
||||
[ follows>> keys ] keep
|
||||
'[ [ precedes>> _ swap check-delete-at ] each ]
|
||||
[ [ ready? ] filter roots get push-all ] bi ;
|
||||
|
||||
: score ( insn -- n )
|
||||
[ parent-index>> ] [ registers>> neg ] [ insn>> insn#>> ] tri 3array ;
|
||||
|
||||
: pull-out-nth ( n seq -- elt )
|
||||
[ nth ] [ remove-nth! drop ] 2bi ;
|
||||
|
||||
: select ( vector quot -- elt )
|
||||
! This could be sped up by a constant factor
|
||||
[ dup <enum> ] dip '[ _ call( insn -- score ) ] assoc-map
|
||||
dup values supremum '[ nip _ = ] assoc-find
|
||||
2drop swap pull-out-nth ; inline
|
||||
|
||||
: select-instruction ( -- insn/f )
|
||||
roots get [ f ] [
|
||||
[ score ] select
|
||||
[ insn>> ]
|
||||
[ set-parent-indices ]
|
||||
[ remove-node ] tri
|
||||
] if-empty ;
|
||||
|
||||
: (reorder) ( -- )
|
||||
select-instruction [
|
||||
, (reorder)
|
||||
] when* ;
|
||||
|
||||
: cut-by ( seq quot -- before after )
|
||||
dupd find drop [ cut ] [ f ] if* ; inline
|
||||
|
||||
UNION: initial-insn
|
||||
##phi ##inc-d ##inc-r ;
|
||||
|
||||
: split-3-ways ( insns -- first middle last )
|
||||
[ initial-insn? not ] cut-by unclip-last ;
|
||||
|
||||
: reorder ( insns -- insns' )
|
||||
split-3-ways [
|
||||
build-dependence-graph
|
||||
build-fan-in-trees
|
||||
[ (reorder) ] V{ } make reverse
|
||||
] dip suffix append ;
|
||||
|
||||
ERROR: not-all-instructions-were-scheduled old-bb new-bb ;
|
||||
|
||||
SYMBOL: check-scheduling?
|
||||
t check-scheduling? set-global
|
||||
|
||||
:: check-instructions ( new-bb old-bb -- )
|
||||
new-bb old-bb [ instructions>> ] bi@
|
||||
[ [ length ] bi@ = ] [ [ unique ] bi@ = ] 2bi and
|
||||
[ old-bb new-bb not-all-instructions-were-scheduled ] unless ;
|
||||
|
||||
ERROR: definition-after-usage vreg old-bb new-bb ;
|
||||
|
||||
:: check-usages ( new-bb old-bb -- )
|
||||
H{ } clone :> useds
|
||||
new-bb instructions>> split-3-ways drop nip
|
||||
[| insn |
|
||||
insn uses-vregs [ useds conjoin ] each
|
||||
insn defs-vreg :> def-reg
|
||||
def-reg useds key?
|
||||
[ def-reg old-bb new-bb definition-after-usage ] when
|
||||
] each ;
|
||||
|
||||
: check-scheduling ( new-bb old-bb -- )
|
||||
[ check-instructions ] [ check-usages ] 2bi ;
|
||||
|
||||
: with-scheduling-check ( bb quot: ( bb -- ) -- )
|
||||
check-scheduling? get [
|
||||
over dup clone
|
||||
[ call( bb -- ) ] 2dip
|
||||
check-scheduling
|
||||
] [
|
||||
call( bb -- )
|
||||
] if ; inline
|
||||
|
||||
: number-insns ( insns -- )
|
||||
[ >>insn# drop ] each-index ;
|
||||
|
||||
: clear-numbers ( insns -- )
|
||||
[ f >>insn# drop ] each ;
|
||||
|
||||
: schedule-block ( bb -- )
|
||||
[
|
||||
[
|
||||
[ number-insns ]
|
||||
[ reorder ]
|
||||
[ clear-numbers ] tri
|
||||
] change-instructions drop
|
||||
] with-scheduling-check ;
|
||||
|
||||
! Really, instruction scheduling should be aware that there are
|
||||
! multiple types of registers, but this number is just used
|
||||
! to decide whether to schedule instructions
|
||||
: num-registers ( -- x ) int-regs machine-registers at length ;
|
||||
|
||||
: might-spill? ( bb -- ? )
|
||||
[ live-in assoc-size ]
|
||||
[ instructions>> [ defs-vreg ] count ] bi
|
||||
+ num-registers >= ;
|
||||
|
||||
: schedule-instructions ( cfg -- cfg' )
|
||||
dup [
|
||||
dup might-spill?
|
||||
[ schedule-block ]
|
||||
[ drop ] if
|
||||
] each-basic-block ;
|
||||
Loading…
Reference in New Issue