compiler.cfg.intrinsics.simd.backend: use less grotesque metaprogramming to determine simd instruction sequences

db4
Joe Groff 2010-03-20 02:16:50 -07:00
parent 6aee6b3adc
commit ee4913702f
1 changed files with 63 additions and 121 deletions

View File

@ -3,145 +3,87 @@ USING: accessors arrays assocs classes combinators
combinators.short-circuit compiler.cfg.builder.blocks combinators.short-circuit compiler.cfg.builder.blocks
compiler.cfg.registers compiler.cfg.stacks compiler.cfg.registers compiler.cfg.stacks
compiler.cfg.stacks.local compiler.tree.propagation.info compiler.cfg.stacks.local compiler.tree.propagation.info
compiler.cfg.instructions
cpu.architecture effects fry generalizations cpu.architecture effects fry generalizations
kernel locals macros math namespaces quotations sequences kernel locals macros make math namespaces quotations sequences
splitting stack-checker words ; splitting stack-checker words ;
IN: compiler.cfg.intrinsics.simd.backend IN: compiler.cfg.intrinsics.simd.backend
! Selection of implementation based on available CPU instructions ! Selection of implementation based on available CPU instructions
: can-has? ( quot -- ? ) GENERIC: insn-available? ( ## -- reps )
[ t \ can-has? ] dip '[ @ drop \ can-has? get ] with-variable ; inline
: can-has-rep? ( rep reps -- ) M: object insn-available? drop t ;
member? \ can-has? [ and ] change ; inline
GENERIC: create-can-has ( word -- word' ) M: ##zero-vector insn-available? rep>> %zero-vector-reps member? ;
M: ##fill-vector insn-available? rep>> %fill-vector-reps member? ;
M: ##gather-vector-2 insn-available? rep>> %gather-vector-2-reps member? ;
M: ##gather-vector-4 insn-available? rep>> %gather-vector-4-reps member? ;
M: ##alien-vector insn-available? rep>> %alien-vector-reps member? ;
M: ##shuffle-vector insn-available? rep>> %shuffle-vector-reps member? ;
M: ##shuffle-vector-imm insn-available? rep>> %shuffle-vector-imm-reps member? ;
M: ##merge-vector-head insn-available? rep>> %merge-vector-reps member? ;
M: ##merge-vector-tail insn-available? rep>> %merge-vector-reps member? ;
M: ##signed-pack-vector insn-available? rep>> %signed-pack-vector-reps member? ;
M: ##unsigned-pack-vector insn-available? rep>> %unsigned-pack-vector-reps member? ;
M: ##unpack-vector-head insn-available? rep>> %unpack-vector-head-reps member? ;
M: ##unpack-vector-tail insn-available? rep>> %unpack-vector-tail-reps member? ;
M: ##tail>head-vector insn-available? rep>> %unpack-vector-head-reps member? ;
M: ##integer>float-vector insn-available? rep>> %integer>float-vector-reps member? ;
M: ##float>integer-vector insn-available? rep>> %float>integer-vector-reps member? ;
M: ##compare-vector insn-available? [ rep>> ] [ cc>> ] bi %compare-vector-reps member? ;
M: ##test-vector insn-available? rep>> %test-vector-reps member? ;
M: ##add-vector insn-available? rep>> %add-vector-reps member? ;
M: ##saturated-add-vector insn-available? rep>> %saturated-add-vector-reps member? ;
M: ##add-sub-vector insn-available? rep>> %add-sub-vector-reps member? ;
M: ##sub-vector insn-available? rep>> %sub-vector-reps member? ;
M: ##saturated-sub-vector insn-available? rep>> %saturated-sub-vector-reps member? ;
M: ##mul-vector insn-available? rep>> %mul-vector-reps member? ;
M: ##mul-high-vector insn-available? rep>> %mul-high-vector-reps member? ;
M: ##mul-horizontal-add-vector insn-available? rep>> %mul-horizontal-add-vector-reps member? ;
M: ##saturated-mul-vector insn-available? rep>> %saturated-mul-vector-reps member? ;
M: ##div-vector insn-available? rep>> %div-vector-reps member? ;
M: ##min-vector insn-available? rep>> %min-vector-reps member? ;
M: ##max-vector insn-available? rep>> %max-vector-reps member? ;
M: ##avg-vector insn-available? rep>> %avg-vector-reps member? ;
M: ##dot-vector insn-available? rep>> %dot-vector-reps member? ;
M: ##sad-vector insn-available? rep>> %sad-vector-reps member? ;
M: ##sqrt-vector insn-available? rep>> %sqrt-vector-reps member? ;
M: ##horizontal-add-vector insn-available? rep>> %horizontal-add-vector-reps member? ;
M: ##horizontal-sub-vector insn-available? rep>> %horizontal-sub-vector-reps member? ;
M: ##abs-vector insn-available? rep>> %abs-vector-reps member? ;
M: ##and-vector insn-available? rep>> %and-vector-reps member? ;
M: ##andn-vector insn-available? rep>> %andn-vector-reps member? ;
M: ##or-vector insn-available? rep>> %or-vector-reps member? ;
M: ##xor-vector insn-available? rep>> %xor-vector-reps member? ;
M: ##not-vector insn-available? rep>> %not-vector-reps member? ;
M: ##shl-vector insn-available? rep>> %shl-vector-reps member? ;
M: ##shr-vector insn-available? rep>> %shr-vector-reps member? ;
M: ##shl-vector-imm insn-available? rep>> %shl-vector-imm-reps member? ;
M: ##shr-vector-imm insn-available? rep>> %shr-vector-imm-reps member? ;
M: ##horizontal-shl-vector-imm insn-available? rep>> %horizontal-shl-vector-imm-reps member? ;
M: ##horizontal-shr-vector-imm insn-available? rep>> %horizontal-shr-vector-imm-reps member? ;
PREDICATE: hat-word < word GENERIC# >vector-op-cond 2 ( quot #pick #dup -- quotpair )
{ M:: callable >vector-op-cond ( quot #pick #dup -- quotpair )
[ name>> { [ "^" head? ] [ "##" head? ] } 1|| ] #dup quot '[ _ ndup [ @ drop ] { } make [ insn-available? ] all? ] quot 2array ;
[ vocabulary>> { "compiler.cfg.intrinsics.simd" "compiler.cfg.hats" } member? ]
} 1&& ;
PREDICATE: vector-op-word < hat-word M:: pair >vector-op-cond ( pair #pick #dup -- quotpair )
name>> "-vector" swap subseq? ;
: reps-word ( word -- word' )
name>> "^^" ?head drop "##" ?head drop
"%" "-reps" surround "cpu.architecture" lookup ;
SYMBOL: blub
:: can-has-^^-quot ( word def effect -- quot )
effect in>> { "rep" } split1 [ length ] bi@ 1 +
word reps-word 1quotation
effect out>> length blub <array> >quotation
'[ [ _ ndrop ] _ ndip @ can-has-rep? @ ] ;
:: can-has-^-quot ( word def effect -- quot )
def create-can-has first ;
: map-concat-like ( seq quot -- seq' )
'[ _ map ] [ concat-as ] bi ; inline
M: object create-can-has 1quotation ;
M: array create-can-has
[ create-can-has ] map-concat-like 1quotation ;
M: callable create-can-has
[ create-can-has ] map-concat-like 1quotation ;
: (can-has-word) ( word -- word' )
name>> "can-has-" prepend "compiler.cfg.intrinsics.simd.backend" lookup ;
: (can-has-quot) ( word -- quot )
[ ] [ def>> ] [ stack-effect ] tri {
{ [ pick name>> "^^" head? ] [ can-has-^^-quot ] }
{ [ pick name>> "##" head? ] [ can-has-^^-quot ] }
{ [ pick name>> "^" head? ] [ can-has-^-quot ] }
} cond ;
: (can-has-nop-quot) ( word -- quot )
stack-effect in>> length '[ _ ndrop blub ] ;
DEFER: can-has-words
M: word create-can-has
can-has-words ?at drop 1quotation ;
M: hat-word create-can-has
(can-has-nop-quot) ;
M: vector-op-word create-can-has
dup (can-has-word) [ 1quotation ] [ (can-has-quot) ] ?if ;
GENERIC# >can-has-cond 2 ( quot #pick #dup -- quotpair )
M:: callable >can-has-cond ( quot #pick #dup -- quotpair )
#dup quot create-can-has '[ _ ndup @ can-has? ] quot 2array ;
M:: pair >can-has-cond ( pair #pick #dup -- quotpair )
pair first2 :> ( class quot ) pair first2 :> ( class quot )
#pick class #dup quot create-can-has #pick class #dup quot
'[ _ npick _ instance? [ _ ndup @ can-has? ] dip and ] '[ _ npick _ instance? [ _ ndup [ @ drop ] { } make [ insn-available? ] all? ] [ f ] if ]
quot 2array ; quot 2array ;
MACRO: v-vector-op ( trials -- ) MACRO: v-vector-op ( trials -- )
[ 1 2 >can-has-cond ] map '[ _ cond ] ; [ 1 2 >vector-op-cond ] map '[ _ cond ] ;
MACRO: vl-vector-op ( trials -- ) MACRO: vl-vector-op ( trials -- )
[ 1 3 >can-has-cond ] map '[ _ cond ] ; [ 1 3 >vector-op-cond ] map '[ _ cond ] ;
MACRO: vv-vector-op ( trials -- ) MACRO: vv-vector-op ( trials -- )
[ 1 3 >can-has-cond ] map '[ _ cond ] ; [ 1 3 >vector-op-cond ] map '[ _ cond ] ;
MACRO: vv-cc-vector-op ( trials -- ) MACRO: vv-cc-vector-op ( trials -- )
[ 2 4 >can-has-cond ] map '[ _ cond ] ; [ 2 4 >vector-op-cond ] map '[ _ cond ] ;
MACRO: vvvv-vector-op ( trials -- ) MACRO: vvvv-vector-op ( trials -- )
[ 1 5 >can-has-cond ] map '[ _ cond ] ; [ 1 5 >vector-op-cond ] map '[ _ cond ] ;
! Special-case conditional instructions
: can-has-^(compare-vector) ( src1 src2 rep cc -- dst )
[ 2drop ] 2dip %compare-vector-reps member?
\ can-has? [ and ] change
blub ;
: can-has-^^test-vector ( src rep vcc -- dst )
[ drop ] 2dip drop %test-vector-reps member?
\ can-has? [ and ] change
blub ;
MACRO: can-has-case ( cases -- )
dup first second inputs 1 +
'[ _ ndrop f ] suffix '[ _ case ] ;
GENERIC# >can-has-trial 1 ( obj #pick -- quot )
M: callable >can-has-trial
drop '[ _ can-has? ] ;
M: pair >can-has-trial
swap first2 dup inputs
'[ _ npick _ instance? [ _ can-has? ] [ _ ndrop blub ] if ] ;
MACRO: can-has-vector-op ( trials #pick #dup -- )
[ '[ _ >can-has-trial ] map ] dip '[ _ _ n|| \ can-has? [ and ] change blub ] ;
: can-has-v-vector-op ( trials -- ? )
1 2 can-has-vector-op ; inline
: can-has-vv-vector-op ( trials -- ? )
1 3 can-has-vector-op ; inline
: can-has-vv-cc-vector-op ( trials -- ? )
2 4 can-has-vector-op ; inline
: can-has-vvvv-vector-op ( trials -- ? )
1 5 can-has-vector-op ; inline
CONSTANT: can-has-words
H{
{ case can-has-case }
{ v-vector-op can-has-v-vector-op }
{ vl-vector-op can-has-vv-vector-op }
{ vv-vector-op can-has-vv-vector-op }
{ vv-cc-vector-op can-has-vv-cc-vector-op }
{ vvvv-vector-op can-has-vvvv-vector-op }
}
! Intrinsic code emission ! Intrinsic code emission