[MLton-commit] r6352
Matthew Fluet
fluet at mlton.org
Thu Jan 24 12:33:22 PST 2008
Added a primitive (structural) polymorphic hash.
On objects with identity (array,ref,etc.), it returns a constant.
(This matches the behavior of MoscowML's Polyhash.hash function.)
We could do better on objects with identity (e.g., gensym a hash value
at birth points and flow to the hashing function), but this suffices
for my immediate purposes.
----------------------------------------------------------------------
U mlton/trunk/basis-library/mlton/mlton.sig
U mlton/trunk/basis-library/mlton/mlton.sml
U mlton/trunk/basis-library/primitive/prim-mlton.sml
U mlton/trunk/lib/mlton/basic/vector.fun
U mlton/trunk/lib/mlton/basic/vector.sig
U mlton/trunk/mlton/atoms/hash-type.fun
U mlton/trunk/mlton/atoms/prim.fun
U mlton/trunk/mlton/atoms/prim.sig
U mlton/trunk/mlton/atoms/source-info.fun
U mlton/trunk/mlton/atoms/source-info.sig
U mlton/trunk/mlton/closure-convert/globalize.fun
A mlton/trunk/mlton/ssa/poly-hash.fun
A mlton/trunk/mlton/ssa/poly-hash.sig
U mlton/trunk/mlton/ssa/remove-unused.fun
U mlton/trunk/mlton/ssa/remove-unused2.fun
U mlton/trunk/mlton/ssa/simplify.fun
U mlton/trunk/mlton/ssa/sources.cm
U mlton/trunk/mlton/ssa/sources.mlb
U mlton/trunk/mlton/ssa/ssa-tree2.fun
U mlton/trunk/mlton/ssa/useless.fun
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/mlton/mlton.sig
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sig 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/basis-library/mlton/mlton.sig 2008-01-24 20:33:19 UTC (rev 6352)
@@ -20,6 +20,8 @@
* of equivalence other types.
*)
val equal: 'a * 'a -> bool
+ (* Structural hash. *)
+ val hash: 'a -> Word32.word
(* val errno: unit -> int *) (* the value of the C errno global *)
val isMLton: bool
val safe: bool
Modified: mlton/trunk/basis-library/mlton/mlton.sml
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sml 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/basis-library/mlton/mlton.sml 2008-01-24 20:33:19 UTC (rev 6352)
@@ -39,6 +39,14 @@
val debug = Primitive.Controls.debug
val eq = Primitive.MLton.eq
val equal = Primitive.MLton.equal
+local
+ fun hash_param depth x =
+ if Int.< (depth, 0)
+ then raise Domain
+ else Primitive.MLton.hash (SeqIndex.fromInt depth, x)
+in
+ fun hash x = hash_param 0xF x
+end
(* val errno = Primitive.errno *)
val safe = Primitive.Controls.safe
Modified: mlton/trunk/basis-library/primitive/prim-mlton.sml
===================================================================
--- mlton/trunk/basis-library/primitive/prim-mlton.sml 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/basis-library/primitive/prim-mlton.sml 2008-01-24 20:33:19 UTC (rev 6352)
@@ -18,6 +18,7 @@
val equal = _prim "MLton_equal": 'a * 'a -> bool;
(* val deserialize = _prim "MLton_deserialize": Word8Vector.vector -> 'a ref; *)
val halt = _prim "MLton_halt": C_Status.t -> unit;
+val hash = _prim "MLton_hash": SeqIndex.int * 'a -> Word32.word;
(* val serialize = _prim "MLton_serialize": 'a ref -> Word8Vector.vector; *)
val share = _prim "MLton_share": 'a -> unit;
val size = _prim "MLton_size": 'a ref -> C_Size.t;
Modified: mlton/trunk/lib/mlton/basic/vector.fun
===================================================================
--- mlton/trunk/lib/mlton/basic/vector.fun 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/lib/mlton/basic/vector.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -306,6 +306,16 @@
| 4 => x4
| _ => Error.bug "Vector.new5")
+fun new6 (x0, x1, x2, x3, x4, x5) =
+ tabulate (6,
+ fn 0 => x0
+ | 1 => x1
+ | 2 => x2
+ | 3 => x3
+ | 4 => x4
+ | 5 => x5
+ | _ => Error.bug "Vector.new6")
+
fun unzip (a: ('a * 'b) t) = (map (a, #1), map (a, #2))
fun unzip3 (a: ('a * 'b * 'c) t) = (map (a, #1), map (a, #2), map (a, #3))
Modified: mlton/trunk/lib/mlton/basic/vector.sig
===================================================================
--- mlton/trunk/lib/mlton/basic/vector.sig 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/lib/mlton/basic/vector.sig 2008-01-24 20:33:19 UTC (rev 6352)
@@ -100,6 +100,7 @@
val new3: 'a * 'a * 'a -> 'a t
val new4: 'a * 'a * 'a * 'a -> 'a t
val new5: 'a * 'a * 'a * 'a * 'a -> 'a t
+ val new6: 'a * 'a * 'a * 'a * 'a * 'a -> 'a t
val partition: 'a t * ('a -> bool) -> {no: 'a t, yes: 'a t}
val partitioni: 'a t * (int * 'a -> bool) -> {no: 'a t, yes: 'a t}
val peek: 'a t * ('a -> bool) -> 'a option
Modified: mlton/trunk/mlton/atoms/hash-type.fun
===================================================================
--- mlton/trunk/mlton/atoms/hash-type.fun 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/atoms/hash-type.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -303,6 +303,7 @@
| MLton_eq => oneTarg (fn t => ([t, t], bool))
| MLton_equal => oneTarg (fn t => ([t, t], bool))
| MLton_halt => done ([cint], unit)
+ | MLton_hash => oneTarg (fn t => ([seqIndex, t], word32))
| MLton_handlesSignals => done ([], bool)
| MLton_installSignalHandler => done ([], unit)
| MLton_share => oneTarg (fn t => ([t], unit))
Modified: mlton/trunk/mlton/atoms/prim.fun
===================================================================
--- mlton/trunk/mlton/atoms/prim.fun 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/atoms/prim.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -87,10 +87,10 @@
*)
| MLton_bug (* ssa to rssa *)
| MLton_deserialize (* unused *)
- | MLton_share
| MLton_eq (* codegen *)
| MLton_equal (* polymorphic equality *)
| MLton_halt (* ssa to rssa *)
+ | MLton_hash (* polymorphic hash *)
(* MLton_handlesSignals and MLton_installSignalHandler work together
* to inform the optimizer and basis library whether or not the
* program uses signal handlers.
@@ -106,6 +106,7 @@
| MLton_handlesSignals (* closure conversion *)
| MLton_installSignalHandler (* backend *)
| MLton_serialize (* unused *)
+ | MLton_share
| MLton_size (* ssa to rssa *)
| MLton_touch (* backend *)
| Real_Math_acos of RealSize.t (* codegen *)
@@ -271,6 +272,7 @@
| MLton_eq => "MLton_eq"
| MLton_equal => "MLton_equal"
| MLton_halt => "MLton_halt"
+ | MLton_hash => "MLton_hash"
| MLton_handlesSignals => "MLton_handlesSignals"
| MLton_installSignalHandler => "MLton_installSignalHandler"
| MLton_serialize => "MLton_serialize"
@@ -412,6 +414,7 @@
| (MLton_eq, MLton_eq) => true
| (MLton_equal, MLton_equal) => true
| (MLton_halt, MLton_halt) => true
+ | (MLton_hash, MLton_hash) => true
| (MLton_handlesSignals, MLton_handlesSignals) => true
| (MLton_installSignalHandler, MLton_installSignalHandler) => true
| (MLton_serialize, MLton_serialize) => true
@@ -575,6 +578,7 @@
| MLton_eq => MLton_eq
| MLton_equal => MLton_equal
| MLton_halt => MLton_halt
+ | MLton_hash => MLton_hash
| MLton_handlesSignals => MLton_handlesSignals
| MLton_installSignalHandler => MLton_installSignalHandler
| MLton_serialize => MLton_serialize
@@ -706,12 +710,16 @@
| Word64 => CPointer_setWord (WordSize.fromBits (Bits.fromInt 64))
end
val cpointerSub = CPointer_sub
+val cpointerToWord = CPointer_toWord
val deref = Ref_deref
val eq = MLton_eq
val equal = MLton_equal
val ffi = FFI
val ffiSymbol = FFI_Symbol
+val hash = MLton_hash
val intInfEqual = IntInf_equal
+val intInfToVector = IntInf_toVector
+val intInfToWord = IntInf_toWord
val intInfNeg = IntInf_neg
val intInfNotb = IntInf_notb
val realCastToWord = Real_castToWord
@@ -724,6 +732,7 @@
val wordAndb = Word_andb
val wordCastToReal = Word_castToReal
val wordEqual = Word_equal
+val wordExtdToWord = Word_extdToWord
val wordLshift = Word_lshift
val wordLt = Word_lt
val wordMul = Word_mul
@@ -731,9 +740,10 @@
val wordNegCheck = Word_negCheck
val wordNotb = Word_notb
val wordOrb = Word_orb
+val wordQuot = Word_quot
val wordRshift = Word_rshift
val wordSub = Word_sub
-val wordExtdToWord = Word_extdToWord
+val wordXorb = Word_xorb
val isCommutative =
fn IntInf_equal => true
@@ -818,6 +828,7 @@
| MLton_eq => Functional
| MLton_equal => Functional
| MLton_halt => SideEffect
+ | MLton_hash => Functional
| MLton_handlesSignals => Functional
| MLton_installSignalHandler => SideEffect
| MLton_serialize => DependsOnState
@@ -1018,6 +1029,7 @@
MLton_eq,
MLton_equal,
MLton_halt,
+ MLton_hash,
MLton_handlesSignals,
MLton_installSignalHandler,
MLton_serialize,
@@ -1138,6 +1150,7 @@
| MLton_deserialize => one result
| MLton_eq => one (arg 0)
| MLton_equal => one (arg 0)
+ | MLton_hash => one (arg 1)
| MLton_serialize => one (arg 0)
| MLton_share => one (arg 0)
| MLton_size => one (arg 0)
@@ -1701,8 +1714,7 @@
fun two name = seq [arg 0, str " ", str name, str " ", arg 1]
in
case p of
- IntInf_equal => two "="
- | MLton_eq => two "="
+ Array_length => one "length"
| Real_Math_acos _ => one "acos"
| Real_Math_asin _ => one "asin"
| Real_Math_atan _ => one "atan"
Modified: mlton/trunk/mlton/atoms/prim.sig
===================================================================
--- mlton/trunk/mlton/atoms/prim.sig 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/atoms/prim.sig 2008-01-24 20:33:19 UTC (rev 6352)
@@ -80,6 +80,7 @@
| MLton_eq (* ssa to rssa *)
| MLton_equal (* polymorphic equality *)
| MLton_halt (* ssa to rssa *)
+ | MLton_hash (* polymorphic hash *)
(* MLton_handlesSignals and MLton_installSignalHandler work together
* to inform the optimizer and basis library whether or not the
* program uses signal handlers.
@@ -223,6 +224,7 @@
val cpointerLt: 'a t
val cpointerSet: CType.t -> 'a t
val cpointerSub: 'a t
+ val cpointerToWord: 'a t
val deref: 'a t
val eq: 'a t (* pointer equality *)
val equal: 'a t (* polymorphic equality *)
@@ -236,7 +238,10 @@
val ffi: 'a CFunction.t -> 'a t
val ffiSymbol: {name: string, cty: CType.t option} -> 'a t
val fromString: string -> 'a t option
+ val hash: 'a t (* polymorphic hash *)
val intInfEqual: 'a t
+ val intInfToWord: 'a t
+ val intInfToVector: 'a t
val isCommutative: 'a t -> bool
(*
* isFunctional p = true iff p always returns same result when given
@@ -267,12 +272,14 @@
val wordAndb: WordSize.t -> 'a t
val wordCastToReal : WordSize.t * RealSize.t -> 'a t
val wordEqual: WordSize.t -> 'a t
+ val wordExtdToWord: WordSize.t * WordSize.t * {signed: bool} -> 'a t
+ val wordLshift: WordSize.t -> 'a t
val wordLt: WordSize.t * {signed: bool} -> 'a t
- val wordLshift: WordSize.t -> 'a t
val wordMul: WordSize.t * {signed: bool} -> 'a t
val wordNeg: WordSize.t -> 'a t
val wordOrb: WordSize.t -> 'a t
+ val wordQuot: WordSize.t * {signed: bool} -> 'a t
val wordRshift: WordSize.t * {signed: bool} -> 'a t
val wordSub: WordSize.t -> 'a t
- val wordExtdToWord: WordSize.t * WordSize.t * {signed: bool} -> 'a t
+ val wordXorb: WordSize.t -> 'a t
end
Modified: mlton/trunk/mlton/atoms/source-info.fun
===================================================================
--- mlton/trunk/mlton/atoms/source-info.fun 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/atoms/source-info.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -128,6 +128,7 @@
val gcArrayAllocate = fromC "GC_arrayAllocate"
val main = fromC "main"
val polyEqual = fromC "poly-equal"
+val polyHash = fromC "poly-hash"
val unknown = fromC "unknown"
end
Modified: mlton/trunk/mlton/atoms/source-info.sig
===================================================================
--- mlton/trunk/mlton/atoms/source-info.sig 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/atoms/source-info.sig 2008-01-24 20:33:19 UTC (rev 6352)
@@ -31,6 +31,7 @@
val main: t
val plist: t -> PropertyList.t
val polyEqual: t
+ val polyHash: t
val toString: t -> string
val toString': t * string -> string
val unknown: t
Modified: mlton/trunk/mlton/closure-convert/globalize.fun
===================================================================
--- mlton/trunk/mlton/closure-convert/globalize.fun 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/closure-convert/globalize.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -104,13 +104,15 @@
val global =
areGlobal args andalso
((Prim.isFunctional prim
- (* Don't want to move MLton_equal into the globals
- * because polymorphic equality isn't implemented
+ (* Don't want to move MLton_equal or MLton_hash
+ * into the globals because polymorphic
+ * equality and hasing isn't implemented
* there.
*)
andalso
(case Prim.name prim of
Prim.Name.MLton_equal => false
+ | Prim.Name.MLton_hash => false
| _ => true))
orelse
(once andalso
Copied: mlton/trunk/mlton/ssa/poly-hash.fun (from rev 6311, mlton/trunk/mlton/ssa/poly-equal.fun)
===================================================================
--- mlton/trunk/mlton/ssa/poly-equal.fun 2008-01-09 21:54:31 UTC (rev 6311)
+++ mlton/trunk/mlton/ssa/poly-hash.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -0,0 +1,853 @@
+(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+functor PolyHash (S: POLY_HASH_STRUCTS): POLY_HASH =
+struct
+
+open S
+
+type int = Int.t
+type word = Word.t
+
+(*
+ * This pass implements polymorphic, structural hashing.
+ *
+ * For each datatype tycon and vector type, it builds a hashing function and
+ * translates calls to MLton_hash into calls to that function.
+ *
+ * For tuples, it does the hashing inline. I.E. it does not create
+ * a separate hashing function for each tuple type.
+ *
+ * All hashing functions are only created if necessary, i.e. if hashing
+ * is actually used at a type.
+ *
+ * Optimizations:
+ *)
+
+open Exp Transfer
+
+structure Dexp =
+ struct
+ open DirectExp
+
+ fun wordFromWord (w: word, ws: WordSize.t): t =
+ word (WordX.fromIntInf (Word.toIntInf w, ws))
+
+ fun shiftInt i =
+ word (WordX.fromIntInf (i, WordSize.shiftArg))
+ fun shiftBits b = shiftInt (Bits.toIntInf b)
+
+ local
+ fun mk prim =
+ fn (e1: t, e2: t, s) =>
+ primApp {prim = prim s,
+ targs = Vector.new0 (),
+ args = Vector.new2 (e1, e2),
+ ty = Type.word s}
+ in
+ val add = mk Prim.wordAdd
+ val andb = mk Prim.wordAndb
+ val lshift = mk Prim.wordLshift
+ val rshift = mk (fn s => Prim.wordRshift (s, {signed = false}))
+ val sub = mk Prim.wordSub
+ val xorb = mk Prim.wordXorb
+ end
+ local
+ fun mk prim =
+ fn (e1: t, e2: t, s, sg) =>
+ primApp {prim = prim (s, sg),
+ targs = Vector.new0 (),
+ args = Vector.new2 (e1, e2),
+ ty = Type.word s}
+ in
+ val mul = mk Prim.wordMul
+ val quot = mk Prim.wordQuot
+ end
+
+ fun wordEqual (e1: t, e2: t, s): t =
+ primApp {prim = Prim.wordEqual s,
+ targs = Vector.new0 (),
+ args = Vector.new2 (e1, e2),
+ ty = Type.bool}
+ fun wordLt (e1: t, e2: t, s, sg): t =
+ primApp {prim = Prim.wordLt (s, {signed = sg}),
+ targs = Vector.new0 (),
+ args = Vector.new2 (e1, e2),
+ ty = Type.bool}
+end
+
+structure Hash =
+ struct
+ val resWordSize = WordSize.word32
+ val resTy = Type.word resWordSize
+
+ fun mkWordBytes {stateTy: Type.t,
+ workWordSize: WordSize.t,
+ combByte: Dexp.t * Dexp.t -> Dexp.t,
+ mix: Dexp.t -> Dexp.t} =
+ let
+ val workBits = WordSize.bits workWordSize
+ val workTy = Type.word workWordSize
+ fun wordBytes (st,w,ws) =
+ let
+ fun extdW w =
+ if WordSize.equals (ws, workWordSize)
+ then w
+ else Dexp.primApp {prim = Prim.wordExtdToWord
+ (ws, workWordSize,
+ {signed = false}),
+ targs = Vector.new0 (),
+ args = Vector.new1 w,
+ ty = workTy}
+
+ val mask =
+ (Dexp.word o WordX.resize)
+ (WordX.allOnes WordSize.word8,
+ workWordSize)
+
+ fun loop (st, w, b) =
+ if Bits.<= (b, Bits.zero)
+ then st
+ else let
+ val dst0 = st
+ val w0 = Var.newNoname ()
+ val dw0 = Dexp.var (w0, workTy)
+ val bw = Var.newNoname ()
+ val dbw = Dexp.var (bw, workTy)
+ val st1 = Var.newNoname ()
+ val dst1 = Dexp.var (st1, stateTy)
+ val st2 = Var.newNoname ()
+ val dst2 = Dexp.var (st2, stateTy)
+ in
+ Dexp.lett
+ {decs = [{var = w0, exp = w},
+ {var = bw, exp =
+ Dexp.andb (dw0, mask, workWordSize)},
+ {var = st1, exp =
+ combByte (dst0, dbw)},
+ {var = st2, exp =
+ mix dst1}],
+ body = loop (dst2,
+ Dexp.rshift (dw0,
+ Dexp.shiftBits Bits.inWord8,
+ workWordSize),
+ Bits.- (b, Bits.inWord8))}
+ end
+ fun lp (st, w, b) =
+ if Bits.<= (b, Bits.zero)
+ then st
+ else let
+ val dst0 = st
+ val w0 = Var.newNoname ()
+ val dw0 = Dexp.var (w0, Type.word ws)
+ val ew = Var.newNoname ()
+ val dew = Dexp.var (ew, workTy)
+ val loopBits = Bits.min (b, workBits)
+ val st1 = Var.newNoname ()
+ val dst1 = Dexp.var (st1, stateTy)
+ in
+ Dexp.lett
+ {decs = [{var = w0, exp = w},
+ {var = ew, exp = extdW dw0},
+ {var = st1, exp = loop (dst0, dew, loopBits)}],
+ body = lp (dst1,
+ Dexp.rshift (dw0,
+ Dexp.shiftBits workBits,
+ ws),
+ Bits.- (b, workBits))}
+ end
+ val st0 = Var.newNoname ()
+ val dst0 = Dexp.var (st0, stateTy)
+ in
+ Dexp.lett
+ {decs = [{var = st0, exp = st}],
+ body = lp (dst0, w, WordSize.bits ws)}
+ end
+ in
+ wordBytes
+ end
+
+ (* Jenkins One-at-a-time hash
+ * http://en.wikipedia.org/wiki/Hash_table
+ *)
+(*
+ val {stateTy, init, wordBytes, fini} =
+ let
+ val stateWordSize = resWordSize
+ val stateTy = Type.word stateWordSize
+ val workWordSize = resWordSize
+ val workTy = Type.word workWordSize
+
+ local
+ fun mk prim =
+ fn (w1, w2) => prim (w1, w2, stateWordSize)
+ in
+ val add = mk Dexp.add
+ val lshift = mk Dexp.lshift
+ val rshift = mk Dexp.rshift
+ val xorb = mk Dexp.xorb
+ end
+
+ fun init () = Dexp.word (WordX.zero stateWordSize)
+ fun combByte (hexp, wexp) =
+ let
+ val h0 = Var.newNoname ()
+ val dh0 = Dexp.var (h0, stateTy)
+ val w0 = Var.newNoname ()
+ val dw0 = Dexp.var (w0, workTy)
+ val h1 = Var.newNoname ()
+ val dh1 = Dexp.var (h1, stateTy)
+ in
+ Dexp.lett
+ {decs = [{var = h0, exp = hexp},
+ {var = w0, exp = wexp},
+ {var = h1, exp = add (dh0, dw0)}],
+ body = dh1}
+ end
+ fun mix hexp =
+ let
+ val h0 = Var.newNoname ()
+ val dh0 = Dexp.var (h0, stateTy)
+ val h1 = Var.newNoname ()
+ val dh1 = Dexp.var (h1, stateTy)
+ val h2 = Var.newNoname ()
+ val dh2 = Dexp.var (h2, stateTy)
+ in
+ Dexp.lett
+ {decs = [{var = h0, exp = hexp},
+ {var = h1, exp = add (dh0, lshift (dh0, Dexp.shiftInt 10))},
+ {var = h2, exp = xorb (dh1, rshift (dh1, Dexp.shiftInt 6))}],
+ body = dh2}
+ end
+ val wordBytes =
+ mkWordBytes
+ {stateTy = stateTy,
+ workWordSize = workWordSize,
+ combByte = combByte,
+ mix = mix}
+ fun fini hexp =
+ let
+ val h0 = Var.newNoname ()
+ val dh0 = Dexp.var (h0, stateTy)
+ val h1 = Var.newNoname ()
+ val dh1 = Dexp.var (h1, stateTy)
+ val h2 = Var.newNoname ()
+ val dh2 = Dexp.var (h2, stateTy)
+ val h3 = Var.newNoname ()
+ val dh3 = Dexp.var (h3, stateTy)
+ in
+ Dexp.lett
+ {decs = [{var = h0, exp = hexp},
+ {var = h1, exp = add (dh0, lshift (dh0, Dexp.shiftInt 3))},
+ {var = h2, exp = xorb (dh1, rshift (dh1, Dexp.shiftInt 11))},
+ {var = h3, exp = add (dh2, lshift (dh2, Dexp.shiftInt 15))}],
+ body = dh3}
+ end
+ in
+ {stateTy = stateTy,
+ init = init,
+ wordBytes = wordBytes,
+ fini = fini}
+ end
+*)
+ (* Modifed FNV
+ * http://home.comcast.net/~bretm/hash/6.html
+ *)
+ val {stateTy, init, wordBytes, fini} =
+ let
+ val stateWordSize = resWordSize
+ val stateTy = Type.word stateWordSize
+ val workWordSize = resWordSize
+ val workTy = Type.word workWordSize
+
+ local
+ fun mk prim =
+ fn (w1, w2) => prim (w1, w2, stateWordSize)
+ in
+ val add = mk Dexp.add
+ val lshift = mk Dexp.lshift
+ val mul = mk (fn (w1,w2,s) => Dexp.mul (w1,w2,s,{signed = false}))
+ val rshift = mk Dexp.rshift
+ val xorb = mk Dexp.xorb
+ end
+
+ fun init () = Dexp.word (WordX.fromIntInf (2166136261, stateWordSize))
+ fun combByte (hexp, wexp) =
+ let
+ val h0 = Var.newNoname ()
+ val dh0 = Dexp.var (h0, stateTy)
+ val w0 = Var.newNoname ()
+ val dw0 = Dexp.var (w0, workTy)
+ val h1 = Var.newNoname ()
+ val dh1 = Dexp.var (h1, stateTy)
+ in
+ Dexp.lett
+ {decs = [{var = h0, exp = hexp},
+ {var = w0, exp = wexp},
+ {var = h1, exp = xorb (dh0, dw0)}],
+ body = dh1}
+ end
+ fun mix hexp =
+ let
+ val h0 = Var.newNoname ()
+ val dh0 = Dexp.var (h0, stateTy)
+ val p = Dexp.word (WordX.fromIntInf (16777619, stateWordSize))
+ val h1 = Var.newNoname ()
+ val dh1 = Dexp.var (h1, stateTy)
+ in
+ Dexp.lett
+ {decs = [{var = h0, exp = hexp},
+ {var = h1, exp = mul (dh0, p)}],
+ body = dh1}
+ end
+ val wordBytes =
+ mkWordBytes
+ {stateTy = stateTy,
+ workWordSize = workWordSize,
+ combByte = combByte,
+ mix = mix}
+ fun fini hexp =
+ let
+ val h0 = Var.newNoname ()
+ val dh0 = Dexp.var (h0, stateTy)
+ val h1 = Var.newNoname ()
+ val dh1 = Dexp.var (h1, stateTy)
+ val h2 = Var.newNoname ()
+ val dh2 = Dexp.var (h2, stateTy)
+ val h3 = Var.newNoname ()
+ val dh3 = Dexp.var (h3, stateTy)
+ val h4 = Var.newNoname ()
+ val dh4 = Dexp.var (h4, stateTy)
+ val h5 = Var.newNoname ()
+ val dh5 = Dexp.var (h5, stateTy)
+ in
+ Dexp.lett
+ {decs = [{var = h0, exp = hexp},
+ {var = h1, exp = add (dh0, lshift (dh0, Dexp.shiftInt 13))},
+ {var = h2, exp = xorb (dh1, rshift (dh1, Dexp.shiftInt 7))},
+ {var = h3, exp = add (dh2, lshift (dh2, Dexp.shiftInt 3))},
+ {var = h4, exp = xorb (dh3, rshift (dh3, Dexp.shiftInt 17))},
+ {var = h5, exp = add (dh4, lshift (dh4, Dexp.shiftInt 5))}],
+ body = dh5}
+ end
+ in
+ {stateTy = stateTy,
+ init = init,
+ wordBytes = wordBytes,
+ fini = fini}
+ end
+ fun wordBytesFromWord (st: Dexp.t, w:word, ws: WordSize.t) =
+ wordBytes (st, Dexp.wordFromWord (w, ws), ws)
+ end
+
+fun polyHash (Program.T {datatypes, globals, functions, main}) =
+ let
+ val shrink = shrinkFunction {globals = globals}
+ val {get = tyconInfo: Tycon.t -> {cons: {con: Con.t,
+ args: Type.t vector} vector},
+ set = setTyconInfo, ...} =
+ Property.getSetOnce
+ (Tycon.plist, Property.initRaise ("PolyHash.info", Tycon.layout))
+ val tyconCons = #cons o tyconInfo
+ val _ =
+ Vector.foreach
+ (datatypes, fn Datatype.T {tycon, cons} =>
+ setTyconInfo (tycon,
+ {cons = cons}))
+ val newFunctions: Function.t list ref = ref []
+ val {get = getHashFunc: Type.t -> Func.t option,
+ set = setHashFunc,
+ destroy = destroyHashFunc} =
+ Property.destGetSet (Type.plist, Property.initConst NONE)
+ val {get = getTyconHashFunc: Tycon.t -> Func.t option,
+ set = setTyconHashFunc, ...} =
+ Property.getSet (Tycon.plist, Property.initConst NONE)
+ val {get = getVectorHashFunc: Type.t -> Func.t option,
+ set = setVectorHashFunc,
+ destroy = destroyVectorHashFunc} =
+ Property.destGetSet (Type.plist, Property.initConst NONE)
+ val returns = SOME (Vector.new1 Hash.stateTy)
+ val seqIndexWordSize = WordSize.seqIndex ()
+ val seqIndexTy = Type.word seqIndexWordSize
+ fun newFunction z =
+ List.push (newFunctions,
+ Function.profile (shrink (Function.new z),
+ SourceInfo.polyHash))
+ fun hashTyconFunc (tycon: Tycon.t): Func.t =
+ case getTyconHashFunc tycon of
+ SOME f => f
+ | NONE =>
+ let
+ val name =
+ Func.newString (concat ["hash_", Tycon.originalName tycon])
+ val _ = setTyconHashFunc (tycon, SOME name)
+ val ty = Type.con (tycon, Vector.new0 ())
+ val st = (Var.newNoname (), Hash.stateTy)
+ val dep = (Var.newNoname (), seqIndexTy)
+ val x = (Var.newNoname (), ty)
+ val args = Vector.new3 (st, dep, x)
+ val dst = Dexp.var st
+ val ddep = Dexp.var dep
+ val dx = Dexp.var x
+ val cons = tyconCons tycon
+ val dep' = Var.newNoname ()
+ val ddep' = Dexp.var (dep', seqIndexTy)
+ val body =
+ Dexp.lett
+ {decs = [{var = dep', exp =
+ Dexp.sub (ddep,
+ Dexp.word (WordX.one seqIndexWordSize),
+ seqIndexWordSize)}],
+ body =
+ Dexp.casee
+ {test = dx,
+ ty = Hash.stateTy,
+ default = NONE,
+ cases =
+ (Dexp.Con o Vector.map)
+ (cons, fn {con, args} =>
+ let
+ val xs =
+ Vector.map
+ (args, fn ty =>
+ (Var.newNoname (), ty))
+ in
+ {con = con,
+ args = xs,
+ body =
+ Vector.fold
+ (xs,
+ Hash.wordBytesFromWord
+ (dst, Con.hash con, WordSize.word32),
+ fn ((x,ty), dstate) =>
+ hashExp (dstate, ddep', Dexp.var (x, ty), ty))}
+ end)}}
+ val (start, blocks) = Dexp.linearize (body, Handler.Caller)
+ val blocks = Vector.fromList blocks
+ val _ =
+ newFunction {args = args,
+ blocks = blocks,
+ mayInline = true,
+ name = name,
+ raises = NONE,
+ returns = returns,
+ start = start}
+ in
+ name
+ end
+ and vectorHashFunc (ty: Type.t): Func.t =
+ case getVectorHashFunc ty of
+ SOME f => f
+ | NONE =>
+ let
+ (* Build two functions, one that hashes the length and the
+ * other that loops.
+ *)
+ val name = Func.newString "vectorHash"
+ val _ = setVectorHashFunc (ty, SOME name)
+ val loop = Func.newString "vectorHashLoop"
+ val vty = Type.vector ty
+ local
+ val st = (Var.newNoname (), Hash.stateTy)
+ val dep = (Var.newNoname (), seqIndexTy)
+ val vec = (Var.newNoname (), vty)
+ val args = Vector.new3 (st, dep, vec)
+ val dst = Dexp.var st
+ val ddep = Dexp.var dep
+ val dvec = Dexp.var vec
+ val len = (Var.newNoname (), seqIndexTy)
+ val dlen = Dexp.var len
+ val maxstepTy = Type.tuple (Vector.new2 (seqIndexTy, seqIndexTy))
+ val maxstep = (Var.newNoname (), maxstepTy)
+ val dmaxstep = Dexp.var maxstep
+ val max = (Var.newNoname (), seqIndexTy)
+ val dmax = Dexp.var max
+ val step = (Var.newNoname (), seqIndexTy)
+ val dstep = Dexp.var step
+ val body =
+ Dexp.lett
+ {decs = [{var = #1 len, exp =
+ Dexp.primApp {prim = Prim.vectorLength,
+ targs = Vector.new1 ty,
+ args = Vector.new1 dvec,
+ ty = seqIndexTy}},
+ {var = #1 maxstep, exp =
+ Dexp.casee
+ {test = Dexp.wordLt (dlen, ddep, seqIndexWordSize, true),
+ ty = maxstepTy,
+ default = NONE,
+ cases =
+ (Dexp.Con o Vector.new2)
+ ({con = Con.truee,
+ args = Vector.new0 (),
+ body =
+ Dexp.tuple
+ {exps = Vector.new2
+ (dlen,
+ Dexp.word (WordX.one seqIndexWordSize)),
+ ty = maxstepTy}},
+ {con = Con.falsee,
+ args = Vector.new0 (),
+ body =
+ let
+ val step = (Var.newNoname (), seqIndexTy)
+ val dstep = Dexp.var step
+ val max = (Var.newNoname (), seqIndexTy)
+ val dmax = Dexp.var max
+ in
+ Dexp.lett
+ {decs = [{var = #1 step, exp =
+ Dexp.quot (dlen,
+ ddep,
+ seqIndexWordSize,
+ {signed = true})},
+ {var = #1 max, exp =
+ Dexp.mul (dstep,
+ ddep,
+ seqIndexWordSize,
+ {signed = true})}],
+ body = Dexp.tuple {exps = Vector.new2 (dmax, dstep),
+ ty = maxstepTy}}
+ end})}}],
+ body =
+ Dexp.call
+ {func = loop,
+ args = (Vector.new6
+ (Hash.wordBytes (dst, dlen, seqIndexWordSize),
+ ddep, dvec,
+ Dexp.select {offset = 0, tuple = dmaxstep, ty = seqIndexTy},
+ Dexp.select {offset = 1, tuple = dmaxstep, ty = seqIndexTy},
+ Dexp.word (WordX.zero seqIndexWordSize))),
+ ty = Hash.stateTy}}
+ val (start, blocks) = Dexp.linearize (body, Handler.Caller)
+ val blocks = Vector.fromList blocks
+ in
+ val _ =
+ newFunction {args = args,
+ blocks = blocks,
+ mayInline = true,
+ name = name,
+ raises = NONE,
+ returns = returns,
+ start = start}
+ end
+ local
+ val st = (Var.newNoname (), Hash.stateTy)
+ val dep = (Var.newNoname (), seqIndexTy)
+ val vec = (Var.newNoname (), vty)
+ val max = (Var.newNoname (), seqIndexTy)
+ val step = (Var.newNoname (), seqIndexTy)
+ val i = (Var.newNoname (), seqIndexTy)
+ val args = Vector.new6 (st, dep, vec, max, step, i)
+ val dst = Dexp.var st
+ val ddep = Dexp.var dep
+ val dvec = Dexp.var vec
+ val dmax = Dexp.var max
+ val dstep = Dexp.var step
+ val di = Dexp.var i
+ val body =
+ let
+ val args =
+ Vector.new6
+ (hashExp
+ (dst,
+ Dexp.sub (ddep,
+ Dexp.word (WordX.one seqIndexWordSize),
+ seqIndexWordSize),
+ Dexp.primApp {prim = Prim.vectorSub,
+ targs = Vector.new1 ty,
+ args = Vector.new2 (dvec, di),
+ ty = ty},
+ ty),
+ ddep,
+ dvec,
+ dmax,
+ dstep,
+ Dexp.add (di,
+ dstep,
+ seqIndexWordSize))
+ in
+ Dexp.casee
+ {test = Dexp.wordEqual
+ (di, dmax, seqIndexWordSize),
+ ty = Hash.stateTy,
+ default = NONE,
+ cases = (Dexp.Con o Vector.new2)
+ ({con = Con.truee,
+ args = Vector.new0 (),
+ body = dst},
+ {con = Con.falsee,
+ args = Vector.new0 (),
+ body = Dexp.call {args = args,
+ func = loop,
+ ty = Hash.stateTy}})}
+ end
+ val (start, blocks) = Dexp.linearize (body, Handler.Caller)
+ val blocks = Vector.fromList blocks
+ in
+ val _ =
+ newFunction {args = args,
+ blocks = blocks,
+ mayInline = true,
+ name = loop,
+ raises = NONE,
+ returns = returns,
+ start = start}
+ end
+ in
+ name
+ end
+ and hashExp (st: Dexp.t, dep: Dexp.t, x: Dexp.t, ty: Type.t): Dexp.t =
+ Dexp.name (st, fn st =>
+ Dexp.name (dep, fn dep =>
+ Dexp.name (x, fn x => hash (st, dep, x, ty))))
+ and hash (st: Var.t, dep: Var.t, x: Var.t, ty: Type.t): Dexp.t =
+ let
+ val dst = Dexp.var (st, Hash.stateTy)
+ val ddep = Dexp.var (dep, seqIndexTy)
+ val dx = Dexp.var (x, ty)
+ fun stateful () =
+ Hash.wordBytesFromWord
+ (dst, Type.hash ty, WordSize.word32)
+
+ val body =
+ case Type.dest ty of
+ Type.Array _ => stateful ()
+ | Type.CPointer =>
+ let
+ val ws = WordSize.cpointer ()
+ val toWord =
+ Dexp.primApp
+ {prim = Prim.cpointerToWord,
+ targs = Vector.new0 (),
+ args = Vector.new1 dx,
+ ty = Type.word ws}
+ in
+ Hash.wordBytes (dst, toWord, ws)
+ end
+ | Type.Datatype tycon =>
+ Dexp.call {func = hashTyconFunc tycon,
+ args = Vector.new3 (dst, ddep, dx),
+ ty = Hash.stateTy}
+ | Type.IntInf =>
+ let
+ val sws = WordSize.smallIntInfWord ()
+ val bws = WordSize.bigIntInfWord ()
+ val toWord =
+ Dexp.primApp
+ {prim = Prim.intInfToWord,
+ targs = Vector.new0 (),
+ args = Vector.new1 dx,
+ ty = Type.word sws}
+ val toVector =
+ Dexp.primApp
+ {prim = Prim.intInfToVector,
+ targs = Vector.new0 (),
+ args = Vector.new1 dx,
+ ty = Type.vector (Type.word bws)}
+ val w = Var.newNoname ()
+ val dw = Dexp.var (w, Type.word sws)
+ val one = Dexp.word (WordX.one sws)
+ in
+ Dexp.lett
+ {decs = [{var = w, exp = toWord}],
+ body =
+ Dexp.casee
+ {test = Dexp.wordEqual (Dexp.andb (dw, one, sws), one, sws),
+ ty = Hash.stateTy,
+ default = NONE,
+ cases =
+ (Dexp.Con o Vector.new2)
+ ({con = Con.truee,
+ args = Vector.new0 (),
+ body = Hash.wordBytes (dst, dw, sws)},
+ {con = Con.falsee,
+ args = Vector.new0 (),
+ body =
+ Dexp.call {func = vectorHashFunc (Type.word bws),
+ args = Vector.new3 (dst, ddep, toVector),
+ ty = Hash.stateTy}})}}
+ end
+ | Type.Real rs =>
+ let
+ val ws = WordSize.fromBits (RealSize.bits rs)
+ val toWord =
+ Dexp.primApp
+ {prim = Prim.realCastToWord (rs, ws),
+ targs = Vector.new0 (),
+ args = Vector.new1 dx,
+ ty = Type.word ws}
+ in
+ Hash.wordBytes (dst, toWord, ws)
+ end
+ | Type.Ref _ => stateful ()
+ | Type.Thread => stateful ()
+ | Type.Tuple tys =>
+ let
+ val max = Vector.length tys - 1
+ (* test components i, i+1, ... *)
+ fun loop (i: int, dst): Dexp.t =
+ if i > max
+ then dst
+ else let
+ val ty = Vector.sub (tys, i)
+ val select =
+ Dexp.select {tuple = dx,
+ offset = i,
+ ty = ty}
+ in
+ loop
+ (i + 1,
+ hashExp (dst, ddep, select, ty))
+ end
+ in
+ loop (0, dst)
+ end
+ | Type.Vector ty =>
+ Dexp.call {func = vectorHashFunc ty,
+ args = Vector.new3 (dst, ddep, dx),
+ ty = Hash.stateTy}
+ | Type.Weak _ => stateful ()
+ | Type.Word ws => Hash.wordBytes (dst, dx, ws)
+ in
+ Dexp.casee
+ {test = Dexp.wordEqual (ddep,
+ Dexp.word (WordX.zero seqIndexWordSize),
+ seqIndexWordSize),
+ ty = Hash.stateTy,
+ default = NONE,
+ cases =
+ (Dexp.Con o Vector.new2)
+ ({con = Con.truee,
+ args = Vector.new0 (),
+ body = dst},
+ {con = Con.falsee,
+ args = Vector.new0 (),
+ body = body})}
+ end
+ fun hashFunc (ty: Type.t): Func.t =
+ case getHashFunc ty of
+ SOME f => f
+ | NONE =>
+ let
+ val name = Func.newString "hash"
+ val _ = setHashFunc (ty, SOME name)
+ val dep = (Var.newNoname (), seqIndexTy)
+ val x = (Var.newNoname (), ty)
+ val args = Vector.new2 (dep, x)
+ val sti = Var.newNoname ()
+ val dsti = Dexp.var (sti, Hash.stateTy)
+ val ddep = Dexp.var dep
+ val dx = Dexp.var x
+ val stf = Var.newNoname ()
+ val dstf = Dexp.var (stf, Hash.stateTy)
+ val w = Var.newNoname ()
+ val dw = Dexp.var (w, Hash.resTy)
+ val body =
+ Dexp.lett
+ {decs = [{var = sti, exp = Hash.init ()},
+ {var = stf, exp = hashExp (dsti, ddep, dx, ty)},
+ {var = w, exp = Hash.fini dstf}],
+ body = dw}
+ val (start, blocks) = Dexp.linearize (body, Handler.Caller)
+ val blocks = Vector.fromList blocks
+ val _ =
+ newFunction {args = args,
+ blocks = blocks,
+ mayInline = true,
+ name = name,
+ raises = NONE,
+ returns = returns,
+ start = start}
+ in
+ name
+ end
+ fun doit blocks =
+ let
+ val blocks =
+ Vector.fold
+ (blocks, [],
+ fn (Block.T {label, args, statements, transfer}, blocks) =>
+ let
+ fun finish ({label, args, statements}, transfer) =
+ Block.T {label = label,
+ args = args,
+ statements = Vector.fromListRev statements,
+ transfer = transfer}
+ val (blocks, las) =
+ Vector.fold
+ (statements,
+ (blocks, {label = label, args = args, statements = []}),
+ fn (stmt as Statement.T {exp, var, ...},
+ (blocks, las as {label, args, statements})) =>
+ let
+ fun normal () = (blocks,
+ {label = label,
+ args = args,
+ statements = stmt::statements})
+ in
+ case exp of
+ PrimApp {prim, targs, args, ...} =>
+ (case (Prim.name prim, Vector.length targs) of
+ (Prim.Name.MLton_hash, 1) =>
+ let
+ val ty = Vector.sub (targs, 0)
+ val dep = Vector.sub (args, 0)
+ val x = Vector.sub (args, 1)
+ val l = Label.newNoname ()
+ in
+ (finish
+ (las,
+ Call {args = Vector.new2 (dep, x),
+ func = hashFunc ty,
+ return = Return.NonTail
+ {cont = l,
+ handler = Handler.Caller}})
+ :: blocks,
+ {label = l,
+ args = Vector.new1 (valOf var, Hash.resTy),
+ statements = []})
+ end
+ | _ => normal ())
+ | _ => normal ()
+ end)
+ in
+ finish (las, transfer)
+ :: blocks
+ end)
+ in
+ Vector.fromList blocks
+ end
+ val functions =
+ List.revMap
+ (functions, fn f =>
+ let
+ val {args, blocks, mayInline, name, raises, returns, start} =
+ Function.dest f
+ in
+ shrink (Function.new {args = args,
+ blocks = doit blocks,
+ mayInline = mayInline,
+ name = name,
+ raises = raises,
+ returns = returns,
+ start = start})
+ end)
+ val program =
+ Program.T {datatypes = datatypes,
+ globals = globals,
+ functions = (!newFunctions) @ functions,
+ main = main}
+ val _ = destroyHashFunc ()
+ val _ = destroyVectorHashFunc ()
+ val _ = Program.clearTop program
+ in
+ program
+ end
+
+end
Copied: mlton/trunk/mlton/ssa/poly-hash.sig (from rev 6303, mlton/trunk/mlton/ssa/poly-equal.sig)
===================================================================
--- mlton/trunk/mlton/ssa/poly-equal.sig 2008-01-09 15:07:26 UTC (rev 6303)
+++ mlton/trunk/mlton/ssa/poly-hash.sig 2008-01-24 20:33:19 UTC (rev 6352)
@@ -0,0 +1,20 @@
+(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
+ * Jagannathan, and Stephen Weeks.
+ * Copyright (C) 1997-2000 NEC Research Institute.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+
+signature POLY_HASH_STRUCTS =
+ sig
+ include SHRINK
+ end
+
+signature POLY_HASH =
+ sig
+ include POLY_HASH_STRUCTS
+
+ val polyHash: Program.t -> Program.t
+ end
Modified: mlton/trunk/mlton/ssa/remove-unused.fun
===================================================================
--- mlton/trunk/mlton/ssa/remove-unused.fun 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/ssa/remove-unused.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -373,7 +373,15 @@
* of constructors as patterns.
*)
=> decon (Vector.sub (targs, 0))
-(* | (Prim.Name.MLton_size, 1) => decon (Vector.sub (targs, 0)) *)
+ | (Prim.Name.MLton_hash, 1)
+ (* MLton_hash will be expanded by poly-hash into uses
+ * of constructors as patterns.
+ *)
+ => decon (Vector.sub (targs, 0))
+(*
+ | (Prim.Name.MLton_size, 1)
+ => decon (Vector.sub (targs, 0))
+*)
| _ => ()
end
| Select {tuple, ...} => visitVar tuple
Modified: mlton/trunk/mlton/ssa/remove-unused2.fun
===================================================================
--- mlton/trunk/mlton/ssa/remove-unused2.fun 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/ssa/remove-unused2.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -483,6 +483,11 @@
* of constructors as patterns.
*)
deconType (tyVar (Vector.sub (args, 0)))
+ | Prim.Name.MLton_hash =>
+ (* MLton_hash will be expanded by poly-equal into uses
+ * of constructors as patterns.
+ *)
+ deconType (tyVar (Vector.sub (args, 0)))
(*
| (Prim.Name.MLton_size, 1) =>
deconType (tyVar (Vector.sub (args, 0)))
Modified: mlton/trunk/mlton/ssa/simplify.fun
===================================================================
--- mlton/trunk/mlton/ssa/simplify.fun 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/ssa/simplify.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -26,6 +26,7 @@
structure LocalRef = LocalRef (S)
structure LoopInvariant = LoopInvariant (S)
structure PolyEqual = PolyEqual (S)
+structure PolyHash = PolyHash (S)
structure Profile = Profile (S)
structure Redundant = Redundant (S)
structure RedundantTests = RedundantTests (S)
@@ -59,14 +60,21 @@
* - before inlining so that equality functions can be inlined
*)
{name = "polyEqual", doit = PolyEqual.polyEqual} ::
+ (* polyHash should run
+ * - after types are simplified
+ * - before inlining so that hash functions can be inlined
+ *)
+ {name = "polyHash", doit = PolyHash.polyHash} ::
+ {name = "introduceLoops2", doit = IntroduceLoops.introduceLoops} ::
+ {name = "loopInvariant2", doit = LoopInvariant.loopInvariant} ::
{name = "contify2", doit = Contify.contify} ::
{name = "inlineNonRecursive", doit = fn p =>
Inline.inlineNonRecursive (p, !Control.inlineNonRec)} ::
{name = "localFlatten2", doit = LocalFlatten.flatten} ::
{name = "removeUnused3", doit = RemoveUnused.remove} ::
{name = "contify3", doit = Contify.contify} ::
- {name = "introduceLoops2", doit = IntroduceLoops.introduceLoops} ::
- {name = "loopInvariant2", doit = LoopInvariant.loopInvariant} ::
+ {name = "introduceLoops3", doit = IntroduceLoops.introduceLoops} ::
+ {name = "loopInvariant3", doit = LoopInvariant.loopInvariant} ::
{name = "localRef", doit = LocalRef.eliminate} ::
{name = "flatten", doit = Flatten.flatten} ::
{name = "localFlatten3", doit = LocalFlatten.flatten} ::
@@ -84,6 +92,8 @@
{name = "constantPropagation", doit = ConstantPropagation.simplify} ::
(* polyEqual cannot be omitted. It implements MLton_equal. *)
{name = "polyEqual", doit = PolyEqual.polyEqual} ::
+ (* polyHash cannot be omitted. It implements MLton_hash. *)
+ {name = "polyHash", doit = PolyHash.polyHash} ::
nil
val ssaPasses : pass list ref = ref ssaPassesDefault
@@ -189,6 +199,7 @@
("localRef", LocalRef.eliminate),
("loopInvariant", LoopInvariant.loopInvariant),
("polyEqual", PolyEqual.polyEqual),
+ ("polyHash", PolyHash.polyHash),
("redundant", Redundant.redundant),
("redundantTests", RedundantTests.simplify),
("removeUnused", RemoveUnused.remove),
Modified: mlton/trunk/mlton/ssa/sources.cm
===================================================================
--- mlton/trunk/mlton/ssa/sources.cm 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/ssa/sources.cm 2008-01-24 20:33:19 UTC (rev 6352)
@@ -91,6 +91,8 @@
loop-invariant.fun
poly-equal.sig
poly-equal.fun
+poly-hash.sig
+poly-hash.fun
profile.sig
profile.fun
profile2.sig
Modified: mlton/trunk/mlton/ssa/sources.mlb
===================================================================
--- mlton/trunk/mlton/ssa/sources.mlb 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/ssa/sources.mlb 2008-01-24 20:33:19 UTC (rev 6352)
@@ -78,6 +78,8 @@
loop-invariant.fun
poly-equal.sig
poly-equal.fun
+ poly-hash.sig
+ poly-hash.fun
profile.sig
profile.fun
profile2.sig
Modified: mlton/trunk/mlton/ssa/ssa-tree2.fun
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree2.fun 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/ssa/ssa-tree2.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -419,6 +419,7 @@
| MLton_eq => eq ()
| MLton_equal => eq ()
| MLton_halt => done ([cint], unit)
+ | MLton_hash => oneArg (fn x => done ([seqIndex, x], word32))
| MLton_handlesSignals => done ([], bool)
| MLton_installSignalHandler => done ([], unit)
| MLton_share => oneArg (fn x => done ([x], unit))
Modified: mlton/trunk/mlton/ssa/useless.fun
===================================================================
--- mlton/trunk/mlton/ssa/useless.fun 2008-01-24 20:28:30 UTC (rev 6351)
+++ mlton/trunk/mlton/ssa/useless.fun 2008-01-24 20:33:19 UTC (rev 6352)
@@ -159,7 +159,7 @@
in
case (value from, value to) of
(Array _, Array _) => unify (from, to)
- | (Ground to, Ground from) => Useful.<= (from, to)
+ | (Ground from, Ground to) => Useful.<= (to, from)
| (Ref _, Ref _) => unify (from, to)
| (Tuple vs, Tuple vs') =>
Vector.foreach2 (vs, vs', coerceSlot)
@@ -168,7 +168,7 @@
(coerce {from = n, to = n'}
; coerceSlot (e, e'))
| (Weak _, Weak _) => unify (from, to)
- | _ => Error.bug "Useles.Value.coerce: strange"
+ | _ => Error.bug "Useless.Value.coerce: strange"
end
val coerce =
@@ -525,6 +525,7 @@
(Vector.foreach (args, deepMakeUseful);
deepMakeUseful result)
| MLton_equal => Vector.foreach (args, deepMakeUseful)
+ | MLton_hash => Vector.foreach (args, deepMakeUseful)
| Ref_assign => coerce {from = arg 1, to = deref (arg 0)}
| Ref_deref => return (deref (arg 0))
| Ref_ref => coerce {from = arg 0, to = deref result}
More information about the MLton-commit
mailing list