implement vand, vor, vandn, and vxor as bitwise intrinsics for simd types

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -171,6 +171,10 @@ IN: compiler.cfg.intrinsics
         { 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-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-v=) [ [ cc= ^^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 ] }

basis/compiler/tree/propagation/simd/simd.factor

@@ -20,6 +20,10 @@ IN: compiler.tree.propagation.simd
     (simd-vbitandn)
     (simd-vbitor)
     (simd-vbitxor)
+    (simd-vand)
+    (simd-vandn)
+    (simd-vor)
+    (simd-vxor)
     (simd-vlshift)
     (simd-vrshift)
     (simd-hlshift)

basis/math/vectors/simd/intrinsics/intrinsics.factor

@@ -44,6 +44,10 @@ SIMD-OP: vbitand
 SIMD-OP: vbitandn
 SIMD-OP: vbitor
 SIMD-OP: vbitxor
+SIMD-OP: vand
+SIMD-OP: vandn
+SIMD-OP: vor
+SIMD-OP: vxor
 SIMD-OP: vlshift
 SIMD-OP: vrshift
 SIMD-OP: hlshift
@@ -125,6 +129,10 @@ M: vector-rep supported-simd-op?
         { \ (simd-vbitandn) [ %andn-vector-reps           ] }
         { \ (simd-vbitor)   [ %or-vector-reps             ] }
         { \ (simd-vbitxor)  [ %xor-vector-reps            ] }
+        { \ (simd-vand)     [ %and-vector-reps            ] }
+        { \ (simd-vandn)    [ %andn-vector-reps           ] }
+        { \ (simd-vor)      [ %or-vector-reps             ] }
+        { \ (simd-vxor)     [ %xor-vector-reps            ] }
         { \ (simd-vlshift)  [ %shl-vector-reps            ] }
         { \ (simd-vrshift)  [ %shr-vector-reps            ] }
         { \ (simd-hlshift)  [ %horizontal-shl-vector-reps ] }

basis/math/vectors/simd/simd-tests.factor

@@ -159,6 +159,12 @@ CONSTANT: simd-classes
 : remove-integer-words ( alist -- alist' )
     { vlshift vrshift } unique assoc-diff ;
 
+: boolean-ops ( -- words )
+    { vand vandn vor vxor } ;
+
+: remove-boolean-words ( alist -- alist' )
+    boolean-ops unique assoc-diff ;
+
 : remove-special-words ( alist -- alist' )
     ! These have their own tests later
     {
@@ -169,6 +175,7 @@ CONSTANT: simd-classes
 : ops-to-check ( elt-class -- alist )
     [ vector-words >alist ] dip
     float = [ remove-integer-words ] [ remove-float-words ] if
+    remove-boolean-words
     remove-special-words ;
 
 : check-vector-ops ( class elt-class compare-quot -- )
@@ -211,6 +218,30 @@ simd-classes&reps [
     [ [ { } ] ] dip first3 '[ _ _ _ check-vector-ops ] unit-test
 ] each
 
+"== Checking boolean operations" print
+
+: random-boolean-vector ( class -- vec )
+    new [ drop 2 random zero? ] map ;
+
+:: check-boolean-op ( word inputs class elt-class -- inputs quot )
+    inputs [
+        {
+            { +vector+ [ class random-boolean-vector ] }
+            { +scalar+ [ 1000 random elt-class float = [ >float ] when ] }
+        } case
+    ] [ ] map-as
+    word '[ _ execute ] ;
+
+: check-boolean-ops ( class elt-class compare-quot -- )
+    [
+        [ boolean-ops [ dup word-schema ] { } map>assoc ] 2dip
+        '[ first2 inputs _ _ check-boolean-op ]
+    ] dip check-optimizer ; inline
+
+simd-classes&reps [
+    [ [ { } ] ] dip first3 '[ _ _ _ check-boolean-ops ] unit-test
+] each
+
 "== Checking shifts and permutations" print
 
 [ int-4{ 256 512 1024 2048 } ]

basis/math/vectors/specialization/specialization.factor

@@ -86,6 +86,10 @@ H{
     { vbitandn { +vector+ +vector+ -> +vector+ } }
     { vbitor { +vector+ +vector+ -> +vector+ } }
     { vbitxor { +vector+ +vector+ -> +vector+ } }
+    { vand { +vector+ +vector+ -> +vector+ } }
+    { vandn { +vector+ +vector+ -> +vector+ } }
+    { vor { +vector+ +vector+ -> +vector+ } }
+    { vxor { +vector+ +vector+ -> +vector+ } }
     { vlshift { +vector+ +scalar+ -> +vector+ } }
     { vrshift { +vector+ +scalar+ -> +vector+ } }
     { hlshift { +vector+ +literal+ -> +vector+ } }

basis/math/vectors/vectors-docs.factor

@@ -329,6 +329,10 @@ HELP: vand
 { $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } }
 { $description "Takes the logical AND of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } ;
 
+HELP: vandn
+{ $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } }
+{ $description "Takes the logical AND-NOT of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } ", where " { $snippet "x AND-NOT y" } " is defined as " { $snippet "NOT(x) AND y" } "." } ;
+
 HELP: vor
 { $values { "u" "a sequence of booleans" } { "v" "a sequence of booleans" } { "w" "a sequence of booleans" } }
 { $description "Takes the logical OR of each corresponding element of " { $snippet "u" } " and " { $snippet "v" } "." } ;

basis/math/vectors/vectors.factor

@@ -7,6 +7,7 @@ QUALIFIED-WITH: alien.c-types c
 IN: math.vectors
 
 GENERIC: element-type ( obj -- c-type )
+M: object element-type drop f ; inline
 
 : vneg ( u -- v ) [ neg ] map ;
 
@@ -52,7 +53,7 @@ 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 ] }
+        { c:float  [ [ [ float>bits ] bi@ ] dip call bits>float   ] }
         [ drop call ]
     } case ; inline
 
@@ -63,6 +64,9 @@ PRIVATE>
         [ drop call ]
     } case ; inline
 
+: element>bool ( x seq -- ? )
+    element-type [ zero? not ] when ; inline
+
 : bitandn ( x y -- z ) [ bitnot ] dip bitand ; inline
 
 GENERIC: new-underlying ( underlying seq -- seq' )
@@ -87,10 +91,11 @@ PRIVATE>
 : hlshift ( u n -- w ) '[ _ <byte-array> prepend 16 head ] change-underlying ;
 : hrshift ( u n -- w ) '[ _ <byte-array> append 16 tail* ] change-underlying ;
 
-: vand ( u v -- w ) [ and ] 2map ;
-: vor  ( u v -- w ) [ or  ] 2map ;
-: vxor ( u v -- w ) [ xor ] 2map ;
-: vnot ( u -- w )   [ not ] map ;
+: 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 ;
 
 : vall? ( v -- ? ) [ ] all? ;
 : vany? ( v -- ? ) [ ] any? ;
@@ -104,7 +109,7 @@ PRIVATE>
 : v=  ( u v -- w ) [ =   ] 2map ;
 
 : v? ( mask true false -- w )
-    [ vbitand ] [ vbitandn ] bi-curry* bi vbitor ; inline
+    [ vand ] [ vandn ] bi-curry* bi vor ; inline
 
 : vfloor    ( u -- v ) [ floor ] map ;
 : vceiling  ( u -- v ) [ ceiling ] map ;