155 lines
4.6 KiB
Factor
155 lines
4.6 KiB
Factor
! Copyright (C) 2010 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: accessors arrays assocs byte-arrays combinators
|
|
disjoint-sets fry kernel locals math math.functions
|
|
namespaces sequences sets
|
|
compiler.cfg
|
|
compiler.cfg.instructions
|
|
compiler.cfg.loop-detection
|
|
compiler.cfg.registers
|
|
compiler.cfg.representations.preferred
|
|
compiler.cfg.representations.coalescing
|
|
compiler.cfg.rpo
|
|
compiler.cfg.utilities
|
|
compiler.utilities
|
|
cpu.architecture ;
|
|
FROM: assocs => change-at ;
|
|
FROM: namespaces => set ;
|
|
IN: compiler.cfg.representations.selection
|
|
|
|
! vregs which must be tagged at the definition site because
|
|
! there is at least one usage that is not int-rep. If all usages
|
|
! are int-rep it is safe to untag at the definition site.
|
|
SYMBOL: tagged-vregs
|
|
|
|
SYMBOL: vreg-reps
|
|
|
|
: handle-def ( vreg rep -- )
|
|
swap vreg>scc vreg-reps get
|
|
[ [ intersect ] when* ] change-at ;
|
|
|
|
: handle-use ( vreg rep -- )
|
|
int-rep eq? [ drop ] [ vreg>scc tagged-vregs get adjoin ] if ;
|
|
|
|
GENERIC: (collect-vreg-reps) ( insn -- )
|
|
|
|
M: ##load-reference (collect-vreg-reps)
|
|
[ dst>> ] [ obj>> ] bi {
|
|
{ [ dup float? ] [ drop { float-rep double-rep } ] }
|
|
{ [ dup byte-array? ] [ drop vector-reps ] }
|
|
[ drop { } ]
|
|
} cond handle-def ;
|
|
|
|
M: vreg-insn (collect-vreg-reps)
|
|
[ [ handle-use ] each-use-rep ]
|
|
[ [ 1array handle-def ] each-def-rep ]
|
|
[ [ 1array handle-def ] each-temp-rep ]
|
|
tri ;
|
|
|
|
M: insn (collect-vreg-reps) drop ;
|
|
|
|
: collect-vreg-reps ( cfg -- )
|
|
H{ } clone vreg-reps set
|
|
HS{ } clone tagged-vregs set
|
|
[ [ (collect-vreg-reps) ] each-non-phi ] each-basic-block ;
|
|
|
|
SYMBOL: possibilities
|
|
|
|
: possible-reps ( vreg reps -- vreg reps )
|
|
{ tagged-rep } union
|
|
2dup [ tagged-vregs get in? not ] [ { tagged-rep } = ] bi* and
|
|
[ drop { tagged-rep int-rep } ] when ;
|
|
|
|
: compute-possibilities ( cfg -- )
|
|
collect-vreg-reps
|
|
vreg-reps get [ possible-reps ] assoc-map possibilities set ;
|
|
|
|
! For every vreg, compute the cost of keeping it in every possible
|
|
! representation.
|
|
|
|
! Cost map maps vreg to representation to cost.
|
|
SYMBOL: costs
|
|
|
|
: init-costs ( -- )
|
|
! Initialize cost as 0 for each possibility.
|
|
possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
|
|
|
|
: increase-cost ( rep scc factor -- )
|
|
! Increase cost of keeping vreg in rep, making a choice of rep less
|
|
! likely. If the rep is not in the cost alist, it means this
|
|
! representation is prohibited.
|
|
[ costs get at 2dup key? ] dip
|
|
'[ [ current-loop-nesting 10^ _ * + ] change-at ] [ 2drop ] if ;
|
|
|
|
:: increase-costs ( vreg preferred factor -- )
|
|
vreg vreg>scc :> scc
|
|
scc possibilities get at [
|
|
dup preferred eq? [ drop ] [ scc factor increase-cost ] if
|
|
] each ; inline
|
|
|
|
UNION: inert-tag-untag-insn
|
|
##add
|
|
##sub
|
|
##and
|
|
##or
|
|
##xor
|
|
##min
|
|
##max ;
|
|
|
|
UNION: inert-arithmetic-tag-untag-insn
|
|
##add-imm
|
|
##sub-imm ;
|
|
|
|
UNION: inert-bitwise-tag-untag-insn
|
|
##and-imm
|
|
##or-imm
|
|
##xor-imm ;
|
|
|
|
GENERIC: has-peephole-opts? ( insn -- ? )
|
|
|
|
M: insn has-peephole-opts? drop f ;
|
|
M: ##load-integer has-peephole-opts? drop t ;
|
|
M: ##load-reference has-peephole-opts? drop t ;
|
|
M: ##neg has-peephole-opts? drop t ;
|
|
M: ##not has-peephole-opts? drop t ;
|
|
M: inert-tag-untag-insn has-peephole-opts? drop t ;
|
|
M: inert-arithmetic-tag-untag-insn has-peephole-opts? drop t ;
|
|
M: inert-bitwise-tag-untag-insn has-peephole-opts? drop t ;
|
|
M: ##mul-imm has-peephole-opts? drop t ;
|
|
M: ##shl-imm has-peephole-opts? drop t ;
|
|
M: ##shr-imm has-peephole-opts? drop t ;
|
|
M: ##sar-imm has-peephole-opts? drop t ;
|
|
M: ##compare-integer-imm has-peephole-opts? drop t ;
|
|
M: ##compare-integer has-peephole-opts? drop t ;
|
|
M: ##compare-integer-imm-branch has-peephole-opts? drop t ;
|
|
M: ##compare-integer-branch has-peephole-opts? drop t ;
|
|
M: ##test-imm has-peephole-opts? drop t ;
|
|
M: ##test has-peephole-opts? drop t ;
|
|
M: ##test-imm-branch has-peephole-opts? drop t ;
|
|
M: ##test-branch has-peephole-opts? drop t ;
|
|
|
|
GENERIC: compute-insn-costs ( insn -- )
|
|
|
|
M: insn compute-insn-costs drop ;
|
|
|
|
M: vreg-insn compute-insn-costs
|
|
dup has-peephole-opts? 2 5 ? '[ _ increase-costs ] each-rep ;
|
|
|
|
: compute-costs ( cfg -- )
|
|
init-costs
|
|
[
|
|
[ basic-block set ]
|
|
[ [ compute-insn-costs ] each-non-phi ] bi
|
|
] each-basic-block ;
|
|
|
|
! For every vreg, compute preferred representation, that minimizes costs.
|
|
: minimize-costs ( costs -- representations )
|
|
[ nip assoc-empty? not ] assoc-filter
|
|
[ >alist alist-min first ] assoc-map ;
|
|
|
|
: compute-representations ( cfg -- )
|
|
compute-costs costs get minimize-costs
|
|
[ components get [ disjoint-set-members ] keep ] dip
|
|
'[ dup _ representative _ at ] H{ } map>assoc
|
|
representations set ;
|