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

50% speedup using unsafe nth/set-nth/exchange in checksums.sha

db4
Doug Coleman 2009-06-21 00:58:36 -05:00
parent f2208728e2
commit 785c341c9b
1 changed files with 51 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

104
basis/checksums/sha/sha.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting grouping math sequences namespaces make USING: accessors checksums checksums.common checksums.stream
io.binary math.bitwise checksums checksums.common combinators combinators.smart fry generalizations grouping
sbufs strings combinators.smart math.ranges fry combinators io.binary kernel literals locals make math math.bitwise
accessors locals checksums.stream multiline literals math.ranges multiline namespaces sbufs sequences
generalizations ; sequences.private splitting strings ;
IN: checksums.sha IN: checksums.sha
SINGLETON: sha1 SINGLETON: sha1
@ -230,21 +230,21 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
: prepare-M-256 ( n seq -- ) : prepare-M-256 ( n seq -- )
{ {
[ [ 16 - ] dip nth ] [ [ 16 - ] dip nth-unsafe ]
[ [ 15 - ] dip nth s0-256 ] [ [ 15 - ] dip nth-unsafe s0-256 ]
[ [ 7 - ] dip nth ] [ [ 7 - ] dip nth-unsafe ]
[ [ 2 - ] dip nth s1-256 w+ w+ w+ ] [ [ 2 - ] dip nth-unsafe s1-256 w+ w+ w+ ]
[ ] [ ]
} 2cleave set-nth ; inline } 2cleave set-nth-unsafe ; inline
: prepare-M-512 ( n seq -- ) : prepare-M-512 ( n seq -- )
{ {
[ [ 16 - ] dip nth ] [ [ 16 - ] dip nth-unsafe ]
[ [ 15 - ] dip nth s0-512 ] [ [ 15 - ] dip nth-unsafe s0-512 ]
[ [ 7 - ] dip nth ] [ [ 7 - ] dip nth-unsafe ]
[ [ 2 - ] dip nth s1-512 w+ w+ w+ ] [ [ 2 - ] dip nth-unsafe s1-512 w+ w+ w+ ]
[ ] [ ]
} 2cleave set-nth ; inline } 2cleave set-nth-unsafe ; inline
: ch ( x y z -- x' ) : ch ( x y z -- x' )
[ bitxor bitand ] keep bitxor ; inline [ bitxor bitand ] keep bitxor ; inline
@ -258,36 +258,36 @@ M: sha-256 initialize-checksum-state drop <sha-256-state> ;
GENERIC: pad-initial-bytes ( string sha2 -- padded-string ) GENERIC: pad-initial-bytes ( string sha2 -- padded-string )
:: T1-256 ( n M H sha2 -- T1 ) :: T1-256 ( n M H sha2 -- T1 )
n M nth n M nth-unsafe
n sha2 K>> nth + n sha2 K>> nth-unsafe +
e H slice3 ch w+ e H slice3 ch w+
e H nth S1-256 w+ e H nth-unsafe S1-256 w+
h H nth w+ ; inline h H nth-unsafe w+ ; inline
: T2-256 ( H -- T2 ) : T2-256 ( H -- T2 )
[ a swap nth S0-256 ] [ a swap nth-unsafe S0-256 ]
[ a swap slice3 maj w+ ] bi ; inline [ a swap slice3 maj w+ ] bi ; inline
:: T1-512 ( n M H sha2 -- T1 ) :: T1-512 ( n M H sha2 -- T1 )
n M nth n M nth-unsafe
n sha2 K>> nth + n sha2 K>> nth-unsafe +
e H slice3 ch w+ e H slice3 ch w+
e H nth S1-512 w+ e H nth-unsafe S1-512 w+
h H nth w+ ; inline h H nth-unsafe w+ ; inline
: T2-512 ( H -- T2 ) : T2-512 ( H -- T2 )
[ a swap nth S0-512 ] [ a swap nth-unsafe S0-512 ]
[ a swap slice3 maj w+ ] bi ; inline [ a swap slice3 maj w+ ] bi ; inline
: update-H ( T1 T2 H -- ) : update-H ( T1 T2 H -- )
h g pick exchange h g pick exchange-unsafe
g f pick exchange g f pick exchange-unsafe
f e pick exchange f e pick exchange-unsafe
pick d pick nth w+ e pick set-nth pick d pick nth-unsafe w+ e pick set-nth-unsafe
d c pick exchange d c pick exchange-unsafe
c b pick exchange c b pick exchange-unsafe
b a pick exchange b a pick exchange-unsafe
[ w+ a ] dip set-nth ; inline [ w+ a ] dip set-nth-unsafe ; inline
: prepare-message-schedule ( seq sha2 -- w-seq ) : prepare-message-schedule ( seq sha2 -- w-seq )
[ word-size>> <sliced-groups> [ be> ] map ] [ word-size>> <sliced-groups> [ be> ] map ]
@ -309,7 +309,7 @@ M: sha2-short checksum-block
[ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ; [ [ block-size>> ] [ H>> clone ] [ ] tri process-chunk ] bi ;
: seq>byte-array ( seq n -- string ) : seq>byte-array ( seq n -- string )
'[ _ >be ] map B{ } join ; '[ _ >be ] map B{ } concat-as ;
: sha1>checksum ( sha2 -- bytes ) : sha1>checksum ( sha2 -- bytes )
H>> 4 seq>byte-array ; H>> 4 seq>byte-array ;
@ -342,16 +342,14 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
drop drop
[ <sha-256-state> ] dip add-checksum-stream get-checksum ; [ <sha-256-state> ] dip add-checksum-stream get-checksum ;
: sha1-W ( t seq -- ) : sha1-W ( t seq -- )
{ {
[ [ 3 - ] dip nth ] [ [ 3 - ] dip nth-unsafe ]
[ [ 8 - ] dip nth bitxor ] [ [ 8 - ] dip nth-unsafe bitxor ]
[ [ 14 - ] dip nth bitxor ] [ [ 14 - ] dip nth-unsafe bitxor ]
[ [ 16 - ] dip nth bitxor 1 bitroll-32 ] [ [ 16 - ] dip nth-unsafe bitxor 1 bitroll-32 ]
[ ] [ ]
} 2cleave set-nth ; } 2cleave set-nth-unsafe ;
: prepare-sha1-message-schedule ( seq -- w-seq ) : prepare-sha1-message-schedule ( seq -- w-seq )
4 <sliced-groups> [ be> ] map 4 <sliced-groups> [ be> ] map
@ -368,11 +366,11 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
} case ; } case ;
:: inner-loop ( n H W K -- temp ) :: inner-loop ( n H W K -- temp )
a H nth :> A a H nth-unsafe :> A
b H nth :> B b H nth-unsafe :> B
c H nth :> C c H nth-unsafe :> C
d H nth :> D d H nth-unsafe :> D
e H nth :> E e H nth-unsafe :> E
[ [
A 5 bitroll-32 A 5 bitroll-32
@ -380,19 +378,19 @@ M: sha-256 checksum-stream ( stream checksum -- byte-array )
E E
n K nth n K nth-unsafe
n W nth n W nth-unsafe
] sum-outputs 32 bits ; ] sum-outputs 32 bits ;
:: process-sha1-chunk ( bytes H W K state -- ) :: process-sha1-chunk ( bytes H W K state -- )
80 [ 80 [
H W K inner-loop H W K inner-loop
d H nth e H set-nth d H nth-unsafe e H set-nth-unsafe
c H nth d H set-nth c H nth-unsafe d H set-nth-unsafe
b H nth 30 bitroll-32 c H set-nth b H nth-unsafe 30 bitroll-32 c H set-nth-unsafe
a H nth b H set-nth a H nth-unsafe b H set-nth-unsafe
a H set-nth a H set-nth-unsafe
] each ] each
state [ H [ w+ ] 2map ] change-H drop ; inline state [ H [ w+ ] 2map ] change-H drop ; inline