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

optimizing random.sfmt

db4
Doug Coleman 2009-10-02 01:18:18 -05:00
parent b8e5e84df3
commit 1239984625
2 changed files with 85 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
basis/random/sfmt/sfmt-tests.factor
View File

@ -1,8 +1,13 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel random.sfmt sequences tools.test ; USING: accessors kernel random random.sfmt random.sfmt.private
sequences tools.test ;
IN: random.sfmt.tests IN: random.sfmt.tests
[ ] [ 100 <sfmt-19937> drop ] unit-test [ ] [ 100 <sfmt-19937> drop ] unit-test
[ 1096298955 ] [ 1096298955 ]
[ 100 <sfmt-19937> generate generate state>> first first ] unit-test [ 100 <sfmt-19937> dup generate dup generate uint-array>> first ] unit-test
[ 2556114782 ]
[ 100 <sfmt-19937> random-32* ] unit-test

145
basis/random/sfmt/sfmt.factor
View File

@ -2,35 +2,30 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types kernel locals math math.ranges USING: accessors alien.c-types kernel locals math math.ranges
math.bitwise math.vectors math.vectors.simd random math.bitwise math.vectors math.vectors.simd random
sequences specialized-arrays sequences.private ; sequences specialized-arrays sequences.private classes.struct ;
IN: random.sfmt
SIMD: uint SIMD: uint
SPECIALIZED-ARRAY: uint SPECIALIZED-ARRAY: uint
SPECIALIZED-ARRAY: uint-4 SPECIALIZED-ARRAY: uint-4
IN: random.sfmt
CONSTANT: SFMT_N 156 <PRIVATE
CONSTANT: SFMT_M 122
CONSTANT: state-multiplier 1812433253 CONSTANT: state-multiplier 1812433253
TUPLE: sfmt STRUCT: sfmt-state
sl1 sl2 sr1 sr2 mask parity { seed uint }
{ r1 uint-4 } { r2 uint-4 } { n uint }
{ seed fixnum } { n fixnum } { m fixnum } { m uint }
{ m-n fixnum } { ix fixnum } { state uint-4-array } ; { m-n int }
{ ix uint }
{ mask uint-4 }
{ r1 uint-4 }
{ r2 uint-4 } ;
: init-state ( sfmt -- sfmt' ) TUPLE: sfmt
dup [ n>> 4 * iota >uint-array ] [ seed>> ] bi { state sfmt-state }
[ { uint-array uint-array }
[ { uint-4-array uint-4-array } ;
[
[ -30 shift ] [ ] bi bitxor
state-multiplier * 32 bits
] dip +
] unless-zero 32 bits
] uint-array{ } accumulate-as nip underlying>> byte-array>uint-4-array
>>state ;
: wA ( w -- wA ) : wA ( w -- wA )
dup 1 hlshift vbitxor ; inline dup 1 hlshift vbitxor ; inline
@ -49,69 +44,85 @@ sl1 sl2 sr1 sr2 mask parity
[ wB ] dip vbitxor [ wB ] dip vbitxor
[ wA ] dip vbitxor ; inline [ wA ] dip vbitxor ; inline
GENERIC: generate ( sfmt -- sfmt' ) GENERIC: generate ( sfmt -- )
M:: sfmt generate ( sfmt -- sfmt' ) M:: sfmt generate ( sfmt -- )
sfmt state>> :> state sfmt state>> :> state
sfmt n>> 2 - state nth-unsafe sfmt (>>r1) sfmt uint-4-array>> :> array
sfmt n>> 1 - state nth-unsafe sfmt (>>r2) state n>> 2 - array nth state (>>r1)
sfmt m>> :> m state n>> 1 - array nth state (>>r2)
sfmt n>> :> n state m>> :> m
sfmt m-n>> :> m-n state n>> :> n
sfmt mask>> :> mask state m-n>> :> m-n
state mask>> :> mask
n m - iota [| i | n m - >fixnum iota [| i |
i state nth-unsafe i array nth-unsafe
i m + state nth-unsafe i m + array nth-unsafe
mask sfmt r1>> sfmt r2>> formula :> r mask state r1>> state r2>> formula :> r
r i state set-nth-unsafe r i array set-nth-unsafe
sfmt r2>> sfmt (>>r1) state r2>> state (>>r1)
r sfmt (>>r2) r state (>>r2)
] each ] each
n m - 1 + n [a,b) [| i | ! n m - 1 + n [a,b) [
i state nth-unsafe m 1 - iota [
m-n i + state nth-unsafe n m - 1 + + >fixnum :> i
mask sfmt r1>> sfmt r2>> formula :> r i array nth-unsafe
m-n i + array nth-unsafe
mask state r1>> state r2>> formula :> r
r i state set-nth-unsafe r i array set-nth-unsafe
sfmt r2>> sfmt (>>r1) state r2>> state (>>r1)
r sfmt (>>r2) r state (>>r2)
] each ] each
sfmt 0 >>ix ; 0 state (>>ix) ;
: <sfmt> ( seed n m sl1 sl2 sr1 sr2 mask parity -- sfmt ) : <sfmt-array> ( sfmt -- uint-array uint-4-array )
sfmt new state>>
swap >>parity [ n>> 4 * iota >uint-array ] [ seed>> ] bi
[
[
[
[ -30 shift ] [ ] bi bitxor
state-multiplier * 32 bits
] dip +
] unless-zero 32 bits
] uint-array{ } accumulate-as nip
dup underlying>> byte-array>uint-4-array ;
: <sfmt-state> ( seed n m mask -- sfmt )
sfmt-state <struct>
swap >>mask swap >>mask
swap >>sr2
swap >>sr1
swap >>sl2
swap >>sl1
swap >>m swap >>m
swap >>n swap >>n
swap 32 bits >>seed swap >>seed
dup [ m>> ] [ n>> ] bi - >>m-n dup [ m>> ] [ n>> ] bi - >>m-n
0 >>ix 0 >>ix ;
init-state
generate ;
: <sfmt-19937> ( seed -- sfmt ) : <sfmt> ( seed n m mask -- sfmt )
348 330 5 3 9 3 <sfmt-state>
uint-4{ HEX: BFFFFFF6 HEX: BFFAFFFF HEX: DDFECB7F HEX: DFFFFFEF } sfmt new
uint-4{ HEX: ecc1327a HEX: a3ac4000 HEX: 0 HEX: 1 } swap >>state
<sfmt> ; dup <sfmt-array> [ >>uint-array ] [ >>uint-4-array ] bi*
[ generate ] keep ;
: refill-sfmt? ( sfmt -- ? ) : refill-sfmt? ( sfmt -- ? )
[ ix>> ] [ n>> 4 * ] bi >= ; state>> [ ix>> ] [ n>> 4 * ] bi >= ;
: nth-sfmt ( sfmt -- n ) : next-ix ( sfmt -- ix )
[ ix>> 4 /mod swap ] state>> [ dup 1 + ] change-ix drop ; inline
[ state>> nth nth ]
[ [ 1 + ] change-ix drop ] tri ; inline : next ( sfmt -- n )
[ next-ix ] [ uint-array>> ] bi nth-unsafe ; inline
PRIVATE>
M: sfmt random-32* ( sfmt -- n ) M: sfmt random-32* ( sfmt -- n )
dup refill-sfmt? [ generate ] when dup refill-sfmt? [ dup generate ] when next ;
nth-sfmt ;
: <sfmt-19937> ( seed -- sfmt )
348 330 uint-4{ HEX: BFFFFFF6 HEX: BFFAFFFF HEX: DDFECB7F HEX: DFFFFFEF }
<sfmt> ;