make math.vectors.simd tests pass again

diff --git a/basis/compiler/cfg/intrinsics/simd/simd.factor b/basis/compiler/cfg/intrinsics/simd/simd.factor
index a96a0b7cb31f7a11ac31e0ccc95c1298ccfd1301..109ac6ce8e12a25d70aa9c0c5ddec34fad78edea 100644 (file)
--- a/basis/compiler/cfg/intrinsics/simd/simd.factor
+++ b/basis/compiler/cfg/intrinsics/simd/simd.factor
@@ -253,14 +253,15 @@ IN: compiler.cfg.intrinsics.simd
             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)
+            head tail wide-rep ^^add-vector wide-rep
+            ^(sum-vector)
         ] }
     } v-vector-op ;
 
 : shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
 
-: ^shuffle-vector-imm ( src1 src2 rep -- dst )
-    {
+: ^shuffle-vector-imm ( src1 shuffle rep -- dst )
+    [ rep-length 0 pad-tail ] keep {
         [ ^^shuffle-vector-imm ]
         [ [ ^load-immediate-shuffle ] [ ^^shuffle-vector ] bi ]
     } vl-vector-op ;
@@ -358,7 +359,7 @@ IN: compiler.cfg.intrinsics.simd
 : emit-simd-v. ( node -- )
     {
         [ ^^dot-vector ]
-        [ [ ^^mul-vector ] [ ^sum-vector ] bi ]
+        { float-vector-rep [ [ ^^mul-vector ] [ ^sum-vector ] bi ] }
     } emit-vv-vector-op ;
 
 : emit-simd-vsqrt ( node -- )

diff --git a/basis/math/vectors/simd/intrinsics/intrinsics.factor b/basis/math/vectors/simd/intrinsics/intrinsics.factor
index a236db00c940f6ee64ab7c3591970a23e2710b76..187c6db586027046eb98d80401e6e426fc4697dc 100644 (file)
--- a/basis/math/vectors/simd/intrinsics/intrinsics.factor
+++ b/basis/math/vectors/simd/intrinsics/intrinsics.factor
@@ -112,8 +112,8 @@ IN: math.vectors.simd.intrinsics
     a rep >rep-array :> a'
     rep <rep-array> :> c'
     elts [| from to |
-        from a' nth-unsafe
-        rep rep-length 1 - bitand
+        from rep rep-length 1 - bitand
+           a' nth-unsafe
         to c' set-nth-unsafe
     ] each-index
     c' underlying>> ; inline
@@ -134,9 +134,12 @@ PRIVATE>
         n 1 + c' set-nth-unsafe
     ] each
     c' underlying>> ;
-: (simd-vs+)               ( a b rep -- c ) dup '[ + _ c-type-clamp ] components-2map ;
-: (simd-vs-)               ( a b rep -- c ) dup '[ - _ c-type-clamp ] components-2map ;
-: (simd-vs*)               ( a b rep -- c ) dup '[ - _ c-type-clamp ] components-2map ;
+: (simd-vs+)               ( a b rep -- c )
+    dup rep-component-type '[ + _ c-type-clamp ] components-2map ;
+: (simd-vs-)               ( a b rep -- c )
+    dup rep-component-type '[ - _ c-type-clamp ] components-2map ;
+: (simd-vs*)               ( a b rep -- c )
+    dup rep-component-type '[ * _ c-type-clamp ] components-2map ;
 : (simd-v*)                ( a b rep -- c ) [ * ] components-2map ;
 : (simd-v/)                ( a b rep -- c ) [ / ] components-2map ;
 : (simd-vmin)              ( a b rep -- c ) [ min ] components-2map ;
@@ -160,9 +163,9 @@ PRIVATE>
 : (simd-vlshift)           ( a n rep -- c ) swap '[ _ shift ] bitwise-components-map ;
 : (simd-vrshift)           ( a n rep -- c ) swap '[ _ neg shift ] bitwise-components-map ;
 : (simd-hlshift)           ( a n rep -- c )
-    drop tail-slice 16 0 pad-tail ;
+    drop head-slice* 16 0 pad-head ;
 : (simd-hrshift)           ( a n rep -- c )
-    drop head-slice 16 0 pad-head ;
+    drop tail-slice 16 0 pad-tail ;
 : (simd-vshuffle-elements) ( a n rep -- c ) [ rep-length 0 pad-tail ] keep (vshuffle) ;
 : (simd-vshuffle-bytes)    ( a b rep -- c ) drop uchar-16-rep (vshuffle) ;
 :: (simd-vmerge-head)      ( a b rep -- c )
@@ -198,17 +201,17 @@ PRIVATE>
 : (simd-vall?)             ( a   rep -- ? ) [ bitand ] bitwise-components-reduce zero? not ;
 : (simd-vnone?)            ( a   rep -- ? ) [ bitor  ] bitwise-components-reduce zero?     ;
 : (simd-v>float)           ( a   rep -- c )
-    [ >rep-array ] [ >float-vector-rep [>rep-array] ] bi call( i -- f ) ;
+    [ >rep-array ] [ >float-vector-rep [>rep-array] ] bi call( i -- f ) underlying>> ;
 : (simd-v>integer)         ( a   rep -- c )
-    [ >rep-array ] [ >int-vector-rep [>rep-array] ] bi call( i -- f ) ;
+    [ >rep-array ] [ >int-vector-rep [>rep-array] ] bi call( i -- f ) underlying>> ;
 : (simd-vpack-signed)      ( a b rep -- c )
     [ 2>rep-array cord-append ]
     [ narrow-vector-rep [ [<rep-array>] ] [ rep-component-type ] bi ] bi
-    '[ _ c-type-clamp ] swap map-as ;
+    '[ _ c-type-clamp ] swap map-as underlying>> ;
 : (simd-vpack-unsigned)    ( a b rep -- c )
     [ 2>rep-array cord-append ]
     [ narrow-vector-rep >uint-vector-rep [ [<rep-array>] ] [ rep-component-type ] bi ] bi
-    '[ _ c-type-clamp ] swap map-as ;
+    '[ _ c-type-clamp ] swap map-as underlying>> ;
 : (simd-vunpack-head)      ( a   rep -- c ) 
     [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
     [ head-slice ] dip call( a' -- c' ) underlying>> ;
@@ -216,7 +219,8 @@ PRIVATE>
     [ >rep-array ] [ widen-vector-rep [ rep-length ] [ [>rep-array] ] bi ] bi
     [ tail-slice ] dip call( a' -- c' ) underlying>> ;
 : (simd-with)              (   n rep -- v )
-    [ rep-length iota swap '[ _ ] ] [ <rep-array> ] bi replicate-as ;
+    [ rep-length iota swap '[ _ ] ] [ <rep-array> ] bi replicate-as 
+    underlying>> ;
 : (simd-gather-2)          ( m n rep -- v ) <rep-array> [ 2 set-firstn ] keep underlying>> ;
 : (simd-gather-4)          ( m n o p rep -- v ) <rep-array> [ 4 set-firstn ] keep underlying>> ;
 : (simd-select)            ( a n rep -- x ) [ swap ] dip >rep-array nth-unsafe ;

diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor
index 1fb947921ca21614ea0badd603f045798a9d0075..b5905893454d8af3e50ebd77f836408769a4bac2 100644 (file)
--- a/basis/math/vectors/simd/simd-tests.factor
+++ b/basis/math/vectors/simd/simd-tests.factor
@@ -5,7 +5,8 @@ math.vectors.simd.private prettyprint random sequences system
 tools.test vocabs assocs compiler.cfg.debugger words
 locals combinators cpu.architecture namespaces byte-arrays alien
 specialized-arrays classes.struct eval classes.algebra sets
-quotations math.constants compiler.units ;
+quotations math.constants compiler.units splitting ;
+FROM: math.vectors.simd.intrinsics => alien-vector set-alien-vector ;
 QUALIFIED-WITH: alien.c-types c
 SPECIALIZED-ARRAY: c:float
 IN: math.vectors.simd.tests
@@ -261,8 +262,8 @@ simd-classes&reps [
 
 : check-boolean-ops ( class elt-class compare-quot -- seq )
     [
-        [ boolean-ops [ dup word-schema ] { } map>assoc ] 2dip
-        '[ first2 inputs _ _ check-boolean-op ]
+        [ boolean-ops [ dup vector-words at ] { } map>assoc ] 2dip
+        '[ first2 vector-word-inputs _ _ check-boolean-op ]
     ] dip check-optimizer ; inline
 
 simd-classes&reps [
@@ -558,7 +559,7 @@ STRUCT: simd-struct
 [ ] [ char-16 new 1array stack. ] unit-test
 
 ! CSSA bug
-[ 8000000 ] [
+[ 4000000 ] [
     int-4{ 1000 1000 1000 1000 }
     [ { int-4 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
 ] unit-test

diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor
index 5289f3f393f25a75843fa180fae721053fac3d57..bde69b5dbded1507027b3326b2ca9086cca979df 100644 (file)
--- a/basis/math/vectors/simd/simd.factor
+++ b/basis/math/vectors/simd/simd.factor
@@ -49,6 +49,9 @@ TUPLE: simd-128
 GENERIC: simd-element-type ( obj -- c-type )
 GENERIC: simd-rep ( simd -- rep )
 
+M: object simd-element-type drop f ;
+M: object simd-rep drop f ;
+
 <<
 <PRIVATE
 
@@ -62,9 +65,6 @@ DEFER: simd-construct-op
     [ 3dup [ drop [ simd-128? ] both? ] [ '[ simd-rep _ eq? ] both? ] 3bi and ]
     2dip if ; inline
 
-: simd-construct-op ( exemplar quot: ( rep -- v ) -- v )
-    [ dup simd-rep ] dip curry make-underlying ; inline
-
 : simd-unbox ( a -- a (a) )
     [ ] [ underlying>> ] bi ; inline
 
@@ -74,6 +74,9 @@ DEFER: simd-construct-op
 : vn->v-op ( a n rep quot: ( (a) n rep -- (c) ) fallback-quot -- c )
     drop [ simd-unbox ] 3dip 3curry make-underlying ; inline
 
+: vn->n-op ( a n rep quot: ( (a) n rep -- n ) fallback-quot -- n )
+    drop [ underlying>> ] 3dip call ; inline
+
 : v->n-op ( a rep quot: ( (a) rep -- n ) fallback-quot -- n )
     drop [ underlying>> ] 2dip call ; inline
 
@@ -95,9 +98,6 @@ DEFER: simd-construct-op
 PRIVATE>
 >>
 
-DEFER: simd-with
-DEFER: simd-cast
-
 <<
 <PRIVATE
 
@@ -113,8 +113,9 @@ A-with DEFINES       ${T}-with
 A-cast DEFINES       ${T}-cast
 A{     DEFINES       ${T}{
 
-ELT   [ A-rep rep-component-type ]
-N     [ A-rep rep-length ]
+ELT     [ A-rep rep-component-type ]
+N       [ A-rep rep-length ]
+COERCER [ ELT c-type-class "coercer" word-prop [ ] or ]
 
 SET-NTH [ ELT dup c:c-setter c:array-accessor ]
 
@@ -136,8 +137,8 @@ M: A set-nth-unsafe
 
 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-with ( n -- v ) COERCER call \ A-rep (simd-with) \ A boa ; inline
+: A-cast ( v -- v' ) underlying>> \ A boa ; inline
 
 ! SIMD vectors as sequences
 
@@ -145,24 +146,7 @@ M: A hashcode* underlying>> hashcode* ; inline
 M: A clone [ clone ] change-underlying ; inline
 M: A length drop N ; inline
 M: A nth-unsafe
-    swap {
-        {  0 [  0 \ A-rep (simd-select) ] }
-        {  1 [  1 \ A-rep (simd-select) ] }
-        {  2 [  2 \ A-rep (simd-select) ] }
-        {  3 [  3 \ A-rep (simd-select) ] }
-        {  4 [  4 \ A-rep (simd-select) ] }
-        {  5 [  5 \ A-rep (simd-select) ] }
-        {  6 [  6 \ A-rep (simd-select) ] }
-        {  7 [  7 \ A-rep (simd-select) ] }
-        {  8 [  8 \ A-rep (simd-select) ] }
-        {  9 [  9 \ A-rep (simd-select) ] }
-        { 10 [ 10 \ A-rep (simd-select) ] }
-        { 11 [ 11 \ A-rep (simd-select) ] }
-        { 12 [ 12 \ A-rep (simd-select) ] }
-        { 13 [ 13 \ A-rep (simd-select) ] }
-        { 14 [ 14 \ A-rep (simd-select) ] }
-        { 15 [ 15 \ A-rep (simd-select) ] }
-    } case ; inline 
+    swap \ A-rep [ (simd-select) ] [ call-next-method ] vn->n-op ; inline
 M: A c:byte-length drop 16 ; inline
 
 M: A new-sequence
@@ -171,7 +155,7 @@ M: A new-sequence
     [ length bad-simd-length ] if ; inline
 
 M: A equal?
-    \ A [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline
+    \ A-rep [ drop v= vall? ] [ 3drop f ] if-both-vectors-match ; inline
 
 ! SIMD primitive operations
 
@@ -205,7 +189,7 @@ M: A vrshift           \ A-rep [ (simd-vrshift)           ] [ call-next-method ]
 M: A hlshift           \ A-rep [ (simd-hlshift)           ] [ call-next-method ] vn->v-op ; inline
 M: A hrshift           \ A-rep [ (simd-hrshift)           ] [ call-next-method ] vn->v-op ; inline
 M: A vshuffle-elements \ A-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vn->v-op ; inline
-M: A vshuffle-bytes    \ A-rep [ (simd-vshuffle-bytes)    ] [ call-next-method ] vv->v-op ; inline
+M: A vshuffle-bytes    \ A-rep [ (simd-vshuffle-bytes)    ] [ call-next-method ] vv'->v-op ; inline
 M: A (vmerge-head)     \ A-rep [ (simd-vmerge-head)       ] [ call-next-method ] vv->v-op ; inline
 M: A (vmerge-tail)     \ A-rep [ (simd-vmerge-tail)       ] [ call-next-method ] vv->v-op ; inline
 M: A v<=               \ A-rep [ (simd-v<=)               ] [ call-next-method ] vv->v-op ; inline
@@ -220,15 +204,15 @@ M: A vnone?            \ A-rep [ (simd-vnone?)            ] [ call-next-method ]
 
 ! SIMD high-level specializations
 
-M: A vbroadcast [ swap nth ] keep simd-with ; inline
-M: A n+v [ simd-with ] keep v+ ; inline
-M: A n-v [ simd-with ] keep v- ; inline
-M: A n*v [ simd-with ] keep v* ; inline
-M: A n/v [ simd-with ] keep v/ ; inline
-M: A v+n over simd-with v+ ; inline
-M: A v-n over simd-with v- ; inline
-M: A v*n over simd-with v* ; inline
-M: A v/n over simd-with v/ ; inline
+M: A vbroadcast swap nth A-with ; inline
+M: A n+v [ A-with ] dip v+ ; inline
+M: A n-v [ A-with ] dip v- ; inline
+M: A n*v [ A-with ] dip v* ; inline
+M: A n/v [ A-with ] dip v/ ; inline
+M: A v+n A-with v+ ; inline
+M: A v-n A-with v- ; inline
+M: A v*n A-with v* ; inline
+M: A v/n A-with v/ ; inline
 M: A norm-sq dup v. assert-positive ; inline
 M: A norm      norm-sq sqrt ; inline
 M: A distance  v- norm ; inline
@@ -236,11 +220,13 @@ M: A distance  v- norm ; inline
 ! M: simd-128 >pprint-sequence ;
 ! M: simd-128 pprint* pprint-object ;
 
-\ A-boa \ A new N {
-    { 2 [ '[ _ [ (simd-gather-2) ] simd-construct-op ] ] }
-    { 4 [ '[ _ [ (simd-gather-4) ] simd-construct-op ] ] }
-    [ swap '[ _ _ nsequence ] ]
-} case BOA-EFFECT define-inline
+\ A-boa
+[ COERCER N napply ] N {
+    { 2 [ [ A-rep (simd-gather-2) A boa ] ] }
+    { 4 [ [ A-rep (simd-gather-4) A boa ] ] }
+    [ \ A new '[ _ _ nsequence ] ]
+} case compose
+BOA-EFFECT define-inline
 
 M: A pprint-delims drop \ A{ \ } ;
 SYNTAX: A{ \ } [ >A ] parse-literal ;
@@ -248,7 +234,7 @@ SYNTAX: A{ \ } [ >A ] parse-literal ;
 c:<c-type>
     byte-array >>class
     A >>boxed-class
-    [ A-rep alien-vector \ A boa ] >>getter
+    [ A-rep alien-vector A boa ] >>getter
     [ [ underlying>> ] 2dip A-rep set-alien-vector ] >>setter
     16 >>size
     16 >>align
@@ -266,21 +252,6 @@ PRIVATE>
 
 INSTANCE: simd-128 sequence
 
-! SIMD constructors
-
-: simd-with ( n seq -- v )
-    [ (simd-with) ] simd-construct-op ; inline
-
-MACRO: simd-boa ( class -- )
-    new dup length {
-        { 2 [ '[ _ [ (simd-gather-2) ] simd-construct-op ] ] }
-        { 4 [ '[ _ [ (simd-gather-4) ] simd-construct-op ] ] }
-        [ swap '[ _ _ nsequence ] ]
-    } case ;
-
-: simd-cast ( v seq -- v' )
-    [ underlying>> ] dip new-underlying ; inline
-
 ! SIMD instances
 
 SIMD-128: char-16

diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor
index d524ba309fc96d1f17d3da81929678d20322d6d9..c0b129e6d27e546c52d5b23259f203e23ce0bf18 100644 (file)
--- a/basis/math/vectors/vectors.factor
+++ b/basis/math/vectors/vectors.factor
@@ -108,10 +108,6 @@ M: object vshuffle-elements
     swap [ '[ _ nth ] ] keep map-as ;
 
 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 )
@@ -123,9 +119,7 @@ GENERIC# vrshift 1 ( u n -- w )
 M: object vrshift neg '[ _ shift ] map ;
 
 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 ;
 
 GENERIC: (vmerge-head) ( u v -- h )
 M: object (vmerge-head) over length 2 /i '[ _ head-slice ] bi@ [ zip ] keep concat-as ;