math.vectors.simd: vlshift, vrshift, hlshift and hrshift were being miscompiled if...

diff --git a/basis/math/vectors/simd/simd-tests.factor b/basis/math/vectors/simd/simd-tests.factor
index 264dbbce595fef88e42759faa320bec068cc374b..79c9047a0ea97d0eadde5844f34fc6053d7b9dbd 100644 (file)
--- a/basis/math/vectors/simd/simd-tests.factor
+++ b/basis/math/vectors/simd/simd-tests.factor
@@ -124,7 +124,14 @@ CONSTANT: vector-words
 : boa-ctors ( -- seq )
     simd-classes [ [ name>> "-boa" append ] [ vocabulary>> ] bi lookup ] map ;
 
-: check-optimizer ( seq quot eq-quot -- failures )
+: check-optimizer ( seq test-quot eq-quot -- failures )
+    #! Use test-quot to generate a bunch of test cases from the
+    #! given inputs. Run each test case optimized and
+    #! unoptimized. Compare results with eq-quot.
+    #!
+    #! seq: sequence of inputs
+    #! test-quot: ( input -- input-quot: ( -- values ) code-quot: ( values -- result ) )
+    #! eq-quot: ( result1 result2 -- ? )
     dup '[
         @
         [ dup [ class-of ] { } map-as ] dip '[ _ declare @ ]
@@ -320,6 +327,9 @@ simd-classes&reps [
 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } [ { char-16 } declare 1 hlshift ] compile-call ] unit-test
 
+[ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
+[ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } [ { char-16 } declare 1 >bignum hlshift ] compile-call ] unit-test
+
 [ char-16{ 0 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 } ]
 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 [ { char-16 fixnum } declare hlshift ] compile-call ] unit-test
 
@@ -329,9 +339,21 @@ simd-classes&reps [
 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } [ { char-16 } declare 1 hrshift ] compile-call ] unit-test
 
+[ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
+[ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } [ { char-16 } declare 1 >bignum hrshift ] compile-call ] unit-test
+
 [ char-16{ 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 0 } ]
 [ char-16{ 1 2 4 8 1 2 4 8 1 2 4 8 1 2 4 8 } 1 [ { char-16 fixnum } declare hrshift ] compile-call ] unit-test
 
+[ int-4{ 4 8 12 16 } ]
+[ int-4{ 1 2 3 4 } 2 vlshift ] unit-test
+
+[ int-4{ 4 8 12 16 } ]
+[ int-4{ 1 2 3 4 } 2 [ { int-4 fixnum } declare vlshift ] compile-call ] unit-test
+
+[ int-4{ 4 8 12 16 } ]
+[ int-4{ 1 2 3 4 } 2 >bignum [ { int-4 bignum } declare vlshift ] compile-call ] unit-test
+
 ! Invalid inputs should not cause the compiler to throw errors
 [ ] [
     [ [ { int-4 } declare t hrshift ] ( a -- b ) define-temp drop ] with-compilation-unit
@@ -510,7 +532,7 @@ TUPLE: inconsistent-vector-test bool branch ;
 
 ! Test element access -- it should box bignums for int-4 on x86
 : test-accesses ( seq -- failures )
-    [ length iota >array ] keep
+    [ length iota dup [ >bignum ] map append ] keep
     '[ [ _ 1quotation ] dip '[ _ swap nth ] ] [ = ] check-optimizer ; inline
 
 [ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-accesses ] unit-test

diff --git a/basis/math/vectors/simd/simd.factor b/basis/math/vectors/simd/simd.factor
index dcd200ee0841d671459821f3e7290aeda01b9195..a0d949fb6860c5d6dcf00a0fcfdbb3b00cc8a5af 100644 (file)
--- a/basis/math/vectors/simd/simd.factor
+++ b/basis/math/vectors/simd/simd.factor
@@ -75,35 +75,40 @@ DEFER: simd-construct-op
 : v->v-op ( a rep quot: ( (a) rep -- (c) ) fallback-quot -- c )
     drop [ simd-unbox ] 2dip 2curry make-underlying ; inline
 
-: vn->v-op ( a n rep quot: ( (a) n rep -- (c) ) fallback-quot -- c )
+: vx->v-op ( a obj rep quot: ( (a) obj 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 )
+: vn->v-op ( a n rep quot: ( (a) n rep -- (c) ) fallback-quot -- c )
+    drop [ [ simd-unbox ] [ >fixnum ] bi* ] 2dip 3curry make-underlying ; inline
+
+: vx->x-op ( a obj rep quot: ( (a) obj rep -- obj ) fallback-quot -- obj )
     drop [ underlying>> ] 3dip call ; inline
 
-: v->n-op ( a rep quot: ( (a) rep -- n ) fallback-quot -- n )
+: v->x-op ( a rep quot: ( (a) rep -- obj ) fallback-quot -- obj )
     drop [ underlying>> ] 2dip call ; inline
 
 : (vv->v-op) ( a b rep quot: ( (a) (b) rep -- (c) ) -- c )
     [ [ simd-unbox ] [ underlying>> ] bi* ] 2dip 3curry make-underlying ; inline
-: (vv->n-op) ( a b rep quot: ( (a) (b) rep -- n ) -- n )
+
+: (vv->x-op) ( a b rep quot: ( (a) (b) rep -- n ) -- n )
     [ [ underlying>> ] bi@ ] 2dip 3curry call ; inline
-: (vvn->v-op) ( a b n rep quot: ( (a) (b) n rep -- (c) ) -- c )
+
+: (vvx->v-op) ( a b obj rep quot: ( (a) (b) obj rep -- (c) ) -- c )
     [ [ simd-unbox ] [ underlying>> ] bi* ] 3dip 2curry 2curry make-underlying ; inline
     
 : vv->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
     [ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
 
-:: vvn->v-op ( a b n rep quot: ( (a) (b) n rep -- (c) ) fallback-quot -- c )
+:: vvx->v-op ( a b obj rep quot: ( (a) (b) obj rep -- (c) ) fallback-quot -- c )
     a b rep
-    [ n swap quot (vvn->v-op) ]
-    [ drop n fallback-quot call ] if-both-vectors-match ; inline
+    [ obj swap quot (vvx->v-op) ]
+    [ drop obj fallback-quot call ] if-both-vectors-match ; inline
 
 : vv'->v-op ( a b rep quot: ( (a) (b) rep -- (c) ) fallback-quot -- c )
     [ '[ _ (vv->v-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors ; inline
 
-: vv->n-op ( a b rep quot: ( (a) (b) rep -- n ) fallback-quot -- n )
-    [ '[ _ (vv->n-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
+: vv->x-op ( a b rep quot: ( (a) (b) rep -- obj ) fallback-quot -- obj )
+    [ '[ _ (vv->x-op) ] ] [ '[ drop @ ] ] bi* if-both-vectors-match ; inline
 
 PRIVATE>
 >>
@@ -153,13 +158,13 @@ M: simd-128 vmin
 M: simd-128 vmax
     dup simd-rep [ (simd-vmax)              ] [ call-next-method ] vv->v-op ; inline
 M: simd-128 v.
-    dup simd-rep [ (simd-v.)                ] [ call-next-method ] vv->n-op ; inline
+    dup simd-rep [ (simd-v.)                ] [ call-next-method ] vv->x-op ; inline
 M: simd-128 vsad
-    dup simd-rep [ (simd-vsad)              ] [ call-next-method ] vv->n-op ; inline
+    dup simd-rep [ (simd-vsad)              ] [ call-next-method ] vv->x-op ; inline
 M: simd-128 vsqrt
     dup simd-rep [ (simd-vsqrt)             ] [ call-next-method ] v->v-op  ; inline
 M: simd-128 sum
-    dup simd-rep [ (simd-sum)               ] [ call-next-method ] v->n-op  ; inline
+    dup simd-rep [ (simd-sum)               ] [ call-next-method ] v->x-op  ; inline
 M: simd-128 vabs
     dup simd-rep [ (simd-vabs)              ] [ call-next-method ] v->v-op  ; inline
 M: simd-128 vbitand
@@ -191,9 +196,9 @@ M: simd-128 hlshift
 M: simd-128 hrshift
     over simd-rep [ (simd-hrshift)           ] [ call-next-method ] vn->v-op ; inline
 M: simd-128 vshuffle-elements
-    over simd-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vn->v-op ; inline
+    over simd-rep [ (simd-vshuffle-elements) ] [ call-next-method ] vx->v-op ; inline
 M: simd-128 vshuffle2-elements
-    over simd-rep [ (simd-vshuffle2-elements) ] [ call-next-method ] vvn->v-op ; inline
+    over simd-rep [ (simd-vshuffle2-elements) ] [ call-next-method ] vvx->v-op ; inline
 M: simd-128 vshuffle-bytes
     dup simd-rep [ (simd-vshuffle-bytes)    ] [ call-next-method ] vv'->v-op ; inline
 M: simd-128 (vmerge-head)
@@ -213,11 +218,11 @@ M: simd-128 v>=
 M: simd-128 vunordered?
     dup simd-rep [ (simd-vunordered?)       ] [ call-next-method ] vv->v-op ; inline
 M: simd-128 vany?
-    dup simd-rep [ (simd-vany?)             ] [ call-next-method ] v->n-op  ; inline
+    dup simd-rep [ (simd-vany?)             ] [ call-next-method ] v->x-op  ; inline
 M: simd-128 vall?
-    dup simd-rep [ (simd-vall?)             ] [ call-next-method ] v->n-op  ; inline
+    dup simd-rep [ (simd-vall?)             ] [ call-next-method ] v->x-op  ; inline
 M: simd-128 vnone?
-    dup simd-rep [ (simd-vnone?)            ] [ call-next-method ] v->n-op  ; inline
+    dup simd-rep [ (simd-vnone?)            ] [ call-next-method ] v->x-op  ; inline
 
 ! SIMD high-level specializations
 
@@ -266,7 +271,7 @@ M: A simd-element-type drop ELT ; inline
 M: A simd-with         drop A-with ; inline
 
 M: A nth-unsafe
-    swap \ A-rep [ (simd-select) ] [ call-next-method ] vn->n-op ; inline
+    swap \ A-rep [ (simd-select) ] [ call-next-method ] vx->x-op ; inline
 M: A set-nth-unsafe
     [ ELT boolean>element ] 2dip
     underlying>> ELT c:set-alien-element ; inline