--- /dev/null
+! 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 ;
+IN: compiler.cfg.dependence
+
+! Dependence graph construction
+
+SYMBOL: roots
+SYMBOL: node-number
+SYMBOL: nodes
+
+! 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? ;
+
+: precedes ( first second -- )
+ swap precedes>> conjoin ;
+
+:: 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 precedes ] when* ] each
+ ] each ;
+
+: make-chain ( nodes -- )
+ [ dup rest-slice [ precedes ] 2each ] unless-empty ;
+
+: instruction-chain ( nodes quot -- )
+ '[ insn>> @ ] filter make-chain ; inline
+
+UNION: stack-read-write ##peek ##replace ;
+UNION: stack-change-height ##inc-d ##inc-r ;
+UNION: stack-insn stack-read-write stack-change-height ;
+
+GENERIC: data-stack-insn? ( insn -- ? )
+M: object data-stack-insn? drop f ;
+M: ##inc-d data-stack-insn? drop t ;
+M: stack-read-write data-stack-insn? loc>> ds-loc? ;
+
+: retain-stack-insn? ( insn -- ? )
+ dup stack-insn? [ data-stack-insn? not ] [ drop f ] if ;
+
+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 ;
+
+: add-control-edges ( nodes -- )
+ {
+ [ [ data-stack-insn? ] instruction-chain ]
+ [ [ retain-stack-insn? ] instruction-chain ]
+ [ [ alien-memory-insn? ] instruction-chain ]
+ [ [ slot-memory-insn? ] instruction-chain ]
+ [ [ string-memory-insn? ] instruction-chain ]
+ [ [ alien-call-insn? ] instruction-chain ]
+ } cleave ;
+
+: set-follows ( nodes -- )
+ [
+ dup precedes>> values [
+ follows>> conjoin
+ ] with each
+ ] each ;
+
+: set-roots ( nodes -- )
+ [ ready? ] filter V{ } like roots set ;
+
+: build-dependence-graph ( instructions -- )
+ [ <node> ] map {
+ [ add-data-edges ]
+ [ add-control-edges ]
+ [ set-follows ]
+ [ nodes set ] ! for assertions later
+ [ set-roots ]
+ } cleave ;
+
+:: 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) ;
+
+: data-dependence? ( to from -- ? )
+ ! If this takes lots of time, then refactor code
+ ! so that nodes store their data dependences
+ [ insn>> ] bi@
+ [ uses-vregs ] [ defs-vreg ] bi*
+ swap member? ;
+
+DEFER: follow-tree
+
+: maybe-cut-node ( node -- ? )
+ ! If this node has multiple successors
+ ! then it needs to be made into the head of a new tree
+ [ precedes>> assoc-size 1 = dup ] keep
+ '[ _ dup , follow-tree ] when ;
+
+: follow-tree ( node -- )
+ ! This is bogus: it misses nodes that aren't reachable
+ ! from the roots because of a control dependence
+ dup dup follows>> values
+ [ data-dependence? ] with filter
+ [ parent>> not ] filter
+ [ maybe-cut-node ] filter
+
+ [ [ >>parent drop ] with each ]
+ [ >>children drop ] 2bi ;
+
+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 ;
+
+: make-trees ( -- trees )
+ [
+ roots get [ dup , follow-tree ] each
+ ] { } make verify-trees ;
+
+: build-fan-in-trees ( -- )
+ make-trees [
+ -1/0. >>parent-index
+ calculate-registers drop
+ ] each ;
--- /dev/null
+! 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>> values ] keep
+ '[ [ precedes>> _ swap check-delete-at ] each ]
+ [ [ ready? ] filter roots get push-all ] bi ;
+
+: score ( insn -- n )
+ [ parent-index>> ] [ registers>> neg ] bi 2array ;
+
+: 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
+
+: split-3-ways ( insns -- first middle last )
+ [ ##phi? 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 ;
+
+: update-vregs ( insn vregs -- )
+ [ [ defs-vreg ] dip '[ _ delete-at ] when* ]
+ [ [ uses-vregs ] dip '[ _ conjoin ] each ] 2bi ;
+
+:: (might-spill?) ( vregs insns -- ? )
+ insns <reversed> [
+ [ vregs update-vregs ]
+ [ temp-vregs length vregs assoc-size + num-registers > ] bi
+ ] any? ;
+
+: might-spill? ( bb -- ? )
+ ! Conservative approximation testing whether a bb might spill
+ ! by calculating register pressure all along, assuming
+ ! everything in live-out are in registers
+ ! This is done bottom-up: a def means the register is no longer live
+ [ live-out H{ } assoc-clone-like ] [ instructions>> ] bi (might-spill?) ;
+
+: schedule-instructions ( cfg -- cfg' )
+ dup [
+ dup might-spill?
+ [ schedule-block ]
+ [ drop ] if
+ ] each-basic-block ;
projects / factor.git / commitdiff