performance improvements
Slava Pestov
parent
d978c8c032
commit
22ab0d97fa
|
|
@ -3,66 +3,58 @@ USING: kernel io strings sequences namespaces math prettyprint
|
|||
unparser test parser lists ;
|
||||
|
||||
: (shift-mod) ( n s w -- n )
|
||||
>r shift r> 1 swap shift mod ;
|
||||
>r shift r> 1 swap shift 1 - bitand ; inline
|
||||
|
||||
: bitroll ( n s w -- n )
|
||||
#! Roll n by s bits to the left, wrapping around after
|
||||
#! w bits.
|
||||
[ mod ] keep
|
||||
[ 1 - bitand ] keep
|
||||
over 0 < [ [ + ] keep ] when
|
||||
[
|
||||
(shift-mod)
|
||||
] 3keep
|
||||
[ - ] keep (shift-mod) bitor ;
|
||||
|
||||
[ (shift-mod) ] 3keep
|
||||
[ - ] keep (shift-mod) bitor ; inline
|
||||
|
||||
: w+ ( int -- int )
|
||||
+ HEX: ffffffff bitand ;
|
||||
+ HEX: ffffffff bitand ; inline
|
||||
|
||||
: nth-int ( string n -- int )
|
||||
4 * dup 4 + rot subseq le> ;
|
||||
2 shift dup 4 + rot <slice> le> ; inline
|
||||
|
||||
: nth-int-be ( string n -- int )
|
||||
4 * dup 4 + rot subseq be> ;
|
||||
2 shift dup 4 + rot <slice> be> ; inline
|
||||
|
||||
: float-sin ( int -- int )
|
||||
sin abs 4294967296 * >bignum ;
|
||||
sin abs 4294967296 * >bignum ; inline
|
||||
|
||||
: update ( num var -- )
|
||||
[ w+ ] change ;
|
||||
[ w+ ] change ; inline
|
||||
|
||||
: update-old-new ( old new -- )
|
||||
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ;
|
||||
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline
|
||||
|
||||
! calculate pad length. leave 8 bytes for length after padding
|
||||
: zero-pad-length ( length -- pad-length )
|
||||
dup 64 mod 56 < 55 119 ? swap - ; ! one less for first byte of padding 0x80
|
||||
dup 56 < 55 119 ? swap - ; ! one less for first byte of padding 0x80
|
||||
|
||||
! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
|
||||
: pad-string-md5 ( string -- padded-string )
|
||||
[
|
||||
dup % "\u0080" %
|
||||
dup length 64 mod zero-pad-length 0 fill %
|
||||
dup length 8 * 8 >le %
|
||||
dup % HEX: 80 ,
|
||||
dup length HEX: 3f bitand zero-pad-length 0 fill %
|
||||
dup length 3 shift 8 >le %
|
||||
] "" make nip ;
|
||||
|
||||
: pad-string-sha1 ( string -- padded-string )
|
||||
[
|
||||
dup % "\u0080" %
|
||||
dup length 64 mod zero-pad-length 0 fill %
|
||||
dup length 8 * 8 >be %
|
||||
dup % HEX: 80 ,
|
||||
dup length HEX: 3f bitand zero-pad-length 0 fill %
|
||||
dup length 3 shift 8 >be %
|
||||
] "" make nip ;
|
||||
|
||||
: num-blocks ( length -- num )
|
||||
64 /i ;
|
||||
-6 shift ;
|
||||
|
||||
: get-block ( string num -- string )
|
||||
64 * dup 64 + rot subseq ;
|
||||
6 shift dup 64 + rot <slice> ;
|
||||
|
||||
: hex-string ( str -- str )
|
||||
[
|
||||
[
|
||||
>hex 2 48 pad-left %
|
||||
] each
|
||||
] "" make ;
|
||||
|
||||
[ [ >hex 2 48 pad-left % ] each ] "" make ;
|
||||
|
|
|
|||
|
|
@ -26,19 +26,19 @@ SYMBOL: old-d
|
|||
! Let [abcd k s i] denote the operation
|
||||
! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
|
||||
|
||||
: (F) ( vars func -- vars result )
|
||||
>r dup second get over third get pick fourth get r> call ; inline
|
||||
: 2to4 dup second get over third get pick fourth get ;
|
||||
|
||||
! # bits to shift, input to float-sin, x, func
|
||||
: (ABCD) ( s i x vars func -- )
|
||||
(F) swap >r w+ swap float-sin w+ r> dup first >r swap r> update
|
||||
dup first get rot 32 bitroll
|
||||
over second get w+ swap first set ; inline
|
||||
: (F) ( vars func -- vars result ) >r 2to4 r> call ; inline
|
||||
|
||||
: ABCD [ a b c d ] swap (ABCD) ; inline
|
||||
: BCDA [ b c d a ] swap (ABCD) ; inline
|
||||
: CDAB [ c d a b ] swap (ABCD) ; inline
|
||||
: DABC [ d a b c ] swap (ABCD) ; inline
|
||||
: (ABCD) ( s i x vars result -- )
|
||||
#! bits to shift, input to float-sin, x, func
|
||||
swap >r w+ swap float-sin w+ r> dup first >r swap r> update
|
||||
dup first get rot 32 bitroll over second get w+ swap first set ;
|
||||
|
||||
: ABCD { a b c d } swap (F) (ABCD) ; inline
|
||||
: BCDA { b c d a } swap (F) (ABCD) ; inline
|
||||
: CDAB { c d a b } swap (F) (ABCD) ; inline
|
||||
: DABC { d a b c } swap (F) (ABCD) ; inline
|
||||
|
||||
! F(X,Y,Z) = XY v not(X) Z
|
||||
: F ( X Y Z -- FXYZ )
|
||||
|
|
@ -56,22 +56,22 @@ SYMBOL: old-d
|
|||
: I ( X Y Z -- IXYZ )
|
||||
rot swap bitnot bitor bitxor ;
|
||||
|
||||
: S11 7 ;
|
||||
: S12 12 ;
|
||||
: S13 17 ;
|
||||
: S14 22 ;
|
||||
: S21 5 ;
|
||||
: S22 9 ;
|
||||
: S23 14 ;
|
||||
: S24 20 ;
|
||||
: S31 4 ;
|
||||
: S32 11 ;
|
||||
: S33 16 ;
|
||||
: S34 23 ;
|
||||
: S41 6 ;
|
||||
: S42 10 ;
|
||||
: S43 15 ;
|
||||
: S44 21 ;
|
||||
: S11 7 ; inline
|
||||
: S12 12 ; inline
|
||||
: S13 17 ; inline
|
||||
: S14 22 ; inline
|
||||
: S21 5 ; inline
|
||||
: S22 9 ; inline
|
||||
: S23 14 ; inline
|
||||
: S24 20 ; inline
|
||||
: S31 4 ; inline
|
||||
: S32 11 ; inline
|
||||
: S33 16 ; inline
|
||||
: S34 23 ; inline
|
||||
: S41 6 ; inline
|
||||
: S42 10 ; inline
|
||||
: S43 15 ; inline
|
||||
: S44 21 ; inline
|
||||
|
||||
: process-md5-block ( block -- )
|
||||
S11 1 pick 0 nth-int [ F ] ABCD
|
||||
|
|
@ -142,13 +142,10 @@ SYMBOL: old-d
|
|||
S43 63 pick 2 nth-int [ I ] CDAB
|
||||
S44 64 pick 9 nth-int [ I ] BCDA
|
||||
update-md
|
||||
drop
|
||||
;
|
||||
drop ;
|
||||
|
||||
: get-md5 ( -- str )
|
||||
[
|
||||
[ a b c d ] [ get 4 >le % ] each
|
||||
] "" make hex-string ;
|
||||
[ [ a b c d ] [ get 4 >le % ] each ] "" make hex-string ;
|
||||
|
||||
: string>md5 ( string -- md5 )
|
||||
[
|
||||
|
|
@ -157,15 +154,9 @@ SYMBOL: old-d
|
|||
drop get-md5
|
||||
] with-scope ;
|
||||
|
||||
: stream>md5 ( stream -- md5 )
|
||||
[
|
||||
contents string>md5
|
||||
] with-scope ;
|
||||
: stream>md5 ( stream -- md5 ) contents string>md5 ;
|
||||
|
||||
: file>md5 ( file -- md5 )
|
||||
[
|
||||
<file-reader> stream>md5
|
||||
] with-scope ;
|
||||
: file>md5 ( file -- md5 ) <file-reader> stream>md5 ;
|
||||
|
||||
: test-md5 ( -- )
|
||||
[ "d41d8cd98f00b204e9800998ecf8427e" ] [ "" string>md5 ] unit-test
|
||||
|
|
@ -176,4 +167,3 @@ SYMBOL: old-d
|
|||
[ "d174ab98d277d9f5a5611c2c9f419d9f" ] [ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789" string>md5 ] unit-test
|
||||
[ "57edf4a22be3c955ac49da2e2107b67a" ] [ "12345678901234567890123456789012345678901234567890123456789012345678901234567890" string>md5 ] unit-test
|
||||
;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue