! Copyright (C) 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: kernel fry sequences namespaces accessors assocs math continuations locals combinators vectors random math.order hashtables sets cpu.architecture compiler.cfg.instructions compiler.cfg.rpo compiler.cfg.ssa.interference.live-ranges compiler.cfg.def-use compiler.cfg.liveness.ssa compiler.cfg.liveness ; IN: compiler.cfg.scheduling ! Scheduling instructions randomly ! In compiler.cfg.optimizer, this goes after representation selection SYMBOL: new-instructions SYMBOL: ready-nodes SYMBOL: node-number ! 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 depends-on ; M: node equal? [ number>> ] bi@ = ; M: node hashcode* nip number>> ; : ( insn -- node ) node new node-number counter >>number swap >>insn H{ } clone >>precedes H{ } clone >>depends-on ; : ready? ( node -- ? ) depends-on>> assoc-empty? ; : precedes ( first second -- ) swap precedes>> conjoin ; :: add-definition-edges ( nodes -- ) ! If one node defines a value and another node uses ! that value, there's a dependency 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 ; UNION: stack-insn ##peek ##replace ##inc-d ##inc-r ; : add-stack-edges ( nodes -- ) ! For now: all stack instructions are in a chain [ insn>> stack-insn? ] filter make-chain ; 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: memory-insn ##read ##write ##alien-read ##alien-write ; : add-slot-edges ( nodes -- ) ! For now: all slot and alien instructions are in a chain [ insn>> memory-insn? ] filter make-chain ; : set-depends-on ( nodes -- ) [ dup precedes>> values [ depends-on>> conjoin ] with each ] each ; : set-ready-nodes ( nodes -- ) [ ready? ] filter V{ } like ready-nodes set ; : build-dependency-graph ( instructions -- ) [ ] map { [ add-definition-edges ] [ add-stack-edges ] [ add-slot-edges ] [ set-depends-on ] [ set-ready-nodes ] } cleave ; ERROR: bad-delete-at key assoc ; : check-delete-at ( key assoc -- ) 2dup key? [ delete-at ] [ bad-delete-at ] if ; : remove-node ( node -- ) [ precedes>> values ] keep '[ [ depends-on>> _ swap check-delete-at ] each ] [ [ ready? ] filter ready-nodes get push-all ] bi ; : score ( insn -- n ) ! Replace this with an appropriate heuristic drop 100 random ; : pull-out-nth ( n seq -- elt ) [ nth ] [ delete-nth ] 2bi ; : select ( vector quot -- elt ) ! This could be sped up by a constant factor [ dup ] dip '[ _ call( insn -- score ) ] assoc-map dup values supremum '[ nip _ = ] assoc-find 2drop swap pull-out-nth ; : select-instruction ( -- insn/f ) ready-nodes get [ f ] [ [ score ] select [ insn>> ] [ remove-node ] bi ] if-empty ; : (reorder) ( -- ) select-instruction [ new-instructions get push (reorder) ] when* ; ! Instructions in the beginning of the BB that can't be scheduled UNION: first-insn ##phi ##prologue ; ! Instructions at the end that can't be scheduled, except branches UNION: last-insn ##epilogue ; : cut-by ( seq quot -- before after ) dupd find drop [ cut ] [ f ] if* ; inline : split-3-ways ( insns -- first middle last ) [ first-insn? not ] cut-by [ last-insn? ] cut-by [ dup length 1 - 0 max cut ] when-empty ; : reorder ( bb -- ) split-3-ways [ new-instructions get push-all ] [ build-dependency-graph (reorder) ] [ new-instructions get push-all ] tri* ; 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 ; : do-scheduling ( instructions -- instructions' ) V{ } clone new-instructions set reorder new-instructions get ; : schedule-block ( bb -- ) [ [ do-scheduling ] change-instructions drop ] with-scheduling-check ; : will-spill? ( bb -- ? ) ! Replace this with a test of whether the bb might spill ! by calculating register pressure all along, assuming ! everything in live-in is in a register drop t ; : schedule-instructions ( cfg -- cfg' ) compute-ssa-live-sets dup compute-live-ranges dup [ dup will-spill? [ schedule-block ] [ drop ] if ] each-basic-block ;