diff --git a/basis/math/vectors/simd/functor/authors.txt b/basis/math/vectors/simd/functor/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/math/vectors/simd/functor/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/math/vectors/simd/functor/functor.factor b/basis/math/vectors/simd/functor/functor.factor deleted file mode 100644 index 480981d165..0000000000 --- a/basis/math/vectors/simd/functor/functor.factor +++ /dev/null @@ -1,522 +0,0 @@ -! 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" } ; - -: 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: - byte-array >>class - class >>boxed-class - [ rep alien-vector class boa ] >>getter - [ [ underlying>> ] 2dip rep set-alien-vector ] >>setter - 16 >>size - 8 >>align - 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 ] } ; - -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 \ 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 - -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: - 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 - 8 >>align - 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 ] read-only } -{ underlying2 byte-array initial: $[ 16 ] 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 16 \ 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 diff --git a/basis/math/vectors/simd/intrinsics/authors.txt b/basis/math/vectors/simd/intrinsics/authors.txt deleted file mode 100644 index d4f5d6b3ae..0000000000 --- a/basis/math/vectors/simd/intrinsics/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Slava Pestov \ No newline at end of file diff --git a/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor b/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor deleted file mode 100644 index 84eee935a0..0000000000 --- a/basis/math/vectors/simd/intrinsics/intrinsics-tests.factor +++ /dev/null @@ -1,18 +0,0 @@ -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 - - diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor deleted file mode 100644 index 003b42fe83..0000000000 --- a/basis/math/vectors/simd/intrinsics/intrinsics.factor +++ /dev/null @@ -1,207 +0,0 @@ -! 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 ; -: simd-conversion-effect ( word -- effect ) - stack-effect [ in>> but-last "rep" suffix ] [ out>> ] bi ; - -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 ] dip rep-size memory>byte-array ; - -: set-alien-vector ( value c-ptr n rep -- ) - ! Inefficient version for when intrinsics are missing - [ swap 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? ; diff --git a/basis/math/vectors/specialization/specialization-tests.factor b/basis/math/vectors/specialization/specialization-tests.factor deleted file mode 100644 index f4d4fd93e8..0000000000 --- a/basis/math/vectors/specialization/specialization-tests.factor +++ /dev/null @@ -1,28 +0,0 @@ -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 diff --git a/basis/math/vectors/specialization/specialization.factor b/basis/math/vectors/specialization/specialization.factor deleted file mode 100644 index 602fd9802c..0000000000 --- a/basis/math/vectors/specialization/specialization.factor +++ /dev/null @@ -1,207 +0,0 @@ -! 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 ] - [ [ , \ declare , def>> % ] [ ] make ] - [ drop stack-effect ] - 2tri - [ define-declared ] [ 2drop ] 3bi ; - -: output-infos ( array-type elt-type schema -- value-infos ) - [ - { - { +vector+ [ drop ] } - { +any-vector+ [ drop parent-vector-class ] } - { +scalar+ [ nip ] } - { +boolean+ [ 2drop boolean ] } - { - +nonnegative+ - [ - nip - dup complex class<= [ drop float ] when - [0,inf] - ] - } - } 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