Paste: Random instruction scheduling

! 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>> ;

: <node> ( 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 -- )
    [ <node> ] 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 <enum> ] 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 ;