From eac9bacf40bb959061a88cef4f75841d805da1fa Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 10 Nov 2009 23:35:46 -0600 Subject: [PATCH] backend for choosing available SIMD intrinsic implementations --- .../intrinsics/simd/backend/backend.factor | 135 ++++++++++++++++++ .../compiler/cfg/intrinsics/simd/simd.factor | 52 +++++-- 2 files changed, 177 insertions(+), 10 deletions(-) create mode 100644 basis/compiler/cfg/intrinsics/simd/backend/backend.factor diff --git a/basis/compiler/cfg/intrinsics/simd/backend/backend.factor b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor new file mode 100644 index 0000000000..4fe9774282 --- /dev/null +++ b/basis/compiler/cfg/intrinsics/simd/backend/backend.factor @@ -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 >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 + ] ; diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor index c4fcdca23e..1cf076af1d 100644 --- a/basis/compiler/cfg/intrinsics/simd/simd.factor +++ b/basis/compiler/cfg/intrinsics/simd/simd.factor @@ -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 ( -- ) {