performance improvements

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
-         (shift-mod)
+     [ - ] keep (shift-mod) bitor ; inline
-     ] 3keep
-     [ - ] keep (shift-mod) bitor ;
-
 
 : 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 % HEX: 80 ,
-        dup length 64 mod zero-pad-length 0 fill %
+        dup length HEX: 3f bitand zero-pad-length 0 fill %
-        dup length 8 * 8 >le %
+        dup length 3 shift 8 >le %
     ] "" make nip ;
 
 : pad-string-sha1 ( string  -- padded-string )
     [
-        dup % "\u0080" %
+        dup % HEX: 80 ,
-        dup length 64 mod zero-pad-length 0 fill %
+        dup length HEX: 3f bitand zero-pad-length 0 fill %
-        dup length 8 * 8 >be %
+        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 ;
-

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 )
+: 2to4 dup second get over third get pick fourth get ;
-    >r dup second get over third get pick fourth get r> call ; inline
 
-! # bits to shift, input to float-sin, x, func
+: (F) ( vars func -- vars result ) >r 2to4 r> call ; inline
-: (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
 
-: ABCD [ a b c d ] swap (ABCD) ; inline
+: (ABCD) ( s i x vars result -- )
-: BCDA [ b c d a ] swap (ABCD) ; inline
+    #! bits to shift, input to float-sin, x, func
-: CDAB [ c d a b ] swap (ABCD) ; inline
+    swap >r w+ swap float-sin w+ r> dup first >r swap r> update
-: DABC [ d a b c ] swap (ABCD) ; inline
+    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 ;
+: S11 7  ; inline
-: S12 12 ;
+: S12 12 ; inline
-: S13 17 ;
+: S13 17 ; inline
-: S14 22 ;
+: S14 22 ; inline
-: S21 5 ;
+: S21 5  ; inline
-: S22 9 ;
+: S22 9  ; inline
-: S23 14 ;
+: S23 14 ; inline
-: S24 20 ;
+: S24 20 ; inline
-: S31 4 ;
+: S31 4 ;  inline
-: S32 11 ;
+: S32 11 ; inline
-: S33 16 ;
+: S33 16 ; inline
-: S34 23 ;
+: S34 23 ; inline
-: S41 6 ;
+: S41 6  ; inline
-: S42 10 ;
+: S42 10 ; inline
-: S43 15 ;
+: S43 15 ; inline
-: S44 21 ;
+: 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 )
+: stream>md5 ( stream -- md5 ) contents string>md5 ;
-    [
-        contents string>md5
-    ] with-scope ;
 
-: file>md5 ( file -- md5 )
+: file>md5 ( file -- md5 ) <file-reader> stream>md5 ;
-    [
-        <file-reader> stream>md5
-    ] with-scope ;
 
 : 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
     ;
-