[MLton-commit] r7437
Matthew Fluet
fluet at mlton.org
Mon Mar 15 18:39:14 PST 2010
Make MLton.hash a complete (linear time) hash.
----------------------------------------------------------------------
U mlton/trunk/basis-library/mlton/mlton.sml
U mlton/trunk/basis-library/primitive/prim-mlton.sml
U mlton/trunk/mlton/atoms/prim.fun
U mlton/trunk/mlton/ssa/poly-hash.fun
----------------------------------------------------------------------
Modified: mlton/trunk/basis-library/mlton/mlton.sml
===================================================================
--- mlton/trunk/basis-library/mlton/mlton.sml 2010-03-13 12:09:26 UTC (rev 7436)
+++ mlton/trunk/basis-library/mlton/mlton.sml 2010-03-16 02:39:12 UTC (rev 7437)
@@ -1,4 +1,5 @@
-(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 2010 Matthew Fluet.
+ * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -39,14 +40,7 @@
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 hash = Primitive.MLton.hash
(* 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 2010-03-13 12:09:26 UTC (rev 7436)
+++ mlton/trunk/basis-library/primitive/prim-mlton.sml 2010-03-16 02:39:12 UTC (rev 7437)
@@ -19,7 +19,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 hash = _prim "MLton_hash": '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/mlton/atoms/prim.fun
===================================================================
--- mlton/trunk/mlton/atoms/prim.fun 2010-03-13 12:09:26 UTC (rev 7436)
+++ mlton/trunk/mlton/atoms/prim.fun 2010-03-16 02:39:12 UTC (rev 7437)
@@ -1285,7 +1285,7 @@
| MLton_eq => oneTarg (fn t => (twoArgs (t, t), bool))
| MLton_equal => oneTarg (fn t => (twoArgs (t, t), bool))
| MLton_halt => noTargs (fn () => (oneArg cint, unit))
- | MLton_hash => oneTarg (fn t => (twoArgs (seqIndex, t), word32))
+ | MLton_hash => oneTarg (fn t => (oneArg t, word32))
| MLton_handlesSignals => noTargs (fn () => (noArgs, bool))
| MLton_installSignalHandler => noTargs (fn () => (noArgs, unit))
| MLton_serialize => oneTarg (fn t => (oneArg t, word8Vector))
@@ -1418,7 +1418,7 @@
| MLton_deserialize => one result
| MLton_eq => one (arg 0)
| MLton_equal => one (arg 0)
- | MLton_hash => one (arg 1)
+ | MLton_hash => one (arg 0)
| MLton_serialize => one (arg 0)
| MLton_share => one (arg 0)
| MLton_size => one (arg 0)
Modified: mlton/trunk/mlton/ssa/poly-hash.fun
===================================================================
--- mlton/trunk/mlton/ssa/poly-hash.fun 2010-03-13 12:09:26 UTC (rev 7436)
+++ mlton/trunk/mlton/ssa/poly-hash.fun 2010-03-16 02:39:12 UTC (rev 7437)
@@ -1,4 +1,4 @@
-(* Copyright (C) 2009 Matthew Fluet.
+(* Copyright (C) 2009-2010 Matthew Fluet.
* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
@@ -52,7 +52,6 @@
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
@@ -64,7 +63,6 @@
ty = Type.word s}
in
val mul = mk Prim.wordMul
- val quot = mk Prim.wordQuot
end
fun wordEqual (e1: t, e2: t, s): t =
@@ -72,11 +70,6 @@
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 =
@@ -386,45 +379,35 @@
val _ = setTyconHashFunc (tycon, SOME name)
val ty = Type.datatypee tycon
val st = (Var.newNoname (), Hash.stateTy)
- val dep = (Var.newNoname (), seqIndexTy)
val x = (Var.newNoname (), ty)
- val args = Vector.new3 (st, dep, x)
+ val args = Vector.new2 (st, 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)}}
+ 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, Dexp.var (x, ty), ty))}
+ end)}
val (start, blocks) = Dexp.linearize (body, Handler.Caller)
val blocks = Vector.fromList blocks
val _ =
@@ -452,71 +435,25 @@
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 args = Vector.new2 (st, 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 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})}}],
+ ty = seqIndexTy}}],
body =
Dexp.call
{func = loop,
- args = (Vector.new6
+ args = (Vector.new4
(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))),
+ dvec, dlen, Dexp.word (WordX.zero seqIndexWordSize))),
ty = Hash.stateTy}}
val (start, blocks) = Dexp.linearize (body, Handler.Caller)
val blocks = Vector.fromList blocks
@@ -532,43 +469,34 @@
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 len = (Var.newNoname (), seqIndexTy)
val i = (Var.newNoname (), seqIndexTy)
- val args = Vector.new6 (st, dep, vec, max, step, i)
+ val args = Vector.new4 (st, vec, len, 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 dlen = Dexp.var len
val di = Dexp.var i
val body =
let
val args =
- Vector.new6
+ Vector.new4
(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,
+ dlen,
Dexp.add (di,
- dstep,
+ Dexp.word (WordX.one seqIndexWordSize),
seqIndexWordSize))
in
Dexp.casee
{test = Dexp.wordEqual
- (di, dmax, seqIndexWordSize),
+ (di, dlen, seqIndexWordSize),
ty = Hash.stateTy,
default = NONE,
cases = (Dexp.Con o Vector.new2)
@@ -596,14 +524,12 @@
in
name
end
- and hashExp (st: Dexp.t, dep: Dexp.t, x: Dexp.t, ty: Type.t): Dexp.t =
+ and hashExp (st: 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 =
+ Dexp.name (x, fn x => hash (st, x, ty)))
+ and hash (st: 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
@@ -626,7 +552,7 @@
end
| Type.Datatype tycon =>
Dexp.call {func = hashTyconFunc tycon,
- args = Vector.new3 (dst, ddep, dx),
+ args = Vector.new2 (dst, dx),
ty = Hash.stateTy}
| Type.IntInf =>
let
@@ -664,7 +590,7 @@
args = Vector.new0 (),
body =
Dexp.call {func = vectorHashFunc (Type.word bws),
- args = Vector.new3 (dst, ddep, toVector),
+ args = Vector.new2 (dst, toVector),
ty = Hash.stateTy}})}}
end
| Type.Real rs =>
@@ -684,7 +610,7 @@
| Type.Tuple tys =>
let
val max = Vector.length tys - 1
- (* test components i, i+1, ... *)
+ (* hash components i, i+1, ... *)
fun loop (i: int, dst): Dexp.t =
if i > max
then dst
@@ -697,32 +623,19 @@
in
loop
(i + 1,
- hashExp (dst, ddep, select, ty))
+ hashExp (dst, select, ty))
end
in
loop (0, dst)
end
| Type.Vector ty =>
Dexp.call {func = vectorHashFunc ty,
- args = Vector.new3 (dst, ddep, dx),
+ args = Vector.new2 (dst, 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})}
+ body
end
fun hashFunc (ty: Type.t): Func.t =
case getHashFunc ty of
@@ -731,12 +644,10 @@
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 args = Vector.new1 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)
@@ -745,7 +656,7 @@
val body =
Dexp.lett
{decs = [{var = sti, exp = Hash.init ()},
- {var = stf, exp = hashExp (dsti, ddep, dx, ty)},
+ {var = stf, exp = hashExp (dsti, dx, ty)},
{var = w, exp = Hash.fini dstf}],
body = dw}
val (start, blocks) = Dexp.linearize (body, Handler.Caller)
@@ -823,13 +734,12 @@
(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 x = Vector.sub (args, 0)
val l = Label.newNoname ()
in
(finish
(las,
- Call {args = Vector.new2 (dep, x),
+ Call {args = Vector.new1 x,
func = hashFunc ty,
return = Return.NonTail
{cont = l,
More information about the MLton-commit
mailing list