\ cleave [ ] 2sequence
\ output>array [ ] 2sequence ;
-: define-inline-method ( class generic quot -- )
- [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
-
: (define-struct-slot-values-method) ( class -- )
[ \ struct-slot-values ] [ struct-slot-values-quot ] bi
define-inline-method ;
literal: rep ;
PURE-INSN: ##horizontal-add-vector
-def: dst/scalar-rep
-use: src
+def: dst
+use: src1 src2
literal: rep ;
PURE-INSN: ##horizontal-sub-vector
-def: dst/scalar-rep
-use: src
+def: dst
+use: src1 src2
literal: rep ;
PURE-INSN: ##horizontal-shl-vector-imm
compiler.cfg.intrinsics.allot
compiler.cfg.intrinsics.fixnum
compiler.cfg.intrinsics.float
-compiler.cfg.intrinsics.simd
compiler.cfg.intrinsics.slots
compiler.cfg.intrinsics.misc
compiler.cfg.comparisons ;
QUALIFIED: math.private
QUALIFIED: math.integers.private
QUALIFIED: math.floats.private
-QUALIFIED: math.vectors.simd.intrinsics
QUALIFIED: math.libm
IN: compiler.cfg.intrinsics
{ math.integers.private:fixnum-log2 [ drop emit-fixnum-log2 ] }
} enable-intrinsics ;
-: enable-simd ( -- )
- {
- { math.vectors.simd.intrinsics:assert-positive [ drop ] }
- { math.vectors.simd.intrinsics:(simd-v+) [ [ ^^add-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vs+) [ [ ^^saturated-add-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-v+-) [ [ ^^add-sub-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-v-) [ [ ^^sub-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vs-) [ [ ^^saturated-sub-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vneg) [ [ generate-neg-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-v*) [ [ ^^mul-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vs*) [ [ ^^saturated-mul-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-v/) [ [ ^^div-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vmin) [ [ generate-min-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vmax) [ [ generate-max-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-v.) [ [ ^^dot-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vabs) [ [ generate-abs-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vsqrt) [ [ ^^sqrt-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vbitand) [ [ ^^and-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vbitandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vbitor) [ [ ^^or-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vbitxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vbitnot) [ [ generate-not-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vand) [ [ ^^and-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vandn) [ [ ^^andn-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vor) [ [ ^^or-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vxor) [ [ ^^xor-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vnot) [ [ generate-not-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-v<=) [ [ cc<= generate-compare-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-v<) [ [ cc< generate-compare-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-v=) [ [ cc= generate-compare-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-v>) [ [ cc> generate-compare-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-v>=) [ [ cc>= generate-compare-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vunordered?) [ [ cc/<>= generate-compare-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vany?) [ [ vcc-any ^^test-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vall?) [ [ vcc-all ^^test-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector-imm ] [ ^^shl-vector ] emit-shift-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector-imm ] [ ^^shr-vector ] emit-shift-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector-imm ] emit-shift-vector-imm-op ] }
- { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector-imm ] emit-shift-vector-imm-op ] }
- { math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
- { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
- { math.vectors.simd.intrinsics:(simd-vshuffle-elements) [ emit-shuffle-vector ] }
- { math.vectors.simd.intrinsics:(simd-vshuffle-bytes) [ emit-shuffle-vector-var ] }
- { math.vectors.simd.intrinsics:(simd-(vmerge-head)) [ [ ^^merge-vector-head ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-(vmerge-tail)) [ [ ^^merge-vector-tail ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-(v>float)) [ [ ^^integer>float-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-(v>integer)) [ [ ^^float>integer-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-(vpack-signed)) [ [ ^^signed-pack-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-(vpack-unsigned)) [ [ ^^unsigned-pack-vector ] emit-binary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-(vunpack-head)) [ [ generate-unpack-vector-head ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-(vunpack-tail)) [ [ generate-unpack-vector-tail ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:(simd-select) [ emit-select-vector ] }
- { math.vectors.simd.intrinsics:(simd-sum) [ [ ^^horizontal-add-vector ] emit-unary-vector-op ] }
- { math.vectors.simd.intrinsics:alien-vector [ emit-alien-vector ] }
- { math.vectors.simd.intrinsics:set-alien-vector [ emit-set-alien-vector ] }
- } enable-intrinsics ;
-
: emit-intrinsic ( node word -- )
"intrinsic" word-prop call( node -- ) ;
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: accessors arrays 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 help.lint.checks
+kernel locals macros math namespaces quotations 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' )
+
+PREDICATE: vector-op-word < word
+ {
+ [ name>> { [ { [ "^" head? ] [ "##" head? ] } 1|| ] [ "-vector" swap subseq? ] } 1&& ]
+ [ vocabulary>> { "compiler.cfg.intrinsics.simd" "compiler.cfg.hats" } member? ]
+ } 1&& ;
+
+: reps-word ( word -- word' )
+ name>> "^^" ?head drop "##" ?head drop
+ "%" "-reps" surround "cpu.architecture" lookup ;
+
+:: can-has-^^-quot ( word def effect -- quot )
+ 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 -- quot )
+ def create-can-has ;
+
+M: object create-can-has 1quotation ;
+
+M: array create-can-has
+ [ create-can-has ] map concat ;
+M: callable create-can-has
+ [ create-can-has ] map concat ;
+
+: (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 ;
+
+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
+ 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 ( 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
+ ] ;
+
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien byte-arrays fry classes.algebra
-cpu.architecture kernel math sequences math.vectors
-math.vectors.simd.intrinsics macros generalizations combinators
-combinators.short-circuit arrays locals
-compiler.tree.propagation.info compiler.cfg.builder.blocks
+USING: accessors alien alien.c-types byte-arrays fry
+classes.algebra cpu.architecture kernel math sequences
+math.vectors math.vectors.simd math.vectors.simd.private
+macros generalizations combinators combinators.short-circuit
+arrays locals compiler.tree.propagation.info
+compiler.cfg.builder.blocks
compiler.cfg.comparisons
compiler.cfg.stacks compiler.cfg.stacks.local compiler.cfg.hats
compiler.cfg.instructions compiler.cfg.registers
+compiler.cfg.intrinsics
compiler.cfg.intrinsics.alien
+compiler.cfg.intrinsics.simd.backend
specialized-arrays ;
-FROM: alien.c-types => heap-size uchar ushort uint ulonglong float double ;
-SPECIALIZED-ARRAYS: uchar ushort uint ulonglong float double ;
+FROM: alien.c-types => heap-size char short int longlong float double ;
+SPECIALIZED-ARRAYS: char uchar short ushort int uint longlong ulonglong float double ;
IN: compiler.cfg.intrinsics.simd
-MACRO: check-elements ( quots -- )
- [ length '[ _ firstn ] ]
- [ '[ _ spread ] ]
- [ length 1 - \ and <repetition> [ ] like ]
- tri 3append ;
-
-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
- ] ;
+! compound vector ops
-: emit-vector-op ( node quot: ( rep -- ) -- )
- { [ representation? ] } if-literals-match ; inline
+: sign-bit-mask ( rep -- byte-array )
+ unsign-rep {
+ { char-16-rep [ uchar-array{
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ HEX: 80 HEX: 80 HEX: 80 HEX: 80
+ } underlying>> ] }
+ { short-8-rep [ ushort-array{
+ HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
+ HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
+ } underlying>> ] }
+ { int-4-rep [ uint-array{
+ HEX: 8000,0000 HEX: 8000,0000
+ HEX: 8000,0000 HEX: 8000,0000
+ } underlying>> ] }
+ { longlong-2-rep [ ulonglong-array{
+ HEX: 8000,0000,0000,0000
+ HEX: 8000,0000,0000,0000
+ } underlying>> ] }
+ } case ;
-: [binary] ( quot -- quot' )
- '[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
+: ^load-neg-zero-vector ( rep -- dst )
+ {
+ { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
+ { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
+ } case ;
-: emit-binary-vector-op ( node quot -- )
- [binary] emit-vector-op ; inline
+: ^load-add-sub-vector ( rep -- dst )
+ unsign-rep {
+ { float-4-rep [ float-array{ -0.0 0.0 -0.0 0.0 } underlying>> ^^load-constant ] }
+ { double-2-rep [ double-array{ -0.0 0.0 } underlying>> ^^load-constant ] }
+ { char-16-rep [ char-array{ -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
+ { short-8-rep [ short-array{ -1 0 -1 0 -1 0 -1 0 } underlying>> ^^load-constant ] }
+ { int-4-rep [ int-array{ -1 0 -1 0 } underlying>> ^^load-constant ] }
+ { longlong-2-rep [ longlong-array{ -1 0 } underlying>> ^^load-constant ] }
+ } case ;
-: [unary] ( quot -- quot' )
- '[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
+: >variable-shuffle ( shuffle rep -- shuffle' )
+ rep-component-type heap-size
+ [ dup <repetition> >byte-array ]
+ [ iota >byte-array ] bi
+ '[ _ n*v _ v+ ] map concat ;
-: emit-unary-vector-op ( node quot -- )
- [unary] emit-vector-op ; inline
+: ^load-immediate-shuffle ( shuffle rep -- dst )
+ >variable-shuffle ^^load-constant ;
-: [unary/param] ( quot -- quot' )
- '[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
+:: ^blend-vector ( mask true false rep -- dst )
+ true mask rep ^^and-vector
+ mask false rep ^^andn-vector
+ rep ^^or-vector ;
-: emit-shift-vector-imm-op ( node quot -- )
- [unary/param]
- { [ integer? ] [ representation? ] } if-literals-match ; inline
+: ^not-vector ( src rep -- dst )
+ {
+ [ ^^not-vector ]
+ [ [ ^^fill-vector ] [ ^^xor-vector ] bi ]
+ } v-vector-op ;
+
+:: ^minmax-compare-vector ( src1 src2 rep cc -- dst )
+ cc order-cc {
+ { cc< [ src1 src2 rep ^^max-vector src1 rep cc/= ^^compare-vector ] }
+ { cc<= [ src1 src2 rep ^^min-vector src1 rep cc= ^^compare-vector ] }
+ { cc> [ src1 src2 rep ^^min-vector src1 rep cc/= ^^compare-vector ] }
+ { cc>= [ src1 src2 rep ^^max-vector src1 rep cc= ^^compare-vector ] }
+ } case ;
-:: emit-shift-vector-op ( node imm-quot var-quot -- )
- node node-input-infos 2 tail-slice* first literal>> integer?
- [ node imm-quot emit-shift-vector-imm-op ]
- [ node var-quot emit-binary-vector-op ] if ; inline
+:: ^((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 ;
-: emit-gather-vector-2 ( node -- )
- [ ^^gather-vector-2 ] emit-binary-vector-op ;
+:: ^(compare-vector) ( src1 src2 rep orig-cc -- dst )
+ rep orig-cc %compare-vector-ccs :> ( ccs not? )
-: emit-gather-vector-4 ( node -- )
+ ccs empty?
+ [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
[
- ds-drop
- [
- D 3 peek-loc
- D 2 peek-loc
- D 1 peek-loc
- D 0 peek-loc
- -4 inc-d
- ] dip
- ^^gather-vector-4
- ds-push
- ] emit-vector-op ;
-
-: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
+ ccs unclip :> ( rest-ccs first-cc )
+ src1 src2 rep first-cc ^((compare-vector)) :> first-dst
-: >variable-shuffle ( shuffle rep -- shuffle' )
- rep-component-type heap-size
- [ dup <repetition> >byte-array ]
- [ iota >byte-array ] bi
- '[ _ n*v _ v+ ] map concat ;
+ rest-ccs first-dst
+ [ [ src1 src2 rep ] dip ^((compare-vector)) rep ^^or-vector ]
+ reduce
-: generate-shuffle-vector-imm ( src shuffle rep -- dst )
- dup %shuffle-vector-imm-reps member?
- [ ^^shuffle-vector-imm ]
- [
- [ >variable-shuffle ^^load-constant ] keep
- ^^shuffle-vector
+ not? [ rep ^not-vector ] when
] if ;
-: emit-shuffle-vector-imm ( node -- )
- ! Pad the permutation with zeroes if it's too short, since we
- ! can't throw an error at this point.
- [ [ rep-components 0 pad-tail ] keep generate-shuffle-vector-imm ] [unary/param]
- { [ shuffle? ] [ representation? ] } if-literals-match ;
+: ^compare-vector ( src1 src2 rep cc -- dst )
+ {
+ [ ^(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)
+ ] }
+ } vv-cc-vector-op ;
+
+: ^unpack-vector-head ( src rep -- dst )
+ {
+ [ ^^unpack-vector-head ]
+ { unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-head ] bi ] }
+ { signed-int-vector-rep [| src rep |
+ src src rep ^^merge-vector-head :> merged
+ rep rep-component-type heap-size 8 * :> bits
+ merged bits rep widen-vector-rep ^^shr-vector-imm
+ ] }
+ { signed-int-vector-rep [| src rep |
+ rep ^^zero-vector :> zero
+ zero src rep cc> ^compare-vector :> sign
+ src sign rep ^^merge-vector-head
+ ] }
+ } v-vector-op ;
-: emit-shuffle-vector-var ( node -- )
- [ ^^shuffle-vector ] [binary]
- { [ %shuffle-vector-reps member? ] } if-literals-match ;
+: ^unpack-vector-tail ( src rep -- dst )
+ {
+ [ ^^unpack-vector-tail ]
+ [ [ ^^tail>head-vector ] [ ^^unpack-vector-head ] bi ]
+ { unsigned-int-vector-rep [ [ ^^zero-vector ] [ ^^merge-vector-tail ] bi ] }
+ { signed-int-vector-rep [| src rep |
+ src src rep ^^merge-vector-tail :> merged
+ rep rep-component-type heap-size 8 * :> bits
+ merged bits rep widen-vector-rep ^^shr-vector-imm
+ ] }
+ { signed-int-vector-rep [| src rep |
+ rep ^^zero-vector :> zero
+ zero src rep cc> ^compare-vector :> sign
+ src sign rep ^^merge-vector-tail
+ ] }
+ } v-vector-op ;
-: emit-shuffle-vector ( node -- )
- dup node-input-infos {
- [ length 3 = ]
- [ first class>> byte-array class<= ]
- [ second class>> byte-array class<= ]
- [ third literal>> representation? ]
- } 1&& [ emit-shuffle-vector-var ] [ emit-shuffle-vector-imm ] if ;
+: ^(sum-vector-2) ( src rep -- dst )
+ {
+ [ dupd ^^horizontal-add-vector ]
+ [| src rep |
+ src src rep ^^merge-vector-head :> head
+ src src rep ^^merge-vector-tail :> tail
+ head tail rep ^^add-vector
+ ]
+ } v-vector-op ;
-: ^^broadcast-vector ( src n rep -- dst )
- [ rep-components swap <array> ] keep
- generate-shuffle-vector-imm ;
+: ^(sum-vector-4) ( src rep -- dst )
+ {
+ [
+ [ dupd ^^horizontal-add-vector ]
+ [ dupd ^^horizontal-add-vector ] bi
+ ]
+ [| src rep |
+ src src rep ^^merge-vector-head :> head
+ src src rep ^^merge-vector-tail :> tail
+ head tail rep ^^add-vector :> src'
+
+ rep widen-vector-rep :> rep'
+ src' src' rep' ^^merge-vector-head :> head'
+ src' src' rep' ^^merge-vector-tail :> tail'
+ head' tail' rep ^^add-vector
+ ]
+ } v-vector-op ;
-: emit-broadcast-vector ( node -- )
- [ ^^broadcast-vector ] [unary/param]
- { [ integer? ] [ representation? ] } if-literals-match ;
+: ^(sum-vector-8) ( src rep -- dst )
+ {
+ [
+ [ dupd ^^horizontal-add-vector ]
+ [ dupd ^^horizontal-add-vector ]
+ [ dupd ^^horizontal-add-vector ] tri
+ ]
+ [| src rep |
+ src src rep ^^merge-vector-head :> head
+ src src rep ^^merge-vector-tail :> tail
+ head tail rep ^^add-vector :> src'
+
+ rep widen-vector-rep :> rep'
+ src' src' rep' ^^merge-vector-head :> head'
+ src' src' rep' ^^merge-vector-tail :> tail'
+ head' tail' rep ^^add-vector :> src''
+
+ rep' widen-vector-rep :> rep''
+ src'' src'' rep'' ^^merge-vector-head :> head''
+ src'' src'' rep'' ^^merge-vector-tail :> tail''
+ head'' tail'' rep ^^add-vector
+ ]
+ } v-vector-op ;
-: ^^with-vector ( src rep -- dst )
- [ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
+: ^(sum-vector-16) ( src rep -- dst )
+ {
+ [
+ {
+ [ dupd ^^horizontal-add-vector ]
+ [ dupd ^^horizontal-add-vector ]
+ [ dupd ^^horizontal-add-vector ]
+ [ dupd ^^horizontal-add-vector ]
+ } cleave
+ ]
+ [| src rep |
+ src src rep ^^merge-vector-head :> head
+ src src rep ^^merge-vector-tail :> tail
+ head tail rep ^^add-vector :> src'
+
+ rep widen-vector-rep :> rep'
+ src' src' rep' ^^merge-vector-head :> head'
+ src' src' rep' ^^merge-vector-tail :> tail'
+ head' tail' rep ^^add-vector :> src''
+
+ rep' widen-vector-rep :> rep''
+ src'' src'' rep'' ^^merge-vector-head :> head''
+ src'' src'' rep'' ^^merge-vector-tail :> tail''
+ head'' tail'' rep ^^add-vector :> src'''
+
+ rep'' widen-vector-rep :> rep'''
+ src''' src''' rep''' ^^merge-vector-head :> head'''
+ src''' src''' rep''' ^^merge-vector-tail :> tail'''
+ head''' tail''' rep ^^add-vector
+ ]
+ } v-vector-op ;
-: ^^select-vector ( src n rep -- dst )
- [ ^^broadcast-vector ] keep ^^vector>scalar ;
+: ^(sum-vector) ( src rep -- dst )
+ [
+ dup rep-length {
+ { 2 [ ^(sum-vector-2) ] }
+ { 4 [ ^(sum-vector-4) ] }
+ { 8 [ ^(sum-vector-8) ] }
+ { 16 [ ^(sum-vector-16) ] }
+ } case
+ ] [ ^^vector>scalar ] bi ;
+
+: ^sum-vector ( src rep -- dst )
+ unsign-rep {
+ { float-vector-rep [ ^(sum-vector) ] }
+ { int-vector-rep [| src rep |
+ src rep ^unpack-vector-head :> head
+ src rep ^unpack-vector-tail :> tail
+ rep widen-vector-rep :> wide-rep
+ head tail wide-rep ^^add-vector wide-rep ^(sum-vector)
+ ] }
+ } v-vector-op ;
-: emit-select-vector ( node -- )
- [ ^^select-vector ] [unary/param]
- { [ integer? ] [ representation? ] } if-literals-match ; inline
+: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
-: emit-alien-vector-op ( node quot: ( rep -- ) -- )
- { [ %alien-vector-reps member? ] } if-literals-match ; inline
+: ^shuffle-vector-imm ( src1 src2 rep -- dst )
+ {
+ [ ^^shuffle-vector-imm ]
+ [ [ ^load-immediate-shuffle ] [ ^^shuffle-vector ] bi ]
+ } vl-vector-op ;
-: emit-alien-vector ( node -- )
- dup [
- '[
- ds-drop prepare-alien-getter
- _ ^^alien-vector ds-push
- ]
- [ inline-alien-getter? ] inline-alien
- ] with emit-alien-vector-op ;
+: ^broadcast-vector ( src n rep -- dst )
+ [ rep-length swap <array> ] keep
+ ^shuffle-vector-imm ;
-: emit-set-alien-vector ( node -- )
- dup [
- '[
- ds-drop prepare-alien-setter ds-pop
- _ ##set-alien-vector
- ]
- [ byte-array inline-alien-setter? ]
- inline-alien
- ] with emit-alien-vector-op ;
+: ^with-vector ( src rep -- dst )
+ [ ^^scalar>vector ] keep [ 0 ] dip ^broadcast-vector ;
-: generate-not-vector ( src rep -- dst )
- dup %not-vector-reps member?
- [ ^^not-vector ]
- [ [ ^^fill-vector ] [ ^^xor-vector ] bi ] if ;
+: ^select-vector ( src n rep -- dst )
+ [ ^broadcast-vector ] keep ^^vector>scalar ;
-:: ((generate-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 ;
+! intrinsic emitters
-:: (generate-compare-vector) ( src1 src2 rep orig-cc -- dst )
- rep orig-cc %compare-vector-ccs :> ( ccs not? )
+: emit-simd-v+ ( node -- )
+ {
+ [ ^^add-vector ]
+ } emit-vv-vector-op ;
- ccs empty?
- [ rep not? [ ^^fill-vector ] [ ^^zero-vector ] if ]
- [
- ccs unclip :> ( rest-ccs first-cc )
- src1 src2 rep first-cc ((generate-compare-vector)) :> first-dst
+: emit-simd-v- ( node -- )
+ {
+ [ ^^sub-vector ]
+ } emit-vv-vector-op ;
- rest-ccs first-dst
- [ [ src1 src2 rep ] dip ((generate-compare-vector)) rep ^^or-vector ]
- reduce
+: emit-simd-vneg ( node -- )
+ {
+ { float-vector-rep [ [ ^load-neg-zero-vector ] [ ^^sub-vector ] bi ] }
+ { int-vector-rep [ [ ^^zero-vector ] [ ^^sub-vector ] bi ] }
+ } emit-v-vector-op ;
- not? [ rep generate-not-vector ] when
- ] if ;
+: emit-simd-v+- ( node -- )
+ {
+ [ ^^add-sub-vector ]
+ { float-vector-rep [| src1 src2 rep |
+ rep ^load-add-sub-vector :> signs
+ src2 signs rep ^^xor-vector :> src2'
+ src1 src2' rep ^^add-vector
+ ] }
+ { int-vector-rep [| src1 src2 rep |
+ rep ^load-add-sub-vector :> signs
+ src2 signs rep ^^xor-vector :> src2'
+ src2' signs rep ^^sub-vector :> src2''
+ src1 src2'' rep ^^add-vector
+ ] }
+ } emit-vv-vector-op ;
+
+: emit-simd-vs+ ( node -- )
+ {
+ { float-vector-rep [ ^^add-vector ] }
+ { int-vector-rep [ ^^saturated-add-vector ] }
+ } emit-vv-vector-op ;
-: sign-bit-mask ( rep -- byte-array )
- unsign-rep {
- { char-16-rep [ uchar-array{
- HEX: 80 HEX: 80 HEX: 80 HEX: 80
- HEX: 80 HEX: 80 HEX: 80 HEX: 80
- HEX: 80 HEX: 80 HEX: 80 HEX: 80
- HEX: 80 HEX: 80 HEX: 80 HEX: 80
- } underlying>> ] }
- { short-8-rep [ ushort-array{
- HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
- HEX: 8000 HEX: 8000 HEX: 8000 HEX: 8000
- } underlying>> ] }
- { int-4-rep [ uint-array{
- HEX: 8000,0000 HEX: 8000,0000
- HEX: 8000,0000 HEX: 8000,0000
- } underlying>> ] }
- { longlong-2-rep [ ulonglong-array{
- HEX: 8000,0000,0000,0000
- HEX: 8000,0000,0000,0000
- } underlying>> ] }
- } case ;
+: emit-simd-vs- ( node -- )
+ {
+ { float-vector-rep [ ^^sub-vector ] }
+ { int-vector-rep [ ^^saturated-sub-vector ] }
+ } emit-vv-vector-op ;
-:: (generate-minmax-compare-vector) ( src1 src2 rep orig-cc -- dst )
- orig-cc order-cc {
- { cc< [ src1 src2 rep ^^max-vector src1 rep cc/= (generate-compare-vector) ] }
- { cc<= [ src1 src2 rep ^^min-vector src1 rep cc= (generate-compare-vector) ] }
- { cc> [ src1 src2 rep ^^min-vector src1 rep cc/= (generate-compare-vector) ] }
- { cc>= [ src1 src2 rep ^^max-vector src1 rep cc= (generate-compare-vector) ] }
- } case ;
+: emit-simd-vs* ( node -- )
+ {
+ { float-vector-rep [ ^^mul-vector ] }
+ { int-vector-rep [ ^^saturated-mul-vector ] }
+ } emit-vv-vector-op ;
+
+: emit-simd-v* ( node -- )
+ {
+ [ ^^mul-vector ]
+ } emit-vv-vector-op ;
-:: generate-compare-vector ( src1 src2 rep orig-cc -- dst )
- {
- {
- [ rep orig-cc %compare-vector-reps member? ]
- [ src1 src2 rep orig-cc (generate-compare-vector) ]
- }
- {
- [ rep %min-vector-reps member? ]
- [ src1 src2 rep orig-cc (generate-minmax-compare-vector) ]
- }
- {
- [ rep unsign-rep orig-cc %compare-vector-reps member? ]
- [
- rep sign-bit-mask ^^load-constant :> sign-bits
- src1 sign-bits rep ^^xor-vector
- src2 sign-bits rep ^^xor-vector
- rep unsign-rep orig-cc (generate-compare-vector)
- ]
- }
- } cond ;
-
-:: generate-unpack-vector-head ( src rep -- dst )
- {
- {
- [ rep %unpack-vector-head-reps member? ]
- [ src rep ^^unpack-vector-head ]
- }
- {
- [ rep unsigned-int-vector-rep? ]
- [
- rep ^^zero-vector :> zero
- src zero rep ^^merge-vector-head
- ]
- }
- {
- [ rep widen-vector-rep %shr-vector-imm-reps member? ]
- [
- src src rep ^^merge-vector-head
- rep rep-component-type
- heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
- ]
- }
+: emit-simd-v/ ( node -- )
+ {
+ [ ^^div-vector ]
+ } emit-vv-vector-op ;
+
+: emit-simd-vmin ( node -- )
+ {
+ [ ^^min-vector ]
[
- rep ^^zero-vector :> zero
- zero src rep cc> ^^compare-vector :> sign
- src sign rep ^^merge-vector-head
- ]
- } cond ;
-
-:: generate-unpack-vector-tail ( src rep -- dst )
- {
- {
- [ rep %unpack-vector-tail-reps member? ]
- [ src rep ^^unpack-vector-tail ]
- }
- {
- [ rep %unpack-vector-head-reps member? ]
- [
- src rep ^^tail>head-vector :> tail
- tail rep ^^unpack-vector-head
- ]
- }
- {
- [ rep unsigned-int-vector-rep? ]
- [
- rep ^^zero-vector :> zero
- src zero rep ^^merge-vector-tail
- ]
- }
- {
- [ rep widen-vector-rep %shr-vector-imm-reps member? ]
- [
- src src rep ^^merge-vector-tail
- rep rep-component-type
- heap-size 8 * rep widen-vector-rep ^^shr-vector-imm
- ]
- }
+ [ cc< ^compare-vector ]
+ [ ^blend-vector ] 3bi
+ ]
+ } emit-vv-vector-op ;
+
+: emit-simd-vmax ( node -- )
+ {
+ [ ^^max-vector ]
[
- rep ^^zero-vector :> zero
- zero src rep cc> ^^compare-vector :> sign
- src sign rep ^^merge-vector-tail
- ]
- } cond ;
+ [ cc> ^compare-vector ]
+ [ ^blend-vector ] 3bi
+ ]
+ } emit-vv-vector-op ;
-:: generate-load-neg-zero-vector ( rep -- dst )
- rep {
- { float-4-rep [ float-array{ -0.0 -0.0 -0.0 -0.0 } underlying>> ^^load-constant ] }
- { double-2-rep [ double-array{ -0.0 -0.0 } underlying>> ^^load-constant ] }
- [ drop rep ^^zero-vector ]
- } case ;
+: emit-simd-v. ( node -- )
+ {
+ [ ^^dot-vector ]
+ [ [ ^^mul-vector ] [ ^sum-vector ] bi ]
+ } emit-vv-vector-op ;
-:: generate-neg-vector ( src rep -- dst )
- rep generate-load-neg-zero-vector
- src rep ^^sub-vector ;
+: emit-simd-vsqrt ( node -- )
+ {
+ [ ^^sqrt-vector ]
+ } emit-v-vector-op ;
-:: generate-blend-vector ( mask true false rep -- dst )
- mask true rep ^^and-vector
- mask false rep ^^andn-vector
- rep ^^or-vector ;
+: emit-simd-sum ( node -- )
+ {
+ [ ^sum-vector ]
+ } emit-v-vector-op ;
-:: generate-abs-vector ( src rep -- dst )
- {
- {
- [ rep unsigned-int-vector-rep? ]
- [ src ]
- }
- {
- [ rep %abs-vector-reps member? ]
- [ src rep ^^abs-vector ]
- }
- {
- [ rep float-vector-rep? ]
- [
- rep generate-load-neg-zero-vector
- src rep ^^andn-vector
- ]
- }
- [
+: emit-simd-vabs ( node -- )
+ {
+ { unsigned-int-vector-rep [ drop ] }
+ [ ^^abs-vector ]
+ { float-vector-rep [ [ ^load-neg-zero-vector ] [ swapd ^^andn-vector ] bi ] }
+ { int-vector-rep [| src rep |
rep ^^zero-vector :> zero
zero src rep ^^sub-vector :> -src
- zero src rep cc> ^^compare-vector :> sign
- sign -src src rep generate-blend-vector
- ]
- } cond ;
+ zero src rep cc> ^compare-vector :> sign
+ sign -src src rep ^blend-vector
+ ] }
+ } emit-v-vector-op ;
-: generate-min-vector ( src1 src2 rep -- dst )
- dup %min-vector-reps member?
- [ ^^min-vector ] [
- [ cc< generate-compare-vector ]
- [ generate-blend-vector ] 3bi
- ] if ;
+: emit-simd-vand ( node -- )
+ {
+ [ ^^and-vector ]
+ } emit-vv-vector-op ;
-: generate-max-vector ( src1 src2 rep -- dst )
- dup %max-vector-reps member?
- [ ^^max-vector ] [
- [ cc> generate-compare-vector ]
- [ generate-blend-vector ] 3bi
- ] if ;
+: emit-simd-vandn ( node -- )
+ {
+ [ ^^andn-vector ]
+ } emit-vv-vector-op ;
+
+: emit-simd-vor ( node -- )
+ {
+ [ ^^or-vector ]
+ } emit-vv-vector-op ;
+
+: emit-simd-vxor ( node -- )
+ {
+ [ ^^xor-vector ]
+ } emit-vv-vector-op ;
+
+: emit-simd-vnot ( node -- )
+ {
+ [ ^not-vector ]
+ } emit-v-vector-op ;
+
+: emit-simd-vlshift ( node -- )
+ {
+ [ ^^shl-vector ]
+ } {
+ [ ^^shl-vector-imm ]
+ } [ integer? ] emit-vv-or-vl-vector-op ;
+
+: emit-simd-vrshift ( node -- )
+ {
+ [ ^^shr-vector ]
+ } {
+ [ ^^shr-vector-imm ]
+ } [ integer? ] emit-vv-or-vl-vector-op ;
+
+: emit-simd-hlshift ( node -- )
+ {
+ [ ^^horizontal-shl-vector-imm ]
+ } [ integer? ] emit-vl-vector-op ;
+
+: emit-simd-hrshift ( node -- )
+ {
+ [ ^^horizontal-shr-vector-imm ]
+ } [ integer? ] emit-vl-vector-op ;
+
+: emit-simd-vshuffle-elements ( node -- )
+ {
+ [ ^shuffle-vector-imm ]
+ } [ shuffle? ] emit-vl-vector-op ;
+
+: emit-simd-vshuffle-bytes ( node -- )
+ {
+ [ ^^shuffle-vector ]
+ } emit-vv-vector-op ;
+
+: emit-simd-vmerge-head ( node -- )
+ {
+ [ ^^merge-vector-head ]
+ } emit-vv-vector-op ;
+
+: emit-simd-vmerge-tail ( node -- )
+ {
+ [ ^^merge-vector-tail ]
+ } emit-vv-vector-op ;
+
+: emit-simd-v<= ( node -- )
+ {
+ [ cc<= ^compare-vector ]
+ } emit-vv-vector-op ;
+: emit-simd-v< ( node -- )
+ {
+ [ cc< ^compare-vector ]
+ } emit-vv-vector-op ;
+: emit-simd-v= ( node -- )
+ {
+ [ cc= ^compare-vector ]
+ } emit-vv-vector-op ;
+: emit-simd-v> ( node -- )
+ {
+ [ cc> ^compare-vector ]
+ } emit-vv-vector-op ;
+: emit-simd-v>= ( node -- )
+ {
+ [ cc>= ^compare-vector ]
+ } emit-vv-vector-op ;
+: emit-simd-vunordered? ( node -- )
+ {
+ [ cc/<>= ^compare-vector ]
+ } emit-vv-vector-op ;
+
+: emit-simd-vany? ( node -- )
+ {
+ [ vcc-any ^^test-vector ]
+ } emit-vv-vector-op ;
+: emit-simd-vall? ( node -- )
+ {
+ [ vcc-all ^^test-vector ]
+ } emit-vv-vector-op ;
+: emit-simd-vnone? ( node -- )
+ {
+ [ vcc-none ^^test-vector ]
+ } emit-vv-vector-op ;
+
+: emit-simd-v>float ( node -- )
+ {
+ { float-vector-rep [ drop ] }
+ { int-vector-rep [ ^^integer>float-vector ] }
+ } emit-v-vector-op ;
+
+: emit-simd-v>integer ( node -- )
+ {
+ { float-vector-rep [ ^^float>integer-vector ] }
+ { int-vector-rep [ dup ] }
+ } emit-v-vector-op ;
+
+: emit-simd-vpack-signed ( node -- )
+ {
+ [ ^^signed-pack-vector ]
+ } emit-vv-vector-op ;
+
+: emit-simd-vpack-unsigned ( node -- )
+ {
+ [ ^^unsigned-pack-vector ]
+ } emit-vv-vector-op ;
+
+: emit-simd-vunpack-head ( node -- )
+ {
+ [ ^unpack-vector-head ]
+ } emit-v-vector-op ;
+
+: emit-simd-vunpack-tail ( node -- )
+ {
+ [ ^unpack-vector-tail ]
+ } emit-v-vector-op ;
+
+: emit-simd-with ( node -- )
+ {
+ [ ^with-vector ]
+ } emit-v-vector-op ;
+: emit-simd-gather-2 ( node -- )
+ {
+ [ ^^gather-vector-2 ]
+ } emit-vv-vector-op ;
+
+: emit-simd-gather-4 ( node -- )
+ {
+ [ ^^gather-vector-4 ]
+ } emit-vvvv-vector-op ;
+
+: emit-simd-select ( node -- )
+ {
+ [ ^select-vector ]
+ } [ integer? ] emit-vl-vector-op ;
+
+: emit-alien-vector ( node -- )
+ 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 -- )
+ 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 ( -- )
+! {
+! { (simd-v+) [ emit-simd-v+ ] }
+! { (simd-v-) [ emit-simd-v- ] }
+! { (simd-vneg) [ emit-simd-vneg ] }
+! { (simd-v+-) [ emit-simd-v+- ] }
+! { (simd-vs+) [ emit-simd-vs+ ] }
+! { (simd-vs-) [ emit-simd-vs- ] }
+! { (simd-vs*) [ emit-simd-vs* ] }
+! { (simd-v*) [ emit-simd-v* ] }
+! { (simd-v/) [ emit-simd-v/ ] }
+! { (simd-vmin) [ emit-simd-vmin ] }
+! { (simd-vmax) [ emit-simd-vmax ] }
+! { (simd-v.) [ emit-simd-v. ] }
+! { (simd-vsqrt) [ emit-simd-vsqrt ] }
+! { (simd-sum) [ emit-simd-sum ] }
+! { (simd-vabs) [ emit-simd-vabs ] }
+! { (simd-vbitand) [ emit-simd-vand ] }
+! { (simd-vbitandn) [ emit-simd-vandn ] }
+! { (simd-vbitor) [ emit-simd-vor ] }
+! { (simd-vbitxor) [ emit-simd-vxor ] }
+! { (simd-vbitnot) [ emit-simd-vnot ] }
+! { (simd-vand) [ emit-simd-vand ] }
+! { (simd-vandn) [ emit-simd-vandn ] }
+! { (simd-vor) [ emit-simd-vor ] }
+! { (simd-vxor) [ emit-simd-vxor ] }
+! { (simd-vnot) [ emit-simd-vnot ] }
+! { (simd-vlshift) [ emit-simd-vlshift ] }
+! { (simd-vrshift) [ emit-simd-vrshift ] }
+! { (simd-hlshift) [ emit-simd-hlshift ] }
+! { (simd-hrshift) [ emit-simd-hrshift ] }
+! { (simd-vshuffle-elements) [ emit-simd-vshuffle-elements ] }
+! { (simd-vshuffle-bytes) [ emit-simd-vshuffle-bytes ] }
+! { (simd-vmerge-head) [ emit-simd-vmerge-head ] }
+! { (simd-vmerge-tail) [ emit-simd-vmerge-tail ] }
+! { (simd-v<=) [ emit-simd-v<= ] }
+! { (simd-v<) [ emit-simd-v< ] }
+! { (simd-v=) [ emit-simd-v= ] }
+! { (simd-v>) [ emit-simd-v> ] }
+! { (simd-v>=) [ emit-simd-v>= ] }
+! { (simd-vunordered?) [ emit-simd-vunordered? ] }
+! { (simd-vany?) [ emit-simd-vany? ] }
+! { (simd-vall?) [ emit-simd-vall? ] }
+! { (simd-vnone?) [ emit-simd-vnone? ] }
+! { (simd-v>float) [ emit-simd-v>float ] }
+! { (simd-v>integer) [ emit-simd-v>integer ] }
+! { (simd-vpack-signed) [ emit-simd-vpack-signed ] }
+! { (simd-vpack-unsigned) [ emit-simd-vpack-unsigned ] }
+! { (simd-vunpack-head) [ emit-simd-vunpack-head ] }
+! { (simd-vunpack-tail) [ emit-simd-vunpack-tail ] }
+! { (simd-with) [ emit-simd-with ] }
+! { (simd-gather-2) [ emit-simd-gather-2 ] }
+! { (simd-gather-4) [ emit-simd-gather-4 ] }
+! { (simd-select) [ emit-simd-select ] }
+! { alien-vector [ emit-alien-vector ] }
+! { set-alien-vector [ emit-set-alien-vector ] }
+! } enable-intrinsics ;
+!
+! enable-simd
! See http://factorcode.org/license.txt for BSD license.
USING: accessors combinators combinators.short-circuit arrays
fry kernel layouts math namespaces sequences cpu.architecture
-math.bitwise math.order math.vectors.simd.intrinsics classes
+math.bitwise math.order classes
vectors locals make alien.c-types io.binary grouping
compiler.cfg
compiler.cfg.registers
M: ##alien-signed-4 rewrite rewrite-alien-addressing ;
M: ##alien-float rewrite rewrite-alien-addressing ;
M: ##alien-double rewrite rewrite-alien-addressing ;
-M: ##alien-vector rewrite rewrite-alien-addressing ;
M: ##set-alien-integer-1 rewrite rewrite-alien-addressing ;
M: ##set-alien-integer-2 rewrite rewrite-alien-addressing ;
M: ##set-alien-integer-4 rewrite rewrite-alien-addressing ;
M: ##set-alien-float rewrite rewrite-alien-addressing ;
M: ##set-alien-double rewrite rewrite-alien-addressing ;
-M: ##set-alien-vector rewrite rewrite-alien-addressing ;
-! Some lame constant folding for SIMD intrinsics. Eventually this
-! should be redone completely.
-
-: rewrite-shuffle-vector-imm ( insn expr -- insn' )
- 2dup [ rep>> ] bi@ eq? [
- [ [ dst>> ] [ src>> vn>vreg ] bi* ]
- [ [ shuffle>> ] bi@ nths ]
- [ drop rep>> ]
- 2tri \ ##shuffle-vector-imm new-insn
- ] [ 2drop f ] if ;
-
-: (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' )
- 2dup length swap length /i group nths concat ;
-
-: fold-shuffle-vector-imm ( insn expr -- insn' )
- [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
- (fold-shuffle-vector-imm) \ ##load-constant new-insn ;
-
-M: ##shuffle-vector-imm rewrite
- dup src>> vreg>expr {
- { [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] }
- { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
- { [ dup constant-expr? ] [ fold-shuffle-vector-imm ] }
- [ 2drop f ]
- } cond ;
-
-: (fold-scalar>vector) ( insn bytes -- insn' )
- [ [ dst>> ] [ rep>> rep-components ] bi ] dip <repetition> concat
- \ ##load-constant new-insn ;
-
-: fold-scalar>vector ( insn expr -- insn' )
- value>> over rep>> {
- { float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
- { double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
- [ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ]
- } case ;
-
-M: ##scalar>vector rewrite
- dup src>> vreg>expr dup constant-expr?
- [ fold-scalar>vector ] [ 2drop f ] if ;
-
-M: ##xor-vector rewrite
- dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
- [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
-
-: vector-not? ( expr -- ? )
- {
- [ not-vector-expr? ]
- [ {
- [ xor-vector-expr? ]
- [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
- } 1&& ]
- } 1|| ;
-
-GENERIC: vector-not-src ( expr -- vreg )
-M: not-vector-expr vector-not-src src>> vn>vreg ;
-M: xor-vector-expr vector-not-src
- dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
-
-M: ##and-vector rewrite
- {
- { [ dup src1>> vreg>expr vector-not? ] [
- {
- [ dst>> ]
- [ src1>> vreg>expr vector-not-src ]
- [ src2>> ]
- [ rep>> ]
- } cleave \ ##andn-vector new-insn
- ] }
- { [ dup src2>> vreg>expr vector-not? ] [
- {
- [ dst>> ]
- [ src2>> vreg>expr vector-not-src ]
- [ src1>> ]
- [ rep>> ]
- } cleave \ ##andn-vector new-insn
- ] }
- [ drop f ]
- } cond ;
-
-M: ##andn-vector rewrite
- dup src1>> vreg>expr vector-not? [
- {
- [ dst>> ]
- [ src1>> vreg>expr vector-not-src ]
- [ src2>> ]
- [ rep>> ]
- } cleave \ ##and-vector new-insn
- ] [ drop f ] if ;
--- /dev/null
+! Copyright (C) 2008, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.short-circuit arrays
+fry kernel layouts math namespaces sequences cpu.architecture
+math.bitwise math.order classes
+vectors locals make alien.c-types io.binary grouping
+math.vectors.simd
+compiler.cfg
+compiler.cfg.registers
+compiler.cfg.comparisons
+compiler.cfg.instructions
+compiler.cfg.value-numbering.expressions
+compiler.cfg.value-numbering.graph
+compiler.cfg.value-numbering.rewrite
+compiler.cfg.value-numbering.simplify ;
+IN: compiler.cfg.value-numbering.simd
+
+M: ##alien-vector rewrite rewrite-alien-addressing ;
+M: ##set-alien-vector rewrite rewrite-alien-addressing ;
+
+! Some lame constant folding for SIMD intrinsics. Eventually this
+! should be redone completely.
+
+: rewrite-shuffle-vector-imm ( insn expr -- insn' )
+ 2dup [ rep>> ] bi@ eq? [
+ [ [ dst>> ] [ src>> vn>vreg ] bi* ]
+ [ [ shuffle>> ] bi@ nths ]
+ [ drop rep>> ]
+ 2tri \ ##shuffle-vector-imm new-insn
+ ] [ 2drop f ] if ;
+
+: (fold-shuffle-vector-imm) ( shuffle bytes -- bytes' )
+ 2dup length swap length /i group nths concat ;
+
+: fold-shuffle-vector-imm ( insn expr -- insn' )
+ [ [ dst>> ] [ shuffle>> ] bi ] dip value>>
+ (fold-shuffle-vector-imm) \ ##load-constant new-insn ;
+
+M: ##shuffle-vector-imm rewrite
+ dup src>> vreg>expr {
+ { [ dup shuffle-vector-imm-expr? ] [ rewrite-shuffle-vector-imm ] }
+ { [ dup reference-expr? ] [ fold-shuffle-vector-imm ] }
+ { [ dup constant-expr? ] [ fold-shuffle-vector-imm ] }
+ [ 2drop f ]
+ } cond ;
+
+: (fold-scalar>vector) ( insn bytes -- insn' )
+ [ [ dst>> ] [ rep>> rep-length ] bi ] dip <repetition> concat
+ \ ##load-constant new-insn ;
+
+: fold-scalar>vector ( insn expr -- insn' )
+ value>> over rep>> {
+ { float-4-rep [ float>bits 4 >le (fold-scalar>vector) ] }
+ { double-2-rep [ double>bits 8 >le (fold-scalar>vector) ] }
+ [ [ untag-fixnum ] dip rep-component-type heap-size >le (fold-scalar>vector) ]
+ } case ;
+
+M: ##scalar>vector rewrite
+ dup src>> vreg>expr dup constant-expr?
+ [ fold-scalar>vector ] [ 2drop f ] if ;
+
+M: ##xor-vector rewrite
+ dup [ src1>> vreg>vn ] [ src2>> vreg>vn ] bi eq?
+ [ [ dst>> ] [ rep>> ] bi \ ##zero-vector new-insn ] [ drop f ] if ;
+
+: vector-not? ( expr -- ? )
+ {
+ [ not-vector-expr? ]
+ [ {
+ [ xor-vector-expr? ]
+ [ [ src1>> ] [ src2>> ] bi [ vn>expr fill-vector-expr? ] either? ]
+ } 1&& ]
+ } 1|| ;
+
+GENERIC: vector-not-src ( expr -- vreg )
+M: not-vector-expr vector-not-src src>> vn>vreg ;
+M: xor-vector-expr vector-not-src
+ dup src1>> vn>expr fill-vector-expr? [ src2>> ] [ src1>> ] if vn>vreg ;
+
+M: ##and-vector rewrite
+ {
+ { [ dup src1>> vreg>expr vector-not? ] [
+ {
+ [ dst>> ]
+ [ src1>> vreg>expr vector-not-src ]
+ [ src2>> ]
+ [ rep>> ]
+ } cleave \ ##andn-vector new-insn
+ ] }
+ { [ dup src2>> vreg>expr vector-not? ] [
+ {
+ [ dst>> ]
+ [ src2>> vreg>expr vector-not-src ]
+ [ src1>> ]
+ [ rep>> ]
+ } cleave \ ##andn-vector new-insn
+ ] }
+ [ drop f ]
+ } cond ;
+
+M: ##andn-vector rewrite
+ dup src1>> vreg>expr vector-not? [
+ {
+ [ dst>> ]
+ [ src1>> vreg>expr vector-not-src ]
+ [ src2>> ]
+ [ rep>> ]
+ } cleave \ ##and-vector new-insn
+ ] [ drop f ] if ;
+
+M: scalar>vector-expr simplify*
+ src>> vn>expr {
+ { [ dup vector>scalar-expr? ] [ src>> ] }
+ [ drop f ]
+ } cond ;
+
+M: shuffle-vector-imm-expr simplify*
+ [ src>> ] [ shuffle>> ] [ rep>> rep-length iota ] tri
+ sequence= [ drop f ] unless ;
+
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors combinators classes math layouts
-sequences math.vectors.simd.intrinsics
+sequences
compiler.cfg.instructions
compiler.cfg.value-numbering.graph
compiler.cfg.value-numbering.expressions ;
[ 2drop f ]
} cond ;
-M: scalar>vector-expr simplify*
- src>> vn>expr {
- { [ dup vector>scalar-expr? ] [ src>> ] }
- [ drop f ]
- } cond ;
-
-M: shuffle-vector-imm-expr simplify*
- [ src>> ] [ shuffle>> ] [ rep>> rep-components iota ] tri
- sequence= [ drop f ] unless ;
-
M: expr simplify* drop f ;
: simplify ( expr -- vn )
accessors sequences compiler.cfg.predecessors locals compiler.cfg.dce
compiler.cfg.ssa.destruction compiler.cfg.loop-detection
compiler.cfg.representations compiler.cfg assocs vectors arrays
-layouts literals namespaces alien ;
+layouts literals namespaces alien compiler.cfg.value-numbering.simd ;
IN: compiler.cfg.value-numbering.tests
: trim-temps ( insns -- insns )
compiler.tree.propagation.simple
compiler.tree.propagation.constraints
compiler.tree.propagation.call-effect
-compiler.tree.propagation.transforms
-compiler.tree.propagation.simd ;
+compiler.tree.propagation.transforms ;
FROM: alien.c-types => (signed-interval) (unsigned-interval) ;
IN: compiler.tree.propagation.known-words
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays combinators fry sequences
compiler.tree.propagation.info cpu.architecture kernel words math
-math.intervals math.vectors.simd.intrinsics ;
+math.intervals math.vectors.simd math.vectors.simd.private ;
IN: compiler.tree.propagation.simd
{
(simd-hrshift)
(simd-vshuffle-bytes)
(simd-vshuffle-elements)
- (simd-(vmerge-head))
- (simd-(vmerge-tail))
- (simd-(v>float))
- (simd-(v>integer))
- (simd-(vpack-signed))
- (simd-(vpack-unsigned))
- (simd-(vunpack-head))
- (simd-(vunpack-tail))
+ (simd-vmerge-head)
+ (simd-vmerge-tail)
+ (simd-v>float)
+ (simd-v>integer)
+ (simd-vpack-signed)
+ (simd-vpack-unsigned)
+ (simd-vunpack-head)
+ (simd-vunpack-tail)
(simd-v<=)
(simd-v<)
(simd-v=)
HOOK: %max-vector cpu ( dst src1 src2 rep -- )
HOOK: %dot-vector cpu ( dst src1 src2 rep -- )
HOOK: %sqrt-vector cpu ( dst src rep -- )
-HOOK: %horizontal-add-vector cpu ( dst src rep -- )
-HOOK: %horizontal-sub-vector cpu ( dst src rep -- )
+HOOK: %horizontal-add-vector cpu ( dst src1 src2 rep -- )
+HOOK: %horizontal-sub-vector cpu ( dst src1 src2 rep -- )
HOOK: %abs-vector cpu ( dst src rep -- )
HOOK: %and-vector cpu ( dst src1 src2 rep -- )
HOOK: %andn-vector cpu ( dst src1 src2 rep -- )
M: x86 %dot-vector
[ two-operand ] keep
{
- { float-4-rep [
- sse4.1?
- [ HEX: ff DPPS ]
- [ [ MULPS ] [ drop dup float-4-rep %horizontal-add-vector ] 2bi ]
- if
- ] }
- { double-2-rep [
- sse4.1?
- [ HEX: ff DPPD ]
- [ [ MULPD ] [ drop dup double-2-rep %horizontal-add-vector ] 2bi ]
- if
- ] }
+ { float-4-rep [ HEX: ff DPPS ] }
+ { double-2-rep [ HEX: ff DPPD ] }
} case ;
M: x86 %dot-vector-reps
{
- { sse3? { float-4-rep double-2-rep } }
+ { sse4.1? { float-4-rep double-2-rep } }
} available-reps ;
-M: x86 %horizontal-add-vector ( dst src rep -- )
- {
- { float-4-rep [ [ float-4-rep %copy ] [ HADDPS ] [ HADDPS ] 2tri ] }
- { double-2-rep [ [ double-2-rep %copy ] [ HADDPD ] 2bi ] }
+M: x86 %horizontal-add-vector ( dst src1 src2 rep -- )
+ [ two-operand ] keep
+ unsign-rep {
+ { float-4-rep [ HADDPS ] }
+ { double-2-rep [ HADDPD ] }
+ { int-4-rep [ PHADDD ] }
+ { short-8-rep [ PHADDW ] }
} case ;
M: x86 %horizontal-add-vector-reps
{
{ sse3? { float-4-rep double-2-rep } }
+ { ssse3? { int-4-rep uint-4-rep short-8-rep ushort-8-rep } }
} available-reps ;
M: x86 %horizontal-shl-vector-imm ( dst src1 src2 rep -- )
M: x86 %horizontal-shl-vector-imm-reps
{
- { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } }
} available-reps ;
M: x86 %horizontal-shr-vector-imm ( dst src1 src2 rep -- )
M: x86 %horizontal-shr-vector-imm-reps
{
- { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+ { sse2? { char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep float-4-rep double-2-rep } }
} available-reps ;
M: x86 %abs-vector ( dst src rep -- )
#! set up by the caller.
stack-frame get total-size>> + stack@ ;
-enable-simd
enable-min/max
enable-fixnum-log2
SYMBOLS: a b c d e f g h ;
+[ [ ] ] [ '[ ] ] unit-test
+[ [ + ] ] [ '[ + ] ] unit-test
[ [ 1 ] ] [ 1 '[ _ ] ] unit-test
[ [ 1 ] ] [ [ 1 ] '[ @ ] ] unit-test
[ [ 1 2 ] ] [ [ 1 ] [ 2 ] '[ @ @ ] ] unit-test
PRIVATE>
M: callable fry ( quot -- quot' )
- 0 swap <dredge-fry>
- [ dredge-fry ] [
- [ prequot>> >quotation ]
- [ quot>> >quotation shallow-fry ] bi append
- ] bi ;
+ [ [ [ ] ] ] [
+ 0 swap <dredge-fry>
+ [ dredge-fry ] [
+ [ prequot>> >quotation ]
+ [ quot>> >quotation shallow-fry ] bi append
+ ] bi
+ ] if-empty ;
SYNTAX: '[ parse-quotation fry append! ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs byte-arrays classes classes.algebra effects fry
-functors generalizations kernel literals locals math math.functions
-math.vectors math.vectors.private math.vectors.simd.intrinsics
-math.vectors.conversion.backend
-math.vectors.specialization parser prettyprint.custom sequences
-sequences.private strings words definitions macros cpu.architecture
-namespaces arrays quotations combinators combinators.short-circuit sets
-layouts ;
-QUALIFIED-WITH: alien.c-types c
-QUALIFIED: math.private
-IN: math.vectors.simd.functor
-
-ERROR: bad-length got expected ;
-
-: vector-true-value ( class -- value )
- {
- { [ dup integer class<= ] [ drop -1 ] }
- { [ dup float class<= ] [ drop -1 bits>double ] }
- } cond ; foldable
-
-: vector-false-value ( class -- value )
- {
- { [ dup integer class<= ] [ drop 0 ] }
- { [ dup float class<= ] [ drop 0.0 ] }
- } cond ; foldable
-
-: boolean>element ( bool/elt class -- elt )
- swap {
- { t [ vector-true-value ] }
- { f [ vector-false-value ] }
- [ nip ]
- } case ; inline
-
-MACRO: simd-boa ( rep class -- simd-array )
- [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ;
-
-: can-be-unboxed? ( type -- ? )
- {
- { c:float [ \ math.private:float+ "intrinsic" word-prop ] }
- { c:double [ \ math.private:float+ "intrinsic" word-prop ] }
- [ c:heap-size cell < ]
- } case ;
-
-: simd-boa-fast? ( rep -- ? )
- [ dup rep-gather-word supported-simd-op? ]
- [ rep-component-type can-be-unboxed? ]
- bi and ;
-
-:: define-boa-custom-inlining ( word rep class -- )
- word [
- drop
- rep simd-boa-fast? [
- [ rep (simd-boa) class boa ]
- ] [ word def>> ] if
- ] "custom-inlining" set-word-prop ;
-
-: simd-with ( rep class x -- simd-array )
- [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline
-
-: simd-with/nth-fast? ( rep -- ? )
- [ \ (simd-vshuffle-elements) supported-simd-op? ]
- [ rep-component-type can-be-unboxed? ]
- bi and ;
-
-:: define-with-custom-inlining ( word rep class -- )
- word [
- drop
- rep simd-with/nth-fast? [
- [ rep rep-coerce rep (simd-with) class boa ]
- ] [ word def>> ] if
- ] "custom-inlining" set-word-prop ;
-
-: simd-nth-fast ( rep -- quot )
- [ rep-components ] keep
- '[ swap _ '[ _ _ (simd-select) ] 2array ] map-index
- '[ swap >fixnum _ case ] ;
-
-: simd-nth-slow ( rep -- quot )
- rep-component-type dup c:c-type-getter-boxer c:array-accessor ;
-
-MACRO: simd-nth ( rep -- x )
- dup simd-with/nth-fast? [ simd-nth-fast ] [ simd-nth-slow ] if ;
-
-: boa-effect ( rep n -- effect )
- [ rep-components ] dip *
- [ CHAR: a + 1string ] map
- { "simd-vector" } <effect> ;
-
-: supported-simd-ops ( assoc rep -- assoc' )
- [ simd-ops get ] dip
- '[ nip _ swap supported-simd-op? ] assoc-filter
- '[ drop _ key? ] assoc-filter ;
-
-ERROR: bad-schema op schema ;
-
-:: op-wrapper ( op specials schemas -- wrapper )
- op {
- [ specials at ]
- [ word-schema schemas at ]
- [ dup word-schema bad-schema ]
- } 1|| ;
-
-: low-level-ops ( simd-ops specials schemas -- alist )
- '[ 1quotation over _ _ op-wrapper [ ] 2sequence ] assoc-map ;
-
-:: high-level-ops ( ctor elt-class -- assoc )
- ! Some SIMD operations are defined in terms of others.
- {
- { vbroadcast [ swap nth ctor execute ] }
- { n+v [ [ ctor execute ] dip v+ ] }
- { v+n [ ctor execute v+ ] }
- { n-v [ [ ctor execute ] dip v- ] }
- { v-n [ ctor execute v- ] }
- { n*v [ [ ctor execute ] dip v* ] }
- { v*n [ ctor execute v* ] }
- { n/v [ [ ctor execute ] dip v/ ] }
- { v/n [ ctor execute v/ ] }
- { norm-sq [ dup v. assert-positive ] }
- { norm [ norm-sq sqrt ] }
- { normalize [ dup norm v/n ] }
- }
- ! To compute dot product and distance with integer vectors, we
- ! have to do things less efficiently, with integer overflow checks,
- ! in the general case.
- elt-class float = [ { distance [ v- norm ] } suffix ] when ;
-
-TUPLE: simd class elt-class ops special-wrappers schema-wrappers ctor rep ;
-
-: define-simd ( simd -- )
- dup rep>> rep-component-type c:c-type-boxed-class >>elt-class
- {
- [ class>> ]
- [ elt-class>> ]
- [ [ ops>> ] [ special-wrappers>> ] [ schema-wrappers>> ] tri low-level-ops ]
- [ rep>> supported-simd-ops ]
- [ [ ctor>> ] [ elt-class>> ] bi high-level-ops assoc-union ]
- } cleave
- specialize-vector-words ;
-
-:: define-simd-128-type ( class rep -- )
- c:<c-type>
- byte-array >>class
- class >>boxed-class
- [ rep alien-vector class boa ] >>getter
- [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter
- 16 >>size
- 16 >>align
- 16 >>align-first
- rep >>rep
- class c:typedef ;
-
-: (define-simd-128) ( simd -- )
- simd-ops get >>ops
- [ define-simd ]
- [ [ class>> ] [ rep>> ] bi define-simd-128-type ] bi ;
-
-FUNCTOR: define-simd-128 ( T -- )
-
-N [ 16 T c:heap-size /i ]
-
-A DEFINES-CLASS ${T}-${N}
-A-boa DEFINES ${A}-boa
-A-with DEFINES ${A}-with
-A-cast DEFINES ${A}-cast
->A DEFINES >${A}
-A{ DEFINES ${A}{
-
-SET-NTH [ T dup c:c-setter c:array-accessor ]
-
-A-rep [ A name>> "-rep" append "cpu.architecture" lookup ]
-A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
-A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op
-A-vv->n-op DEFINES-PRIVATE ${A}-vv->n-op
-A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
-A-v->n-op DEFINES-PRIVATE ${A}-v->n-op
-A-v-conversion-op DEFINES-PRIVATE ${A}-v-conversion-op
-A-vv-conversion-op DEFINES-PRIVATE ${A}-vv-conversion-op
-
-A-element-class [ A-rep rep-component-type c:c-type-boxed-class ]
-
-WHERE
-
-TUPLE: A
-{ underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
-
-INSTANCE: A simd-128
-
-M: A clone underlying>> clone \ A boa ; inline
-
-M: A length drop N ; inline
-
-M: A equal?
- over \ A instance? [ v= vall? ] [ 2drop f ] if ;
-
-M: A nth-unsafe underlying>> A-rep simd-nth ; inline
-
-M: A set-nth-unsafe
- [ A-element-class boolean>element ] 2dip
- underlying>> SET-NTH call ; inline
-
-: >A ( seq -- simd-array ) \ A new clone-like ;
-
-M: A like drop dup \ A instance? [ >A ] unless ; inline
-
-M: A new-underlying drop \ A boa ; inline
-
-M: A new-sequence
- drop dup N =
- [ drop 16 <byte-array> \ A boa ]
- [ N bad-length ]
- if ; inline
-
-M: A c:byte-length underlying>> length ; inline
-
-M: A element-type drop A-rep rep-component-type ;
-
-M: A pprint-delims drop \ A{ \ } ;
-
-M: A >pprint-sequence ;
-
-M: A pprint* pprint-object ;
-
-SYNTAX: A{ \ } [ >A ] parse-literal ;
-
-: A-with ( x -- simd-array ) [ A-rep A ] dip simd-with ;
-
-\ A-with \ A-rep \ A define-with-custom-inlining
-
-\ A-boa [ \ A-rep \ A simd-boa ] \ A-rep 1 boa-effect define-declared
-
-\ A-rep rep-gather-word [
- \ A-boa \ A-rep \ A define-boa-custom-inlining
-] when
-
-: A-cast ( simd-array -- simd-array' )
- underlying>> \ A boa ; inline
-
-INSTANCE: A sequence
-
-<PRIVATE
-
-: A-vv->v-op ( v1 v2 quot -- v3 )
- [ [ underlying>> ] bi@ A-rep ] dip call \ A boa ; inline
-
-: A-vn->v-op ( v1 v2 quot -- v3 )
- [ [ underlying>> ] dip A-rep ] dip call \ A boa ; inline
-
-: A-vv->n-op ( v1 v2 quot -- n )
- [ [ underlying>> ] bi@ A-rep ] dip call ; inline
-
-: A-v->v-op ( v1 quot -- v2 )
- [ underlying>> A-rep ] dip call \ A boa ; inline
-
-: A-v->n-op ( v quot -- n )
- [ underlying>> A-rep ] dip call ; inline
-
-: A-v-conversion-op ( v1 to-type quot -- v2 )
- swap [ underlying>> A-rep ] [ call ] [ '[ _ boa ] call( u -- v ) ] tri* ; inline
-
-: A-vv-conversion-op ( v1 v2 to-type quot -- v2 )
- swap {
- [ underlying>> ]
- [ underlying>> A-rep ]
- [ call ]
- [ '[ _ boa ] call( u -- v ) ]
- } spread ; inline
-
-simd new
- \ A >>class
- \ A-with >>ctor
- \ A-rep >>rep
- {
- { (v>float) A-v-conversion-op }
- { (v>integer) A-v-conversion-op }
- { (vpack-signed) A-vv-conversion-op }
- { (vpack-unsigned) A-vv-conversion-op }
- { (vunpack-head) A-v-conversion-op }
- { (vunpack-tail) A-v-conversion-op }
- } >>special-wrappers
- {
- { { +vector+ +vector+ -> +vector+ } A-vv->v-op }
- { { +vector+ +any-vector+ -> +vector+ } A-vv->v-op }
- { { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
- { { +vector+ +literal+ -> +vector+ } A-vn->v-op }
- { { +vector+ +vector+ -> +scalar+ } A-vv->n-op }
- { { +vector+ +vector+ -> +boolean+ } A-vv->n-op }
- { { +vector+ -> +vector+ } A-v->v-op }
- { { +vector+ -> +scalar+ } A-v->n-op }
- { { +vector+ -> +boolean+ } A-v->n-op }
- { { +vector+ -> +nonnegative+ } A-v->n-op }
- } >>schema-wrappers
-(define-simd-128)
-
-PRIVATE>
-
-;FUNCTOR
-
-! Synthesize 256-bit vectors from a pair of 128-bit vectors
-SLOT: underlying1
-SLOT: underlying2
-
-:: define-simd-256-type ( class rep -- )
- c:<c-type>
- class >>class
- class >>boxed-class
- [
- [ rep alien-vector ]
- [ 16 + >fixnum rep alien-vector ] 2bi
- class boa
- ] >>getter
- [
- [ [ underlying1>> ] 2dip rep set-alien-vector ]
- [ [ underlying2>> ] 2dip 16 + >fixnum rep set-alien-vector ]
- 3bi
- ] >>setter
- 32 >>size
- 16 >>align
- 16 >>align-first
- rep >>rep
- class c:typedef ;
-
-: (define-simd-256) ( simd -- )
- simd-ops get { vshuffle-elements vshuffle-bytes hlshift hrshift } unique assoc-diff >>ops
- [ define-simd ]
- [ [ class>> ] [ rep>> ] bi define-simd-256-type ] bi ;
-
-FUNCTOR: define-simd-256 ( T -- )
-
-N [ 32 T c:heap-size /i ]
-
-N/2 [ N 2 /i ]
-A/2 IS ${T}-${N/2}
-A/2-boa IS ${A/2}-boa
-A/2-with IS ${A/2}-with
-
-A DEFINES-CLASS ${T}-${N}
-A-boa DEFINES ${A}-boa
-A-with DEFINES ${A}-with
-A-cast DEFINES ${A}-cast
->A DEFINES >${A}
-A{ DEFINES ${A}{
-
-A-deref DEFINES-PRIVATE ${A}-deref
-
-A-rep [ A/2 name>> "-rep" append "cpu.architecture" lookup ]
-A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
-A-vn->v-op DEFINES-PRIVATE ${A}-vn->v-op
-A-v->v-op DEFINES-PRIVATE ${A}-v->v-op
-A-v.-op DEFINES-PRIVATE ${A}-v.-op
-(A-v->n-op) DEFINES-PRIVATE (${A}-v->v-op)
-A-sum-op DEFINES-PRIVATE ${A}-sum-op
-A-vany-op DEFINES-PRIVATE ${A}-vany-op
-A-vall-op DEFINES-PRIVATE ${A}-vall-op
-A-vmerge-head-op DEFINES-PRIVATE ${A}-vmerge-head-op
-A-vmerge-tail-op DEFINES-PRIVATE ${A}-vmerge-tail-op
-A-v-conversion-op DEFINES-PRIVATE ${A}-v-conversion-op
-A-vpack-op DEFINES-PRIVATE ${A}-vpack-op
-A-vunpack-head-op DEFINES-PRIVATE ${A}-vunpack-head-op
-A-vunpack-tail-op DEFINES-PRIVATE ${A}-vunpack-tail-op
-
-WHERE
-
-SLOT: underlying1
-SLOT: underlying2
-
-TUPLE: A
-{ underlying1 byte-array initial: $[ 16 <byte-array> ] read-only }
-{ underlying2 byte-array initial: $[ 16 <byte-array> ] read-only } ;
-
-INSTANCE: A simd-256
-
-M: A clone
- [ underlying1>> clone ] [ underlying2>> clone ] bi
- \ A boa ; inline
-
-M: A length drop N ; inline
-
-M: A equal?
- over \ A instance? [ v= vall? ] [ 2drop f ] if ;
-
-: A-deref ( n seq -- n' seq' )
- over N/2 < [ underlying1>> ] [ [ N/2 - ] dip underlying2>> ] if \ A/2 boa ; inline
-
-M: A nth-unsafe A-deref nth-unsafe ; inline
-
-M: A set-nth-unsafe A-deref set-nth-unsafe ; inline
-
-: >A ( seq -- simd-array ) \ A new clone-like ;
-
-M: A like drop dup \ A instance? [ >A ] unless ; inline
-
-M: A new-sequence
- drop dup N =
- [ drop 16 <byte-array> 16 <byte-array> \ A boa ]
- [ N bad-length ]
- if ; inline
-
-M: A c:byte-length drop 32 ; inline
-
-M: A element-type drop A-rep rep-component-type ;
-
-SYNTAX: A{ \ } [ >A ] parse-literal ;
-
-M: A pprint-delims drop \ A{ \ } ;
-
-M: A >pprint-sequence ;
-
-M: A pprint* pprint-object ;
-
-: A-with ( x -- simd-array )
- [ A/2-with ] [ A/2-with ] bi [ underlying>> ] bi@
- \ A boa ; inline
-
-: A-boa ( ... -- simd-array )
- [ A/2-boa ] N/2 ndip A/2-boa [ underlying>> ] bi@
- \ A boa ; inline
-
-\ A-rep 2 boa-effect \ A-boa set-stack-effect
-
-: A-cast ( simd-array -- simd-array' )
- [ underlying1>> ] [ underlying2>> ] bi \ A boa ; inline
-
-INSTANCE: A sequence
-
-: A-vv->v-op ( v1 v2 quot -- v3 )
- [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
- [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
- \ A boa ; inline
-
-: A-vn->v-op ( v1 v2 quot -- v3 )
- [ [ [ underlying1>> ] dip A-rep ] dip call ]
- [ [ [ underlying2>> ] dip A-rep ] dip call ] 3bi
- \ A boa ; inline
-
-: A-v->v-op ( v1 combine-quot -- v2 )
- [ [ underlying1>> A-rep ] dip call ]
- [ [ underlying2>> A-rep ] dip call ] 2bi
- \ A boa ; inline
-
-: A-v.-op ( v1 v2 quot -- n )
- [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
- [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
- + ; inline
-
-: (A-v->n-op) ( v1 quot reduce-quot -- n )
- '[ [ underlying1>> ] [ underlying2>> ] bi A-rep @ A-rep ] dip call ; inline
-
-: A-sum-op ( v1 quot -- n )
- [ (simd-v+) ] (A-v->n-op) ; inline
-
-: A-vany-op ( v1 quot -- n )
- [ (simd-vbitor) ] (A-v->n-op) ; inline
-: A-vall-op ( v1 quot -- n )
- [ (simd-vbitand) ] (A-v->n-op) ; inline
-
-: A-vmerge-head-op ( v1 v2 quot -- v )
- drop
- [ underlying1>> ] bi@
- [ A-rep (simd-(vmerge-head)) ]
- [ A-rep (simd-(vmerge-tail)) ] 2bi
- \ A boa ; inline
-
-: A-vmerge-tail-op ( v1 v2 quot -- v )
- drop
- [ underlying2>> ] bi@
- [ A-rep (simd-(vmerge-head)) ]
- [ A-rep (simd-(vmerge-tail)) ] 2bi
- \ A boa ; inline
-
-: A-v-conversion-op ( v1 to-type quot -- v )
- swap [
- [ [ underlying1>> A-rep ] dip call ]
- [ [ underlying2>> A-rep ] dip call ] 2bi
- ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline
-
-: A-vpack-op ( v1 v2 to-type quot -- v )
- swap [
- '[ [ underlying1>> ] [ underlying2>> ] bi A-rep @ ] bi*
- ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline
-
-: A-vunpack-head-op ( v1 to-type quot -- v )
- '[
- underlying1>>
- [ A-rep @ ]
- [ A-rep (simd-(vunpack-tail)) ] bi
- ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline
-
-: A-vunpack-tail-op ( v1 to-type quot -- v )
- '[
- underlying2>>
- [ A-rep (simd-(vunpack-head)) ]
- [ A-rep @ ] bi
- ] dip '[ _ boa ] call( u1 u2 -- v ) ; inline
-
-simd new
- \ A >>class
- \ A-with >>ctor
- \ A-rep >>rep
- {
- { v. A-v.-op }
- { sum A-sum-op }
- { vnone? A-vany-op }
- { vany? A-vany-op }
- { vall? A-vall-op }
- { (vmerge-head) A-vmerge-head-op }
- { (vmerge-tail) A-vmerge-tail-op }
- { (v>integer) A-v-conversion-op }
- { (v>float) A-v-conversion-op }
- { (vpack-signed) A-vpack-op }
- { (vpack-unsigned) A-vpack-op }
- { (vunpack-head) A-vunpack-head-op }
- { (vunpack-tail) A-vunpack-tail-op }
- } >>special-wrappers
- {
- { { +vector+ +vector+ -> +vector+ } A-vv->v-op }
- { { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
- { { +vector+ +literal+ -> +vector+ } A-vn->v-op }
- { { +vector+ -> +vector+ } A-v->v-op }
- } >>schema-wrappers
-(define-simd-256)
-
-;FUNCTOR
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-IN: math.vectors.simd.intrinsics.tests
-USING: math.vectors.simd.intrinsics cpu.architecture tools.test ;
-
-[ 16 ] [ uchar-16-rep rep-components ] unit-test
-[ 16 ] [ char-16-rep rep-components ] unit-test
-[ 8 ] [ ushort-8-rep rep-components ] unit-test
-[ 8 ] [ short-8-rep rep-components ] unit-test
-[ 4 ] [ uint-4-rep rep-components ] unit-test
-[ 4 ] [ int-4-rep rep-components ] unit-test
-[ 4 ] [ float-4-rep rep-components ] unit-test
-[ 2 ] [ double-2-rep rep-components ] unit-test
-
-{ 4 1 } [ uint-4-rep (simd-boa) ] must-infer-as
-{ 4 1 } [ int-4-rep (simd-boa) ] must-infer-as
-{ 4 1 } [ float-4-rep (simd-boa) ] must-infer-as
-{ 2 1 } [ double-2-rep (simd-boa) ] must-infer-as
-
-
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.data assocs combinators
-cpu.architecture compiler.cfg.comparisons fry generalizations
-kernel libc macros math
-math.vectors.conversion.backend
-sequences sets effects accessors namespaces
-lexer parser vocabs.parser words arrays math.vectors ;
-IN: math.vectors.simd.intrinsics
-
-ERROR: bad-simd-call word ;
-
-<<
-
-: simd-effect ( word -- effect )
- stack-effect [ in>> "rep" suffix ] [ out>> ] bi <effect> ;
-: simd-conversion-effect ( word -- effect )
- stack-effect [ in>> but-last "rep" suffix ] [ out>> ] bi <effect> ;
-
-SYMBOL: simd-ops
-
-V{ } clone simd-ops set-global
-
-: (SIMD-OP:) ( accum quot -- accum )
- [
- scan-word dup name>> "(simd-" ")" surround create-in
- [ nip dup '[ _ bad-simd-call ] define ]
- ] dip
- '[ _ dip set-stack-effect ]
- [ 2array simd-ops get push ]
- 2tri ; inline
-
-SYNTAX: SIMD-OP:
- [ simd-effect ] (SIMD-OP:) ;
-
-SYNTAX: SIMD-CONVERSION-OP:
- [ simd-conversion-effect ] (SIMD-OP:) ;
-
->>
-
-SIMD-OP: v+
-SIMD-OP: v-
-SIMD-OP: vneg
-SIMD-OP: v+-
-SIMD-OP: vs+
-SIMD-OP: vs-
-SIMD-OP: vs*
-SIMD-OP: v*
-SIMD-OP: v/
-SIMD-OP: vmin
-SIMD-OP: vmax
-SIMD-OP: v.
-SIMD-OP: vsqrt
-SIMD-OP: sum
-SIMD-OP: vabs
-SIMD-OP: vbitand
-SIMD-OP: vbitandn
-SIMD-OP: vbitor
-SIMD-OP: vbitxor
-SIMD-OP: vbitnot
-SIMD-OP: vand
-SIMD-OP: vandn
-SIMD-OP: vor
-SIMD-OP: vxor
-SIMD-OP: vnot
-SIMD-OP: vlshift
-SIMD-OP: vrshift
-SIMD-OP: hlshift
-SIMD-OP: hrshift
-SIMD-OP: vshuffle-elements
-SIMD-OP: vshuffle-bytes
-SIMD-OP: (vmerge-head)
-SIMD-OP: (vmerge-tail)
-SIMD-OP: v<=
-SIMD-OP: v<
-SIMD-OP: v=
-SIMD-OP: v>
-SIMD-OP: v>=
-SIMD-OP: vunordered?
-SIMD-OP: vany?
-SIMD-OP: vall?
-SIMD-OP: vnone?
-
-SIMD-CONVERSION-OP: (v>float)
-SIMD-CONVERSION-OP: (v>integer)
-SIMD-CONVERSION-OP: (vpack-signed)
-SIMD-CONVERSION-OP: (vpack-unsigned)
-SIMD-CONVERSION-OP: (vunpack-head)
-SIMD-CONVERSION-OP: (vunpack-tail)
-
-: (simd-with) ( x rep -- v ) bad-simd-call ;
-: (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
-: (simd-gather-4) ( a b c d rep -- v ) bad-simd-call ;
-: (simd-select) ( v n rep -- x ) bad-simd-call ;
-
-: assert-positive ( x -- y ) ;
-
-: alien-vector ( c-ptr n rep -- value )
- ! Inefficient version for when intrinsics are missing
- [ swap <displaced-alien> ] dip rep-size memory>byte-array ;
-
-: set-alien-vector ( value c-ptr n rep -- )
- ! Inefficient version for when intrinsics are missing
- [ swap <displaced-alien> swap ] dip rep-size memcpy ;
-
-<<
-
-: rep-components ( rep -- n )
- 16 swap rep-component-type heap-size /i ; foldable
-
-: rep-coercer ( rep -- quot )
- {
- { [ dup int-vector-rep? ] [ [ >fixnum ] ] }
- { [ dup float-vector-rep? ] [ [ >float ] ] }
- } cond nip ; foldable
-
-: rep-coerce ( value rep -- value' )
- rep-coercer call( value -- value' ) ; inline
-
-CONSTANT: rep-gather-words
- {
- { 2 (simd-gather-2) }
- { 4 (simd-gather-4) }
- }
-
-: rep-gather-word ( rep -- word )
- rep-components rep-gather-words at ;
-
->>
-
-MACRO: (simd-boa) ( rep -- quot )
- {
- [ rep-coercer ]
- [ rep-components ]
- [ ]
- [ rep-gather-word ]
- } cleave
- '[ _ _ napply _ _ execute ] ;
-
-GENERIC# supported-simd-op? 1 ( rep intrinsic -- ? )
-
-: (%unpack-reps) ( -- reps )
- %merge-vector-reps [ int-vector-rep? ] filter
- %unpack-vector-head-reps union ;
-
-: (%abs-reps) ( -- reps )
- cc> %compare-vector-reps [ int-vector-rep? ] filter
- %xor-vector-reps [ float-vector-rep? ] filter
- union
- [ { } ] [ { uchar-16-rep ushort-8-rep uint-4-rep ulonglong-2-rep } union ] if-empty ;
-
-: (%shuffle-imm-reps) ( -- reps )
- %shuffle-vector-reps %shuffle-vector-imm-reps union ;
-
-M: vector-rep supported-simd-op?
- {
- { \ (simd-v+) [ %add-vector-reps ] }
- { \ (simd-vs+) [ %saturated-add-vector-reps ] }
- { \ (simd-v+-) [ %add-sub-vector-reps ] }
- { \ (simd-v-) [ %sub-vector-reps ] }
- { \ (simd-vs-) [ %saturated-sub-vector-reps ] }
- { \ (simd-vneg) [ %sub-vector-reps ] }
- { \ (simd-v*) [ %mul-vector-reps ] }
- { \ (simd-vs*) [ %saturated-mul-vector-reps ] }
- { \ (simd-v/) [ %div-vector-reps ] }
- { \ (simd-vmin) [ %min-vector-reps cc< %compare-vector-reps union ] }
- { \ (simd-vmax) [ %max-vector-reps cc> %compare-vector-reps union ] }
- { \ (simd-v.) [ %dot-vector-reps ] }
- { \ (simd-vsqrt) [ %sqrt-vector-reps ] }
- { \ (simd-sum) [ %horizontal-add-vector-reps ] }
- { \ (simd-vabs) [ (%abs-reps) ] }
- { \ (simd-vbitand) [ %and-vector-reps ] }
- { \ (simd-vbitandn) [ %andn-vector-reps ] }
- { \ (simd-vbitor) [ %or-vector-reps ] }
- { \ (simd-vbitxor) [ %xor-vector-reps ] }
- { \ (simd-vbitnot) [ %xor-vector-reps ] }
- { \ (simd-vand) [ %and-vector-reps ] }
- { \ (simd-vandn) [ %andn-vector-reps ] }
- { \ (simd-vor) [ %or-vector-reps ] }
- { \ (simd-vxor) [ %xor-vector-reps ] }
- { \ (simd-vnot) [ %xor-vector-reps ] }
- { \ (simd-vlshift) [ %shl-vector-reps ] }
- { \ (simd-vrshift) [ %shr-vector-reps ] }
- { \ (simd-hlshift) [ %horizontal-shl-vector-imm-reps ] }
- { \ (simd-hrshift) [ %horizontal-shr-vector-imm-reps ] }
- { \ (simd-vshuffle-elements) [ (%shuffle-imm-reps) ] }
- { \ (simd-vshuffle-bytes) [ %shuffle-vector-reps ] }
- { \ (simd-(vmerge-head)) [ %merge-vector-reps ] }
- { \ (simd-(vmerge-tail)) [ %merge-vector-reps ] }
- { \ (simd-(v>float)) [ %integer>float-vector-reps ] }
- { \ (simd-(v>integer)) [ %float>integer-vector-reps ] }
- { \ (simd-(vpack-signed)) [ %signed-pack-vector-reps ] }
- { \ (simd-(vpack-unsigned)) [ %unsigned-pack-vector-reps ] }
- { \ (simd-(vunpack-head)) [ (%unpack-reps) ] }
- { \ (simd-(vunpack-tail)) [ (%unpack-reps) ] }
- { \ (simd-v<=) [ unsign-rep cc<= %compare-vector-reps ] }
- { \ (simd-v<) [ unsign-rep cc< %compare-vector-reps ] }
- { \ (simd-v=) [ unsign-rep cc= %compare-vector-reps ] }
- { \ (simd-v>) [ unsign-rep cc> %compare-vector-reps ] }
- { \ (simd-v>=) [ unsign-rep cc>= %compare-vector-reps ] }
- { \ (simd-vunordered?) [ unsign-rep cc/<>= %compare-vector-reps ] }
- { \ (simd-gather-2) [ %gather-vector-2-reps ] }
- { \ (simd-gather-4) [ %gather-vector-4-reps ] }
- { \ (simd-vany?) [ %test-vector-reps ] }
- { \ (simd-vall?) [ %test-vector-reps ] }
- { \ (simd-vnone?) [ %test-vector-reps ] }
- } case member? ;
--- /dev/null
+USING: math.vectors.simd mirrors ;
+IN: math.vectors.simd.mirrors
+INSTANCE: simd-128 enumerated-sequence
USING: classes.tuple.private cpu.architecture help.markup
help.syntax kernel.private math math.vectors
-math.vectors.simd.intrinsics sequences ;
+sequences ;
IN: math.vectors.simd
ARTICLE: "math.vectors.simd.intro" "Introduction to SIMD support"
$nl
"SSE2 introduces double-precision SIMD (" { $snippet "double-2" } " and " { $snippet "double-4" } ") and integer SIMD (all types). Integer SIMD is missing a few features, in particular the " { $link vmin } " and " { $link vmax } " operations only work on " { $snippet "uchar-16" } " and " { $snippet "short-8" } "."
$nl
-"SSE3 introduces horizontal adds (summing all components of a single vector register), which is useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } "."
+"SSE3 introduces horizontal adds (summing all components of a single vector register), which are useful for computing dot products. Where available, SSE3 operations are used to speed up " { $link sum } ", " { $link v. } ", " { $link norm-sq } ", " { $link norm } ", and " { $link distance } "."
$nl
"SSSE3 introduces " { $link vabs } " for " { $snippet "char-16" } ", " { $snippet "short-8" } " and " { $snippet "int-4" } "."
$nl
ARTICLE: "math.vectors.simd.types" "SIMD vector types"
"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type and " { $snippet "count" } " is a vector dimension."
$nl
-"To use a SIMD vector type, a parsing word is used to generate the relevant code and bring it into the vocabulary search path; this is the same idea as with " { $link "specialized-arrays" } ":"
-{ $subsections
- POSTPONE: SIMD:
- POSTPONE: SIMDS:
-}
-"The following scalar types are supported:"
-{ $code
- "char"
- "uchar"
- "short"
- "ushort"
- "int"
- "uint"
- "longlong"
- "ulonglong"
- "float"
- "double"
-}
-
-"The following vector types are generated from the above scalar types:"
+"The following vector types are available:"
{ $code
"char-16"
"uchar-16"
"math.vectors.simd.intrinsics"
} ;
-HELP: SIMD:
-{ $syntax "SIMD: type" }
-{ $values { "type" "a scalar C type" } }
-{ $description "Defines 128-bit and 256-bit SIMD arrays for holding elements of " { $snippet "type" } " into the vocabulary search path. The allowed scalar types, and the auto-generated type/length vector combinations that result, are listed in " { $link "math.vectors.simd.types" } ". Generated words are documented in " { $link "math.vectors.simd.words" } "." } ;
-
-HELP: SIMDS:
-{ $syntax "SIMDS: type type type ... ;" }
-{ $values { "type" "a scalar C type" } }
-{ $description "Defines 128-bit and 256-bit SIMD arrays for holding elements of each " { $snippet "type" } " into the vocabulary search path. The possible type/length combinations are listed in " { $link "math.vectors.simd.types" } " and the generated words are documented in " { $link "math.vectors.simd.words" } "." } ;
-
-{ POSTPONE: SIMD: POSTPONE: SIMDS: } related-words
-
ABOUT: "math.vectors.simd"
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types combinators fry kernel parser math math.parser
-math.vectors.simd.functor sequences splitting vocabs.generated
-vocabs.loader vocabs.parser words accessors vocabs compiler.units
-definitions ;
+USING: accessors alien.c-types byte-arrays classes combinators
+cpu.architecture fry functors generalizations generic
+generic.parser kernel lexer literals macros math math.functions
+math.vectors math.vectors.private namespaces parser
+prettyprint.custom quotations sequences sequences.private vocabs
+vocabs.loader ;
QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd
-ERROR: bad-base-type type ;
+DEFER: vconvert
+DEFER: simd-with
+DEFER: simd-boa
+DEFER: simd-cast
+ERROR: bad-simd-call word ;
+ERROR: bad-simd-length got expected ;
+
+<<
+<PRIVATE
+! Primitive SIMD constructors
+
+GENERIC: new-underlying ( underlying seq -- seq' )
+
+: make-underlying ( seq quot -- seq' )
+ dip new-underlying ; inline
+: change-underlying ( seq quot -- seq' )
+ '[ underlying>> @ ] keep new-underlying ; inline
+PRIVATE>
+>>
+
+<PRIVATE
+
+! SIMD intrinsics
+
+: (simd-v+) ( a b rep -- c ) \ v+ bad-simd-call ;
+: (simd-v-) ( a b rep -- c ) \ v- bad-simd-call ;
+: (simd-vneg) ( a rep -- c ) \ vneg bad-simd-call ;
+: (simd-v+-) ( a b rep -- c ) \ v+- bad-simd-call ;
+: (simd-vs+) ( a b rep -- c ) \ vs+ bad-simd-call ;
+: (simd-vs-) ( a b rep -- c ) \ vs- bad-simd-call ;
+: (simd-vs*) ( a b rep -- c ) \ vs* bad-simd-call ;
+: (simd-v*) ( a b rep -- c ) \ v* bad-simd-call ;
+: (simd-v/) ( a b rep -- c ) \ v/ bad-simd-call ;
+: (simd-vmin) ( a b rep -- c ) \ vmin bad-simd-call ;
+: (simd-vmax) ( a b rep -- c ) \ vmax bad-simd-call ;
+: (simd-v.) ( a b rep -- n ) \ v. bad-simd-call ;
+: (simd-vsqrt) ( a rep -- c ) \ vsqrt bad-simd-call ;
+: (simd-sum) ( a rep -- n ) \ sum bad-simd-call ;
+: (simd-vabs) ( a rep -- c ) \ vabs bad-simd-call ;
+: (simd-vbitand) ( a b rep -- c ) \ vbitand bad-simd-call ;
+: (simd-vbitandn) ( a b rep -- c ) \ vbitandn bad-simd-call ;
+: (simd-vbitor) ( a b rep -- c ) \ vbitor bad-simd-call ;
+: (simd-vbitxor) ( a b rep -- c ) \ vbitxor bad-simd-call ;
+: (simd-vbitnot) ( a rep -- c ) \ vbitnot bad-simd-call ;
+: (simd-vand) ( a b rep -- c ) \ vand bad-simd-call ;
+: (simd-vandn) ( a b rep -- c ) \ vandn bad-simd-call ;
+: (simd-vor) ( a b rep -- c ) \ vor bad-simd-call ;
+: (simd-vxor) ( a b rep -- c ) \ vxor bad-simd-call ;
+: (simd-vnot) ( a rep -- c ) \ vnot bad-simd-call ;
+: (simd-vlshift) ( a n rep -- c ) \ vlshift bad-simd-call ;
+: (simd-vrshift) ( a n rep -- c ) \ vrshift bad-simd-call ;
+: (simd-hlshift) ( a n rep -- c ) \ hlshift bad-simd-call ;
+: (simd-hrshift) ( a n rep -- c ) \ hrshift bad-simd-call ;
+: (simd-vshuffle-elements) ( a n rep -- c ) \ vshuffle-elements bad-simd-call ;
+: (simd-vshuffle-bytes) ( a b rep -- c ) \ vshuffle-bytes bad-simd-call ;
+: (simd-vmerge-head) ( a b rep -- c ) \ (vmerge-head) bad-simd-call ;
+: (simd-vmerge-tail) ( a b rep -- c ) \ (vmerge-tail) bad-simd-call ;
+: (simd-v<=) ( a b rep -- c ) \ v<= bad-simd-call ;
+: (simd-v<) ( a b rep -- c ) \ v< bad-simd-call ;
+: (simd-v=) ( a b rep -- c ) \ v= bad-simd-call ;
+: (simd-v>) ( a b rep -- c ) \ v> bad-simd-call ;
+: (simd-v>=) ( a b rep -- c ) \ v>= bad-simd-call ;
+: (simd-vunordered?) ( a b rep -- c ) \ vunordered? bad-simd-call ;
+: (simd-vany?) ( a rep -- ? ) \ vany? bad-simd-call ;
+: (simd-vall?) ( a rep -- ? ) \ vall? bad-simd-call ;
+: (simd-vnone?) ( a rep -- ? ) \ vnone? bad-simd-call ;
+: (simd-v>float) ( a rep -- c ) \ vconvert bad-simd-call ;
+: (simd-v>integer) ( a rep -- c ) \ vconvert bad-simd-call ;
+: (simd-vpack-signed) ( a b rep -- c ) \ vconvert bad-simd-call ;
+: (simd-vpack-unsigned) ( a b rep -- c ) \ vconvert bad-simd-call ;
+: (simd-vunpack-head) ( a rep -- c ) \ vconvert bad-simd-call ;
+: (simd-vunpack-tail) ( a rep -- c ) \ vconvert bad-simd-call ;
+: (simd-with) ( n rep -- v ) \ simd-with bad-simd-call ;
+: (simd-gather-2) ( m n rep -- v ) \ simd-boa bad-simd-call ;
+: (simd-gather-4) ( m n o p rep -- v ) \ simd-boa bad-simd-call ;
+: (simd-select) ( a n rep -- n ) \ nth bad-simd-call ;
+
+PRIVATE>
+
+: alien-vector ( c-ptr n rep -- value ) \ alien-vector bad-simd-call ;
+: set-alien-vector ( c-ptr n rep -- value ) \ set-alien-vector bad-simd-call ;
+
+<PRIVATE
+
+! Helper for boolean vector literals
+
+: vector-true-value ( class -- value )
+ { c:float c:double } member? [ -1 bits>double ] [ -1 ] if ; foldable
+
+: vector-false-value ( type -- value )
+ { c:float c:double } member? [ 0.0 ] [ 0 ] if ; foldable
+
+: boolean>element ( bool/elt type -- elt )
+ swap {
+ { t [ vector-true-value ] }
+ { f [ vector-false-value ] }
+ [ nip ]
+ } case ; inline
+
+PRIVATE>
+
+! SIMD base type
+
+TUPLE: simd-128
+ { underlying byte-array read-only initial: $[ 16 <byte-array> ] } ;
+
+GENERIC: simd-element-type ( obj -- c-type )
+GENERIC: simd-rep ( simd -- rep )
+
+<<
+: rep-length ( rep -- n )
+ 16 swap rep-component-type heap-size /i ; foldable
+
+<PRIVATE
+
+! SIMD concrete type functor
+
+FUNCTOR: define-simd-128 ( T -- )
+
+A DEFINES-CLASS ${T}
+A-rep IS ${T}-rep
+>A DEFINES >${T}
+A-boa DEFINES ${T}-boa
+A-with DEFINES ${T}-with
+A-cast DEFINES ${T}-cast
+A{ DEFINES ${T}{
+
+ELT [ A-rep rep-component-type ]
+N [ A-rep rep-length ]
+
+SET-NTH [ ELT dup c:c-setter c:array-accessor ]
+
+WHERE
+
+TUPLE: A < simd-128 ;
+
+M: A new-underlying drop \ A boa ; inline
+M: A simd-rep drop A-rep ; inline
+M: A simd-element-type drop ELT ; inline
+M: A length drop N ; inline
+
+M: A set-nth-unsafe
+ [ ELT boolean>element ] 2dip
+ underlying>> SET-NTH call ; inline
+
+: >A ( seq -- simd ) \ A new clone-like ; inline
+
+M: A like drop dup \ A instance? [ >A ] unless ; inline
+
+: A-with ( n -- v ) \ A new simd-with ; inline
+: A-cast ( v -- v' ) \ A new simd-cast ; inline
+: A-boa ( ...n -- v ) \ A new simd-boa ; inline
+
+M: A pprint-delims drop \ A{ \ } ;
+SYNTAX: A{ \ } [ >A ] parse-literal ;
+
+c:<c-type>
+ byte-array >>class
+ A >>boxed-class
+ [ A-rep alien-vector \ A boa ] >>getter
+ [ [ underlying>> ] 2dip A-rep set-alien-vector ] >>setter
+ 16 >>size
+ 16 >>align
+ A-rep >>rep
+\ A c:typedef
+
+;FUNCTOR
+
+SYNTAX: SIMD-128:
+ scan define-simd-128 ;
+
+PRIVATE>
+
+>>
+
+SIMD-128: char-16
+SIMD-128: uchar-16
+SIMD-128: short-8
+SIMD-128: ushort-8
+SIMD-128: int-4
+SIMD-128: uint-4
+SIMD-128: longlong-2
+SIMD-128: ulonglong-2
+SIMD-128: float-4
+SIMD-128: double-2
+
+: assert-positive ( x -- y ) ;
+
+! SIMD vectors as sequences
+
+M: simd-128 hashcode* underlying>> hashcode* ; inline
+M: simd-128 clone [ clone ] change-underlying ; inline
+M: simd-128 length simd-rep rep-length ; inline
+M: simd-128 nth-unsafe [ nip ] 2keep simd-rep (simd-select) ; inline
+M: simd-128 c:byte-length drop 16 ; inline
+
+M: simd-128 new-sequence
+ 2dup length =
+ [ nip [ 16 (byte-array) ] make-underlying ]
+ [ length bad-simd-length ] if ; inline
+
+M: simd-128 >pprint-sequence ;
+M: simd-128 pprint* pprint-object ;
+
+INSTANCE: simd-128 sequence
+
+! Unboxers for SIMD operations
+<<
<PRIVATE
-: simd-vocab ( base-type -- vocab )
- name>> "math.vectors.simd.instances." prepend ;
+: if-both-vectors ( a b t f -- )
+ [ 2dup [ simd-128? ] both? ] 2dip if ; inline
+
+: if-both-vectors-match ( a b t f -- )
+ [ 2dup [ [ simd-128? ] both? ] [ [ simd-rep ] bi@ eq? ] 2bi and ]
+ 2dip if ; inline
-: parse-base-type ( c-type -- c-type )
- dup { c:char c:uchar c:short c:ushort c:int c:uint c:longlong c:ulonglong c:float c:double } member-eq?
- [ bad-base-type ] unless ;
+: simd-construct-op ( exemplar quot: ( rep -- v ) -- v )
+ [ dup simd-rep ] dip curry make-underlying ; inline
-: forget-instances ( -- )
- [
- "math.vectors.simd.instances" child-vocabs
- [ forget-vocab ] each
- ] with-compilation-unit ;
+: simd-unbox ( a -- a (a) a-rep )
+ [ ] [ underlying>> ] [ simd-rep ] tri ; inline
+
+: simd-v->v-op ( a quot: ( (a) rep -- (c) ) -- c )
+ [ simd-unbox ] dip 2curry make-underlying ; inline
+
+: simd-vn->v-op ( a n quot: ( (a) n rep -- (c) ) -- c )
+ [ simd-unbox ] [ swap ] [ 3curry ] tri* make-underlying ; inline
+
+: simd-v->n-op ( a quot: ( (a) rep -- n ) -- n )
+ [ [ underlying>> ] [ simd-rep ] bi ] dip call ; inline
+
+: ((simd-vv->v-op)) ( a b quot: ( (a) (b) rep -- (c) ) -- c )
+ [ simd-unbox ] [ underlying>> swap ] [ 3curry ] tri* make-underlying ; inline
+
+: ((simd-vv->n-op)) ( a b quot: ( (a) (b) rep -- n ) -- n )
+ [ [ underlying>> ] [ simd-rep ] bi ]
+ [ underlying>> swap ] [ ] tri* call ; inline
+
+: (simd-vv->v-op) ( a b quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
+ [ '[ _ ((simd-vv->v-op)) ] ] dip if-both-vectors-match ; inline
+
+: (simd-vv'->v-op) ( a b quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
+ [ '[ _ ((simd-vv->v-op)) ] ] dip if-both-vectors ; inline
+
+: (simd-vv->n-op) ( a b quot: ( (a) (b) rep -- n ) fallback-quot -- n )
+ [ '[ _ ((simd-vv->n-op)) ] ] dip if-both-vectors-match ; inline
+
+: (simd-method-fallback) ( accum word -- accum )
+ [ current-method get literalize \ (call-next-method) [ ] 2sequence suffix! ]
+ dip suffix! ;
+
+SYNTAX: simd-vv->v-op
+ \ (simd-vv->v-op) (simd-method-fallback) ;
+SYNTAX: simd-vv'->v-op
+ \ (simd-vv'->v-op) (simd-method-fallback) ;
+SYNTAX: simd-vv->n-op
+ \ (simd-vv->n-op) (simd-method-fallback) ;
PRIVATE>
+>>
+
+M: simd-128 equal?
+ [ v= vall? ] [ 2drop f ] if-both-vectors-match ; inline
+
+! SIMD constructors
+
+: simd-with ( n seq -- v )
+ [ (simd-with) ] simd-construct-op ; inline
+
+MACRO: simd-boa ( seq -- )
+ dup length {
+ { 2 [ '[ _ dup [ (simd-gather-2) ] simd-construct-op ] ] }
+ { 4 [ '[ _ dup [ (simd-gather-4) ] simd-construct-op ] ] }
+ [ '[ _ _ nsequence ] ]
+ } case ;
+
+: simd-cast ( v seq -- v' )
+ [ underlying>> ] dip new-underlying ; inline
+
+! SIMD primitive operations
+
+M: simd-128 v+ [ (simd-v+) ] simd-vv->v-op ; inline
+M: simd-128 v- [ (simd-v-) ] simd-vv->v-op ; inline
+M: simd-128 vneg [ (simd-vneg) ] simd-v->v-op ; inline
+M: simd-128 v+- [ (simd-v+-) ] simd-vv->v-op ; inline
+M: simd-128 vs+ [ (simd-vs+) ] simd-vv->v-op ; inline
+M: simd-128 vs- [ (simd-vs-) ] simd-vv->v-op ; inline
+M: simd-128 vs* [ (simd-vs*) ] simd-vv->v-op ; inline
+M: simd-128 v* [ (simd-v*) ] simd-vv->v-op ; inline
+M: simd-128 v/ [ (simd-v/) ] simd-vv->v-op ; inline
+M: simd-128 vmin [ (simd-vmin) ] simd-vv->v-op ; inline
+M: simd-128 vmax [ (simd-vmax) ] simd-vv->v-op ; inline
+M: simd-128 v. [ (simd-v.) ] simd-vv->n-op ; inline
+M: simd-128 vsqrt [ (simd-vsqrt) ] simd-v->v-op ; inline
+M: simd-128 sum [ (simd-sum) ] simd-v->n-op ; inline
+M: simd-128 vabs [ (simd-vabs) ] simd-v->v-op ; inline
+M: simd-128 vbitand [ (simd-vbitand) ] simd-vv->v-op ; inline
+M: simd-128 vbitandn [ (simd-vbitandn) ] simd-vv->v-op ; inline
+M: simd-128 vbitor [ (simd-vbitor) ] simd-vv->v-op ; inline
+M: simd-128 vbitxor [ (simd-vbitxor) ] simd-vv->v-op ; inline
+M: simd-128 vbitnot [ (simd-vbitnot) ] simd-v->v-op ; inline
+M: simd-128 vand [ (simd-vand) ] simd-vv->v-op ; inline
+M: simd-128 vandn [ (simd-vandn) ] simd-vv->v-op ; inline
+M: simd-128 vor [ (simd-vor) ] simd-vv->v-op ; inline
+M: simd-128 vxor [ (simd-vxor) ] simd-vv->v-op ; inline
+M: simd-128 vnot [ (simd-vnot) ] simd-v->v-op ; inline
+M: simd-128 vlshift [ (simd-vlshift) ] simd-vn->v-op ; inline
+M: simd-128 vrshift [ (simd-vrshift) ] simd-vn->v-op ; inline
+M: simd-128 hlshift [ (simd-hlshift) ] simd-vn->v-op ; inline
+M: simd-128 hrshift [ (simd-hrshift) ] simd-vn->v-op ; inline
+M: simd-128 vshuffle-elements [ (simd-vshuffle-elements) ] simd-vn->v-op ; inline
+M: simd-128 vshuffle-bytes [ (simd-vshuffle-bytes) ] simd-vv->v-op ; inline
+M: simd-128 (vmerge-head) [ (simd-vmerge-head) ] simd-vv->v-op ; inline
+M: simd-128 (vmerge-tail) [ (simd-vmerge-tail) ] simd-vv->v-op ; inline
+M: simd-128 v<= [ (simd-v<=) ] simd-vv->v-op ; inline
+M: simd-128 v< [ (simd-v<) ] simd-vv->v-op ; inline
+M: simd-128 v= [ (simd-v=) ] simd-vv->v-op ; inline
+M: simd-128 v> [ (simd-v>) ] simd-vv->v-op ; inline
+M: simd-128 v>= [ (simd-v>=) ] simd-vv->v-op ; inline
+M: simd-128 vunordered? [ (simd-vunordered?) ] simd-vv->v-op ; inline
+M: simd-128 vany? [ (simd-vany?) ] simd-v->n-op ; inline
+M: simd-128 vall? [ (simd-vall?) ] simd-v->n-op ; inline
+M: simd-128 vnone? [ (simd-vnone?) ] simd-v->n-op ; inline
+
+! SIMD high-level specializations
+
+M: simd-128 vbroadcast [ swap nth ] keep simd-with ; inline
+M: simd-128 n+v [ simd-with ] keep v+ ; inline
+M: simd-128 n-v [ simd-with ] keep v- ; inline
+M: simd-128 n*v [ simd-with ] keep v* ; inline
+M: simd-128 n/v [ simd-with ] keep v/ ; inline
+M: simd-128 v+n over simd-with v+ ; inline
+M: simd-128 v-n over simd-with v- ; inline
+M: simd-128 v*n over simd-with v* ; inline
+M: simd-128 v/n over simd-with v/ ; inline
+M: simd-128 norm-sq dup v. assert-positive ; inline
+M: simd-128 norm norm-sq sqrt ; inline
+M: simd-128 distance v- norm ; inline
-: define-simd-vocab ( type -- vocab )
- parse-base-type
- [ simd-vocab ] keep '[
- _
- [ define-simd-128 ]
- [ define-simd-256 ] bi
- ] generate-vocab ;
+! misc
-SYNTAX: SIMD:
- scan-word define-simd-vocab use-vocab ;
+M: simd-128 vshuffle ( u perm -- v )
+ vshuffle-bytes ; inline
-SYNTAX: SIMDS:
- \ ; parse-until [ define-simd-vocab use-vocab ] each ;
+"compiler.tree.propagation.simd" require
+"compiler.cfg.intrinsics.simd" require
+"compiler.cfg.value-numbering.simd" require
+"mirrors" vocab [
+ "math.vectors.simd.mirrors" require
+] when
+++ /dev/null
-IN: math.vectors.specialization.tests
-USING: compiler.tree.debugger math.vectors tools.test kernel
-kernel.private math specialized-arrays ;
-QUALIFIED-WITH: alien.c-types c
-QUALIFIED-WITH: alien.complex c
-SPECIALIZED-ARRAY: c:double
-SPECIALIZED-ARRAY: c:complex-float
-SPECIALIZED-ARRAY: c:float
-
-[ V{ t } ] [
- [ { double-array double-array } declare distance 0.0 < not ] final-literals
-] unit-test
-
-[ V{ float } ] [
- [ { float-array float } declare v*n norm ] final-classes
-] unit-test
-
-[ V{ complex } ] [
- [ { complex-float-array complex-float-array } declare v. ] final-classes
-] unit-test
-
-[ V{ float } ] [
- [ { float-array float } declare v*n norm ] final-classes
-] unit-test
-
-[ V{ float } ] [
- [ { complex-float-array complex } declare v*n norm ] final-classes
-] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: words kernel make sequences effects sets kernel.private
-accessors combinators math math.intervals math.vectors
-math.vectors.conversion.backend namespaces assocs fry splitting
-classes.algebra generalizations locals
-compiler.tree.propagation.info ;
-IN: math.vectors.specialization
-
-SYMBOLS: -> +vector+ +any-vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
-
-: parent-vector-class ( type -- type' )
- {
- { [ dup simd-128 class<= ] [ drop simd-128 ] }
- { [ dup simd-256 class<= ] [ drop simd-256 ] }
- [ "Not a vector class" throw ]
- } cond ;
-
-: signature-for-schema ( array-type elt-type schema -- signature )
- [
- {
- { +vector+ [ drop ] }
- { +any-vector+ [ drop parent-vector-class ] }
- { +scalar+ [ nip ] }
- { +boolean+ [ 2drop boolean ] }
- { +nonnegative+ [ nip ] }
- { +literal+ [ 2drop f ] }
- } case
- ] with with map ;
-
-: (specialize-vector-word) ( word array-type elt-type schema -- word' )
- signature-for-schema
- [ [ name>> ] [ [ name>> ] map "," join ] bi* "=>" glue f <word> ]
- [ [ , \ declare , def>> % ] [ ] make ]
- [ drop stack-effect ]
- 2tri
- [ define-declared ] [ 2drop ] 3bi ;
-
-: output-infos ( array-type elt-type schema -- value-infos )
- [
- {
- { +vector+ [ drop <class-info> ] }
- { +any-vector+ [ drop parent-vector-class <class-info> ] }
- { +scalar+ [ nip <class-info> ] }
- { +boolean+ [ 2drop boolean <class-info> ] }
- {
- +nonnegative+
- [
- nip
- dup complex class<= [ drop float ] when
- [0,inf] <class/interval-info>
- ]
- }
- } case
- ] with with map ;
-
-: record-output-signature ( word array-type elt-type schema -- word )
- output-infos
- [ drop ]
- [ drop ]
- [ [ stack-effect in>> length '[ _ ndrop ] ] dip append ] 2tri
- "outputs" set-word-prop ;
-
-CONSTANT: vector-words
-H{
- { [v-] { +vector+ +vector+ -> +vector+ } }
- { distance { +vector+ +vector+ -> +nonnegative+ } }
- { n*v { +scalar+ +vector+ -> +vector+ } }
- { n+v { +scalar+ +vector+ -> +vector+ } }
- { n-v { +scalar+ +vector+ -> +vector+ } }
- { n/v { +scalar+ +vector+ -> +vector+ } }
- { norm { +vector+ -> +nonnegative+ } }
- { norm-sq { +vector+ -> +nonnegative+ } }
- { normalize { +vector+ -> +vector+ } }
- { v* { +vector+ +vector+ -> +vector+ } }
- { vs* { +vector+ +vector+ -> +vector+ } }
- { v*n { +vector+ +scalar+ -> +vector+ } }
- { v+ { +vector+ +vector+ -> +vector+ } }
- { vs+ { +vector+ +vector+ -> +vector+ } }
- { v+- { +vector+ +vector+ -> +vector+ } }
- { v+n { +vector+ +scalar+ -> +vector+ } }
- { v- { +vector+ +vector+ -> +vector+ } }
- { vneg { +vector+ -> +vector+ } }
- { vs- { +vector+ +vector+ -> +vector+ } }
- { v-n { +vector+ +scalar+ -> +vector+ } }
- { v. { +vector+ +vector+ -> +scalar+ } }
- { v/ { +vector+ +vector+ -> +vector+ } }
- { v/n { +vector+ +scalar+ -> +vector+ } }
- { vceiling { +vector+ -> +vector+ } }
- { vfloor { +vector+ -> +vector+ } }
- { vmax { +vector+ +vector+ -> +vector+ } }
- { vmin { +vector+ +vector+ -> +vector+ } }
- { vneg { +vector+ -> +vector+ } }
- { vtruncate { +vector+ -> +vector+ } }
- { sum { +vector+ -> +scalar+ } }
- { vabs { +vector+ -> +vector+ } }
- { vsqrt { +vector+ -> +vector+ } }
- { vbitand { +vector+ +vector+ -> +vector+ } }
- { vbitandn { +vector+ +vector+ -> +vector+ } }
- { vbitor { +vector+ +vector+ -> +vector+ } }
- { vbitxor { +vector+ +vector+ -> +vector+ } }
- { vbitnot { +vector+ -> +vector+ } }
- { vand { +vector+ +vector+ -> +vector+ } }
- { vandn { +vector+ +vector+ -> +vector+ } }
- { vor { +vector+ +vector+ -> +vector+ } }
- { vxor { +vector+ +vector+ -> +vector+ } }
- { vnot { +vector+ -> +vector+ } }
- { vlshift { +vector+ +scalar+ -> +vector+ } }
- { vrshift { +vector+ +scalar+ -> +vector+ } }
- { hlshift { +vector+ +literal+ -> +vector+ } }
- { hrshift { +vector+ +literal+ -> +vector+ } }
- { vshuffle-elements { +vector+ +literal+ -> +vector+ } }
- { vshuffle-bytes { +vector+ +any-vector+ -> +vector+ } }
- { vbroadcast { +vector+ +literal+ -> +vector+ } }
- { (vmerge-head) { +vector+ +vector+ -> +vector+ } }
- { (vmerge-tail) { +vector+ +vector+ -> +vector+ } }
- { (v>float) { +vector+ +literal+ -> +vector+ } }
- { (v>integer) { +vector+ +literal+ -> +vector+ } }
- { (vpack-signed) { +vector+ +vector+ +literal+ -> +vector+ } }
- { (vpack-unsigned) { +vector+ +vector+ +literal+ -> +vector+ } }
- { (vunpack-head) { +vector+ +literal+ -> +vector+ } }
- { (vunpack-tail) { +vector+ +literal+ -> +vector+ } }
- { v<= { +vector+ +vector+ -> +vector+ } }
- { v< { +vector+ +vector+ -> +vector+ } }
- { v= { +vector+ +vector+ -> +vector+ } }
- { v> { +vector+ +vector+ -> +vector+ } }
- { v>= { +vector+ +vector+ -> +vector+ } }
- { vunordered? { +vector+ +vector+ -> +vector+ } }
- { vany? { +vector+ -> +boolean+ } }
- { vall? { +vector+ -> +boolean+ } }
- { vnone? { +vector+ -> +boolean+ } }
-}
-
-PREDICATE: vector-word < word vector-words key? ;
-
-: specializations ( word -- assoc )
- dup "specializations" word-prop
- [ ] [ V{ } clone [ "specializations" set-word-prop ] keep ] ?if ;
-
-M: vector-word subwords specializations values [ word? ] filter ;
-
-: add-specialization ( new-word signature word -- )
- specializations set-at ;
-
-ERROR: bad-vector-word word ;
-
-: word-schema ( word -- schema )
- vector-words ?at [ bad-vector-word ] unless ;
-
-: inputs ( schema -- seq ) { -> } split first ;
-
-: outputs ( schema -- seq ) { -> } split second ;
-
-: loop-vector-op ( word array-type elt-type -- word' )
- pick word-schema
- [ inputs (specialize-vector-word) ]
- [ outputs record-output-signature ] 3bi ;
-
-:: specialize-vector-word ( word array-type elt-type simd -- word/quot' )
- word simd key? [ word simd at ] [ word array-type elt-type loop-vector-op ] if ;
-
-:: input-signature ( word array-type elt-type -- signature )
- array-type elt-type word word-schema inputs signature-for-schema ;
-
-: vector-words-for-type ( elt-type -- words )
- {
- ! Can't do shifts on floats
- { [ dup float class<= ] [ vector-words keys { vlshift vrshift } diff ] }
- ! Can't divide integers
- { [ dup integer class<= ] [ vector-words keys { vsqrt n/v v/n v/ normalize } diff ] }
- ! Can't compute square root of complex numbers (vsqrt uses fsqrt not sqrt)
- { [ dup complex class<= ] [ vector-words keys { vsqrt } diff ] }
- [ { } ]
- } cond
- ! Don't specialize horizontal shifts, shuffles, and conversions at all, they're only for SIMD
- {
- hlshift hrshift vshuffle-elements vshuffle-bytes vbroadcast
- (v>integer) (v>float)
- (vpack-signed) (vpack-unsigned)
- (vunpack-head) (vunpack-tail)
- } diff
- nip ;
-
-:: specialize-vector-words ( array-type elt-type simd -- )
- elt-type vector-words-for-type simd keys union [
- [ array-type elt-type simd specialize-vector-word ]
- [ array-type elt-type input-signature ]
- [ ]
- tri add-specialization
- ] each ;
-
-: specialization-matches? ( value-infos signature -- ? )
- [ [ [ class>> ] dip class<= ] [ literal?>> ] if* ] 2all? ;
-
-: find-specialization ( classes word -- word/f )
- specializations
- [ first specialization-matches? ] with find
- swap [ second ] when ;
-
-: vector-word-custom-inlining ( #call -- word/f )
- [ in-d>> [ value-info ] map ] [ word>> ] bi
- find-specialization ;
-
-vector-words keys [
- [ vector-word-custom-inlining ]
- "custom-inlining" set-word-prop
-] each
QUALIFIED-WITH: alien.c-types c
IN: math.vectors
-MIXIN: simd-128
-MIXIN: simd-256
+GENERIC: vneg ( u -- v )
+M: object vneg [ neg ] map ;
-GENERIC: element-type ( obj -- c-type )
-M: object element-type drop f ; inline
+GENERIC# v+n 1 ( u n -- v )
+M: object v+n [ + ] curry map ;
-: vneg ( u -- v ) [ neg ] map ;
+GENERIC: n+v ( n v -- w )
+M: object n+v [ + ] with map ;
-: v+n ( u n -- v ) [ + ] curry map ;
-: n+v ( n u -- v ) [ + ] with map ;
-: v-n ( u n -- v ) [ - ] curry map ;
-: n-v ( n u -- v ) [ - ] with map ;
+GENERIC# v-n 1 ( u n -- w )
+M: object v-n [ - ] curry map ;
-: v*n ( u n -- v ) [ * ] curry map ;
-: n*v ( n u -- v ) [ * ] with map ;
-: v/n ( u n -- v ) [ / ] curry map ;
-: n/v ( n u -- v ) [ / ] with map ;
+GENERIC: n-v ( n v -- w )
+M: object n-v [ - ] with map ;
-: v+ ( u v -- w ) [ + ] 2map ;
-: v- ( u v -- w ) [ - ] 2map ;
-: [v-] ( u v -- w ) [ [-] ] 2map ;
-: v* ( u v -- w ) [ * ] 2map ;
-: v/ ( u v -- w ) [ / ] 2map ;
+GENERIC# v*n 1 ( u n -- v )
+M: object v*n [ * ] curry map ;
+
+GENERIC: n*v ( n v -- w )
+M: object n*v [ * ] with map ;
+
+GENERIC# v/n 1 ( u n -- v )
+M: object v/n [ / ] curry map ;
+
+GENERIC: n/v ( n v -- w )
+M: object n/v [ / ] with map ;
+
+GENERIC: v+ ( u v -- w )
+M: object v+ [ + ] 2map ;
+
+GENERIC: v- ( u v -- w )
+M: object v- [ - ] 2map ;
+
+GENERIC: [v-] ( u v -- w )
+M: object [v-] [ [-] ] 2map ;
+
+GENERIC: v* ( u v -- w )
+M: object v* [ * ] 2map ;
+
+GENERIC: v/ ( u v -- w )
+M: object v/ [ / ] 2map ;
<PRIVATE
PRIVATE>
-: vmax ( u v -- w ) [ [ float-max ] [ max ] if-both-floats ] 2map ;
-: vmin ( u v -- w ) [ [ float-min ] [ min ] if-both-floats ] 2map ;
+GENERIC: vmax ( u v -- w )
+M: object vmax [ [ float-max ] [ max ] if-both-floats ] 2map ;
+
+GENERIC: vmin ( u v -- w )
+M: object vmin [ [ float-min ] [ min ] if-both-floats ] 2map ;
-: v+- ( u v -- w )
+GENERIC: v+- ( u v -- w )
+M: object v+-
[ t ] 2dip
[ [ not ] 2dip pick [ + ] [ - ] if ] 2map
nip ;
-<PRIVATE
+GENERIC: vs+ ( u v -- w )
+M: object vs+ [ + ] 2map ;
-: 2saturate-map ( u v quot -- w )
- pick element-type '[ @ _ c-type-clamp ] 2map ; inline
+GENERIC: vs- ( u v -- w )
+M: object vs- [ - ] 2map ;
-PRIVATE>
+GENERIC: vs* ( u v -- w )
+M: object vs* [ * ] 2map ;
-: vs+ ( u v -- w ) [ + ] 2saturate-map ;
-: vs- ( u v -- w ) [ - ] 2saturate-map ;
-: vs* ( u v -- w ) [ * ] 2saturate-map ;
+GENERIC: vabs ( u -- v )
+M: object vabs [ abs ] map ;
-: vabs ( u -- v ) [ abs ] map ;
-: vsqrt ( u -- v ) [ >float fsqrt ] map ;
+GENERIC: vsqrt ( u -- v )
+M: object vsqrt [ >float fsqrt ] map ;
<PRIVATE
-: fp-bitwise-op ( x y seq quot -- z )
- swap element-type {
- { c:double [ [ [ double>bits ] bi@ ] dip call bits>double ] }
- { c:float [ [ [ float>bits ] bi@ ] dip call bits>float ] }
- [ drop call ]
- } case ; inline
-
-: fp-bitwise-unary ( x seq quot -- z )
- swap element-type {
- { c:double [ [ double>bits ] dip call bits>double ] }
- { c:float [ [ float>bits ] dip call bits>float ] }
- [ drop call ]
- } case ; inline
-
-: element>bool ( x seq -- ? )
- element-type [ [ f ] when-zero ] when ; inline
-
: bitandn ( x y -- z ) [ bitnot ] dip bitand ; inline
-GENERIC: new-underlying ( underlying seq -- seq' )
-
-: change-underlying ( seq quot -- seq' )
- '[ underlying>> @ ] keep new-underlying ; inline
-
PRIVATE>
-: vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ;
-: vbitandn ( u v -- w ) over '[ _ [ bitandn ] fp-bitwise-op ] 2map ;
-: vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ;
-: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
-: vbitnot ( u -- w ) dup '[ _ [ bitnot ] fp-bitwise-unary ] map ;
-
-:: vbroadcast ( u n -- v ) u length n u nth <repetition> u like ;
-
-: vshuffle-elements ( u perm -- v )
+GENERIC: vbitand ( u v -- w )
+M: object vbitand [ bitand ] 2map ;
+GENERIC: vbitandn ( u v -- w )
+M: object vbitandn [ bitandn ] 2map ;
+GENERIC: vbitor ( u v -- w )
+M: object vbitor [ bitor ] 2map ;
+GENERIC: vbitxor ( u v -- w )
+M: object vbitxor [ bitxor ] 2map ;
+GENERIC: vbitnot ( u -- w )
+M: object vbitnot [ bitnot ] map ;
+
+GENERIC# vbroadcast 1 ( u n -- v )
+M:: object vbroadcast ( u n -- v ) u length n u nth <repetition> u like ;
+
+GENERIC# vshuffle-elements 1 ( u perm -- v )
+M: object vshuffle-elements
over length 0 pad-tail
swap [ '[ _ nth ] ] keep map-as ;
-: vshuffle-bytes ( u perm -- v )
+GENERIC# vshuffle-bytes 1 ( u perm -- v )
+M: object vshuffle-bytes
underlying>> [
swap [ '[ 15 bitand _ nth ] ] keep map-as
] curry change-underlying ;
GENERIC: vshuffle ( u perm -- v )
M: array vshuffle ( u perm -- v )
vshuffle-elements ; inline
-M: simd-128 vshuffle ( u perm -- v )
- vshuffle-bytes ; inline
-: vlshift ( u n -- w ) '[ _ shift ] map ;
-: vrshift ( u n -- w ) neg '[ _ shift ] map ;
+GENERIC# vlshift 1 ( u n -- w )
+M: object vlshift '[ _ shift ] map ;
+GENERIC# vrshift 1 ( u n -- w )
+M: object vrshift neg '[ _ shift ] map ;
-: hlshift ( u n -- w ) '[ _ <byte-array> prepend 16 head ] change-underlying ;
-: hrshift ( u n -- w ) '[ _ <byte-array> append 16 tail* ] change-underlying ;
+GENERIC# hlshift 1 ( u n -- w )
+M: object hlshift '[ _ <byte-array> prepend 16 head ] change-underlying ;
+GENERIC# hrshift 1 ( u n -- w )
+M: object hrshift '[ _ <byte-array> append 16 tail* ] change-underlying ;
-: (vmerge-head) ( u v -- h )
- over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ;
-: (vmerge-tail) ( u v -- t )
- over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ;
+GENERIC: (vmerge-head) ( u v -- h )
+M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ;
+GENERIC: (vmerge-tail) ( u v -- t )
+M: object (vmerge-tail) over length 2 /i '[ _ tail-slice ] bi@ [ zip ] keep concat-as ;
-: (vmerge) ( u v -- h t )
+GENERIC: (vmerge) ( u v -- h t )
+M: object (vmerge)
[ (vmerge-head) ] [ (vmerge-tail) ] 2bi ; inline
-: vmerge ( u v -- w ) [ zip ] keep concat-as ;
+GENERIC: vmerge ( u v -- w )
+M: object vmerge [ zip ] keep concat-as ;
-: vand ( u v -- w ) over '[ [ _ element>bool ] bi@ and ] 2map ;
-: vandn ( u v -- w ) over '[ [ _ element>bool ] bi@ [ not ] dip and ] 2map ;
-: vor ( u v -- w ) over '[ [ _ element>bool ] bi@ or ] 2map ;
-: vxor ( u v -- w ) over '[ [ _ element>bool ] bi@ xor ] 2map ;
-: vnot ( u -- w ) dup '[ _ element>bool not ] map ;
+GENERIC: vand ( u v -- w )
+M: object vand [ and ] 2map ;
-: vall? ( v -- ? ) dup '[ _ element>bool ] all? ;
-: vany? ( v -- ? ) dup '[ _ element>bool ] any? ;
-: vnone? ( v -- ? ) dup '[ _ element>bool not ] all? ;
+GENERIC: vandn ( u v -- w )
+M: object vandn [ [ not ] dip and ] 2map ;
-: v< ( u v -- w ) [ < ] 2map ;
-: v<= ( u v -- w ) [ <= ] 2map ;
-: v>= ( u v -- w ) [ >= ] 2map ;
-: v> ( u v -- w ) [ > ] 2map ;
-: vunordered? ( u v -- w ) [ unordered? ] 2map ;
-: v= ( u v -- w ) [ = ] 2map ;
+GENERIC: vor ( u v -- w )
+M: object vor [ or ] 2map ;
-: v? ( mask true false -- result )
+GENERIC: vxor ( u v -- w )
+M: object vxor [ xor ] 2map ;
+
+GENERIC: vnot ( u -- w )
+M: object vnot [ not ] map ;
+
+GENERIC: vall? ( v -- ? )
+M: object vall? [ ] all? ;
+
+GENERIC: vany? ( v -- ? )
+M: object vany? [ ] any? ;
+
+GENERIC: vnone? ( v -- ? )
+M: object vnone? [ not ] all? ;
+
+GENERIC: v< ( u v -- w )
+M: object v< [ < ] 2map ;
+
+GENERIC: v<= ( u v -- w )
+M: object v<= [ <= ] 2map ;
+
+GENERIC: v>= ( u v -- w )
+M: object v>= [ >= ] 2map ;
+
+GENERIC: v> ( u v -- w )
+M: object v> [ > ] 2map ;
+
+GENERIC: vunordered? ( u v -- w )
+M: object vunordered? [ unordered? ] 2map ;
+
+GENERIC: v= ( u v -- w )
+M: object v= [ = ] 2map ;
+
+GENERIC: v? ( mask true false -- result )
+M: object v?
[ vand ] [ vandn ] bi-curry* bi vor ; inline
:: vif ( mask true-quot false-quot -- result )
: vceiling ( u -- v ) [ ceiling ] map ;
: vtruncate ( u -- v ) [ truncate ] map ;
-: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ;
-: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ;
+: vsupremum ( seq -- vmax ) [ ] [ vmax ] map-reduce ; inline
+: vinfimum ( seq -- vmin ) [ ] [ vmin ] map-reduce ; inline
+
+GENERIC: v. ( u v -- x )
+M: object v. [ conjugate * ] [ + ] 2map-reduce ;
+
+GENERIC: norm-sq ( v -- x )
+M: object norm-sq [ absq ] [ + ] map-reduce ;
-: v. ( u v -- x ) [ conjugate * ] [ + ] 2map-reduce ;
-: norm-sq ( v -- x ) [ absq ] [ + ] map-reduce ;
-: norm ( v -- x ) norm-sq sqrt ;
-: normalize ( u -- v ) dup norm v/n ;
+GENERIC: norm ( v -- x )
+M: object norm norm-sq sqrt ;
-: distance ( u v -- x ) [ - absq ] [ + ] 2map-reduce sqrt ;
+: normalize ( u -- v ) dup norm v/n ; inline
+
+GENERIC: distance ( u v -- x )
+M: object distance [ - absq ] [ + ] 2map-reduce sqrt ;
: set-axis ( u v axis -- w )
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
: v~ ( a b epsilon -- ? )
[ ~ ] curry 2all? ; inline
-HINTS: vneg { array } ;
-HINTS: norm-sq { array } ;
-HINTS: norm { array } ;
-HINTS: normalize { array } ;
-HINTS: distance { array array } ;
-
-HINTS: n*v { object array } ;
-HINTS: v*n { array object } ;
-HINTS: n/v { array } ;
-HINTS: v/n { array object } ;
-
-HINTS: v+ { array array } ;
-HINTS: v- { array array } ;
-HINTS: v* { array array } ;
-HINTS: v/ { array array } ;
-HINTS: vmax { array array } ;
-HINTS: vmin { array array } ;
-HINTS: v. { array array } ;
+HINTS: M\ object vneg { array } ;
+HINTS: M\ object norm-sq { array } ;
+HINTS: M\ object norm { array } ;
+HINTS: M\ object distance { array array } ;
+
+HINTS: M\ object n*v { object array } ;
+HINTS: M\ object v*n { array object } ;
+HINTS: M\ object n/v { object array } ;
+HINTS: M\ object v/n { array object } ;
+
+HINTS: M\ object v+ { array array } ;
+HINTS: M\ object v- { array array } ;
+HINTS: M\ object v* { array array } ;
+HINTS: M\ object v/ { array array } ;
+HINTS: M\ object vmax { array array } ;
+HINTS: M\ object vmin { array array } ;
+HINTS: M\ object v. { array array } ;
HINTS: vlerp { array array array } ;
HINTS: vnlerp { array array object } ;
HINTS: bilerp { object object object object array } ;
HINTS: trilerp { object object object object object object object object array } ;
+
IN: specialized-arrays.mirrors
INSTANCE: specialized-array enumerated-sequence
-INSTANCE: simd-128 enumerated-sequence
-INSTANCE: simd-256 enumerated-sequence
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types alien.data alien.parser
assocs byte-arrays classes compiler.units functors kernel lexer
-libc math math.vectors math.vectors.private
-math.vectors.specialization namespaces
+libc math math.vectors math.vectors.private namespaces
parser prettyprint.custom sequences sequences.private strings
summary vocabs vocabs.loader vocabs.parser vocabs.generated
words fry combinators make ;
[ drop \ T bad-byte-array-length ] unless
<direct-A> ; inline
-M: A new-underlying drop byte-array>A ;
-
M: A clone [ underlying>> clone ] [ length>> ] bi <direct-A> ; inline
M: A length length>> ; inline
M: A byte-length length \ T heap-size * ; inline
-M: A element-type drop \ T ; inline
-
M: A direct-array-syntax drop \ A@ ;
M: A pprint-delims drop \ A{ \ } ;
INSTANCE: A specialized-array
-A T c-type-boxed-class f specialize-vector-words
-
;FUNCTOR
GENERIC: (underlying-type) ( c-type -- c-type' )
: create-method-in ( class generic -- method )
create-method dup set-word dup save-location ;
+: define-inline-method ( class generic quot -- )
+ [ create-method-in ] dip [ define ] [ drop make-inline ] 2bi ;
+
: CREATE-METHOD ( -- method )
scan-word bootstrap-word scan-word create-method-in ;
: trim ( seq quot -- newseq )
[ trim-slice ] [ drop ] 2bi like ; inline
-: sum ( seq -- n ) 0 [ + ] binary-reduce ;
+GENERIC: sum ( seq -- n )
+M: object sum 0 [ + ] binary-reduce ; inline
: product ( seq -- n ) 1 [ * ] binary-reduce ;
projects / factor.git / commitdiff