mlton/ssa/poly-hash.fun

   1 (* Copyright (C) 2009-2010 Matthew Fluet.
   2  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor PolyHash (S: SSA_TRANSFORM_STRUCTS): SSA_TRANSFORM =
  11 struct
  12
  13 open S
  14
  15 (*
  16  * This pass implements polymorphic, structural hashing.
  17  *
  18  * For each datatype tycon and vector type, it builds a hashing function and
  19  * translates calls to MLton_hash into calls to that function.
  20  *
  21  * For tuples, it does the hashing inline.  I.E. it does not create
  22  * a separate hashing function for each tuple type.
  23  *
  24  * All hashing functions are only created if necessary, i.e. if hashing
  25  * is actually used at a type.
  26  *
  27  * Optimizations:
  28  *)
  29
  30 open Exp Transfer
  31
  32 structure Dexp =
  33    struct
  34       open DirectExp
  35
  36       fun wordFromWord (w: word, ws: WordSize.t): t =
  37          word (WordX.fromIntInf (Word.toIntInf w, ws))
  38
  39       fun shiftInt i =
  40          word (WordX.fromIntInf (i, WordSize.shiftArg))
  41       fun shiftBits b = shiftInt (Bits.toIntInf b)
  42
  43       local
  44          fun mk prim =
  45             fn (e1: t, e2: t, s) =>
  46             primApp {prim = prim s,
  47                      targs = Vector.new0 (),
  48                      args = Vector.new2 (e1, e2),
  49                      ty = Type.word s}
  50       in
  51          val add = mk Prim.wordAdd
  52          val andb = mk Prim.wordAndb
  53          val rshift = mk (fn s => Prim.wordRshift (s, {signed = false}))
  54          val xorb = mk Prim.wordXorb
  55       end
  56       local
  57          fun mk prim =
  58             fn (e1: t, e2: t, s, sg) =>
  59             primApp {prim = prim (s, sg),
  60                      targs = Vector.new0 (),
  61                      args = Vector.new2 (e1, e2),
  62                      ty = Type.word s}
  63       in
  64          val mul = mk Prim.wordMul
  65       end
  66
  67       fun wordEqual (e1: t, e2: t, s): t =
  68          primApp {prim = Prim.wordEqual s,
  69                   targs = Vector.new0 (),
  70                   args = Vector.new2 (e1, e2),
  71                   ty = Type.bool}
  72 end
  73
  74 structure Hash =
  75    struct
  76       val resWordSize = WordSize.word32
  77       val resTy = Type.word resWordSize
  78
  79       fun mkWordBytes {stateTy: Type.t,
  80                        workWordSize: WordSize.t,
  81                        combByte: Dexp.t * Dexp.t -> Dexp.t,
  82                        mix: Dexp.t -> Dexp.t} =
  83          let
  84             val workBits = WordSize.bits workWordSize
  85             val workTy = Type.word workWordSize
  86             fun wordBytes (st,w,ws) =
  87                let
  88                   fun extdW w =
  89                      if WordSize.equals (ws, workWordSize)
  90                         then w
  91                      else Dexp.primApp {prim = Prim.wordExtdToWord
  92                                                (ws, workWordSize,
  93                                                 {signed = false}),
  94                                         targs = Vector.new0 (),
  95                                         args = Vector.new1 w,
  96                                         ty = workTy}
  97
  98                   val mask =
  99                      (Dexp.word o WordX.resize)
 100                      (WordX.allOnes WordSize.word8,
 101                       workWordSize)
 102
 103                   fun loop (st, w, b) =
 104                      if Bits.<= (b, Bits.zero)
 105                         then st
 106                      else let
 107                              val dst0 = st
 108                              val w0 = Var.newNoname ()
 109                              val dw0 = Dexp.var (w0, workTy)
 110                              val bw = Var.newNoname ()
 111                              val dbw = Dexp.var (bw, workTy)
 112                              val st1 = Var.newNoname ()
 113                              val dst1 = Dexp.var (st1, stateTy)
 114                              val st2 = Var.newNoname ()
 115                              val dst2 = Dexp.var (st2, stateTy)
 116                           in
 117                              Dexp.lett
 118                              {decs = [{var = w0, exp = w},
 119                                       {var = bw, exp =
 120                                        Dexp.andb (dw0, mask, workWordSize)},
 121                                       {var = st1, exp =
 122                                        combByte (dst0, dbw)},
 123                                       {var = st2, exp =
 124                                        mix dst1}],
 125                               body = loop (dst2,
 126                                            Dexp.rshift (dw0,
 127                                                         Dexp.shiftBits Bits.inWord8,
 128                                                         workWordSize),
 129                                            Bits.- (b, Bits.inWord8))}
 130                           end
 131                   fun lp (st, w, b) =
 132                      if Bits.<= (b, Bits.zero)
 133                         then st
 134                      else let
 135                              val dst0 = st
 136                              val w0 = Var.newNoname ()
 137                              val dw0 = Dexp.var (w0, Type.word ws)
 138                              val ew = Var.newNoname ()
 139                              val dew = Dexp.var (ew, workTy)
 140                              val loopBits = Bits.min (b, workBits)
 141                              val st1 = Var.newNoname ()
 142                              val dst1 = Dexp.var (st1, stateTy)
 143                           in
 144                              Dexp.lett
 145                              {decs = [{var = w0, exp = w},
 146                                       {var = ew, exp = extdW dw0},
 147                                       {var = st1, exp = loop (dst0, dew, loopBits)}],
 148                               body = lp (dst1,
 149                                          Dexp.rshift (dw0,
 150                                                       Dexp.shiftBits workBits,
 151                                                       ws),
 152                                          Bits.- (b, workBits))}
 153                           end
 154                   val st0 = Var.newNoname ()
 155                   val dst0 = Dexp.var (st0, stateTy)
 156                in
 157                   Dexp.lett
 158                   {decs = [{var = st0, exp = st}],
 159                    body = lp (dst0, w, WordSize.bits ws)}
 160                end
 161          in
 162             wordBytes
 163          end
 164
 165 (*
 166       (* Jenkins hash function
 167        * http://en.wikipedia.org/wiki/Jenkins_hash_function  (20100315)
 168        *)
 169       val {stateTy: Type.t,
 170            init: unit -> Dexp.t,
 171            wordBytes: Dexp.t * Dexp.t * WordSize.t -> Dexp.t,
 172            fini: Dexp.t -> Dexp.t} =
 173          let
 174             val stateWordSize = resWordSize
 175             val stateTy = Type.word stateWordSize
 176             val workWordSize = resWordSize
 177             val workTy = Type.word workWordSize
 178
 179             local
 180                fun mk prim =
 181                   fn (w1, w2) => prim (w1, w2, stateWordSize)
 182             in
 183                val add = mk Dexp.add
 184                val lshift = mk Dexp.lshift
 185                val rshift = mk Dexp.rshift
 186                val xorb = mk Dexp.xorb
 187             end
 188
 189             fun init () = Dexp.word (WordX.zero stateWordSize)
 190             fun combByte (hexp, wexp) =
 191                let
 192                   val h0 = Var.newNoname ()
 193                   val dh0 = Dexp.var (h0, stateTy)
 194                   val w0 = Var.newNoname ()
 195                   val dw0 = Dexp.var (w0, workTy)
 196                   val h1 = Var.newNoname ()
 197                   val dh1 = Dexp.var (h1, stateTy)
 198                in
 199                   Dexp.lett
 200                   {decs = [{var = h0, exp = hexp},
 201                            {var = w0, exp = wexp},
 202                            {var = h1, exp = add (dh0, dw0)}],
 203                    body = dh1}
 204                end
 205             fun mix hexp =
 206                let
 207                   val h0 = Var.newNoname ()
 208                   val dh0 = Dexp.var (h0, stateTy)
 209                   val h1 = Var.newNoname ()
 210                   val dh1 = Dexp.var (h1, stateTy)
 211                   val h2 = Var.newNoname ()
 212                   val dh2 = Dexp.var (h2, stateTy)
 213                in
 214                   Dexp.lett
 215                   {decs = [{var = h0, exp = hexp},
 216                            {var = h1, exp = add (dh0, lshift (dh0, Dexp.shiftInt 10))},
 217                            {var = h2, exp = xorb (dh1, rshift (dh1, Dexp.shiftInt 6))}],
 218                    body = dh2}
 219                end
 220             val wordBytes =
 221                mkWordBytes
 222                {stateTy = stateTy,
 223                 workWordSize = workWordSize,
 224                 combByte = combByte,
 225                 mix = mix}
 226             fun fini hexp =
 227                let
 228                   val h0 = Var.newNoname ()
 229                   val dh0 = Dexp.var (h0, stateTy)
 230                   val h1 = Var.newNoname ()
 231                   val dh1 = Dexp.var (h1, stateTy)
 232                   val h2 = Var.newNoname ()
 233                   val dh2 = Dexp.var (h2, stateTy)
 234                   val h3 = Var.newNoname ()
 235                   val dh3 = Dexp.var (h3, stateTy)
 236                in
 237                   Dexp.lett
 238                   {decs = [{var = h0, exp = hexp},
 239                            {var = h1, exp = add (dh0, lshift (dh0, Dexp.shiftInt 3))},
 240                            {var = h2, exp = xorb (dh1, rshift (dh1, Dexp.shiftInt 11))},
 241                            {var = h3, exp = add (dh2, lshift (dh2, Dexp.shiftInt 15))}],
 242                    body = dh3}
 243                end
 244          in
 245             {stateTy = stateTy,
 246              init = init,
 247              wordBytes = wordBytes,
 248              fini = fini}
 249          end
 250 *)
 251
 252       (* FNV-1a hash function
 253        * http://en.wikipedia.org/wiki/Fowler-Noll-Vo_hash_function  (20100315)
 254        *)
 255       val {stateTy: Type.t,
 256            init: unit -> Dexp.t,
 257            wordBytes: Dexp.t * Dexp.t * WordSize.t -> Dexp.t,
 258            fini: Dexp.t -> Dexp.t} =
 259          let
 260             val stateWordSize = resWordSize
 261             val stateTy = Type.word stateWordSize
 262             val workWordSize = resWordSize
 263             val workTy = Type.word workWordSize
 264
 265             local
 266                fun mk prim =
 267                   fn (w1, w2) => prim (w1, w2, stateWordSize)
 268             in
 269                val mul = mk (fn (w1,w2,s) => Dexp.mul (w1,w2,s,{signed = false}))
 270                val xorb = mk Dexp.xorb
 271             end
 272
 273             val fnv_prime = WordX.fromIntInf (16777619, stateWordSize)
 274             val fnv_offset_bias = WordX.fromIntInf (2166136261, stateWordSize)
 275
 276             fun init () = Dexp.word fnv_offset_bias
 277             fun combByte (hexp, wexp) =
 278                let
 279                   val h0 = Var.newNoname ()
 280                   val dh0 = Dexp.var (h0, stateTy)
 281                   val w0 = Var.newNoname ()
 282                   val dw0 = Dexp.var (w0, workTy)
 283                   val h1 = Var.newNoname ()
 284                   val dh1 = Dexp.var (h1, stateTy)
 285                in
 286                   Dexp.lett
 287                   {decs = [{var = h0, exp = hexp},
 288                            {var = w0, exp = wexp},
 289                            {var = h1, exp = xorb (dh0, dw0)}],
 290                    body = dh1}
 291                end
 292             fun mix hexp =
 293                let
 294                   val h0 = Var.newNoname ()
 295                   val dh0 = Dexp.var (h0, stateTy)
 296                   val p = Dexp.word fnv_prime
 297                   val h1 = Var.newNoname ()
 298                   val dh1 = Dexp.var (h1, stateTy)
 299                in
 300                   Dexp.lett
 301                   {decs = [{var = h0, exp = hexp},
 302                            {var = h1, exp = mul (dh0, p)}],
 303                    body = dh1}
 304                end
 305             val wordBytes =
 306                mkWordBytes
 307                {stateTy = stateTy,
 308                 workWordSize = workWordSize,
 309                 combByte = combByte,
 310                 mix = mix}
 311             fun fini hexp = hexp
 312          in
 313             {stateTy = stateTy,
 314              init = init,
 315              wordBytes = wordBytes,
 316              fini = fini}
 317          end
 318       fun wordBytesFromWord (st: Dexp.t, w:word, ws: WordSize.t) =
 319          wordBytes (st, Dexp.wordFromWord (w, ws), ws)
 320    end
 321
 322 fun transform (Program.T {datatypes, globals, functions, main}) =
 323    let
 324       val {get = funcInfo: Func.t -> {hasHash: bool},
 325            set = setFuncInfo, ...} =
 326          Property.getSet (Func.plist, Property.initConst {hasHash = false})
 327       val {get = labelInfo: Label.t -> {hasHash: bool},
 328            set = setLabelInfo, ...} =
 329          Property.getSet (Label.plist, Property.initConst {hasHash = false})
 330       val {get = tyconInfo: Tycon.t -> {cons: {con: Con.t,
 331                                                args: Type.t vector} vector},
 332            set = setTyconInfo, ...} =
 333          Property.getSetOnce
 334          (Tycon.plist, Property.initRaise ("PolyHash.info", Tycon.layout))
 335       val tyconCons = #cons o tyconInfo
 336       val {get = getHashFunc: Type.t -> Func.t option,
 337            set = setHashFunc,
 338            destroy = destroyHashFunc} =
 339          Property.destGetSet (Type.plist, Property.initConst NONE)
 340       val {get = getTyconHashFunc: Tycon.t -> Func.t option,
 341            set = setTyconHashFunc, ...} =
 342          Property.getSet (Tycon.plist, Property.initConst NONE)
 343       val {get = getVectorHashFunc: Type.t -> Func.t option,
 344            set = setVectorHashFunc,
 345            destroy = destroyVectorHashFunc} =
 346          Property.destGetSet (Type.plist, Property.initConst NONE)
 347       val returns = SOME (Vector.new1 Hash.stateTy)
 348       val seqIndexWordSize = WordSize.seqIndex ()
 349       val seqIndexTy = Type.word seqIndexWordSize
 350       val newFunctions: Function.t list ref = ref []
 351       fun newFunction z =
 352          List.push (newFunctions,
 353                     Function.profile (Function.new z,
 354                                       SourceInfo.polyHash))
 355       fun hashTyconFunc (tycon: Tycon.t): Func.t =
 356          case getTyconHashFunc tycon of
 357             SOME f => f
 358           | NONE =>
 359                let
 360                   val name =
 361                      Func.newString (concat ["hash_", Tycon.originalName tycon])
 362                   val _ = setTyconHashFunc (tycon, SOME name)
 363                   val ty = Type.datatypee tycon
 364                   val st = (Var.newNoname (), Hash.stateTy)
 365                   val x = (Var.newNoname (), ty)
 366                   val args = Vector.new2 (st, x)
 367                   val dst = Dexp.var st
 368                   val dx = Dexp.var x
 369                   val cons = tyconCons tycon
 370                   val body =
 371                      Dexp.casee
 372                      {test = dx,
 373                       ty = Hash.stateTy,
 374                       default = NONE,
 375                       cases =
 376                       (Dexp.Con o Vector.map)
 377                       (cons, fn {con, args} =>
 378                        let
 379                           val xs =
 380                              Vector.map
 381                              (args, fn ty =>
 382                               (Var.newNoname (), ty))
 383                        in
 384                           {con = con,
 385                            args = xs,
 386                            body =
 387                            Vector.fold
 388                            (xs,
 389                             Hash.wordBytesFromWord
 390                             (dst, Con.hash con, WordSize.word32),
 391                             fn ((x,ty), dstate) =>
 392                             hashExp (dstate, Dexp.var (x, ty), ty))}
 393                        end)}
 394                   val (start, blocks) = Dexp.linearize (body, Handler.Caller)
 395                   val blocks = Vector.fromList blocks
 396                   val _ =
 397                      newFunction {args = args,
 398                                   blocks = blocks,
 399                                   mayInline = true,
 400                                   name = name,
 401                                   raises = NONE,
 402                                   returns = returns,
 403                                   start = start}
 404                in
 405                   name
 406                end
 407       and vectorHashFunc (ty: Type.t): Func.t =
 408          case getVectorHashFunc ty of
 409             SOME f => f
 410           | NONE =>
 411                let
 412                   (* Build two functions, one that hashes the length and the
 413                    * other that loops.
 414                    *)
 415                   val name = Func.newString "vectorHash"
 416                   val _ = setVectorHashFunc (ty, SOME name)
 417                   val loop = Func.newString "vectorHashLoop"
 418                   val vty = Type.vector ty
 419                   local
 420                      val st = (Var.newNoname (), Hash.stateTy)
 421                      val vec = (Var.newNoname (), vty)
 422                      val args = Vector.new2 (st, vec)
 423                      val dst = Dexp.var st
 424                      val dvec = Dexp.var vec
 425                      val len = (Var.newNoname (), seqIndexTy)
 426                      val dlen = Dexp.var len
 427                      val body =
 428                         Dexp.lett
 429                         {decs = [{var = #1 len, exp =
 430                                   Dexp.primApp {prim = Prim.vectorLength,
 431                                                 targs = Vector.new1 ty,
 432                                                 args = Vector.new1 dvec,
 433                                                 ty = seqIndexTy}}],
 434                          body =
 435                          Dexp.call
 436                          {func = loop,
 437                           args = (Vector.new4
 438                                   (Hash.wordBytes (dst, dlen, seqIndexWordSize),
 439                                    dvec, dlen, Dexp.word (WordX.zero seqIndexWordSize))),
 440                           ty = Hash.stateTy}}
 441                      val (start, blocks) = Dexp.linearize (body, Handler.Caller)
 442                      val blocks = Vector.fromList blocks
 443                   in
 444                      val _ =
 445                         newFunction {args = args,
 446                                      blocks = blocks,
 447                                      mayInline = true,
 448                                      name = name,
 449                                      raises = NONE,
 450                                      returns = returns,
 451                                      start = start}
 452                   end
 453                   local
 454                      val st = (Var.newNoname (), Hash.stateTy)
 455                      val vec = (Var.newNoname (), vty)
 456                      val len = (Var.newNoname (), seqIndexTy)
 457                      val i = (Var.newNoname (), seqIndexTy)
 458                      val args = Vector.new4 (st, vec, len, i)
 459                      val dst = Dexp.var st
 460                      val dvec = Dexp.var vec
 461                      val dlen = Dexp.var len
 462                      val di = Dexp.var i
 463                      val body =
 464                         let
 465                            val args =
 466                               Vector.new4
 467                               (hashExp
 468                                (dst,
 469                                 Dexp.primApp {prim = Prim.vectorSub,
 470                                               targs = Vector.new1 ty,
 471                                               args = Vector.new2 (dvec, di),
 472                                               ty = ty},
 473                                 ty),
 474                                dvec,
 475                                dlen,
 476                                Dexp.add (di,
 477                                          Dexp.word (WordX.one seqIndexWordSize),
 478                                          seqIndexWordSize))
 479                         in
 480                            Dexp.casee
 481                            {test = Dexp.wordEqual
 482                                    (di, dlen, seqIndexWordSize),
 483                             ty = Hash.stateTy,
 484                             default = NONE,
 485                             cases = (Dexp.Con o Vector.new2)
 486                                     ({con = Con.truee,
 487                                       args = Vector.new0 (),
 488                                       body = dst},
 489                                      {con = Con.falsee,
 490                                       args = Vector.new0 (),
 491                                       body = Dexp.call {args = args,
 492                                                         func = loop,
 493                                                         ty = Hash.stateTy}})}
 494                         end
 495                      val (start, blocks) = Dexp.linearize (body, Handler.Caller)
 496                      val blocks = Vector.fromList blocks
 497                   in
 498                      val _ =
 499                         newFunction {args = args,
 500                                      blocks = blocks,
 501                                      mayInline = true,
 502                                      name = loop,
 503                                      raises = NONE,
 504                                      returns = returns,
 505                                      start = start}
 506                   end
 507                in
 508                   name
 509                end
 510       and hashExp (st: Dexp.t, x: Dexp.t, ty: Type.t): Dexp.t =
 511          Dexp.name (st, fn st =>
 512          Dexp.name (x, fn x => hash (st, x, ty)))
 513       and hash (st: Var.t, x: Var.t, ty: Type.t): Dexp.t =
 514          let
 515             val dst = Dexp.var (st, Hash.stateTy)
 516             val dx = Dexp.var (x, ty)
 517             fun stateful () =
 518                Hash.wordBytesFromWord
 519                (dst, Type.hash ty, WordSize.word32)
 520
 521             val body =
 522                case Type.dest ty of
 523                   Type.Array _ => stateful ()
 524                 | Type.CPointer =>
 525                      let
 526                         val ws = WordSize.cpointer ()
 527                         val toWord =
 528                            Dexp.primApp
 529                            {prim = Prim.cpointerToWord,
 530                             targs = Vector.new0 (),
 531                             args = Vector.new1 dx,
 532                             ty = Type.word ws}
 533                      in
 534                         Hash.wordBytes (dst, toWord, ws)
 535                      end
 536                 | Type.Datatype tycon =>
 537                      Dexp.call {func = hashTyconFunc tycon,
 538                                 args = Vector.new2 (dst, dx),
 539                                 ty = Hash.stateTy}
 540                 | Type.IntInf =>
 541                      let
 542                         val sws = WordSize.smallIntInfWord ()
 543                         val bws = WordSize.bigIntInfWord ()
 544                         val toWord =
 545                            Dexp.primApp
 546                            {prim = Prim.intInfToWord,
 547                             targs = Vector.new0 (),
 548                             args = Vector.new1 dx,
 549                             ty = Type.word sws}
 550                         val toVector =
 551                            Dexp.primApp
 552                            {prim = Prim.intInfToVector,
 553                             targs = Vector.new0 (),
 554                             args = Vector.new1 dx,
 555                             ty = Type.vector (Type.word bws)}
 556                         val w = Var.newNoname ()
 557                         val dw = Dexp.var (w, Type.word sws)
 558                         val one = Dexp.word (WordX.one sws)
 559                      in
 560                         Dexp.lett
 561                         {decs = [{var = w, exp = toWord}],
 562                          body =
 563                          Dexp.casee
 564                          {test = Dexp.wordEqual (Dexp.andb (dw, one, sws), one, sws),
 565                           ty = Hash.stateTy,
 566                           default = NONE,
 567                           cases =
 568                           (Dexp.Con o Vector.new2)
 569                           ({con = Con.truee,
 570                             args = Vector.new0 (),
 571                             body = Hash.wordBytes (dst, dw, sws)},
 572                            {con = Con.falsee,
 573                             args = Vector.new0 (),
 574                             body =
 575                             Dexp.call {func = vectorHashFunc (Type.word bws),
 576                                        args = Vector.new2 (dst, toVector),
 577                                        ty = Hash.stateTy}})}}
 578                      end
 579                 | Type.Real rs =>
 580                      let
 581                         val ws = WordSize.fromBits (RealSize.bits rs)
 582                         val toWord =
 583                            Dexp.primApp
 584                            {prim = Prim.realCastToWord (rs, ws),
 585                             targs = Vector.new0 (),
 586                             args = Vector.new1 dx,
 587                             ty = Type.word ws}
 588                      in
 589                         Hash.wordBytes (dst, toWord, ws)
 590                      end
 591                 | Type.Ref _ => stateful ()
 592                 | Type.Thread => stateful ()
 593                 | Type.Tuple tys =>
 594                      let
 595                         val max = Vector.length tys - 1
 596                         (* hash components i, i+1, ... *)
 597                         fun loop (i: int, dst): Dexp.t =
 598                            if i > max
 599                               then dst
 600                            else let
 601                                    val ty = Vector.sub (tys, i)
 602                                    val select =
 603                                       Dexp.select {tuple = dx,
 604                                                    offset = i,
 605                                                    ty = ty}
 606                                 in
 607                                    loop
 608                                    (i + 1,
 609                                     hashExp (dst, select, ty))
 610                                 end
 611                      in
 612                         loop (0, dst)
 613                      end
 614                 | Type.Vector ty =>
 615                      Dexp.call {func = vectorHashFunc ty,
 616                                 args = Vector.new2 (dst, dx),
 617                                 ty = Hash.stateTy}
 618                 | Type.Weak _ => stateful ()
 619                 | Type.Word ws => Hash.wordBytes (dst, dx, ws)
 620          in
 621             body
 622          end
 623       fun hashFunc (ty: Type.t): Func.t =
 624          case getHashFunc ty of
 625             SOME f => f
 626           | NONE =>
 627                let
 628                   val name = Func.newString "hash"
 629                   val _ = setHashFunc (ty, SOME name)
 630                   val x = (Var.newNoname (), ty)
 631                   val args = Vector.new1 x
 632                   val sti = Var.newNoname ()
 633                   val dsti = Dexp.var (sti, Hash.stateTy)
 634                   val dx = Dexp.var x
 635                   val stf = Var.newNoname ()
 636                   val dstf = Dexp.var (stf, Hash.stateTy)
 637                   val w = Var.newNoname ()
 638                   val dw = Dexp.var (w, Hash.resTy)
 639                   val body =
 640                      Dexp.lett
 641                      {decs = [{var = sti, exp = Hash.init ()},
 642                               {var = stf, exp = hashExp (dsti, dx, ty)},
 643                               {var = w, exp = Hash.fini dstf}],
 644                       body = dw}
 645                   val (start, blocks) = Dexp.linearize (body, Handler.Caller)
 646                   val blocks = Vector.fromList blocks
 647                   val _ =
 648                      newFunction {args = args,
 649                                   blocks = blocks,
 650                                   mayInline = true,
 651                                   name = name,
 652                                   raises = NONE,
 653                                   returns = returns,
 654                                   start = start}
 655                in
 656                   name
 657                end
 658
 659       val _ =
 660          Vector.foreach
 661          (datatypes, fn Datatype.T {tycon, cons} =>
 662           setTyconInfo (tycon,
 663                         {cons = cons}))
 664       val () =
 665          List.foreach
 666          (functions, fn f =>
 667           let
 668              val {name, blocks, ...} = Function.dest f
 669           in
 670              Vector.foreach
 671              (blocks, fn Block.T {label, statements, ...} =>
 672               let
 673                  fun setHasHash () =
 674                     (setFuncInfo (name, {hasHash = true})
 675                      ; setLabelInfo (label, {hasHash = true}))
 676               in
 677                  Vector.foreach
 678                  (statements, fn Statement.T {exp, ...} =>
 679                   (case exp of
 680                       PrimApp {prim, ...} =>
 681                          (case Prim.name prim of
 682                              Prim.Name.MLton_hash => setHasHash ()
 683                            | _ => ())
 684                     | _ => ()))
 685               end)
 686           end)
 687       fun doit blocks =
 688          let
 689             val blocks =
 690                Vector.fold
 691                (blocks, [],
 692                 fn (block as Block.T {label, args, statements, transfer}, blocks) =>
 693                 if not (#hasHash (labelInfo label))
 694                    then block::blocks
 695                 else
 696                 let
 697                    fun finish ({label, args, statements}, transfer) =
 698                       Block.T {label = label,
 699                                args = args,
 700                                statements = Vector.fromListRev statements,
 701                                transfer = transfer}
 702                    val (blocks, las) =
 703                       Vector.fold
 704                       (statements,
 705                        (blocks, {label = label, args = args, statements = []}),
 706                        fn (stmt as Statement.T {exp, var, ...},
 707                            (blocks, las as {label, args, statements})) =>
 708                        let
 709                          fun normal () = (blocks,
 710                                           {label = label,
 711                                            args = args,
 712                                            statements = stmt::statements})
 713                        in
 714                          case exp of
 715                             PrimApp {prim, targs, args, ...} =>
 716                                (case (Prim.name prim, Vector.length targs) of
 717                                    (Prim.Name.MLton_hash, 1) =>
 718                                       let
 719                                          val ty = Vector.first targs
 720                                          val x = Vector.first args
 721                                          val l = Label.newNoname ()
 722                                       in
 723                                         (finish
 724                                          (las,
 725                                           Call {args = Vector.new1 x,
 726                                                 func = hashFunc ty,
 727                                                 return = Return.NonTail
 728                                                          {cont = l,
 729                                                           handler = Handler.Caller}})
 730                                          :: blocks,
 731                                          {label = l,
 732                                           args = Vector.new1 (valOf var, Hash.resTy),
 733                                           statements = []})
 734                                       end
 735                                  | _ => normal ())
 736                           | _ => normal ()
 737                        end)
 738                 in
 739                    finish (las, transfer)
 740                    :: blocks
 741                 end)
 742          in
 743             Vector.fromList blocks
 744          end
 745       val functions =
 746          List.revMap
 747          (functions, fn f =>
 748           let
 749              val {args, blocks, mayInline, name, raises, returns, start} =
 750                 Function.dest f
 751              val f =
 752                 if #hasHash (funcInfo name)
 753                    then Function.new {args = args,
 754                                       blocks = doit blocks,
 755                                       mayInline = mayInline,
 756                                       name = name,
 757                                       raises = raises,
 758                                       returns = returns,
 759                                       start = start}
 760                 else f
 761              val () = Function.clear f
 762           in
 763              f
 764           end)
 765       val program =
 766          Program.T {datatypes = datatypes,
 767                     globals = globals,
 768                     functions = (!newFunctions) @ functions,
 769                     main = main}
 770       val _ = destroyHashFunc ()
 771       val _ = destroyVectorHashFunc ()
 772       val _ = Program.clearTop program
 773    in
 774       program
 775    end
 776
 777 end