compiler.cfg.intrinsics.simd.backend: use less grotesque metaprogramming to determine simd instruction sequences
Joe Groff
parent
6aee6b3adc
commit
ee4913702f
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue