Merge branch 'master' of git://factorcode.org/git/factor into improved-aa

basis/compiler/cfg/comparisons/comparisons.factor

@@ -9,6 +9,9 @@ SYMBOLS:
     cc<  cc<=  cc=  cc>  cc>=  cc<>  cc<>= 
     cc/< cc/<= cc/= cc/> cc/>= cc/<> cc/<>= ;
 
+SYMBOLS:
+    vcc-all vcc-notall vcc-any vcc-none ;
+
 : negate-cc ( cc -- cc' )
     H{
         { cc<    cc/<   }
@@ -27,6 +30,14 @@ SYMBOLS:
         { cc/<>= cc<>=  }
     } at ;
 
+: negate-vcc ( cc -- cc' )
+    H{
+        { vcc-all vcc-notall }
+        { vcc-any vcc-none }
+        { vcc-none vcc-any }
+        { vcc-notall vcc-all }
+    } at ;
+
 : swap-cc ( cc -- cc' )
     H{
         { cc<   cc> }

basis/compiler/cfg/instructions/instructions.factor

@@ -276,6 +276,28 @@ def: dst
 use: src
 literal: shuffle rep ;
 
+PURE-INSN: ##compare-vector
+def: dst
+use: src1 src2
+literal: rep cc ;
+
+PURE-INSN: ##test-vector
+def: dst/int-rep
+use: src1
+temp: temp/int-rep
+literal: rep vcc ;
+
+INSN: ##test-vector-branch
+use: src1
+temp: temp/int-rep
+literal: rep vcc ;
+
+INSN: _test-vector-branch
+literal: label
+use: src1
+temp: temp/int-rep
+literal: rep vcc ;
+
 PURE-INSN: ##add-vector
 def: dst
 use: src1 src2

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-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 ] }
+        { math.vectors.simd.intrinsics:(simd-vnone?) [ [ vcc-none ^^test-vector ] emit-unary-vector-op ] }
         { math.vectors.simd.intrinsics:(simd-vlshift) [ [ ^^shl-vector ] emit-binary-vector-op ] }
         { math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-vector ] emit-binary-vector-op ] }
         { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector ] emit-horizontal-shift ] }

basis/compiler/cfg/linearization/linearization.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math accessors sequences namespaces make
 combinators assocs arrays locals layouts hashtables
-cpu.architecture
+cpu.architecture generalizations
 compiler.cfg
 compiler.cfg.comparisons
 compiler.cfg.stack-frame
@@ -42,14 +42,26 @@ M: ##branch linearize-insn
 
 : successors ( bb -- first second ) successors>> first2 ; inline
 
+:: conditional ( bb insn n conditional-quot negate-cc-quot -- bb successor label ... )
+    bb insn
+    conditional-quot
+    [ drop dup successors>> second useless-branch? ] 2bi
+    [ [ swap block-number ] n ndip ]
+    [ [ block-number ] n ndip negate-cc-quot call ] if ; inline
+
 : (binary-conditional) ( bb insn -- bb successor1 successor2 src1 src2 cc )
     [ dup successors ]
     [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
 
 : binary-conditional ( bb insn -- bb successor label2 src1 src2 cc )
-    [ (binary-conditional) ]
+    3 [ (binary-conditional) ] [ negate-cc ] conditional ;
-    [ drop dup successors>> second useless-branch? ] 2bi
+
-    [ [ swap block-number ] 3dip ] [ [ block-number ] 3dip negate-cc ] if ;
+: (test-vector-conditional) ( bb insn -- bb successor1 successor2 src1 temp rep vcc )
+    [ dup successors ]
+    [ { [ src1>> ] [ temp>> ] [ rep>> ] [ vcc>> ] } cleave ] bi* ; inline
+
+: test-vector-conditional ( bb insn -- bb successor label src1 temp rep vcc )
+    4 [ (test-vector-conditional) ] [ negate-vcc ] conditional ;
 
 M: ##compare-branch linearize-insn
     binary-conditional _compare-branch emit-branch ;
@@ -63,6 +75,9 @@ M: ##compare-float-ordered-branch linearize-insn
 M: ##compare-float-unordered-branch linearize-insn
     binary-conditional _compare-float-unordered-branch emit-branch ;
 
+M: ##test-vector-branch linearize-insn
+    test-vector-conditional _test-vector-branch emit-branch ;
+
 : overflow-conditional ( bb insn -- bb successor label2 dst src1 src2 )
     [ dup successors block-number ]
     [ [ dst>> ] [ src1>> ] [ src2>> ] tri ] bi* ; inline

basis/compiler/cfg/value-numbering/rewrite/rewrite.factor

@@ -40,6 +40,7 @@ M: insn rewrite drop f ;
         [ compare-imm-expr? ]
         [ compare-float-unordered-expr? ]
         [ compare-float-ordered-expr? ]
+        [ test-vector-expr? ]
     } 1|| ;
 
 : rewrite-boolean-comparison? ( insn -- ? )
@@ -53,12 +54,21 @@ M: insn rewrite drop f ;
 : >compare-imm-expr< ( expr -- in1 in2 cc )
     [ src1>> vn>vreg ] [ src2>> vn>constant ] [ cc>> ] tri ; inline
 
+: >test-vector-expr< ( expr -- src1 temp rep vcc )
+    {
+        [ src1>> vn>vreg ]
+        [ drop next-vreg ]
+        [ rep>> ]
+        [ vcc>> ]
+    } cleave ; inline
+
 : rewrite-boolean-comparison ( expr -- insn )
     src1>> vreg>expr {
         { [ dup compare-expr? ] [ >compare-expr< \ ##compare-branch new-insn ] }
         { [ dup compare-imm-expr? ] [ >compare-imm-expr< \ ##compare-imm-branch new-insn ] }
         { [ dup compare-float-unordered-expr? ] [ >compare-expr< \ ##compare-float-unordered-branch new-insn ] }
         { [ dup compare-float-ordered-expr? ] [ >compare-expr< \ ##compare-float-ordered-branch new-insn ] }
+        { [ dup test-vector-expr? ] [ >test-vector-expr< \ ##test-vector-branch new-insn ] }
     } cond ;
 
 : tag-fixnum-expr? ( expr -- ? )

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -14,6 +14,8 @@ IN: compiler.cfg.value-numbering.tests
             [ ##compare-imm? ]
             [ ##compare-float-unordered? ]
             [ ##compare-float-ordered? ]
+            [ ##test-vector? ]
+            [ ##test-vector-branch? ]
         } 1|| [ f >>temp ] when
     ] map ;
 
@@ -137,6 +139,22 @@ IN: compiler.cfg.value-numbering.tests
     } value-numbering-step trim-temps
 ] unit-test
 
+[
+    {
+        T{ ##peek f 1 D -1 }
+        T{ ##unbox-vector f 1111 1 float-4-rep }
+        T{ ##test-vector f 1 1111 f float-4-rep vcc-any }
+        T{ ##test-vector-branch f 1111 f float-4-rep vcc-any }
+    }
+] [
+    {
+        T{ ##peek f 1 D -1 }
+        T{ ##unbox-vector f 1111 1 float-4-rep }
+        T{ ##test-vector f 1 1111 2 float-4-rep vcc-any }
+        T{ ##compare-imm-branch f 1 5 cc/= }
+    } value-numbering-step trim-temps
+] unit-test
+
 ! Immediate operand conversion
 [
     {

basis/compiler/codegen/codegen.factor

@@ -163,6 +163,8 @@ CODEGEN: ##zero-vector %zero-vector
 CODEGEN: ##gather-vector-2 %gather-vector-2
 CODEGEN: ##gather-vector-4 %gather-vector-4
 CODEGEN: ##shuffle-vector %shuffle-vector
+CODEGEN: ##compare-vector %compare-vector
+CODEGEN: ##test-vector %test-vector
 CODEGEN: ##add-vector %add-vector
 CODEGEN: ##saturated-add-vector %saturated-add-vector
 CODEGEN: ##add-sub-vector %add-sub-vector
@@ -229,6 +231,7 @@ CODEGEN: _compare-branch %compare-branch
 CODEGEN: _compare-imm-branch %compare-imm-branch
 CODEGEN: _compare-float-ordered-branch %compare-float-ordered-branch
 CODEGEN: _compare-float-unordered-branch %compare-float-unordered-branch
+CODEGEN: _test-vector-branch %test-vector-branch
 CODEGEN: _dispatch %dispatch
 CODEGEN: _spill %spill
 CODEGEN: _reload %reload

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

@@ -25,6 +25,7 @@ IN: compiler.tree.propagation.simd
     (simd-hlshift)
     (simd-hrshift)
     (simd-vshuffle)
+    (simd-v=)
     (simd-with)
     (simd-gather-2)
     (simd-gather-4)
@@ -45,6 +46,12 @@ IN: compiler.tree.propagation.simd
 
 \ (simd-v.) [ 2nip scalar-output-class ] "outputs" set-word-prop
 
+{
+    (simd-vany?)
+    (simd-vall?)
+    (simd-vnone?)
+} [ { boolean } "default-output-classes" set-word-prop ] each
+
 \ (simd-select) [ 2nip scalar-output-class ] "outputs" set-word-prop
 
 \ assert-positive [

basis/cpu/architecture/architecture.factor

@@ -217,6 +217,9 @@ HOOK: %zero-vector cpu ( dst rep -- )
 HOOK: %gather-vector-2 cpu ( dst src1 src2 rep -- )
 HOOK: %gather-vector-4 cpu ( dst src1 src2 src3 src4 rep -- )
 HOOK: %shuffle-vector cpu ( dst src shuffle rep -- )
+HOOK: %compare-vector cpu ( dst src1 src2 rep cc -- )
+HOOK: %test-vector cpu ( dst src1 temp rep vcc -- )
+HOOK: %test-vector-branch cpu ( label src1 temp rep vcc -- )
 HOOK: %add-vector cpu ( dst src1 src2 rep -- )
 HOOK: %saturated-add-vector cpu ( dst src1 src2 rep -- )
 HOOK: %add-sub-vector cpu ( dst src1 src2 rep -- )
@@ -250,6 +253,8 @@ HOOK: %zero-vector-reps cpu ( -- reps )
 HOOK: %gather-vector-2-reps cpu ( -- reps )
 HOOK: %gather-vector-4-reps cpu ( -- reps )
 HOOK: %shuffle-vector-reps cpu ( -- reps )
+HOOK: %compare-vector-reps cpu ( -- reps )
+HOOK: %test-vector-reps cpu ( -- reps )
 HOOK: %add-vector-reps cpu ( -- reps )
 HOOK: %saturated-add-vector-reps cpu ( -- reps )
 HOOK: %add-sub-vector-reps cpu ( -- reps )

basis/cpu/ppc/ppc.factor

@@ -261,6 +261,8 @@ M: ppc %zero-vector-reps { } ;
 M: ppc %gather-vector-2-reps { } ;
 M: ppc %gather-vector-4-reps { } ;
 M: ppc %shuffle-vector-reps { } ;
+M: ppc %compare-vector-reps { } ;
+M: ppc %test-vector-reps { } ;
 M: ppc %add-vector-reps { } ;
 M: ppc %saturated-add-vector-reps { } ;
 M: ppc %add-sub-vector-reps { } ;

basis/cpu/x86/x86.factor

@@ -708,6 +708,65 @@ M: x86 %shuffle-vector-reps
         { sse2? { double-2-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
     } available-reps ;
 
+: %compare-vector-equal ( dst src rep -- )
+    unsign-rep {
+        { double-2-rep   [ CMPEQPD ] }
+        { float-4-rep    [ CMPEQPS ] }
+        { longlong-2-rep [ PCMPEQQ ] }
+        { int-4-rep      [ PCMPEQD ] }
+        { short-8-rep    [ PCMPEQW ] }
+        { char-16-rep    [ PCMPEQB ] }
+    } case ;
+
+M: x86 %compare-vector ( dst src1 src2 rep cc -- )
+    [ [ two-operand ] keep ] dip {
+        { cc= [ %compare-vector-equal ] }
+    } case ;
+
+M: x86 %compare-vector-reps
+    {
+        { sse? { float-4-rep } }
+        { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep } }
+        { sse4.1? { longlong-2-rep ulonglong-2-rep } }
+    } available-reps ;
+
+:: %test-vector-mask ( dst temp mask vcc -- )
+    vcc {
+        { vcc-any    [ dst dst TEST dst temp \ CMOVNE %boolean ] }
+        { vcc-none   [ dst dst TEST dst temp \ CMOVE  %boolean ] }
+        { vcc-all    [ dst mask CMP dst temp \ CMOVE  %boolean ] }
+        { vcc-notall [ dst mask CMP dst temp \ CMOVNE %boolean ] }
+    } case ;
+
+: %move-vector-mask ( dst src rep -- mask )
+    {
+        { double-2-rep [ MOVMSKPD HEX: 3 ] }
+        { float-4-rep  [ MOVMSKPS HEX: f ] }
+        [ drop PMOVMSKB HEX: ffff ]
+    } case ;
+
+M:: x86 %test-vector ( dst src temp rep vcc -- )
+    dst src rep %move-vector-mask :> mask
+    dst temp mask vcc %test-vector-mask ;
+
+:: %test-vector-mask-branch ( label temp mask vcc -- )
+    vcc {
+        { vcc-any    [ temp temp TEST label JNE ] }
+        { vcc-none   [ temp temp TEST label JE ] }
+        { vcc-all    [ temp mask CMP label JE ] }
+        { vcc-notall [ temp mask CMP label JNE ] }
+    } case ;
+
+M:: x86 %test-vector-branch ( label src temp rep vcc -- )
+    temp src rep %move-vector-mask :> mask
+    label temp mask vcc %test-vector-mask-branch ;
+
+M: x86 %test-vector-reps
+    {
+        { sse? { float-4-rep } }
+        { sse2? { double-2-rep char-16-rep uchar-16-rep short-8-rep ushort-8-rep int-4-rep uint-4-rep longlong-2-rep ulonglong-2-rep } }
+    } available-reps ;
+
 M: x86 %add-vector ( dst src1 src2 rep -- )
     [ two-operand ] keep
     {

basis/math/vectors/simd/functor/functor.factor

@@ -1,17 +1,37 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs byte-arrays classes effects fry
+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.specialization parser prettyprint.custom sequences
 sequences.private strings words definitions macros cpu.architecture
-namespaces arrays quotations combinators sets layouts ;
+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 ] ;
 
@@ -72,14 +92,17 @@ MACRO: simd-nth ( rep -- x )
     '[ nip _ swap supported-simd-op? ] assoc-filter
     '[ drop _ key? ] assoc-filter ;
 
-ERROR: bad-schema schema ;
+ERROR: bad-schema op schema ;
 
-: low-level-ops ( simd-ops alist -- alist' )
+:: op-wrapper ( op specials schemas -- wrapper )
-    '[
+    op {
-        1quotation
+        [ specials at ]
-        over word-schema _ ?at [ bad-schema ] unless
+        [ word-schema schemas at ]
-        [ ] 2sequence
+        [ dup word-schema bad-schema ]
-    ] assoc-map ;
+    } 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.
@@ -103,14 +126,14 @@ ERROR: bad-schema schema ;
     ! in the general case.
     elt-class float = [ { distance [ v- norm ] } suffix ] when ;
 
-TUPLE: simd class elt-class ops wrappers ctor rep ;
+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>> ] [ wrappers>> ] bi low-level-ops ]
+        [ [ ops>> ] [ special-wrappers>> ] [ schema-wrappers>> ] tri low-level-ops ]
         [ rep>> supported-simd-ops ]
         [ [ ctor>> ] [ elt-class>> ] bi high-level-ops assoc-union ]
     } cleave
@@ -152,6 +175,8 @@ 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-element-class [ A-rep rep-component-type c:c-type-boxed-class ]
+
 WHERE
 
 TUPLE: A
@@ -161,9 +186,14 @@ 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 underlying>> SET-NTH call ; 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 ;
 
@@ -177,8 +207,6 @@ M: A new-sequence
     [ N bad-length ]
     if ; inline
 
-M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
-
 M: A c:byte-length underlying>> length ; inline
 
 M: A element-type drop A-rep rep-component-type ;
@@ -235,7 +263,7 @@ simd new
         { { +vector+ -> +vector+ } A-v->v-op }
         { { +vector+ -> +scalar+ } A-v->n-op }
         { { +vector+ -> +nonnegative+ } A-v->n-op }
-    } >>wrappers
+    } >>schema-wrappers
 (define-simd-128)
 
 PRIVATE>
@@ -291,9 +319,12 @@ 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-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.-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
 
 WHERE
 
@@ -310,6 +341,9 @@ M: A clone
 
 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
 
@@ -327,8 +361,6 @@ M: A new-sequence
     [ N bad-length ]
     if ; inline
 
-M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
-
 M: A c:byte-length drop 32 ; inline
 
 M: A element-type drop A-rep rep-component-type ;
@@ -366,32 +398,44 @@ INSTANCE: A sequence
     [ [ [ underlying2>> ] dip A-rep ] dip call ] 3bi
     \ A boa ; inline
 
-: A-vv->n-op ( v1 v2 quot -- v3 )
-    [ [ [ underlying1>> ] bi@ A-rep ] dip call ]
-    [ [ [ underlying2>> ] bi@ A-rep ] dip call ] 3bi
-    + ; 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->n-op ( v1 combine-quot -- v2 )
+: A-v.-op ( v1 v2 quot -- n )
-    [ [ underlying1>> ] [ underlying2>> ] bi A-rep (simd-v+) A-rep ] dip call ; inline
+    [ [ [ 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
 
 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 }
+    } >>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+ -> +scalar+ } A-vv->n-op }
         { { +vector+ -> +vector+ } A-v->v-op }
-        { { +vector+ -> +scalar+ } A-v->n-op }
+    } >>schema-wrappers
-        { { +vector+ -> +nonnegative+ } A-v->n-op }
-    } >>wrappers
 (define-simd-256)
 
 ;FUNCTOR

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

@@ -49,6 +49,10 @@ SIMD-OP: vrshift
 SIMD-OP: hlshift
 SIMD-OP: hrshift
 SIMD-OP: vshuffle
+SIMD-OP: v=
+SIMD-OP: vany?
+SIMD-OP: vall?
+SIMD-OP: vnone?
 
 : (simd-with) ( x rep -- v ) bad-simd-call ;
 : (simd-gather-2) ( a b rep -- v ) bad-simd-call ;
@@ -126,6 +130,10 @@ M: vector-rep supported-simd-op?
         { \ (simd-hlshift)  [ %horizontal-shl-vector-reps ] }
         { \ (simd-hrshift)  [ %horizontal-shr-vector-reps ] }
         { \ (simd-vshuffle) [ %shuffle-vector-reps        ] }
+        { \ (simd-v=)       [ %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? ;

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

@@ -161,7 +161,10 @@ CONSTANT: simd-classes
 
 : remove-special-words ( alist -- alist' )
     ! These have their own tests later
-    { hlshift hrshift vshuffle vbroadcast } unique assoc-diff ;
+    {
+        hlshift hrshift vshuffle vbroadcast
+        v= vany? vall? vnone?
+    } unique assoc-diff ;
 
 : ops-to-check ( elt-class -- alist )
     [ vector-words >alist ] dip
@@ -281,6 +284,141 @@ simd-classes [
     ] unit-test
 ] each
 
+"== Checking element tests" print
+
+[ short-8{ t f t f f f t f } ]
+[ short-8{ 1 2 3 4 5 6 7 8 } short-8{ 1 0 3 -1 -2 -3 7 -4 } v= ] unit-test
+
+[ short-8{ t f t f f f t f } ]
+[ short-8{ 1 2 3 4 5 6 7 8 } short-8{ 1 0 3 -1 -2 -3 7 -4 } [ { short-8 short-8 } declare v= ] compile-call ] unit-test
+
+[ int-8{ t f t f f f t f } ]
+[ int-8{ 1 2 3 4 5 6 7 8 } int-8{ 1 0 3 -1 -2 -3 7 -4 } v= ] unit-test
+
+[ int-8{ t f t f f f t f } ]
+[ int-8{ 1 2 3 4 5 6 7 8 } int-8{ 1 0 3 -1 -2 -3 7 -4 } [ { int-8 int-8 } declare v= ] compile-call ] unit-test
+
+[ int-4{ t f t f } ]
+[ int-4{ 1 2 3 4 } int-4{ 1 0 3 -1 } [ { int-4 int-4 } declare v= ] compile-call ] unit-test
+
+[ int-4{ t f t f } ]
+[ int-4{ 1 2 3 4 } int-4{ 1 0 3 -1 } v= ] unit-test
+
+[ int-4{ t f t f } ]
+[ int-4{ 1 2 3 4 } int-4{ 1 0 3 -1 } [ { int-4 int-4 } declare v= ] compile-call ] unit-test
+
+[ t ]
+[
+    float-4{ t f t f }
+    float-4{ 1.0 0/0. 3.0 4.0 } float-4{ 1.0 0/0. 3.0 -1.0 } v=
+    exact=
+] unit-test
+
+[ t ]
+[
+    float-4{ t f t f }
+    float-4{ 1.0 0/0. 3.0 4.0 } float-4{ 1.0 0/0. 3.0 -1.0 } [ { float-4 float-4 } declare v= ] compile-call
+    exact=
+] unit-test
+
+[ t ]
+[
+    float-8{ t f t f f t t t }
+    float-8{ 1.0 0/0. 3.0 4.0 5.0 6.0 7.0 8.0 } float-8{ 1.0 0/0. 3.0 -1.0 -2.0 6.0 7.0 8.0 } v=
+    exact=
+] unit-test
+
+[ t ]
+[
+    float-8{ t f t f f t t t }
+    float-8{ 1.0 0/0. 3.0 4.0 5.0 6.0 7.0 8.0 } float-8{ 1.0 0/0. 3.0 -1.0 -2.0 6.0 7.0 8.0 } [ { float-8 float-8 } declare v= ] compile-call
+    exact=
+] unit-test
+
+[ t ]
+[
+    double-2{ f t }
+    double-2{ 0/0. 3.0 } double-2{ 0/0. 3.0 } v=
+    exact=
+] unit-test
+
+[ t ]
+[
+    double-2{ f t }
+    double-2{ 0/0. 3.0 } double-2{ 0/0. 3.0 } [ { double-2 double-2 } declare v= ] compile-call
+    exact=
+] unit-test
+
+:: test-vector-tests-bool ( vector declaration -- none? any? all? )
+    vector
+    [ [ declaration declare vnone? ] compile-call ]
+    [ [ declaration declare vany?  ] compile-call ]
+    [ [ declaration declare vall?  ] compile-call ] tri ; inline
+
+: yes ( -- x ) t ;
+: no ( -- x ) f ;
+
+:: test-vector-tests-branch ( vector declaration -- none? any? all? )
+    vector
+    [ [ declaration declare vnone? [ yes ] [ no ] if ] compile-call ]
+    [ [ declaration declare vany?  [ yes ] [ no ] if ] compile-call ]
+    [ [ declaration declare vall?  [ yes ] [ no ] if ] compile-call ] tri ; inline
+
+SYMBOL: !!inconsistent!!
+
+: ?inconsistent ( a b -- ab/inconsistent )
+    2dup = [ drop ] [ 2drop !!inconsistent!! ] if ;
+
+:: test-vector-tests ( vector decl -- none? any? all? )
+    vector decl test-vector-tests-bool :> bool-all :> bool-any :> bool-none
+    vector decl test-vector-tests-branch :> branch-all :> branch-any :> branch-none
+    
+    bool-none branch-none ?inconsistent
+    bool-any  branch-any  ?inconsistent
+    bool-all  branch-all  ?inconsistent ; inline
+
+[ f t t ]
+[ float-4{ t t t t } { float-4 } test-vector-tests ] unit-test
+[ f t f ]
+[ float-4{ f t t t } { float-4 } test-vector-tests ] unit-test
+[ t f f ]
+[ float-4{ f f f f } { float-4 } test-vector-tests ] unit-test
+
+[ f t t ]
+[ double-2{ t t } { double-2 } test-vector-tests ] unit-test
+[ f t f ]
+[ double-2{ f t } { double-2 } test-vector-tests ] unit-test
+[ t f f ]
+[ double-2{ f f } { double-2 } test-vector-tests ] unit-test
+
+[ f t t ]
+[ int-4{ t t t t } { int-4 } test-vector-tests ] unit-test
+[ f t f ]
+[ int-4{ f t t t } { int-4 } test-vector-tests ] unit-test
+[ t f f ]
+[ int-4{ f f f f } { int-4 } test-vector-tests ] unit-test
+
+[ f t t ]
+[ float-8{ t t t t t t t t } { float-8 } test-vector-tests ] unit-test
+[ f t f ]
+[ float-8{ f t t t t f t t } { float-8 } test-vector-tests ] unit-test
+[ t f f ]
+[ float-8{ f f f f f f f f } { float-8 } test-vector-tests ] unit-test
+
+[ f t t ]
+[ double-4{ t t t t } { double-4 } test-vector-tests ] unit-test
+[ f t f ]
+[ double-4{ f t t f } { double-4 } test-vector-tests ] unit-test
+[ t f f ]
+[ double-4{ f f f f } { double-4 } test-vector-tests ] unit-test
+
+[ f t t ]
+[ int-8{ t t t t t t t t } { int-8 } test-vector-tests ] unit-test
+[ f t f ]
+[ int-8{ f t t t t f f f } { int-8 } test-vector-tests ] unit-test
+[ t f f ]
+[ int-8{ f f f f f f f f } { int-8 } test-vector-tests ] unit-test
+
 "== Checking element access" print
 
 ! Test element access -- it should box bignums for int-4 on x86

basis/math/vectors/specialization/specialization.factor

@@ -92,6 +92,10 @@ H{
     { hrshift { +vector+ +literal+ -> +vector+ } }
     { vshuffle { +vector+ +literal+ -> +vector+ } }
     { vbroadcast { +vector+ +literal+ -> +vector+ } }
+    { v= { +vector+ +vector+ -> +vector+ } }
+    { vany? { +vector+ -> +scalar+ } }
+    { vall? { +vector+ -> +scalar+ } }
+    { vnone? { +vector+ -> +scalar+ } }
 }
 
 PREDICATE: vector-word < word vector-words key? ;

basis/math/vectors/vectors-docs.factor

@@ -61,8 +61,11 @@ ARTICLE: "math-vectors-logic" "Vector componentwise logic"
 { $subsection vand }
 { $subsection vor }
 { $subsection vxor }
-{ $subsection vmask }
 { $subsection v? }
+"Entire vector tests:"
+{ $subsection vall? }
+{ $subsection vany? }
+{ $subsection vnone? }
 "Element shuffling:"
 { $subsection vshuffle } ;
 
@@ -338,13 +341,21 @@ HELP: vnot
 { $values { "u" "a sequence of booleans" } { "w" "a sequence of booleans" } }
 { $description "Takes the logical NOT of each element of " { $snippet "u" } "." } ;
 
-HELP: vmask
-{ $values { "u" "a sequence of numbers" } { "?" "a sequence of booleans" } { "u'" "a sequence of numbers" } }
-{ $description "Returns a copy of " { $snippet "u" } " with the elements for which the corresponding element of " { $snippet "?" } " is false replaced by zero." } ;
-
 HELP: v?
-{ $values { "?" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "w" "a sequence of numbers" } }
+{ $values { "mask" "a sequence of booleans" } { "true" "a sequence of numbers" } { "false" "a sequence of numbers" } { "w" "a sequence of numbers" } }
-{ $description "Creates a new sequence by selecting elements from the " { $snippet "true" } " and " { $snippet "false" } " sequences based on whether the corresponding element of the " { $snippet "?" } " sequence is true or false." } ;
+{ $description "Creates a new sequence by selecting elements from the " { $snippet "true" } " and " { $snippet "false" } " sequences based on whether the corresponding bits of the " { $snippet "mask" } " sequence are set or not." } ;
+
+HELP: vany?
+{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } }
+{ $description "Returns true if any element of " { $snippet "v" } " is true." } ;
+
+HELP: vall?
+{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } }
+{ $description "Returns true if every element of " { $snippet "v" } " is true." } ;
+
+HELP: vnone?
+{ $values { "v" "a sequence of booleans" } { "?" "a boolean" } }
+{ $description "Returns true if every element of " { $snippet "v" } " is false." } ;
 
 { 2map v+ v- v* v/ } related-words
 
@@ -352,6 +363,6 @@ HELP: v?
 
 { vs+ vs- vs* } related-words
 
-{ v< v<= v= v> v>= vunordered? vand vor vxor vnot vmask v? } related-words
+{ v< v<= v= v> v>= vunordered? vand vor vxor vnot vany? vall? vnone? v? } related-words
 
 { vbitand vbitandn vbitor vbitxor vbitnot } related-words

basis/math/vectors/vectors.factor

@@ -92,16 +92,19 @@ PRIVATE>
 : vxor ( u v -- w ) [ xor ] 2map ;
 : vnot ( u -- w )   [ not ] map ;
 
-: v<  ( u v -- w ) [ <   ] { } 2map-as ;
+: vall? ( v -- ? ) [ ] all? ;
-: v<= ( u v -- w ) [ <=  ] { } 2map-as ;
+: vany? ( v -- ? ) [ ] any? ;
-: v>= ( u v -- w ) [ >=  ] { } 2map-as ;
+: vnone? ( v -- ? ) [ not ] all? ;
-: v>  ( u v -- w ) [ >   ] { } 2map-as ;
-: vunordered? ( u v -- w ) [ unordered? ] { } 2map-as ;
-: v=  ( u v -- w ) [ =   ] { } 2map-as ;
 
-: v?   ( ? true false -- w ) [ ? ] pick 3map-as ;
+: 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 ;
 
-: vmask ( u ? -- u' ) swap dup dup vbitxor v? ;
+: v? ( mask true false -- w )
+    [ vbitand ] [ vbitandn ] bi-curry* bi vbitor ; inline
 
 : vfloor    ( u -- v ) [ floor ] map ;
 : vceiling  ( u -- v ) [ ceiling ] map ;

extra/math/matrices/simd/simd-tests.factor

@@ -53,6 +53,19 @@ IN: math.matrices.simd.tests
     1.0e-7 m~ 
 ] unit-test
 
+[ t ] [
+    float-4{ 0.0 1.0 0.0 1.0 } pi 1/2. * rotation-matrix4
+    S{ matrix4 f
+        float-4-array{
+            float-4{  0.0  0.0  1.0 0.0 }
+            float-4{  0.0  1.0  0.0 0.0 }
+            float-4{ -1.0  0.0  0.0 0.0 }
+            float-4{  0.0  0.0  0.0 1.0 }
+        }
+    }
+    1.0e-7 m~ 
+] unit-test
+
 [
     S{ matrix4 f
         float-4-array{

extra/math/matrices/simd/simd.factor

@@ -95,6 +95,17 @@ TYPED:: m4. ( a: matrix4 b: matrix4 -- c: matrix4 )
 
     c set-rows ;
 
+TYPED:: v.m4 ( a: float-4 b: matrix4 -- c: float-4 )
+    b rows :> b4 :> b3 :> b2 :> b1
+    
+    a first  b1 n*v
+    a second b2 n*v v+
+    a third  b3 n*v v+
+    a fourth b4 n*v v+ ;
+
+TYPED:: m4.v ( a: matrix4 b: float-4 -- c: float-4 )
+    a rows [ b v. ] 4 napply float-4-boa ;
+
 CONSTANT: identity-matrix4
     S{ matrix4 f
         float-4-array{
@@ -121,7 +132,7 @@ TYPED:: m4^n ( m: matrix4 n: fixnum -- m^n: matrix4 )
 TYPED:: scale-matrix4 ( factors: float-4 -- matrix: matrix4 )
     matrix4 (struct) :> c
 
-    factors { t t t f } vmask :> factors'
+    factors float-4{ t t t f } vbitand :> factors'
 
     factors' { 0 3 3 3 } vshuffle
     factors' { 3 1 3 3 } vshuffle
@@ -137,11 +148,11 @@ TYPED:: translation-matrix4 ( offset: float-4 -- matrix: matrix4 )
     matrix4 (struct) :> c
 
     float-4{ 0.0 0.0 0.0 1.0 } :> c4
-    { t t t f } offset c4 v? :> offset'
+    float-4{ t t t f } offset c4 v? :> offset'
 
-    offset' { 3 3 3 0 } vshuffle { t f f t } vmask
+    offset' { 3 3 3 0 } vshuffle float-4{ t f f t } vbitand
-    offset' { 3 3 3 1 } vshuffle { f t f t } vmask
+    offset' { 3 3 3 1 } vshuffle float-4{ f t f t } vbitand
-    offset' { 3 3 3 2 } vshuffle { f f t t } vmask
+    offset' { 3 3 3 2 } vshuffle float-4{ f f t t } vbitand
     c4
 
     c set-rows ;
@@ -165,17 +176,17 @@ TYPED:: rotation-matrix4 ( axis: float-4 theta: float -- matrix: matrix4 )
 
     axis2 cc ones axis2 v- v* v+ :> diagonal
 
-    axis { 0 0 1 3 } vshuffle axis { 1 2 2 3 } vshuffle v* 1-c v*
+    axis { 1 0 0 3 } vshuffle axis { 2 2 1 3 } vshuffle v* 1-c v*
-    { t t t f } vmask :> triangle-a
+    float-4{ t t t f } vbitand :> triangle-a
-    ss { 2 1 0 3 } vshuffle triangle-sign v* :> triangle-b
+    ss axis v* triangle-sign v* :> triangle-b
     triangle-a triangle-b v+ :> triangle-lo
     triangle-a triangle-b v- :> triangle-hi
 
     diagonal scale-matrix4 :> diagonal-m
 
-    triangle-hi { 3 0 1 3 } vshuffle
+    triangle-hi { 3 2 1 3 } vshuffle
-    triangle-hi { 3 3 2 3 } vshuffle triangle-lo { 0 3 3 3 } vshuffle v+
+    triangle-hi { 3 3 0 3 } vshuffle triangle-lo { 2 3 3 3 } vshuffle v+
-    triangle-lo { 1 2 3 3 } vshuffle
+    triangle-lo { 1 0 3 3 } vshuffle
     float-4 new
 
     triangle-m set-rows drop
@@ -186,12 +197,12 @@ TYPED:: frustum-matrix4 ( xy: float-4 near: float far: float -- matrix: matrix4
     matrix4 (struct) :> c
 
     near near near far + 2 near far * * float-4-boa :> num
-    { t t f f } xy near far - float-4-with v? :> denom
+    float-4{ t t f f } xy near far - float-4-with v? :> denom
     num denom v/ :> fov
 
-    fov { 0 0 0 0 } vshuffle { t f f f } vmask
+    fov { 0 0 0 0 } vshuffle float-4{ t f f f } vbitand
-    fov { 1 1 1 1 } vshuffle { f t f f } vmask
+    fov { 1 1 1 1 } vshuffle float-4{ f t f f } vbitand
-    fov { 2 2 2 3 } vshuffle { f f t t } vmask
+    fov { 2 2 2 3 } vshuffle float-4{ f f t t } vbitand
     float-4{ 0.0 0.0 -1.0 0.0 }
 
     c set-rows ;

misc/vim/syntax/factor.vim

@@ -23,7 +23,7 @@ else
     set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255
 endif
 
-syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorTriString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple,factorStruct
+syn cluster factorCluster contains=factorComment,factorFryDirective,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorTriString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple,factorStruct
 
 syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained
 syn match factorComment /\<#!\>.*/ contains=factorTodo
@@ -44,9 +44,11 @@ syn region factorPGenericN matchgroup=factorPGenericNDelims start=/\<GENERIC#\s\
 syn region None matchgroup=factorPrivate start=/\<<PRIVATE\>/ end=/\<PRIVATE>\>/ contains=@factorDefnContents,factorPrivateDefn,factorPrivateMethod,factorPGeneric,factorPGenericN
 
 
-syn keyword factorBoolean boolean f general-t t
+syn keyword factorBoolean f t
+syn match factorFryDirective /\<\(@\|_\)\>/ contained
 syn keyword factorCompileDirective inline foldable recursive
 
+syn keyword factorKeyword boolean
 syn keyword factorKeyword or tuck 2bi 2tri while wrapper nip 4dip wrapper? bi* callstack>array both? hashcode die dupd callstack callstack? 3dup tri@ pick curry build ?execute 3bi prepose >boolean ?if clone eq? tri* ? = swapd call-clear 2over 2keep 3keep clear 2dup when not tuple? dup 2bi* 2tri* call tri-curry object bi@ do unless* if* loop bi-curry* drop when* assert= retainstack assert? -rot execute 2bi@ 2tri@ boa with either? 3drop bi curry? datastack until 3dip over 3curry roll tri-curry* swap tri-curry@ 2nip and throw set-retainstack bi-curry (clone) hashcode* compose spin 2dip if 3tri unless compose? tuple keep 2curry equal? set-datastack assert tri 2drop most <wrapper> boolean? identity-tuple? null new set-callstack dip bi-curry@ rot -roll xor identity-tuple boolean
 syn keyword factorKeyword ?at assoc? assoc-clone-like assoc= delete-at* assoc-partition extract-keys new-assoc value? assoc-size map>assoc push-at assoc-like key? assoc-intersect assoc-refine update assoc-union assoc-combine at* assoc-empty? at+ set-at assoc-all? assoc-subset? assoc-hashcode change-at assoc-each assoc-diff zip values value-at rename-at inc-at enum? at cache assoc>map <enum> assoc assoc-map enum value-at* remove-all assoc-map-as >alist assoc-filter-as substitute-here clear-assoc assoc-stack maybe-set-at substitute assoc-filter 2cache delete-at assoc-find keys assoc-any? unzip
 syn keyword factorKeyword case execute-effect no-cond no-case? 3cleave>quot 2cleave cond>quot wrong-values? no-cond? cleave>quot no-case case>quot 3cleave wrong-values to-fixed-point alist>quot case-find cond cleave call-effect 2cleave>quot recursive-hashcode linear-case-quot spread spread>quot
@@ -190,6 +192,7 @@ if version >= 508 || !exists("did_factor_syn_inits")
     HiLink factorConditional            Conditional
     HiLink factorKeyword                Keyword
     HiLink factorOperator               Operator
+    HiLink factorFryDirective           Operator
     HiLink factorBoolean                Boolean
     HiLink factorDefnDelims             Typedef
     HiLink factorMethodDelims           Typedef