benchmark/tests/md5.sml

   1 (* Copyright (C) 2001 Daniel Wang. All rights reserved.
   2  Derived from the RSA Data Security, Inc. MD5 Message-Digest Algorithm.
   3  *)
   4 signature MD5 =
   5   sig
   6     type md5state
   7 (*    type slice = (Word8Vector.vector * int * int option) *)
   8     val init : md5state
   9     (* val updateSlice : (md5state * slice) -> md5state
  10     *)
  11     val update : (md5state * Word8Vector.vector) -> md5state
  12     val final  : md5state -> Word8Vector.vector
  13     val toHexString :  Word8Vector.vector -> string
  14   end
  15
  16 (* Quick and dirty transliteration of C code *)
  17 structure MD5 :> MD5 =
  18   struct
  19     structure W32 = Word32
  20     structure W8V =
  21       struct
  22         open Word8Vector
  23         fun extract (vec, s, l) =
  24            let
  25               val n =
  26                  case l of
  27                     NONE => length vec - s
  28                   | SOME i => i
  29            in
  30               tabulate (n, fn i => sub (vec, s + i))
  31            end
  32       end
  33     type word64  = {hi:W32.word,lo:W32.word}
  34     type word128 = {A:W32.word, B:W32.word, C:W32.word,  D:W32.word}
  35     type md5state = {digest:word128,
  36                        mlen:word64,
  37                         buf:Word8Vector.vector}
  38
  39
  40
  41     val w64_zero = ({hi=0w0,lo=0w0}:word64)
  42     fun mul8add ({hi,lo},n) = let
  43       val mul8lo = W32.<< (W32.fromInt (n),0w3)
  44       val mul8hi = W32.>> (W32.fromInt (n),0w29)
  45       val lo = W32.+ (lo,mul8lo)
  46       val cout = if W32.< (lo,mul8lo) then 0w1 else 0w0
  47       val hi = W32.+ (mul8hi,W32.+ (hi,cout))
  48     in {hi=hi,lo=lo}
  49     end
  50
  51     fun packLittle wrds = let
  52       fun loop [] = []
  53         | loop (w::ws) = let
  54             val b0 = Word8.fromLarge (W32.toLarge w)
  55             val b1 = Word8.fromLarge (W32.toLarge (W32.>> (w,0w8)))
  56             val b2 = Word8.fromLarge (W32.toLarge (W32.>> (w,0w16)))
  57             val b3 = Word8.fromLarge (W32.toLarge (W32.>> (w,0w24)))
  58           in b0::b1::b2::b3:: (loop ws)
  59           end
  60     in W8V.fromList (loop wrds)
  61     end
  62
  63     val S11 = 0w7
  64     val S12 = 0w12
  65     val S13 = 0w17
  66     val S14 = 0w22
  67     val S21 = 0w5
  68     val S22 = 0w9
  69     val S23 = 0w14
  70     val S24 = 0w20
  71     val S31 = 0w4
  72     val S32 = 0w11
  73     val S33 = 0w16
  74     val S34 = 0w23
  75     val S41 = 0w6
  76     val S42 = 0w10
  77     val S43 = 0w15
  78     val S44 = 0w21
  79
  80     fun PADDING i =  W8V.tabulate (i,(fn 0 => 0wx80 | _ => 0wx0))
  81
  82     fun F (x,y,z) = W32.orb (W32.andb (x,y),
  83                            W32.andb (W32.notb x,z))
  84     fun G (x,y,z) = W32.orb (W32.andb (x,z),
  85                            W32.andb (y,W32.notb z))
  86     fun H (x,y,z) = W32.xorb (x,W32.xorb (y,z))
  87     fun I (x,y,z) = W32.xorb (y,W32.orb (x,W32.notb z))
  88     fun ROTATE_LEFT (x,n) =
  89       W32.orb (W32.<< (x,n), W32.>> (x,0w32 - n))
  90
  91     fun XX f (a,b,c,d,x,s,ac) = let
  92       val a = W32.+ (a,W32.+ (W32.+ (f (b,c,d),x),ac))
  93       val a = ROTATE_LEFT (a,s)
  94     in W32.+ (a,b)
  95     end
  96
  97     val FF = XX F
  98     val GG = XX G
  99     val HH = XX H
 100     val II = XX I
 101
 102     val empty_buf = W8V.tabulate (0,(fn x => raise (Fail "buf")))
 103     val init = {digest= {A=0wx67452301,
 104                         B=0wxefcdab89,
 105                         C=0wx98badcfe,
 106                         D=0wx10325476},
 107                 mlen=w64_zero,
 108                 buf=empty_buf} : md5state
 109
 110     fun update ({buf,digest,mlen}:md5state,input) = let
 111       val inputLen = W8V.length input
 112       val needBytes = 64 - W8V.length buf
 113       fun loop (i,digest) =
 114         if i + 63 < inputLen then
 115           loop (i + 64,transform (digest,i,input))
 116         else (i,digest)
 117       val (buf,(i,digest)) =
 118         if inputLen >= needBytes then  let
 119           val buf = W8V.concat [buf,W8V.extract (input,0,SOME needBytes)]
 120           val digest = transform (digest,0,buf)
 121         in (empty_buf,loop (needBytes,digest))
 122         end
 123         else (buf,(0,digest))
 124       val buf = W8V.concat [buf, W8V.extract (input,i,SOME (inputLen-i))]
 125       val mlen = mul8add (mlen,inputLen)
 126     in {buf=buf,digest=digest,mlen=mlen}
 127     end
 128     and final (state:md5state) = let
 129       val {mlen= {lo,hi},buf,...} = state
 130       val bits = packLittle [lo,hi]
 131       val index = W8V.length buf
 132       val padLen = if index < 56 then 56 - index else 120 - index
 133       val state = update (state,PADDING padLen)
 134       val {digest= {A,B,C,D},...} = update (state,bits)
 135     in packLittle [A,B,C,D]
 136     end
 137     and transform ({A,B,C,D},i,buf) = let
 138       val off = i div PackWord32Little.bytesPerElem
 139       fun x (n)  = Word32.fromLarge (PackWord32Little.subVec (buf,n + off))
 140       val (a,b,c,d) = (A,B,C,D)
 141       (* fetch to avoid range checks *)
 142       val x_00 = x (0)  val x_01 = x (1)  val x_02 = x (2)  val x_03 = x (3)
 143       val x_04 = x (4)  val x_05 = x (5)  val x_06 = x (6)  val x_07 = x (7)
 144       val x_08 = x (8)  val x_09 = x (9)  val x_10 = x (10) val x_11 = x (11)
 145       val x_12 = x (12) val x_13 = x (13) val x_14 = x (14) val x_15 = x (15)
 146
 147       val a = FF (a, b, c, d, x_00, S11, 0wxd76aa478) (* 1 *)
 148       val d = FF (d, a, b, c, x_01, S12, 0wxe8c7b756) (* 2 *)
 149       val c = FF (c, d, a, b, x_02, S13, 0wx242070db) (* 3 *)
 150       val b = FF (b, c, d, a, x_03, S14, 0wxc1bdceee) (* 4 *)
 151       val a = FF (a, b, c, d, x_04, S11, 0wxf57c0faf) (* 5 *)
 152       val d = FF (d, a, b, c, x_05, S12, 0wx4787c62a) (* 6 *)
 153       val c = FF (c, d, a, b, x_06, S13, 0wxa8304613) (* 7 *)
 154       val b = FF (b, c, d, a, x_07, S14, 0wxfd469501) (* 8 *)
 155       val a = FF (a, b, c, d, x_08, S11, 0wx698098d8) (* 9 *)
 156       val d = FF (d, a, b, c, x_09, S12, 0wx8b44f7af) (* 10 *)
 157       val c = FF (c, d, a, b, x_10, S13, 0wxffff5bb1) (* 11 *)
 158       val b = FF (b, c, d, a, x_11, S14, 0wx895cd7be) (* 12 *)
 159       val a = FF (a, b, c, d, x_12, S11, 0wx6b901122) (* 13 *)
 160       val d = FF (d, a, b, c, x_13, S12, 0wxfd987193) (* 14 *)
 161       val c = FF (c, d, a, b, x_14, S13, 0wxa679438e) (* 15 *)
 162       val b = FF (b, c, d, a, x_15, S14, 0wx49b40821) (* 16 *)
 163
 164       (* Round 2 *)
 165       val a = GG (a, b, c, d, x_01, S21, 0wxf61e2562) (* 17 *)
 166       val d = GG (d, a, b, c, x_06, S22, 0wxc040b340) (* 18 *)
 167       val c = GG (c, d, a, b, x_11, S23, 0wx265e5a51) (* 19 *)
 168       val b = GG (b, c, d, a, x_00, S24, 0wxe9b6c7aa) (* 20 *)
 169       val a = GG (a, b, c, d, x_05, S21, 0wxd62f105d) (* 21 *)
 170       val d = GG (d, a, b, c, x_10, S22,  0wx2441453) (* 22 *)
 171       val c = GG (c, d, a, b, x_15, S23, 0wxd8a1e681) (* 23 *)
 172       val b = GG (b, c, d, a, x_04, S24, 0wxe7d3fbc8) (* 24 *)
 173       val a = GG (a, b, c, d, x_09, S21, 0wx21e1cde6) (* 25 *)
 174       val d = GG (d, a, b, c, x_14, S22, 0wxc33707d6) (* 26 *)
 175       val c = GG (c, d, a, b, x_03, S23, 0wxf4d50d87) (* 27 *)
 176       val b = GG (b, c, d, a, x_08, S24, 0wx455a14ed) (* 28 *)
 177       val a = GG (a, b, c, d, x_13, S21, 0wxa9e3e905) (* 29 *)
 178       val d = GG (d, a, b, c, x_02, S22, 0wxfcefa3f8) (* 30 *)
 179       val c = GG (c, d, a, b, x_07, S23, 0wx676f02d9) (* 31 *)
 180       val b = GG (b, c, d, a, x_12, S24, 0wx8d2a4c8a) (* 32 *)
 181
 182       (* Round 3 *)
 183       val a = HH (a, b, c, d, x_05, S31, 0wxfffa3942) (* 33 *)
 184       val d = HH (d, a, b, c, x_08, S32, 0wx8771f681) (* 34 *)
 185       val c = HH (c, d, a, b, x_11, S33, 0wx6d9d6122) (* 35 *)
 186       val b = HH (b, c, d, a, x_14, S34, 0wxfde5380c) (* 36 *)
 187       val a = HH (a, b, c, d, x_01, S31, 0wxa4beea44) (* 37 *)
 188       val d = HH (d, a, b, c, x_04, S32, 0wx4bdecfa9) (* 38 *)
 189       val c = HH (c, d, a, b, x_07, S33, 0wxf6bb4b60) (* 39 *)
 190       val b = HH (b, c, d, a, x_10, S34, 0wxbebfbc70) (* 40 *)
 191       val a = HH (a, b, c, d, x_13, S31, 0wx289b7ec6) (* 41 *)
 192       val d = HH (d, a, b, c, x_00, S32, 0wxeaa127fa) (* 42 *)
 193       val c = HH (c, d, a, b, x_03, S33, 0wxd4ef3085) (* 43 *)
 194       val b = HH (b, c, d, a, x_06, S34,  0wx4881d05) (* 44 *)
 195       val a = HH (a, b, c, d, x_09, S31, 0wxd9d4d039) (* 45 *)
 196       val d = HH (d, a, b, c, x_12, S32, 0wxe6db99e5) (* 46 *)
 197       val c = HH (c, d, a, b, x_15, S33, 0wx1fa27cf8) (* 47 *)
 198       val b = HH (b, c, d, a, x_02, S34, 0wxc4ac5665) (* 48 *)
 199
 200       (* Round 4 *)
 201       val a = II (a, b, c, d, x_00, S41, 0wxf4292244) (* 49 *)
 202       val d = II (d, a, b, c, x_07, S42, 0wx432aff97) (* 50 *)
 203       val c = II (c, d, a, b, x_14, S43, 0wxab9423a7) (* 51 *)
 204       val b = II (b, c, d, a, x_05, S44, 0wxfc93a039) (* 52 *)
 205       val a = II (a, b, c, d, x_12, S41, 0wx655b59c3) (* 53 *)
 206       val d = II (d, a, b, c, x_03, S42, 0wx8f0ccc92) (* 54 *)
 207       val c = II (c, d, a, b, x_10, S43, 0wxffeff47d) (* 55 *)
 208       val b = II (b, c, d, a, x_01, S44, 0wx85845dd1) (* 56 *)
 209       val a = II (a, b, c, d, x_08, S41, 0wx6fa87e4f) (* 57 *)
 210       val d = II (d, a, b, c, x_15, S42, 0wxfe2ce6e0) (* 58 *)
 211       val c = II (c, d, a, b, x_06, S43, 0wxa3014314) (* 59 *)
 212       val b = II (b, c, d, a, x_13, S44, 0wx4e0811a1) (* 60 *)
 213       val a = II (a, b, c, d, x_04, S41, 0wxf7537e82) (* 61 *)
 214       val d = II (d, a, b, c, x_11, S42, 0wxbd3af235) (* 62 *)
 215       val c = II (c, d, a, b, x_02, S43, 0wx2ad7d2bb) (* 63 *)
 216       val b = II (b, c, d, a, x_09, S44, 0wxeb86d391) (* 64 *)
 217
 218       val A = Word32.+ (A,a)
 219       val B = Word32.+ (B,b)
 220       val C = Word32.+ (C,c)
 221       val D = Word32.+ (D,d)
 222     in {A=A,B=B,C=C,D=D}
 223     end
 224
 225     val hxd = "0123456789abcdef"
 226     fun toHexString v = let
 227       fun byte2hex (b,acc) =
 228         (String.sub (hxd,(Word8.toInt b) div 16))::
 229         (String.sub (hxd,(Word8.toInt b) mod 16))::acc
 230       val digits = Word8Vector.foldr byte2hex [] v
 231     in String.implode (digits)
 232     end
 233   end
 234
 235 structure Test =
 236   struct
 237     val tests =
 238       [("", "d41d8cd98f00b204e9800998ecf8427e"),
 239        ("a", "0cc175b9c0f1b6a831c399e269772661"),
 240        ("abc", "900150983cd24fb0d6963f7d28e17f72"),
 241        ("message digest", "f96b697d7cb7938d525a2f31aaf161d0"),
 242        ("abcdefghijklmnopqrstuvwxyz", "c3fcd3d76192e4007dfb496cca67e13b"),
 243        ("ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789",
 244         "d174ab98d277d9f5a5611c2c9f419d9f"),
 245        ("12345678901234567890123456789012345678901234567890123456789012345678901234567890",
 246         "57edf4a22be3c955ac49da2e2107b67a")]
 247
 248     fun do_tests () =  let
 249       fun f (x,s) = let
 250         val mstate = MD5.update (MD5.init,Byte.stringToBytes x)
 251         val hash = MD5.final (mstate)
 252       in print ("   input: "^x^"\n");
 253         print ("expected: "^s^"\n");
 254         print ("produced: "^MD5.toHexString (hash)^"\n")
 255       end
 256     in List.app f tests
 257     end
 258     val BLOCK_LEN = 10000
 259     val BLOCK_COUNT = 100000
 260     fun time_test () = let
 261       val block = Word8Vector.tabulate (BLOCK_LEN,Word8.fromInt)
 262       fun loop (n,s) =
 263         if n < BLOCK_COUNT then
 264           loop (n+1,MD5.update (s,block))
 265         else s
 266     in
 267        loop (0,MD5.init)
 268     end
 269   end
 270
 271 structure Main =
 272    struct
 273       fun doit n =
 274          if n = 0
 275             then ()
 276          else (Test.time_test ()
 277                ; doit (n - 1))
 278    end