backend for choosing available SIMD intrinsic implementations
Joe Groff
parent
788289e51e
commit
eac9bacf40
|
|
@ -0,0 +1,135 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors fry generalizations kernel locals math sequences
|
||||
splitting words ;
|
||||
IN: compiler.cfg.intrinsics.simd.backend
|
||||
|
||||
! Selection of implementation based on available CPU instructions
|
||||
|
||||
: can-has? ( quot -- ? )
|
||||
[ t \ can-has? ] dip '[ @ drop \ can-has? get ] with-variable ; inline
|
||||
|
||||
GENERIC: create-can-has-word ( word -- word' )
|
||||
|
||||
PREDICATE: vector-op-word
|
||||
{
|
||||
[ name>> { [ { [ "^" head? ] [ "##" head? ] } 1|| ] [ "-vector" swap subseq? ] } 1&& ]
|
||||
[ vocabulary>> { "compiler.cfg.intrinsics.simd" "cpu.architecture" } member? ]
|
||||
} 1&& ;
|
||||
|
||||
: reps-word ( word -- word' )
|
||||
name>> "^^" ?head drop "##" ?head drop
|
||||
"%" "-reps" surround "cpu.architecture" lookup ;
|
||||
|
||||
:: can-has-^^-quot ( word def effect -- def' )
|
||||
effect in>> { "rep" } split1 [ length ] bi@ 1 +
|
||||
word reps-word
|
||||
effect out>> length f <array> >quotation
|
||||
'[ [ _ ndrop ] _ ndip _ execute member? \ can-has? [ and ] change @ ] ;
|
||||
|
||||
:: can-has-^-quot ( word def effect -- def' )
|
||||
def create-can-has ;
|
||||
|
||||
M: object create-can-has ;
|
||||
|
||||
M: sequence create-can-has
|
||||
[ create-can-has-word ] map ;
|
||||
|
||||
: (create-can-has-word) ( word -- word' created? )
|
||||
name>> "can-has-" prepend "compiler.cfg.intrinsics.simd.backend"
|
||||
2dup lookup
|
||||
[ 2nip f ] [ create t ] if* ;
|
||||
|
||||
: (create-can-has-quot) ( word -- def effect )
|
||||
[ ] [ def>> ] [ stack-effect ] tri [
|
||||
{
|
||||
{ [ pick "^^" head? ] [ can-has-^^-quot ] }
|
||||
{ [ pick "##" head? ] [ can-has-^^-quot ] }
|
||||
{ [ pick "^" head? ] [ can-has-^-quot ] }
|
||||
} cond
|
||||
] keep ;
|
||||
|
||||
M: vector-op-word create-can-has
|
||||
[ (create-can-has-word) ] keep
|
||||
'[ _ (create-can-has-quot) define-declared ]
|
||||
[ nip ] if ;
|
||||
|
||||
GENERIC# >can-has-cond 2 ( quot #pick #dup -- quotpair )
|
||||
M:: callable >can-has-cond
|
||||
#dup quot create-can-has '[ _ ndup _ can-has? ] quot 2array ;
|
||||
|
||||
M:: pair >can-has-cond ( pair #pick #dup -- quotpair )
|
||||
pair first2 :> ( class quot )
|
||||
#pick class #dup quot create-can-has
|
||||
'[ _ npick _ instance? [ _ ndup _ can-has? ] dip and ]
|
||||
quot 2array ;
|
||||
|
||||
MACRO: v-vector-op ( trials -- )
|
||||
[ 1 2 >can-has-cond ] map '[ _ cond ] ;
|
||||
MACRO: vl-vector-op ( trials -- )
|
||||
[ 1 3 >can-has-cond ] map '[ _ cond ] ;
|
||||
MACRO: vv-vector-op ( trials -- )
|
||||
[ 1 3 >can-has-cond ] map '[ _ cond ] ;
|
||||
MACRO: vv-cc-vector-op ( trials -- )
|
||||
[ 2 4 >can-has-cond ] map '[ _ cond ] ;
|
||||
MACRO: vvvv-vector-op ( trials -- )
|
||||
[ 1 5 >can-has-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
|
||||
f ;
|
||||
|
||||
! Intrinsic code emission
|
||||
|
||||
MACRO: if-literals-match ( quots -- )
|
||||
[ length ] [ ] [ length ] tri
|
||||
! n quots n
|
||||
'[
|
||||
! node quot
|
||||
[
|
||||
dup node-input-infos
|
||||
_ tail-slice* [ literal>> ] map
|
||||
dup _ check-elements
|
||||
] dip
|
||||
swap [
|
||||
! node literals quot
|
||||
[ _ firstn ] dip call
|
||||
drop
|
||||
] [ 2drop emit-primitive ] if
|
||||
] ;
|
||||
|
||||
CONSTANT: [unary] [ ds-drop ds-pop ]
|
||||
CONSTANT: [unary/param] [ [ -2 inc-d ds-pop ] dip ]
|
||||
CONSTANT: [binary] [ ds-drop 2inputs ]
|
||||
CONSTANT: [quaternary]
|
||||
[
|
||||
ds-drop
|
||||
D 3 peek-loc
|
||||
D 2 peek-loc
|
||||
D 1 peek-loc
|
||||
D 0 peek-loc
|
||||
-4 inc-d
|
||||
]
|
||||
|
||||
:: [emit-vector-op] ( trials params-quot op-quot literal-preds -- quot ) ;
|
||||
params-quot trials op-quot literal-preds
|
||||
'[ [ _ dip _ @ ds-push ] _ if-literals-match ] ;
|
||||
|
||||
MACRO: emit-v-vector-op ( trials -- )
|
||||
[unary] [ v-vector-op ] { [ representation? ] } [emit-vector-op] ;
|
||||
MACRO: emit-vl-vector-op ( trials literal-pred -- )
|
||||
[ [unary/param] [ vl-vector-op ] { [ representation? ] } ] dip prefix [emit-vector-op] ;
|
||||
MACRO: emit-vv-vector-op ( trials -- )
|
||||
[binary] [ vv-vector-op ] { [ representation? ] } [emit-vector-op] ;
|
||||
MACRO: emit-vvvv-vector-op ( trials -- )
|
||||
[quaternary] [ vvvv-vector-op ] { [ representation? ] } [emit-vector-op] ;
|
||||
|
||||
MACRO:: emit-vv-or-vl-vector-op ( trials literal-pred -- )
|
||||
literal-pred trials literal-pred trials
|
||||
'[
|
||||
dup node-input-infos 2 tail-slice* first literal>> @
|
||||
[ _ _ emit-vl-vector-op ]
|
||||
[ _ emit-vv-vector-op ] if
|
||||
] ;
|
||||
|
|
@ -9,6 +9,7 @@ compiler.cfg.comparisons
|
|||
compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
|
||||
compiler.cfg.instructions compiler.cfg.registers
|
||||
compiler.cfg.intrinsics.alien
|
||||
compiler.cfg.intrinsics.simd.backend
|
||||
specialized-arrays ;
|
||||
FROM: alien.c-types => heap-size char short int longlong float double ;
|
||||
SPECIALIZED-ARRAYS: char short int longlong float double ;
|
||||
|
|
@ -76,15 +77,37 @@ IN: compiler.cfg.intrinsics.simd
|
|||
{ cc>= [ src1 src2 rep ^^max-vector src1 rep cc= ^^compare-vector ] }
|
||||
} case ;
|
||||
|
||||
:: ^((compare-vector)) ( src1 src2 rep {cc,swap} -- dst )
|
||||
{cc,swap} first2 :> ( cc swap? )
|
||||
swap?
|
||||
[ src2 src1 rep cc ^^compare-vector ]
|
||||
[ src1 src2 rep cc ^^compare-vector ] if ;
|
||||
|
||||
:: ^(compare-vector) ( src1 src2 rep orig-cc -- dst )
|
||||
rep orig-cc %compare-vector-ccs :> ( ccs not? )
|
||||
|
||||
ccs empty?
|
||||
[ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
|
||||
[
|
||||
ccs unclip :> ( rest-ccs first-cc )
|
||||
src1 src2 rep first-cc ^((compare-vector)) :> first-dst
|
||||
|
||||
rest-ccs first-dst
|
||||
[ [ src1 src2 rep ] dip ^((compare-vector)) rep ^^or-vector ]
|
||||
reduce
|
||||
|
||||
not? [ rep generate-not-vector ] when
|
||||
] if ;
|
||||
|
||||
: ^compare-vector ( src1 src2 rep cc -- dst )
|
||||
{
|
||||
[ ^^compare-vector ]
|
||||
[ ^(compare-vector) ]
|
||||
[ ^minmax-compare-vector ]
|
||||
{ unsigned-int-vector-rep [| src1 src2 rep cc |
|
||||
rep sign-bit-mask ^^load-constant :> sign-bits
|
||||
src1 sign-bits rep ^^xor-vector
|
||||
src2 sign-bits rep ^^xor-vector
|
||||
rep unsign-rep cc ^^compare-vector
|
||||
rep unsign-rep cc ^(compare-vector)
|
||||
] }
|
||||
} vv-cc-vector-op ;
|
||||
|
||||
|
|
@ -95,7 +118,7 @@ IN: compiler.cfg.intrinsics.simd
|
|||
{ signed-int-vector-rep [| src rep |
|
||||
src src rep ^^merge-vector-head :> merged
|
||||
rep rep-component-type heap-size 8 * :> bits
|
||||
merged bits rep ^widened-shr-vector-imm
|
||||
merged bits rep widen-rep ^shr-vector-imm
|
||||
] }
|
||||
{ signed-int-vector-rep [| src rep |
|
||||
rep ^^zero-vector :> zero
|
||||
|
|
@ -499,14 +522,23 @@ IN: compiler.cfg.intrinsics.simd
|
|||
} [ integer? ] emit-vl-vector-op ;
|
||||
|
||||
: emit-alien-vector ( node -- )
|
||||
{
|
||||
[ ^^alien-vector ]
|
||||
} emit-alien-vector-op ;
|
||||
dup [
|
||||
'[
|
||||
ds-drop prepare-alien-getter
|
||||
_ ^^alien-vector ds-push
|
||||
]
|
||||
[ inline-alien-getter? ] inline-alien
|
||||
] with { [ %alien-vector-reps member? ] } if-literals-match ;
|
||||
|
||||
: emit-set-alien-vector ( node -- )
|
||||
{
|
||||
[ ^^set-alien-vector ]
|
||||
} emit-set-alien-vector-op ;
|
||||
dup [
|
||||
'[
|
||||
ds-drop prepare-alien-setter ds-pop
|
||||
_ ##set-alien-vector
|
||||
]
|
||||
[ byte-array inline-alien-setter? ]
|
||||
inline-alien
|
||||
] with { [ %alien-vector-reps member? ] } if-literals-match ;
|
||||
|
||||
: enable-simd ( -- )
|
||||
{
|
||||
|
|
|
|||
Loading…
Reference in New Issue