Merge branch 's3' of git://github.com/littledan/Factor into s3

basis/compiler/cfg/dependence/dependence.factor

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

basis/compiler/cfg/height/height.factor

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

basis/compiler/cfg/height/summary.txt

@@ -0,0 +1 @@
+Stack height normalization coalesces height changes at start of basic block

basis/compiler/cfg/optimizer/optimizer.factor

@@ -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

basis/compiler/cfg/scheduling/scheduling.factor

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