Merge branch 'master' of git://factorcode.org/git/factor into bleeding_edge
Jon Harper
commit
2dafa24383
|
|
@ -44,6 +44,9 @@ M: word test-cfg
|
|||
nl
|
||||
] each ;
|
||||
|
||||
: test-mr. ( quot -- )
|
||||
test-mr mr. ; inline
|
||||
|
||||
! Prettyprinting
|
||||
: pprint-loc ( loc word -- ) <block pprint-word n>> pprint* block> ;
|
||||
|
||||
|
|
@ -79,4 +82,4 @@ M: rs-loc pprint* \ R pprint-loc ;
|
|||
[ [ defs-vreg ] [ defs-vreg-rep ] bi 2dup and [ 2array ] [ 2drop f ] if ]
|
||||
bi [ suffix ] when*
|
||||
] map concat
|
||||
] map concat >hashtable representations set ;
|
||||
] map concat >hashtable representations set ;
|
||||
|
|
|
|||
|
|
@ -404,12 +404,12 @@ literal: rep ;
|
|||
|
||||
PURE-INSN: ##shl-vector
|
||||
def: dst
|
||||
use: src1 src2/scalar-rep
|
||||
use: src1 src2/int-scalar-rep
|
||||
literal: rep ;
|
||||
|
||||
PURE-INSN: ##shr-vector
|
||||
def: dst
|
||||
use: src1 src2/scalar-rep
|
||||
use: src1 src2/int-scalar-rep
|
||||
literal: rep ;
|
||||
|
||||
! Scalar/vector conversion
|
||||
|
|
|
|||
|
|
@ -74,7 +74,9 @@ MACRO: if-literals-match ( quots -- )
|
|||
: shuffle? ( obj -- ? ) { [ array? ] [ [ integer? ] all? ] } 1&& ;
|
||||
|
||||
: emit-shuffle-vector ( node -- )
|
||||
[ ^^shuffle-vector ] [unary/param]
|
||||
! Pad the permutation with zeroes if its too short, since we
|
||||
! can't throw an error at this point.
|
||||
[ [ rep-components 0 pad-tail ] keep ^^shuffle-vector ] [unary/param]
|
||||
{ [ shuffle? ] [ representation? ] } if-literals-match ;
|
||||
|
||||
: ^^broadcast-vector ( src n rep -- dst )
|
||||
|
|
|
|||
|
|
@ -386,24 +386,24 @@ M:: ppc %box-displaced-alien ( dst displacement base displacement' base' base-cl
|
|||
"end" resolve-label
|
||||
] with-scope ;
|
||||
|
||||
M: ppc %alien-unsigned-1 0 LBZ ;
|
||||
M: ppc %alien-unsigned-2 0 LHZ ;
|
||||
M: ppc %alien-unsigned-1 LBZ ;
|
||||
M: ppc %alien-unsigned-2 LHZ ;
|
||||
|
||||
M: ppc %alien-signed-1 dupd 0 LBZ dup EXTSB ;
|
||||
M: ppc %alien-signed-2 0 LHA ;
|
||||
M: ppc %alien-signed-1 [ dup ] 2dip LBZ dup EXTSB ;
|
||||
M: ppc %alien-signed-2 LHA ;
|
||||
|
||||
M: ppc %alien-cell 0 LWZ ;
|
||||
M: ppc %alien-cell LWZ ;
|
||||
|
||||
M: ppc %alien-float 0 LFS ;
|
||||
M: ppc %alien-double 0 LFD ;
|
||||
M: ppc %alien-float LFS ;
|
||||
M: ppc %alien-double LFD ;
|
||||
|
||||
M: ppc %set-alien-integer-1 swap 0 STB ;
|
||||
M: ppc %set-alien-integer-2 swap 0 STH ;
|
||||
M: ppc %set-alien-integer-1 swapd STB ;
|
||||
M: ppc %set-alien-integer-2 swapd STH ;
|
||||
|
||||
M: ppc %set-alien-cell swap 0 STW ;
|
||||
M: ppc %set-alien-cell swapd STW ;
|
||||
|
||||
M: ppc %set-alien-float swap 0 STFS ;
|
||||
M: ppc %set-alien-double swap 0 STFD ;
|
||||
M: ppc %set-alien-float swapd STFS ;
|
||||
M: ppc %set-alien-double swapd STFD ;
|
||||
|
||||
: load-zone-ptr ( reg -- )
|
||||
"nursery" %load-vm-field-addr ;
|
||||
|
|
|
|||
|
|
@ -317,13 +317,19 @@ M:: x86 %set-string-nth-fast ( ch str index temp -- )
|
|||
: %alien-unsigned-getter ( dst src offset size -- )
|
||||
[ MOVZX ] %alien-integer-getter ; inline
|
||||
|
||||
: %alien-signed-getter ( dst src offset size -- )
|
||||
[ MOVSX ] %alien-integer-getter ; inline
|
||||
|
||||
:: %alien-integer-setter ( ptr offset value size -- )
|
||||
value { ptr } size [| new-value |
|
||||
new-value value int-rep %copy
|
||||
ptr offset [+] new-value size n-bit-version-of MOV
|
||||
] with-small-register ; inline
|
||||
|
||||
M: x86 %alien-unsigned-1 8 %alien-unsigned-getter ;
|
||||
M: x86 %alien-unsigned-2 16 %alien-unsigned-getter ;
|
||||
M: x86 %alien-unsigned-4 32 [ 2drop ] %alien-integer-getter ;
|
||||
|
||||
: %alien-signed-getter ( dst src offset size -- )
|
||||
[ MOVSX ] %alien-integer-getter ; inline
|
||||
|
||||
M: x86 %alien-signed-1 8 %alien-signed-getter ;
|
||||
M: x86 %alien-signed-2 16 %alien-signed-getter ;
|
||||
M: x86 %alien-signed-4 32 %alien-signed-getter ;
|
||||
|
|
@ -333,12 +339,6 @@ M: x86 %alien-float [+] MOVSS ;
|
|||
M: x86 %alien-double [+] MOVSD ;
|
||||
M: x86 %alien-vector [ [+] ] dip %copy ;
|
||||
|
||||
:: %alien-integer-setter ( ptr offset value size -- )
|
||||
value { ptr } size [| new-value |
|
||||
new-value value int-rep %copy
|
||||
ptr offset [+] new-value size n-bit-version-of MOV
|
||||
] with-small-register ; inline
|
||||
|
||||
M: x86 %set-alien-integer-1 8 %alien-integer-setter ;
|
||||
M: x86 %set-alien-integer-2 16 %alien-integer-setter ;
|
||||
M: x86 %set-alien-integer-4 32 %alien-integer-setter ;
|
||||
|
|
@ -1045,8 +1045,20 @@ M: x86 %shr-vector-reps
|
|||
: scalar-sized-reg ( reg rep -- reg' )
|
||||
rep-size 8 * n-bit-version-of ;
|
||||
|
||||
M: x86 %integer>scalar scalar-sized-reg MOVD ;
|
||||
M: x86 %scalar>integer swap [ scalar-sized-reg ] dip MOVD ;
|
||||
M: x86 %integer>scalar drop MOVD ;
|
||||
|
||||
M:: x86 %scalar>integer ( dst src rep -- )
|
||||
rep {
|
||||
{ int-scalar-rep [
|
||||
dst 32-bit-version-of src MOVD
|
||||
dst dst 32-bit-version-of
|
||||
2dup eq? [ 2drop ] [ MOVSX ] if
|
||||
] }
|
||||
{ uint-scalar-rep [
|
||||
dst 32-bit-version-of src MOVD
|
||||
] }
|
||||
} case ;
|
||||
|
||||
M: x86 %vector>scalar %copy ;
|
||||
M: x86 %scalar>vector %copy ;
|
||||
|
||||
|
|
|
|||
|
|
@ -181,20 +181,22 @@ M: word link-long-text
|
|||
|
||||
: >topic ( obj -- topic ) dup topic? [ >link ] unless ;
|
||||
|
||||
: topic-span ( topic quot -- ) [ >topic ] dip ($span) ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: ($link) ( topic -- ) >topic link-text ;
|
||||
: ($link) ( topic -- ) [ link-text ] topic-span ;
|
||||
: $link ( element -- ) first ($link) ;
|
||||
|
||||
: ($long-link) ( topic -- ) >topic link-long-text ;
|
||||
: ($long-link) ( topic -- ) [ link-long-text ] topic-span ;
|
||||
: $long-link ( element -- ) first ($long-link) ;
|
||||
|
||||
: ($pretty-link) ( topic -- )
|
||||
>topic [ link-icon ] [ drop bl ] [ link-text ] tri ;
|
||||
[ [ link-icon ] [ drop bl ] [ link-text ] tri ] topic-span ;
|
||||
: $pretty-link ( element -- ) first ($pretty-link) ;
|
||||
|
||||
: ($long-pretty-link) ( topic -- )
|
||||
>topic [ link-icon ] [ drop bl ] [ link-long-text ] tri ;
|
||||
[ [ link-icon ] [ drop bl ] [ link-long-text ] tri ] topic-span ;
|
||||
|
||||
: <$pretty-link> ( definition -- element )
|
||||
1array \ $pretty-link prefix ;
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ tools.test vocabs assocs compiler.cfg.debugger words
|
|||
locals math.vectors.specialization combinators cpu.architecture
|
||||
math.vectors.simd.intrinsics namespaces byte-arrays alien
|
||||
specialized-arrays classes.struct eval classes.algebra sets
|
||||
quotations math.constants ;
|
||||
quotations math.constants compiler.units ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
SPECIALIZED-ARRAY: c:float
|
||||
SIMD: c:char
|
||||
|
|
@ -216,12 +216,27 @@ simd-classes&reps [
|
|||
[ int-4{ 256 512 1024 2048 } ]
|
||||
[ int-4{ 1 2 4 8 } [ { int-4 } declare 1 hlshift ] compile-call ] unit-test
|
||||
|
||||
[ int-4{ 256 512 1024 2048 } ]
|
||||
[ int-4{ 1 2 4 8 } 1 [ { int-4 fixnum } declare hlshift ] compile-call ] unit-test
|
||||
|
||||
[ int-4{ 1 2 4 8 } ]
|
||||
[ int-4{ 256 512 1024 2048 } 1 hrshift ] unit-test
|
||||
|
||||
[ int-4{ 1 2 4 8 } ]
|
||||
[ int-4{ 256 512 1024 2048 } [ { int-4 } declare 1 hrshift ] compile-call ] unit-test
|
||||
|
||||
[ int-4{ 1 2 4 8 } ]
|
||||
[ int-4{ 256 512 1024 2048 } 1 [ { int-4 fixnum } declare hrshift ] 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
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
[ [ { int-4 } declare { 3 2 1 } vshuffle ] (( a -- b )) define-temp drop ] with-compilation-unit
|
||||
] unit-test
|
||||
|
||||
! Shuffles
|
||||
: shuffles-for ( n -- shuffles )
|
||||
{
|
||||
|
|
@ -278,6 +293,7 @@ simd-classes [
|
|||
[ { } ] [ uint-4{ HEX: ffffffff 2 3 4 } test-accesses ] unit-test
|
||||
|
||||
[ HEX: 7fffffff ] [ int-4{ HEX: 7fffffff 3 4 -8 } first ] unit-test
|
||||
[ -8 ] [ int-4{ HEX: 7fffffff 3 4 -8 } last ] unit-test
|
||||
[ HEX: ffffffff ] [ uint-4{ HEX: ffffffff 2 3 4 } first ] unit-test
|
||||
|
||||
[ { } ] [ double-2{ 1.0 2.0 } test-accesses ] unit-test
|
||||
|
|
@ -313,6 +329,9 @@ simd-classes [
|
|||
[ { } ] [ longlong-4{ 1 2 3 4 } test-broadcast ] unit-test
|
||||
[ { } ] [ ulonglong-4{ 1 2 3 4 } test-broadcast ] unit-test
|
||||
|
||||
! Make sure we use the fallback in the correct situations
|
||||
[ int-4{ 3 3 3 3 } ] [ int-4{ 12 34 3 17 } 2 [ { int-4 fixnum } declare vbroadcast ] compile-call ] unit-test
|
||||
|
||||
"== Checking alien operations" print
|
||||
|
||||
[ float-4{ 1 2 3 4 } ] [
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ SYMBOLS: -> +vector+ +scalar+ +nonnegative+ +literal+ ;
|
|||
{ +vector+ [ drop ] }
|
||||
{ +scalar+ [ nip ] }
|
||||
{ +nonnegative+ [ nip ] }
|
||||
{ +literal+ [ 2drop object ] }
|
||||
{ +literal+ [ 2drop f ] }
|
||||
} case
|
||||
] with with map ;
|
||||
|
||||
|
|
@ -136,7 +136,7 @@ ERROR: bad-vector-word word ;
|
|||
[ { } ]
|
||||
} cond
|
||||
! Don't specialize horizontal shifts or shuffles at all, they're only for SIMD
|
||||
{ hlshift hrshift vshuffle } diff
|
||||
{ hlshift hrshift vshuffle vbroadcast } diff
|
||||
nip ;
|
||||
|
||||
:: specialize-vector-words ( array-type elt-type simd -- )
|
||||
|
|
@ -147,13 +147,16 @@ ERROR: bad-vector-word word ;
|
|||
tri add-specialization
|
||||
] each ;
|
||||
|
||||
: specialization-matches? ( value-infos signature -- ? )
|
||||
[ [ [ class>> ] dip class<= ] [ literal?>> ] if* ] 2all? ;
|
||||
|
||||
: find-specialization ( classes word -- word/f )
|
||||
specializations
|
||||
[ first [ class<= ] 2all? ] with find
|
||||
[ first specialization-matches? ] with find
|
||||
swap [ second ] when ;
|
||||
|
||||
: vector-word-custom-inlining ( #call -- word/f )
|
||||
[ in-d>> [ value-info class>> ] map ] [ word>> ] bi
|
||||
[ in-d>> [ value-info ] map ] [ word>> ] bi
|
||||
find-specialization ;
|
||||
|
||||
vector-words keys [
|
||||
|
|
|
|||
|
|
@ -1,10 +1,21 @@
|
|||
USING: help.markup help.syntax math math.functions sequences ;
|
||||
IN: math.vectors
|
||||
|
||||
ARTICLE: "math-vectors" "Vector arithmetic"
|
||||
"Any Factor sequence can be used to represent a mathematical vector, however for best performance, the sequences defined by the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "math.vectors.simd" } " vocabularies should be used."
|
||||
$nl
|
||||
"Acting on vectors by a scalar:"
|
||||
ARTICLE: "math-vectors-arithmetic" "Vector arithmetic"
|
||||
"Vector/vector binary operations:"
|
||||
{ $subsection v+ }
|
||||
{ $subsection v- }
|
||||
{ $subsection v+- }
|
||||
{ $subsection v* }
|
||||
{ $subsection v/ }
|
||||
"Vector unary operations:"
|
||||
{ $subsection vneg }
|
||||
{ $subsection vabs }
|
||||
{ $subsection vsqrt }
|
||||
{ $subsection vfloor }
|
||||
{ $subsection vceiling }
|
||||
{ $subsection vtruncate }
|
||||
"Vector/scalar and scalar/vector binary operations:"
|
||||
{ $subsection vneg }
|
||||
{ $subsection v*n }
|
||||
{ $subsection n*v }
|
||||
|
|
@ -14,24 +25,21 @@ $nl
|
|||
{ $subsection n+v }
|
||||
{ $subsection v-n }
|
||||
{ $subsection n-v }
|
||||
"Vector unary operations:"
|
||||
{ $subsection vneg }
|
||||
{ $subsection vabs }
|
||||
{ $subsection vsqrt }
|
||||
{ $subsection vfloor }
|
||||
{ $subsection vceiling }
|
||||
{ $subsection vtruncate }
|
||||
"Vector/vector binary operations:"
|
||||
{ $subsection v+ }
|
||||
{ $subsection v- }
|
||||
{ $subsection v+- }
|
||||
{ $subsection v* }
|
||||
{ $subsection v/ }
|
||||
"Saturated arithmetic (only on " { $link "specialized-arrays" } "):"
|
||||
{ $subsection vs+ }
|
||||
{ $subsection vs- }
|
||||
{ $subsection vs* }
|
||||
"Componentwise vector operations:"
|
||||
"Inner product and norm:"
|
||||
{ $subsection v. }
|
||||
{ $subsection norm }
|
||||
{ $subsection norm-sq }
|
||||
{ $subsection normalize }
|
||||
"Comparing entire vectors:"
|
||||
{ $subsection distance }
|
||||
{ $subsection v~ } ;
|
||||
|
||||
ARTICLE: "math-vectors-logic" "Vector componentwise logic"
|
||||
"Element comparisons:"
|
||||
{ $subsection v< }
|
||||
{ $subsection v<= }
|
||||
{ $subsection v= }
|
||||
|
|
@ -40,6 +48,8 @@ $nl
|
|||
{ $subsection vunordered? }
|
||||
{ $subsection vmax }
|
||||
{ $subsection vmin }
|
||||
{ $subsection vsupremum }
|
||||
{ $subsection vinfimum }
|
||||
"Bitwise operations:"
|
||||
{ $subsection vbitand }
|
||||
{ $subsection vbitandn }
|
||||
|
|
@ -47,31 +57,29 @@ $nl
|
|||
{ $subsection vbitxor }
|
||||
{ $subsection vlshift }
|
||||
{ $subsection vrshift }
|
||||
"Componentwise logical operations:"
|
||||
"Element logical operations:"
|
||||
{ $subsection vand }
|
||||
{ $subsection vor }
|
||||
{ $subsection vxor }
|
||||
{ $subsection vmask }
|
||||
{ $subsection v? }
|
||||
"Shuffling:"
|
||||
{ $subsection vshuffle }
|
||||
"Inner product and norm:"
|
||||
{ $subsection v. }
|
||||
{ $subsection norm }
|
||||
{ $subsection norm-sq }
|
||||
{ $subsection normalize }
|
||||
"Comparing entire vectors:"
|
||||
{ $subsection distance }
|
||||
{ $subsection v~ }
|
||||
"Other functions:"
|
||||
{ $subsection vsupremum }
|
||||
{ $subsection vinfimum }
|
||||
"Element shuffling:"
|
||||
{ $subsection vshuffle } ;
|
||||
|
||||
ARTICLE: "math-vectors-misc" "Miscellaneous vector functions"
|
||||
{ $subsection trilerp }
|
||||
{ $subsection bilerp }
|
||||
{ $subsection vlerp }
|
||||
{ $subsection vnlerp }
|
||||
{ $subsection vbilerp } ;
|
||||
|
||||
|
||||
ARTICLE: "math-vectors" "Vector operations"
|
||||
"Any Factor sequence can be used to represent a mathematical vector, however for best performance, the sequences defined by the " { $vocab-link "specialized-arrays" } " and " { $vocab-link "math.vectors.simd" } " vocabularies should be used."
|
||||
{ $subsection "math-vectors-arithmetic" }
|
||||
{ $subsection "math-vectors-logic" }
|
||||
{ $subsection "math-vectors-misc" } ;
|
||||
|
||||
ABOUT: "math-vectors"
|
||||
|
||||
HELP: vneg
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: random random.dummy tools.test ;
|
||||
IN: random.dummy.tests
|
||||
|
||||
[ 10 ] [ 10 <random-dummy> random-32* ] unit-test
|
||||
[ 100 ] [ 10 <random-dummy> 100 seed-random random-32* ] unit-test
|
||||
|
|
@ -4,8 +4,8 @@ IN: random.dummy
|
|||
TUPLE: random-dummy i ;
|
||||
C: <random-dummy> random-dummy
|
||||
|
||||
M: random-dummy seed-random ( seed obj -- )
|
||||
(>>i) ;
|
||||
M: random-dummy seed-random ( obj seed -- obj )
|
||||
>>i ;
|
||||
|
||||
M: random-dummy random-32* ( obj -- r )
|
||||
[ dup 1 + ] change-i drop ;
|
||||
|
|
|
|||
|
|
@ -27,3 +27,9 @@ IN: random.mersenne-twister.tests
|
|||
[ 3 ] [ 101 [ 3 random-bytes length ] test-rng ] unit-test
|
||||
[ 33 ] [ 101 [ 33 random-bytes length ] test-rng ] unit-test
|
||||
[ t ] [ 101 [ 100 random-bits log2 90 > ] test-rng ] unit-test
|
||||
|
||||
[ t ]
|
||||
[
|
||||
1234 <mersenne-twister>
|
||||
[ random-32* ] [ 1234 seed-random random-32* ] bi =
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -62,15 +62,21 @@ PRIVATE>
|
|||
init-mt-seq 0 mersenne-twister boa
|
||||
dup mt-generate ;
|
||||
|
||||
M: mersenne-twister seed-random ( mt seed -- )
|
||||
init-mt-seq >>seq drop ;
|
||||
M: mersenne-twister seed-random ( mt seed -- mt' )
|
||||
init-mt-seq >>seq
|
||||
[ mt-generate ]
|
||||
[ 0 >>i drop ]
|
||||
[ ] tri ;
|
||||
|
||||
M: mersenne-twister random-32* ( mt -- r )
|
||||
[ next-index ]
|
||||
[ seq>> nth-unsafe mt-temper ]
|
||||
[ [ 1 + ] change-i drop ] tri ;
|
||||
|
||||
[
|
||||
: default-mersenne-twister ( -- mersenne-twister )
|
||||
[ 32 random-bits ] with-system-random
|
||||
<mersenne-twister> random-generator set-global
|
||||
<mersenne-twister> ;
|
||||
|
||||
[
|
||||
default-mersenne-twister random-generator set-global
|
||||
] "bootstrap.random" add-init-hook
|
||||
|
|
|
|||
|
|
@ -2,8 +2,12 @@ USING: help.markup help.syntax math kernel sequences ;
|
|||
IN: random
|
||||
|
||||
HELP: seed-random
|
||||
{ $values { "tuple" "a random number generator" } { "seed" "an integer between 0 and 2^32-1" } }
|
||||
{ $description "Seed the random number generator." }
|
||||
{ $values
|
||||
{ "tuple" "a random number generator" }
|
||||
{ "seed" "a seed specific to the random number generator" }
|
||||
{ "tuple'" "a random number generator" }
|
||||
}
|
||||
{ $description "Seed the random number generator. Repeatedly seeding the random number generator should provide the same sequence of random numbers." }
|
||||
{ $notes "Not supported on all random number generators." } ;
|
||||
|
||||
HELP: random-32*
|
||||
|
|
@ -29,6 +33,10 @@ HELP: random
|
|||
"heads" }
|
||||
} ;
|
||||
|
||||
HELP: random-32
|
||||
{ $values { "n" "a 32-bit random integer" } }
|
||||
{ $description "Outputs 32 random bits. This word is more efficient than calling " { $link random } " because no scaling is done on the output." } ;
|
||||
|
||||
HELP: random-bytes
|
||||
{ $values { "n" "an integer" } { "byte-array" "a random integer" } }
|
||||
{ $description "Outputs an integer with n bytes worth of bits." }
|
||||
|
|
@ -104,6 +112,8 @@ $nl
|
|||
$nl
|
||||
"Generate a random object:"
|
||||
{ $subsection random }
|
||||
"Efficient 32-bit random numbers:"
|
||||
{ $subsection random-32 }
|
||||
"Combinators to change the random number generator:"
|
||||
{ $subsection with-random }
|
||||
{ $subsection with-system-random }
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ SYMBOL: system-random-generator
|
|||
SYMBOL: secure-random-generator
|
||||
SYMBOL: random-generator
|
||||
|
||||
GENERIC: seed-random ( tuple seed -- )
|
||||
GENERIC# seed-random 1 ( tuple seed -- tuple' )
|
||||
GENERIC: random-32* ( tuple -- r )
|
||||
GENERIC: random-bytes* ( n tuple -- byte-array )
|
||||
|
||||
|
|
@ -55,6 +55,8 @@ PRIVATE>
|
|||
[ length random-integer ] keep nth
|
||||
] if-empty ;
|
||||
|
||||
: random-32 ( -- n ) random-generator get random-32* ;
|
||||
|
||||
: randomize ( seq -- seq )
|
||||
dup length [ dup 1 > ]
|
||||
[ [ iota random ] [ 1 - ] bi [ pick exchange ] keep ]
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types alien.syntax unix.types unix.stat classes.struct ;
|
||||
USING: alien.c-types alien.syntax unix.types classes.struct
|
||||
unix.stat ;
|
||||
IN: unix.statfs.openbsd
|
||||
|
||||
CONSTANT: MFSNAMELEN 16
|
||||
|
|
@ -30,4 +31,4 @@ STRUCT: statfs
|
|||
{ f_mntfromname { char MNAMELEN } }
|
||||
{ mount_info char[160] } ;
|
||||
|
||||
FUNCTION: int statfs ( char* path, statvfs* buf ) ;
|
||||
FUNCTION: int statfs ( char* path, statfs* buf ) ;
|
||||
|
|
|
|||
|
|
@ -37,13 +37,13 @@ TUPLE: test-implementation x ;
|
|||
C: <test-implementation> test-implementation
|
||||
|
||||
{
|
||||
{ "IInherited" {
|
||||
{ IInherited {
|
||||
[ drop S_OK ] ! ISimple::returnOK
|
||||
[ drop E_FAIL ] ! ISimple::returnError
|
||||
[ x>> ] ! IInherited::getX
|
||||
[ >>x drop ] ! IInherited::setX
|
||||
} }
|
||||
{ "IUnrelated" {
|
||||
{ IUnrelated {
|
||||
[ swap x>> + ] ! IUnrelated::xPlus
|
||||
[ spin x>> * + ] ! IUnrelated::xMulAdd
|
||||
} }
|
||||
|
|
@ -85,7 +85,7 @@ dup +test-wrapper+ set [
|
|||
+guinea-pig-implementation+ get ISimple-iid com-query-interface
|
||||
dup com-release
|
||||
] unit-test
|
||||
"void*" heap-size +guinea-pig-implementation+ get <displaced-alien>
|
||||
void* heap-size +guinea-pig-implementation+ get <displaced-alien>
|
||||
+guinea-pig-implementation+ get
|
||||
2array [
|
||||
+guinea-pig-implementation+ get IUnrelated-iid com-query-interface
|
||||
|
|
|
|||
|
|
@ -52,13 +52,13 @@ unless
|
|||
swap GUID memory>struct
|
||||
_ case
|
||||
[
|
||||
"void*" heap-size * rot <displaced-alien> com-add-ref
|
||||
void* heap-size * rot <displaced-alien> com-add-ref
|
||||
swap 0 set-alien-cell S_OK
|
||||
] [ nip f swap 0 set-alien-cell E_NOINTERFACE ] if*
|
||||
] ;
|
||||
|
||||
: (make-add-ref) ( interfaces -- quot )
|
||||
length "void*" heap-size * '[
|
||||
length void* heap-size * '[
|
||||
_
|
||||
[ alien-unsigned-4 1 + dup ]
|
||||
[ set-alien-unsigned-4 ]
|
||||
|
|
@ -66,7 +66,7 @@ unless
|
|||
] ;
|
||||
|
||||
: (make-release) ( interfaces -- quot )
|
||||
length "void*" heap-size * '[
|
||||
length void* heap-size * '[
|
||||
_
|
||||
[ drop ]
|
||||
[ alien-unsigned-4 1 - dup ]
|
||||
|
|
@ -84,7 +84,7 @@ unless
|
|||
: (thunk) ( n -- quot )
|
||||
dup 0 =
|
||||
[ drop [ ] ]
|
||||
[ "void*" heap-size neg * '[ _ swap <displaced-alien> ] ]
|
||||
[ void* heap-size neg * '[ _ swap <displaced-alien> ] ]
|
||||
if ;
|
||||
|
||||
: (thunked-quots) ( quots iunknown-methods thunk -- {thunk,quot}s )
|
||||
|
|
@ -97,15 +97,15 @@ unless
|
|||
[ [ (( -- alien )) define-declared ] pick [ call ] dip ]
|
||||
with-compilation-unit ;
|
||||
|
||||
: (callback-word) ( function-name interface-name counter -- word )
|
||||
[ "::" rot 3append "-callback-" ] dip number>string 3append
|
||||
: (callback-word) ( function-name interface counter -- word )
|
||||
[ name>> "::" rot 3append "-callback-" ] dip number>string 3append
|
||||
"windows.com.wrapper.callbacks" create ;
|
||||
|
||||
: (finish-thunk) ( param-count thunk quot -- thunked-quot )
|
||||
[ [ drop [ ] ] [ swap 1 - '[ _ _ ndip ] ] if-empty ]
|
||||
dip compose ;
|
||||
|
||||
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
|
||||
: (make-interface-callbacks) ( interface quots iunknown-methods n -- words )
|
||||
(thunk) (thunked-quots)
|
||||
swap [ find-com-interface-definition family-tree-functions ]
|
||||
keep (next-vtbl-counter) '[
|
||||
|
|
@ -128,8 +128,8 @@ unless
|
|||
curry map-index ;
|
||||
|
||||
: (malloc-wrapped-object) ( wrapper -- wrapped-object )
|
||||
vtbls>> length "void*" heap-size *
|
||||
[ "ulong" heap-size + malloc ] keep
|
||||
vtbls>> length void* heap-size *
|
||||
[ ulong heap-size + malloc ] keep
|
||||
[ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ;
|
||||
|
||||
: (callbacks>vtbl) ( callbacks -- vtbl )
|
||||
|
|
|
|||
|
|
@ -20,15 +20,39 @@ HELP: checksum-stream
|
|||
|
||||
HELP: checksum-bytes
|
||||
{ $values { "bytes" "a sequence of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
|
||||
{ $contract "Computes the checksum of all data in a sequence." } ;
|
||||
{ $contract "Computes the checksum of all data in a sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: checksums checksums.crc32 prettyprint ;"
|
||||
"B{ 1 10 100 } crc32 checksum-bytes ."
|
||||
"B{ 78 179 254 238 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: checksum-lines
|
||||
{ $values { "lines" "a sequence of sequences of bytes" } { "checksum" "a checksum specifier" } { "value" byte-array } }
|
||||
{ $contract "Computes the checksum of all data in a sequence." } ;
|
||||
{ $contract "Computes the checksum of all data in a sequence." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: checksums checksums.crc32 prettyprint ;"
|
||||
"""{
|
||||
"Take me out to the ball game"
|
||||
"Take me out with the crowd"
|
||||
} crc32 checksum-lines ."""
|
||||
"B{ 111 205 9 27 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: checksum-file
|
||||
{ $values { "path" "a pathname specifier" } { "checksum" "a checksum specifier" } { "value" byte-array } }
|
||||
{ $contract "Computes the checksum of all data in a file." } ;
|
||||
{ $contract "Computes the checksum of all data in a file." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: checksums checksums.crc32 prettyprint ;"
|
||||
""""resource:license.txt" crc32 checksum-file ."""
|
||||
"B{ 100 139 199 92 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "checksums" "Checksums"
|
||||
"A " { $emphasis "checksum" } " is a function mapping sequences of bytes to fixed-length strings. While checksums are not one-to-one, a good checksum should have a low probability of collision. Additionally, some checksum algorithms are designed to be hard to reverse, in the sense that finding an input string which hashes to a given checksum string requires a brute-force search."
|
||||
|
|
|
|||
|
|
@ -0,0 +1,23 @@
|
|||
USING: kernel locals math math.matrices math.order math.vectors
|
||||
prettyprint sequences ;
|
||||
IN: benchmark.3d-matrix-scalar
|
||||
|
||||
:: p-matrix ( dim fov near far -- matrix )
|
||||
dim dup first2 min v/n fov v*n near v*n
|
||||
near far frustum-matrix4 ;
|
||||
|
||||
:: mv-matrix ( pitch yaw location -- matrix )
|
||||
{ 1.0 0.0 0.0 } pitch rotation-matrix4
|
||||
{ 0.0 1.0 0.0 } yaw rotation-matrix4
|
||||
location vneg translation-matrix4 m. m. ;
|
||||
|
||||
:: 3d-matrix ( -- )
|
||||
f :> result!
|
||||
100000 [
|
||||
{ 1024.0 768.0 } 0.7 0.25 1024.0 p-matrix :> p
|
||||
3.0 1.0 { 10.0 -0.0 2.0 } mv-matrix :> mv
|
||||
mv p m. result!
|
||||
] times
|
||||
result . ;
|
||||
|
||||
MAIN: 3d-matrix
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
USING: kernel locals math math.matrices.simd math.order math.vectors
|
||||
math.vectors.simd prettyprint sequences typed ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
SIMD: c:float
|
||||
IN: benchmark.3d-matrix-vector
|
||||
|
||||
: v2min ( xy -- xx )
|
||||
dup { 1 0 2 3 } vshuffle vmin ; inline
|
||||
|
||||
TYPED:: p-matrix ( dim: float-4 fov: float near: float far: float -- matrix: matrix4 )
|
||||
dim dup v2min v/ fov v*n near v*n
|
||||
near far frustum-matrix4 ;
|
||||
|
||||
TYPED:: mv-matrix ( pitch: float yaw: float location: float-4 -- matrix: matrix4 )
|
||||
float-4{ 1.0 0.0 0.0 0.0 } pitch rotation-matrix4
|
||||
float-4{ 0.0 1.0 0.0 0.0 } yaw rotation-matrix4
|
||||
location vneg translation-matrix4 m4. m4. ;
|
||||
|
||||
:: 3d-matrix ( -- )
|
||||
f :> result!
|
||||
100000 [
|
||||
float-4{ 1024.0 768.0 0.0 0.0 } 0.7 0.25 1024.0 p-matrix :> p
|
||||
3.0 1.0 float-4{ 10.0 -0.0 2.0 0.0 } mv-matrix :> mv
|
||||
mv p m4. result!
|
||||
] times
|
||||
result . ;
|
||||
|
||||
MAIN: 3d-matrix
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
USING: locals math math.combinatorics math.matrices
|
||||
prettyprint sequences typed ;
|
||||
IN: benchmark.matrix-exponential-scalar
|
||||
|
||||
:: e^m ( m iterations -- e^m )
|
||||
{
|
||||
{ 0.0 0.0 0.0 0.0 }
|
||||
{ 0.0 0.0 0.0 0.0 }
|
||||
{ 0.0 0.0 0.0 0.0 }
|
||||
{ 0.0 0.0 0.0 0.0 }
|
||||
}
|
||||
iterations iota [| i |
|
||||
m i m^n i factorial >float m/n m+
|
||||
] each ;
|
||||
|
||||
:: matrix-e ( -- )
|
||||
f :> result!
|
||||
4 identity-matrix :> i4
|
||||
10000 [
|
||||
i4 20 e^m result!
|
||||
] times
|
||||
result . ;
|
||||
|
||||
MAIN: matrix-e
|
||||
|
|
@ -0,0 +1,18 @@
|
|||
USING: locals math math.combinatorics math.matrices.simd
|
||||
prettyprint sequences typed ;
|
||||
IN: benchmark.matrix-exponential-simd
|
||||
|
||||
TYPED:: e^m4 ( m: matrix4 iterations: fixnum -- e^m: matrix4 )
|
||||
zero-matrix4
|
||||
iterations iota [| i |
|
||||
m i m4^n i factorial >float m4/n m4+
|
||||
] each ;
|
||||
|
||||
:: matrix-e ( -- )
|
||||
f :> result!
|
||||
10000 [
|
||||
identity-matrix4 20 e^m4 result!
|
||||
] times
|
||||
result . ;
|
||||
|
||||
MAIN: matrix-e
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! (c)Joe Groff bsd license
|
||||
USING: accessors classes.struct generalizations kernel locals
|
||||
math math.functions math.matrices.simd math.vectors
|
||||
math math.combinatorics math.functions math.matrices.simd math.vectors
|
||||
math.vectors.simd sequences sequences.private specialized-arrays
|
||||
typed ;
|
||||
QUALIFIED-WITH: alien.c-types c
|
||||
|
|
@ -105,6 +105,19 @@ CONSTANT: identity-matrix4
|
|||
}
|
||||
}
|
||||
|
||||
CONSTANT: zero-matrix4
|
||||
S{ matrix4 f
|
||||
float-4-array{
|
||||
float-4{ 0.0 0.0 0.0 0.0 }
|
||||
float-4{ 0.0 0.0 0.0 0.0 }
|
||||
float-4{ 0.0 0.0 0.0 0.0 }
|
||||
float-4{ 0.0 0.0 0.0 0.0 }
|
||||
}
|
||||
}
|
||||
|
||||
TYPED:: m4^n ( m: matrix4 n: fixnum -- m^n: matrix4 )
|
||||
identity-matrix4 n [ m m4. ] times ;
|
||||
|
||||
TYPED:: scale-matrix4 ( factors: float-4 -- matrix: matrix4 )
|
||||
matrix4 (struct) :> c
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,58 @@
|
|||
! Copyright (C) 2009 Jon Harper.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs kernel math math.combinatorics math.functions
|
||||
math.parser math.primes namespaces project-euler.common
|
||||
sequences sets strings grouping math.ranges arrays ;
|
||||
IN: project-euler.051
|
||||
|
||||
SYMBOL: family-count
|
||||
SYMBOL: large-families
|
||||
: reset-globals ( -- )
|
||||
H{ } clone family-count set
|
||||
H{ } clone large-families set ;
|
||||
|
||||
: append-or-create ( value seq/f -- seq )
|
||||
dup [ swap suffix ] [ drop 1array ] if ;
|
||||
: append-at ( value key assoc -- )
|
||||
[ at append-or-create ] 2keep set-at ;
|
||||
: digits-positions ( str -- positions )
|
||||
H{ } clone swap over [ swapd append-at ] curry each-index ;
|
||||
|
||||
: *-if-index ( char combination index -- char )
|
||||
member? [ drop CHAR: * ] when ;
|
||||
: replace-positions-with-* ( str positions -- str )
|
||||
[ *-if-index ] curry map-index ;
|
||||
: all-size-combinations ( seq -- combinations )
|
||||
dup length [1,b] [ all-combinations ] with map concat ;
|
||||
|
||||
: families ( stra -- seq )
|
||||
dup digits-positions values
|
||||
[ all-size-combinations [ replace-positions-with-* ] with map ] with map concat ;
|
||||
|
||||
: save-family ( family -- )
|
||||
family-count get dupd at 8 = [ large-families get conjoin ] [ drop ] if ;
|
||||
: increment-family ( family -- )
|
||||
family-count get dupd at* [ 1 + ] [ drop 1 ] if swap family-count get set-at ;
|
||||
: handle-family ( family -- )
|
||||
[ increment-family ] [ save-family ] bi ;
|
||||
|
||||
! Test all primes that have length n
|
||||
: n-digits-primes ( n -- primes )
|
||||
[ 1 - 10^ ] [ 10^ ] bi primes-between ;
|
||||
: test-n-digits-primes ( n -- seq )
|
||||
reset-globals
|
||||
n-digits-primes
|
||||
[ number>string families [ handle-family ] each ] each
|
||||
large-families get ;
|
||||
|
||||
: fill-*-with-ones ( str -- str )
|
||||
[ dup CHAR: * = [ drop CHAR: 1 ] when ] map ;
|
||||
|
||||
! recursively test all primes by length until we find an answer
|
||||
: (euler051) ( i -- answer )
|
||||
dup test-n-digits-primes
|
||||
dup assoc-size 0 >
|
||||
[ nip values [ fill-*-with-ones string>number ] map infimum ]
|
||||
[ drop 1 + (euler051) ] if ;
|
||||
: euler051 ( -- answer )
|
||||
2 (euler051) ;
|
||||
|
|
@ -4,5 +4,7 @@ IN: typed.debugger
|
|||
|
||||
: typed-test-mr ( word -- mrs )
|
||||
"typed-word" word-prop test-mr ; inline
|
||||
: typed-test-mr. ( word -- )
|
||||
"typed-word" word-prop test-mr mr. ; inline
|
||||
: typed-optimized. ( word -- )
|
||||
"typed-word" word-prop optimized. ; inline
|
||||
|
|
|
|||
Loading…
Reference in New Issue