steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-09-30 00:07:45 -05:00
parent 55ab9c3002 d70b95e4b8
commit 7e679e1683
20 changed files with 191 additions and 80 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/cfg/intrinsics/intrinsics.factor
View File

@ -175,7 +175,7 @@ IN: compiler.cfg.intrinsics
{ math.vectors.simd.intrinsics:(simd-vrshift) [ [ ^^shr-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 ] } { math.vectors.simd.intrinsics:(simd-hlshift) [ [ ^^horizontal-shl-vector ] emit-horizontal-shift ] }
{ math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] } { math.vectors.simd.intrinsics:(simd-hrshift) [ [ ^^horizontal-shr-vector ] emit-horizontal-shift ] }
{ math.vectors.simd.intrinsics:(simd-broadcast) [ emit-broadcast-vector ] } { math.vectors.simd.intrinsics:(simd-with) [ [ ^^with-vector ] emit-unary-vector-op ] }
{ math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] } { math.vectors.simd.intrinsics:(simd-gather-2) [ emit-gather-vector-2 ] }
{ math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] } { math.vectors.simd.intrinsics:(simd-gather-4) [ emit-gather-vector-4 ] }
{ math.vectors.simd.intrinsics:(simd-vshuffle) [ emit-shuffle-vector ] } { math.vectors.simd.intrinsics:(simd-vshuffle) [ emit-shuffle-vector ] }

38
basis/compiler/cfg/intrinsics/simd/simd.factor
View File

@ -35,16 +35,23 @@ MACRO: if-literals-match ( quots -- )
: emit-vector-op ( node quot: ( rep -- ) -- ) : emit-vector-op ( node quot: ( rep -- ) -- )
{ [ representation? ] } if-literals-match ; inline { [ representation? ] } if-literals-match ; inline
: [binary] ( quot -- quot' )
'[ [ ds-drop 2inputs ] dip @ ds-push ] ; inline
: emit-binary-vector-op ( node quot -- ) : emit-binary-vector-op ( node quot -- )
'[ [ ds-drop 2inputs ] dip @ ds-push ] [binary] emit-vector-op ; inline
emit-vector-op ; inline
: [unary] ( quot -- quot' )
'[ [ ds-drop ds-pop ] dip @ ds-push ] ; inline
: emit-unary-vector-op ( node quot -- ) : emit-unary-vector-op ( node quot -- )
'[ [ ds-drop ds-pop ] dip @ ds-push ] [unary] emit-vector-op ; inline
emit-vector-op ; inline
: [unary/param] ( quot -- quot' )
'[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] ; inline
: emit-horizontal-shift ( node quot -- ) : emit-horizontal-shift ( node quot -- )
'[ [ -2 inc-d ds-pop ] 2dip @ ds-push ] [unary/param]
{ [ integer? ] [ representation? ] } if-literals-match ; inline { [ integer? ] [ representation? ] } if-literals-match ; inline
: emit-gather-vector-2 ( node -- ) : emit-gather-vector-2 ( node -- )
@ -67,24 +74,25 @@ MACRO: if-literals-match ( quots -- )
: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ; : shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
: emit-shuffle-vector ( node -- ) : emit-shuffle-vector ( node -- )
[ [ -2 inc-d ds-pop ] 2dip ^^shuffle-vector ds-push ] [ ^^shuffle-vector ] [unary/param]
{ [ shuffle? ] [ representation? ] } if-literals-match ; inline { [ shuffle? ] [ representation? ] } if-literals-match ;
: ^^broadcast-vector ( src rep -- dst ) : ^^broadcast-vector ( src n rep -- dst )
[ ^^scalar>vector ] keep [ rep-components swap <array> ] keep
[ rep-components 0 <array> ] keep
^^shuffle-vector ; ^^shuffle-vector ;
: emit-broadcast-vector ( node -- ) : emit-broadcast-vector ( node -- )
[ ^^broadcast-vector ] emit-unary-vector-op ; [ ^^broadcast-vector ] [unary/param]
{ [ integer? ] [ representation? ] } if-literals-match ;
: ^^with-vector ( src rep -- dst )
[ ^^scalar>vector ] keep [ 0 ] dip ^^broadcast-vector ;
: ^^select-vector ( src n rep -- dst ) : ^^select-vector ( src n rep -- dst )
[ rep-components swap <array> ] keep [ ^^broadcast-vector ] keep ^^vector>scalar ;
[ ^^shuffle-vector ] keep
^^vector>scalar ;
: emit-select-vector ( node -- ) : emit-select-vector ( node -- )
[ [ -2 inc-d ds-pop ] 2dip ^^select-vector ds-push ] [ ^^select-vector ] [unary/param]
{ [ integer? ] [ representation? ] } if-literals-match ; inline { [ integer? ] [ representation? ] } if-literals-match ; inline
: emit-alien-vector ( node -- ) : emit-alien-vector ( node -- )

3
basis/compiler/cfg/ssa/destruction/destruction.factor
View File

@ -3,7 +3,6 @@
USING: accessors arrays assocs fry kernel namespaces USING: accessors arrays assocs fry kernel namespaces
sequences sequences.deep sequences sequences.deep
sets vectors sets vectors
cpu.architecture
compiler.cfg.rpo compiler.cfg.rpo
compiler.cfg.def-use compiler.cfg.def-use
compiler.cfg.renaming compiler.cfg.renaming
@ -68,7 +67,7 @@ M: insn prepare-insn
[ defs-vreg ] [ uses-vregs ] bi [ defs-vreg ] [ uses-vregs ] bi
2dup empty? not and [ 2dup empty? not and [
first first
2dup [ rep-of reg-class-of ] bi@ eq? 2dup [ rep-of ] bi@ eq?
[ try-to-coalesce ] [ 2drop ] if [ try-to-coalesce ] [ 2drop ] if
] [ 2drop ] if ; ] [ 2drop ] if ;

2
basis/compiler/tree/propagation/simd/simd.factor
View File

@ -25,7 +25,7 @@ IN: compiler.tree.propagation.simd
(simd-hlshift) (simd-hlshift)
(simd-hrshift) (simd-hrshift)
(simd-vshuffle) (simd-vshuffle)
(simd-broadcast) (simd-with)
(simd-gather-2) (simd-gather-2)
(simd-gather-4) (simd-gather-4)
alien-vector alien-vector

2
basis/generalizations/generalizations-docs.factor
View File

@ -202,7 +202,7 @@ HELP: nwith
} ; } ;
HELP: napply HELP: napply
{ $values { "quot" quotation } { "n" integer } } { $values { "n" integer } }
{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth." { $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."
} }
{ $examples { $examples

5
basis/generalizations/generalizations-tests.factor
View File

@ -1,4 +1,5 @@
USING: tools.test generalizations kernel math arrays sequences ascii ; USING: tools.test generalizations kernel math arrays sequences
ascii fry math.parser ;
IN: generalizations.tests IN: generalizations.tests
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test { 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test
@ -72,3 +73,5 @@ IN: generalizations.tests
1 2 3 4 3 nover ; 1 2 3 4 3 nover ;
[ 1 2 3 4 1 2 3 ] [ nover-test ] unit-test [ 1 2 3 4 1 2 3 ] [ nover-test ] unit-test
[ '[ number>string _ append ] 4 napply ] must-infer

4
basis/generalizations/generalizations.factor
View File

@ -87,8 +87,8 @@ MACRO: nspread ( quots n -- )
'[ [ _ _ nspread ] _ ndip @ ] '[ [ _ _ nspread ] _ ndip @ ]
] if ; ] if ;
MACRO: napply ( quot n -- ) MACRO: napply ( n -- )
swap <repetition> spread>quot ; [ [ drop ] ] dip [ '[ tuck _ 2dip call ] ] times ;
MACRO: mnswap ( m n -- ) MACRO: mnswap ( m n -- )
1 + '[ _ -nrot ] swap '[ _ _ napply ] ; 1 + '[ _ -nrot ] swap '[ _ _ napply ] ;

1
basis/math/floats/env/env-tests.factor vendored
View File

@ -29,6 +29,7 @@ set-default-fp-env
[ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test [ t ] +fp-overflow+ [ 1.0e250 1.0e100 ] [ * ] test-fp-exception-compiled unit-test
[ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test [ t ] +fp-underflow+ [ 1.0e-250 1.0e-100 ] [ * ] test-fp-exception-compiled unit-test
[ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test [ t ] +fp-overflow+ [ 2.0 100,000.0 ] [ fpow ] test-fp-exception-compiled unit-test
[ t ] +fp-invalid-operation+ [ 2.0 0/0. 1.0e-9 ] [ ~ ] test-fp-exception-compiled unit-test
! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug: ! No underflow on Linux with this test, just inexact. Reported as an Ubuntu bug:
! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113 ! https://bugs.launchpad.net/ubuntu/+source/glibc/+bug/429113

6
basis/math/functions/functions-tests.factor
View File

@ -44,8 +44,14 @@ IN: math.functions.tests
[ 4.0 ] [ 10000.0 log10 ] unit-test [ 4.0 ] [ 10000.0 log10 ] unit-test
[ t ] [ 1 exp e 1.e-10 ~ ] unit-test [ t ] [ 1 exp e 1.e-10 ~ ] unit-test
[ f ] [ 1 exp 0/0. 1.e-10 ~ ] unit-test
[ f ] [ 0/0. 1 exp 1.e-10 ~ ] unit-test
[ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test [ t ] [ 1.0 exp e 1.e-10 ~ ] unit-test
[ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test [ t ] [ -1 exp e * 1.0 1.e-10 ~ ] unit-test
[ f ] [ 1/0. 1/0. 1.e-10 ~ ] unit-test
[ f ] [ 1/0. -1/0. 1.e-10 ~ ] unit-test
[ f ] [ 1/0. 0/0. 1.e-10 ~ ] unit-test
[ f ] [ 0/0. -1/0. 1.e-10 ~ ] unit-test
[ 1.0 ] [ 0 cosh ] unit-test [ 1.0 ] [ 0 cosh ] unit-test
[ 1.0 ] [ 0.0 cosh ] unit-test [ 1.0 ] [ 0.0 cosh ] unit-test

1
basis/math/functions/functions.factor
View File

@ -141,7 +141,6 @@ M: real absq sq ; inline
: ~ ( x y epsilon -- ? ) : ~ ( x y epsilon -- ? )
{ {
{ [ 2over [ fp-nan? ] either? ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] } { [ dup zero? ] [ drop number= ] }
{ [ dup 0 < ] [ neg ~rel ] } { [ dup 0 < ] [ neg ~rel ] }
[ ~abs ] [ ~abs ]

62
basis/math/vectors/simd/functor/functor.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types assocs byte-arrays classes effects fry USING: accessors assocs byte-arrays classes effects fry
functors generalizations kernel literals locals math math.functions functors generalizations kernel literals locals math math.functions
math.vectors math.vectors.private math.vectors.simd.intrinsics math.vectors math.vectors.private math.vectors.simd.intrinsics
math.vectors.specialization parser prettyprint.custom sequences math.vectors.specialization parser prettyprint.custom sequences
sequences.private strings words definitions macros cpu.architecture sequences.private strings words definitions macros cpu.architecture
namespaces arrays quotations combinators sets ; namespaces arrays quotations combinators sets layouts ;
QUALIFIED-WITH: math m QUALIFIED-WITH: alien.c-types c
IN: math.vectors.simd.functor IN: math.vectors.simd.functor
ERROR: bad-length got expected ; ERROR: bad-length got expected ;
@ -14,10 +14,22 @@ ERROR: bad-length got expected ;
MACRO: simd-boa ( rep class -- simd-array ) MACRO: simd-boa ( rep class -- simd-array )
[ rep-components ] [ new ] bi* '[ _ _ nsequence ] ; [ rep-components ] [ new ] bi* '[ _ _ nsequence ] ;
: can-be-unboxed? ( type -- ? )
{
{ c:float [ t ] }
{ c:double [ t ] }
[ 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 -- ) :: define-boa-custom-inlining ( word rep class -- )
word [ word [
drop drop
rep rep rep-gather-word supported-simd-op? [ rep simd-boa-fast? [
[ rep (simd-boa) class boa ] [ rep (simd-boa) class boa ]
] [ word def>> ] if ] [ word def>> ] if
] "custom-inlining" set-word-prop ; ] "custom-inlining" set-word-prop ;
@ -25,25 +37,34 @@ MACRO: simd-boa ( rep class -- simd-array )
: simd-with ( rep class x -- simd-array ) : simd-with ( rep class x -- simd-array )
[ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline [ rep-components ] [ new ] [ '[ _ ] ] tri* swap replicate-as ; inline
: simd-with-fast? ( rep -- ? )
[ \ (simd-vshuffle) supported-simd-op? ]
[ rep-component-type can-be-unboxed? ]
bi and ;
:: define-with-custom-inlining ( word rep class -- ) :: define-with-custom-inlining ( word rep class -- )
word [ word [
drop drop
rep \ (simd-vshuffle) supported-simd-op? [ rep simd-with-fast? [
[ rep rep-coerce rep (simd-broadcast) class boa ] [ rep rep-coerce rep (simd-with) class boa ]
] [ word def>> ] if ] [ word def>> ] if
] "custom-inlining" set-word-prop ; ] "custom-inlining" set-word-prop ;
: simd-nth-fast? ( rep -- ? )
[ \ (simd-vshuffle) supported-simd-op? ]
[ rep-component-type can-be-unboxed? ]
bi and ;
: simd-nth-fast ( rep -- quot ) : simd-nth-fast ( rep -- quot )
[ rep-components ] keep [ rep-components ] keep
'[ swap _ '[ _ _ (simd-select) ] 2array ] map-index '[ swap _ '[ _ _ (simd-select) ] 2array ] map-index
'[ swap >fixnum _ case ] ; '[ swap >fixnum _ case ] ;
: simd-nth-slow ( rep -- quot ) : simd-nth-slow ( rep -- quot )
rep-component-type dup c-type-getter-boxer array-accessor ; rep-component-type dup c:c-type-getter-boxer c:array-accessor ;
MACRO: simd-nth ( rep -- x ) MACRO: simd-nth ( rep -- x )
dup \ (simd-vshuffle) supported-simd-op? dup simd-nth-fast? [ simd-nth-fast ] [ simd-nth-slow ] if ;
[ simd-nth-fast ] [ simd-nth-slow ] if ;
: boa-effect ( rep n -- effect ) : boa-effect ( rep n -- effect )
[ rep-components ] dip * [ rep-components ] dip *
@ -67,6 +88,7 @@ ERROR: bad-schema schema ;
:: high-level-ops ( ctor elt-class -- assoc ) :: high-level-ops ( ctor elt-class -- assoc )
! Some SIMD operations are defined in terms of others. ! Some SIMD operations are defined in terms of others.
{ {
{ vbroadcast [ swap nth ctor execute ] }
{ vneg [ [ dup vbitxor ] keep v- ] } { vneg [ [ dup vbitxor ] keep v- ] }
{ n+v [ [ ctor execute ] dip v+ ] } { n+v [ [ ctor execute ] dip v+ ] }
{ v+n [ ctor execute v+ ] } { v+n [ ctor execute v+ ] }
@ -83,12 +105,12 @@ ERROR: bad-schema schema ;
! To compute dot product and distance with integer vectors, we ! To compute dot product and distance with integer vectors, we
! have to do things less efficiently, with integer overflow checks, ! have to do things less efficiently, with integer overflow checks,
! in the general case. ! in the general case.
elt-class m:float = [ { distance [ v- norm ] } suffix ] when ; elt-class float = [ { distance [ v- norm ] } suffix ] when ;
TUPLE: simd class elt-class ops wrappers ctor rep ; TUPLE: simd class elt-class ops wrappers ctor rep ;
: define-simd ( simd -- ) : define-simd ( simd -- )
dup rep>> rep-component-type c-type-boxed-class >>elt-class dup rep>> rep-component-type c:c-type-boxed-class >>elt-class
{ {
[ class>> ] [ class>> ]
[ elt-class>> ] [ elt-class>> ]
@ -99,7 +121,7 @@ TUPLE: simd class elt-class ops wrappers ctor rep ;
specialize-vector-words ; specialize-vector-words ;
:: define-simd-128-type ( class rep -- ) :: define-simd-128-type ( class rep -- )
<c-type> c:<c-type>
byte-array >>class byte-array >>class
class >>boxed-class class >>boxed-class
[ rep alien-vector class boa ] >>getter [ rep alien-vector class boa ] >>getter
@ -107,7 +129,7 @@ TUPLE: simd class elt-class ops wrappers ctor rep ;
16 >>size 16 >>size
8 >>align 8 >>align
rep >>rep rep >>rep
class typedef ; class c:typedef ;
: (define-simd-128) ( simd -- ) : (define-simd-128) ( simd -- )
simd-ops get >>ops simd-ops get >>ops
@ -116,7 +138,7 @@ TUPLE: simd class elt-class ops wrappers ctor rep ;
FUNCTOR: define-simd-128 ( T -- ) FUNCTOR: define-simd-128 ( T -- )
N [ 16 T heap-size /i ] N [ 16 T c:heap-size /i ]
A DEFINES-CLASS ${T}-${N} A DEFINES-CLASS ${T}-${N}
A-boa DEFINES ${A}-boa A-boa DEFINES ${A}-boa
@ -125,7 +147,7 @@ A-cast DEFINES ${A}-cast
>A DEFINES >${A} >A DEFINES >${A}
A{ DEFINES ${A}{ A{ DEFINES ${A}{
SET-NTH [ T dup c-setter array-accessor ] SET-NTH [ T dup c:c-setter c:array-accessor ]
A-rep [ A name>> "-rep" append "cpu.architecture" lookup ] A-rep [ A name>> "-rep" append "cpu.architecture" lookup ]
A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op A-vv->v-op DEFINES-PRIVATE ${A}-vv->v-op
@ -161,7 +183,7 @@ M: A new-sequence
M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ; M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
M: A byte-length underlying>> length ; inline M: A c:byte-length underlying>> length ; inline
M: A element-type drop A-rep rep-component-type ; M: A element-type drop A-rep rep-component-type ;
@ -229,7 +251,7 @@ SLOT: underlying1
SLOT: underlying2 SLOT: underlying2
:: define-simd-256-type ( class rep -- ) :: define-simd-256-type ( class rep -- )
<c-type> c:<c-type>
class >>class class >>class
class >>boxed-class class >>boxed-class
[ [
@ -245,7 +267,7 @@ SLOT: underlying2
32 >>size 32 >>size
8 >>align 8 >>align
rep >>rep rep >>rep
class typedef ; class c:typedef ;
: (define-simd-256) ( simd -- ) : (define-simd-256) ( simd -- )
simd-ops get { vshuffle hlshift hrshift } unique assoc-diff >>ops simd-ops get { vshuffle hlshift hrshift } unique assoc-diff >>ops
@ -254,7 +276,7 @@ SLOT: underlying2
FUNCTOR: define-simd-256 ( T -- ) FUNCTOR: define-simd-256 ( T -- )
N [ 32 T heap-size /i ] N [ 32 T c:heap-size /i ]
N/2 [ N 2 / ] N/2 [ N 2 / ]
A/2 IS ${T}-${N/2} A/2 IS ${T}-${N/2}
@ -311,7 +333,7 @@ M: A new-sequence
M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ; M: A equal? over \ A instance? [ sequence= ] [ 2drop f ] if ;
M: A byte-length drop 32 ; inline M: A c:byte-length drop 32 ; inline
M: A element-type drop A-rep rep-component-type ; M: A element-type drop A-rep rep-component-type ;

52
basis/math/vectors/simd/intrinsics/intrinsics.factor
View File

@ -50,7 +50,7 @@ SIMD-OP: hlshift
SIMD-OP: hrshift SIMD-OP: hrshift
SIMD-OP: vshuffle SIMD-OP: vshuffle
: (simd-broadcast) ( x rep -- v ) bad-simd-call ; : (simd-with) ( x rep -- v ) bad-simd-call ;
: (simd-gather-2) ( a b 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-gather-4) ( a b c d rep -- v ) bad-simd-call ;
: (simd-select) ( v n rep -- x ) bad-simd-call ; : (simd-select) ( v n rep -- x ) bad-simd-call ;
@ -103,29 +103,29 @@ GENERIC# supported-simd-op? 1 ( rep intrinsic -- ? )
M: vector-rep supported-simd-op? M: vector-rep supported-simd-op?
{ {
{ \ (simd-v+) [ %add-vector-reps ] } { \ (simd-v+) [ %add-vector-reps ] }
{ \ (simd-vs+) [ %saturated-add-vector-reps ] } { \ (simd-vs+) [ %saturated-add-vector-reps ] }
{ \ (simd-v+-) [ %add-sub-vector-reps ] } { \ (simd-v+-) [ %add-sub-vector-reps ] }
{ \ (simd-v-) [ %sub-vector-reps ] } { \ (simd-v-) [ %sub-vector-reps ] }
{ \ (simd-vs-) [ %saturated-sub-vector-reps ] } { \ (simd-vs-) [ %saturated-sub-vector-reps ] }
{ \ (simd-v*) [ %mul-vector-reps ] } { \ (simd-v*) [ %mul-vector-reps ] }
{ \ (simd-vs*) [ %saturated-mul-vector-reps ] } { \ (simd-vs*) [ %saturated-mul-vector-reps ] }
{ \ (simd-v/) [ %div-vector-reps ] } { \ (simd-v/) [ %div-vector-reps ] }
{ \ (simd-vmin) [ %min-vector-reps ] } { \ (simd-vmin) [ %min-vector-reps ] }
{ \ (simd-vmax) [ %max-vector-reps ] } { \ (simd-vmax) [ %max-vector-reps ] }
{ \ (simd-v.) [ %dot-vector-reps ] } { \ (simd-v.) [ %dot-vector-reps ] }
{ \ (simd-vsqrt) [ %sqrt-vector-reps ] } { \ (simd-vsqrt) [ %sqrt-vector-reps ] }
{ \ (simd-sum) [ %horizontal-add-vector-reps ] } { \ (simd-sum) [ %horizontal-add-vector-reps ] }
{ \ (simd-vabs) [ %abs-vector-reps ] } { \ (simd-vabs) [ %abs-vector-reps ] }
{ \ (simd-vbitand) [ %and-vector-reps ] } { \ (simd-vbitand) [ %and-vector-reps ] }
{ \ (simd-vbitandn) [ %andn-vector-reps ] } { \ (simd-vbitandn) [ %andn-vector-reps ] }
{ \ (simd-vbitor) [ %or-vector-reps ] } { \ (simd-vbitor) [ %or-vector-reps ] }
{ \ (simd-vbitxor) [ %xor-vector-reps ] } { \ (simd-vbitxor) [ %xor-vector-reps ] }
{ \ (simd-vlshift) [ %shl-vector-reps ] } { \ (simd-vlshift) [ %shl-vector-reps ] }
{ \ (simd-vrshift) [ %shr-vector-reps ] } { \ (simd-vrshift) [ %shr-vector-reps ] }
{ \ (simd-hlshift) [ %horizontal-shl-vector-reps ] } { \ (simd-hlshift) [ %horizontal-shl-vector-reps ] }
{ \ (simd-hrshift) [ %horizontal-shr-vector-reps ] } { \ (simd-hrshift) [ %horizontal-shr-vector-reps ] }
{ \ (simd-vshuffle) [ %shuffle-vector-reps ] } { \ (simd-vshuffle) [ %shuffle-vector-reps ] }
{ \ (simd-gather-2) [ %gather-vector-2-reps ] } { \ (simd-gather-2) [ %gather-vector-2-reps ] }
{ \ (simd-gather-4) [ %gather-vector-4-reps ] } { \ (simd-gather-4) [ %gather-vector-4-reps ] }
} case member? ; } case member? ;

63
basis/math/vectors/simd/simd-tests.factor
View File

@ -6,7 +6,7 @@ tools.test vocabs assocs compiler.cfg.debugger words
locals math.vectors.specialization combinators cpu.architecture locals math.vectors.specialization combinators cpu.architecture
math.vectors.simd.intrinsics namespaces byte-arrays alien math.vectors.simd.intrinsics namespaces byte-arrays alien
specialized-arrays classes.struct eval classes.algebra sets specialized-arrays classes.struct eval classes.algebra sets
quotations ; quotations math.constants ;
QUALIFIED-WITH: alien.c-types c QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: c:float SPECIALIZED-ARRAY: c:float
SIMD: c:char SIMD: c:char
@ -124,6 +124,10 @@ CONSTANT: simd-classes
] [ = ] check-optimizer ] [ = ] check-optimizer
] unit-test ] unit-test
[ HEX: ffffffff ] [ HEX: ffffffff uint-4-with first ] unit-test
[ HEX: ffffffff ] [ HEX: ffffffff [ uint-4-with ] compile-call first ] unit-test
"== Checking -boa constructors" print "== Checking -boa constructors" print
[ { } ] [ [ { } ] [
@ -133,6 +137,8 @@ CONSTANT: simd-classes
] [ = ] check-optimizer ] [ = ] check-optimizer
] unit-test ] unit-test
[ HEX: ffffffff ] [ HEX: ffffffff 2 3 4 [ uint-4-boa ] compile-call first ] unit-test
"== Checking vector operations" print "== Checking vector operations" print
: random-vector ( class -- vec ) : random-vector ( class -- vec )
@ -155,7 +161,7 @@ CONSTANT: simd-classes
: remove-special-words ( alist -- alist' ) : remove-special-words ( alist -- alist' )
! These have their own tests later ! These have their own tests later
{ hlshift hrshift vshuffle } unique assoc-diff ; { hlshift hrshift vshuffle vbroadcast } unique assoc-diff ;
: ops-to-check ( elt-class -- alist ) : ops-to-check ( elt-class -- alist )
[ vector-words >alist ] dip [ vector-words >alist ] dip
@ -171,21 +177,29 @@ CONSTANT: simd-classes
: approx= ( x y -- ? ) : approx= ( x y -- ? )
{ {
{ [ 2dup [ float? ] both? ] [ -1.e8 ~ ] } { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
{ [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
{ [ 2dup [ sequence? ] both? ] [ { [ 2dup [ sequence? ] both? ] [
[ [
{ {
{ [ 2dup [ fp-nan? ] both? ] [ 2drop t ] } { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
{ [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
{ [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] } { [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] }
} cond } cond
] 2all? ] 2all?
] } ] }
} cond ; } cond ;
: exact= ( x y -- ? )
{
{ [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
{ [ 2dup [ sequence? ] both? ] [ [ fp-bitwise= ] 2all? ] }
} cond ;
: simd-classes&reps ( -- alist ) : simd-classes&reps ( -- alist )
simd-classes [ simd-classes [
{ {
{ [ dup name>> "float" head? ] [ float [ approx= ] ] } { [ dup name>> "float" head? ] [ float [ approx= ] ] }
{ [ dup name>> "double" head? ] [ float [ = ] ] } { [ dup name>> "double" head? ] [ float [ exact= ] ] }
[ fixnum [ = ] ] [ fixnum [ = ] ]
} cond 3array } cond 3array
] map ; ] map ;
@ -263,6 +277,9 @@ simd-classes [
[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-accesses ] unit-test [ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-accesses ] unit-test
[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-accesses ] unit-test [ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-accesses ] unit-test
[ HEX: 7fffffff ] [ int-4{ HEX: 7fffffff 3 4 -8 } first ] unit-test
[ HEX: ffffffff ] [ uint-4{ HEX: ffffffff 2 3 4 } first ] unit-test
[ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test [ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test
[ { } ] [ longlong-2{ 1 2 } test-accesses ] unit-test [ { } ] [ longlong-2{ 1 2 } test-accesses ] unit-test
[ { } ] [ ulonglong-2{ 1 2 } test-accesses ] unit-test [ { } ] [ ulonglong-2{ 1 2 } test-accesses ] unit-test
@ -275,6 +292,27 @@ simd-classes [
[ { } ] [ longlong-4{ 1 2 3 4 } test-accesses ] unit-test [ { } ] [ longlong-4{ 1 2 3 4 } test-accesses ] unit-test
[ { } ] [ ulonglong-4{ 1 2 3 4 } test-accesses ] unit-test [ { } ] [ ulonglong-4{ 1 2 3 4 } test-accesses ] unit-test
"== Checking broadcast" print
: test-broadcast ( seq -- failures )
[ length >array ] keep
'[ [ _ 1quotation ] dip '[ _ vbroadcast ] ] [ = ] check-optimizer ; inline
[ { } ] [ float-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
[ { } ] [ int-4{ HEX: 7fffffff 3 4 -8 } test-broadcast ] unit-test
[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-broadcast ] unit-test
[ { } ] [ double-2{ 1.0 2.0 } test-broadcast ] unit-test
[ { } ] [ longlong-2{ 1 2 } test-broadcast ] unit-test
[ { } ] [ ulonglong-2{ 1 2 } test-broadcast ] unit-test
[ { } ] [ float-8{ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 } test-broadcast ] unit-test
[ { } ] [ int-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test
[ { } ] [ uint-8{ 1 2 3 4 5 6 7 8 } test-broadcast ] unit-test
[ { } ] [ double-4{ 1.0 2.0 3.0 4.0 } test-broadcast ] unit-test
[ { } ] [ longlong-4{ 1 2 3 4 } test-broadcast ] unit-test
[ { } ] [ ulonglong-4{ 1 2 3 4 } test-broadcast ] unit-test
"== Checking alien operations" print "== Checking alien operations" print
[ float-4{ 1 2 3 4 } ] [ [ float-4{ 1 2 3 4 } ] [
@ -344,8 +382,25 @@ STRUCT: simd-struct
[ ] [ char-16 new 1array stack. ] unit-test [ ] [ char-16 new 1array stack. ] unit-test
! Other regressions ! CSSA bug
[ 8000000 ] [ [ 8000000 ] [
int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 } int-8{ 1000 1000 1000 1000 1000 1000 1000 1000 }
[ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call [ { int-8 } declare dup [ * ] [ + ] 2map-reduce ] compile-call
] unit-test ] unit-test
! Coalescing was too aggressive
:: broken ( axis theta -- a b c )
axis { float-4 } declare drop
theta { float } declare drop
theta cos float-4-with :> cc
theta sin float-4-with :> ss
axis cc v+ :> diagonal
diagonal cc ss ; inline
[ t ] [
float-4{ 1.0 0.0 1.0 0.0 } pi [ broken 3array ]
[ compile-call ] [ call ] 3bi =
] unit-test

1
basis/math/vectors/specialization/specialization.factor
View File

@ -91,6 +91,7 @@ H{
{ hlshift { +vector+ +literal+ -> +vector+ } } { hlshift { +vector+ +literal+ -> +vector+ } }
{ hrshift { +vector+ +literal+ -> +vector+ } } { hrshift { +vector+ +literal+ -> +vector+ } }
{ vshuffle { +vector+ +literal+ -> +vector+ } } { vshuffle { +vector+ +literal+ -> +vector+ } }
{ vbroadcast { +vector+ +literal+ -> +vector+ } }
} }
PREDICATE: vector-word < word vector-words key? ; PREDICATE: vector-word < word vector-words key? ;

12
basis/math/vectors/vectors-docs.factor
View File

@ -245,6 +245,18 @@ HELP: hrshift
{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "w" "a SIMD array" } } { $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "w" "a SIMD array" } }
{ $description "Shifts the entire SIMD array to the right by " { $snippet "n" } " bytes. This word may only be used in a context where the compiler can statically infer that the input is a SIMD array." } ; { $description "Shifts the entire SIMD array to the right by " { $snippet "n" } " bytes. This word may only be used in a context where the compiler can statically infer that the input is a SIMD array." } ;
HELP: vbroadcast
{ $values { "u" "a SIMD array" } { "n" "a non-negative integer" } { "v" "a SIMD array" } }
{ $description "Outputs a new SIMD array of the same type as " { $snippet "u" } " where every element is equal to the " { $snippet "n" } "th element of " { $snippet "u" } "." }
{ $examples
{ $example
"USING: alien.c-types math.vectors math.vectors.simd" "prettyprint ;"
"SIMD: int"
"int-4{ 69 42 911 13 } 2 vbroadcast ."
"int-4{ 911 911 911 911 }"
}
} ;
HELP: vshuffle HELP: vshuffle
{ $values { "u" "a SIMD array" } { "perm" "an array of integers" } { "v" "a SIMD array" } } { $values { "u" "a SIMD array" } { "perm" "an array of integers" } { "v" "a SIMD array" } }
{ $description "Permutes the elements of a SIMD array. Duplicate entries are allowed in the permutation." } { $description "Permutes the elements of a SIMD array. Duplicate entries are allowed in the permutation." }

6
basis/math/vectors/vectors.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2005, 2009 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays alien.c-types kernel sequences math math.functions USING: arrays alien.c-types kernel sequences math math.functions
hints math.order math.libm fry combinators byte-arrays accessors ; hints math.order math.libm fry combinators byte-arrays accessors
locals ;
QUALIFIED-WITH: alien.c-types c QUALIFIED-WITH: alien.c-types c
IN: math.vectors IN: math.vectors
@ -77,7 +78,8 @@ PRIVATE>
: vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ; : vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ;
: vbitnot ( u -- w ) dup '[ _ [ bitnot ] fp-bitwise-unary ] map ; : vbitnot ( u -- w ) dup '[ _ [ bitnot ] fp-bitwise-unary ] map ;
: vshuffle ( u perm -- v ) swap [ nths ] keep like ; :: vbroadcast ( u n -- v ) u length n u nth <repetition> u like ;
: vshuffle ( u perm -- v ) swap [ '[ _ nth ] ] keep map-as ;
: vlshift ( u n -- w ) '[ _ shift ] map ; : vlshift ( u n -- w ) '[ _ shift ] map ;
: vrshift ( u n -- w ) neg '[ _ shift ] map ; : vrshift ( u n -- w ) neg '[ _ shift ] map ;

3
core/layouts/layouts-tests.factor
View File

@ -6,3 +6,6 @@ IN: system.tests
! Smoke test ! Smoke test
[ t ] [ max-array-capacity cell-bits 2^ < ] unit-test [ t ] [ max-array-capacity cell-bits 2^ < ] unit-test
[ t ] [ most-negative-fixnum fixnum? ] unit-test
[ t ] [ most-positive-fixnum fixnum? ] unit-test

4
core/layouts/layouts.factor
View File

@ -49,10 +49,10 @@ SYMBOL: mega-cache-size
cell-bits (first-bignum) ; inline cell-bits (first-bignum) ; inline
: most-positive-fixnum ( -- n ) : most-positive-fixnum ( -- n )
first-bignum 1 - ; inline first-bignum 1 - >fixnum ; inline
: most-negative-fixnum ( -- n ) : most-negative-fixnum ( -- n )
first-bignum neg ; inline first-bignum neg >fixnum ; inline
: (max-array-capacity) ( b -- n ) : (max-array-capacity) ( b -- n )
5 - 2^ 1 - ; inline 5 - 2^ 1 - ; inline

2
extra/bloom-filters/bloom-filters.factor
View File

@ -127,7 +127,7 @@ PRIVATE>
! Make sure it's a fixnum here to speed up double-hashing. ! Make sure it's a fixnum here to speed up double-hashing.
: hashcodes-from-hashcode ( n -- n n ) : hashcodes-from-hashcode ( n -- n n )
dup most-positive-fixnum >fixnum bitxor ; dup most-positive-fixnum bitxor ;
: hashcodes-from-object ( obj -- n n ) : hashcodes-from-object ( obj -- n n )
hashcode abs hashcodes-from-hashcode ; hashcode abs hashcodes-from-hashcode ;

2
extra/project-euler/044/044.factor
View File

@ -41,7 +41,7 @@ IN: project-euler.044
PRIVATE> PRIVATE>
: euler044 ( -- answer ) : euler044 ( -- answer )
most-positive-fixnum >fixnum most-positive-fixnum
2500 [1,b] [ 2500 [1,b] [
dup [1,b] [ dup [1,b] [
euler044-step euler044-step