From 22ab0d97fa101ce5eb57e581d7248af786620aff Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 10 Sep 2005 19:53:17 +0000 Subject: [PATCH] performance improvements --- contrib/crypto/common.factor | 48 ++++++++++-------------- contrib/crypto/md5.factor | 72 ++++++++++++++++-------------------- 2 files changed, 51 insertions(+), 69 deletions(-) diff --git a/contrib/crypto/common.factor b/contrib/crypto/common.factor index 0181b3f766..4d934c8f6c 100644 --- a/contrib/crypto/common.factor +++ b/contrib/crypto/common.factor @@ -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 le> ; inline : nth-int-be ( string n -- int ) - 4 * dup 4 + rot subseq be> ; + 2 shift dup 4 + rot 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 ; : hex-string ( str -- str ) - [ - [ - >hex 2 48 pad-left % - ] each - ] "" make ; - + [ [ >hex 2 48 pad-left % ] each ] "" make ; diff --git a/contrib/crypto/md5.factor b/contrib/crypto/md5.factor index 489345dfac..17762e86f7 100644 --- a/contrib/crypto/md5.factor +++ b/contrib/crypto/md5.factor @@ -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 ) - [ - stream>md5 - ] with-scope ; +: file>md5 ( file -- md5 ) 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 ; -