207 lines
6.3 KiB
Factor
207 lines
6.3 KiB
Factor
! (c)2009 Joe Groff bsd license
|
|
USING: accessors arrays assocs classes combinators
|
|
combinators.short-circuit compiler.cfg.builder.blocks
|
|
compiler.cfg.registers compiler.cfg.stacks
|
|
compiler.cfg.stacks.local compiler.tree.propagation.info
|
|
cpu.architecture effects fry generalizations
|
|
kernel locals macros math namespaces quotations sequences
|
|
splitting stack-checker 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
|
|
|
|
: can-has-rep? ( rep reps -- )
|
|
member? \ can-has? [ and ] change ; inline
|
|
|
|
GENERIC: create-can-has ( word -- word' )
|
|
|
|
PREDICATE: hat-word < word
|
|
{
|
|
[ name>> { [ "^" head? ] [ "##" head? ] } 1|| ]
|
|
[ vocabulary>> { "compiler.cfg.intrinsics.simd" "compiler.cfg.hats" } member? ]
|
|
} 1&& ;
|
|
|
|
PREDICATE: vector-op-word < hat-word
|
|
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 )
|
|
#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
|
|
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 infer in>> length 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 infer in>> length
|
|
'[ _ 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
|
|
|
|
MACRO: check-elements ( quots -- )
|
|
[ length '[ _ firstn ] ]
|
|
[ '[ _ spread ] ]
|
|
[ length 1 - \ and <repetition> [ ] like ]
|
|
tri 3append ;
|
|
|
|
ERROR: bad-simd-intrinsic node ;
|
|
|
|
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 bad-simd-intrinsic ] 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 ( var-trials imm-trials literal-pred -- )
|
|
literal-pred imm-trials literal-pred var-trials
|
|
'[
|
|
dup node-input-infos 2 tail-slice* first literal>> @
|
|
[ _ _ emit-vl-vector-op ]
|
|
[ _ emit-vv-vector-op ] if
|
|
] ;
|
|
|