[MLton-commit] r6926
Vesa Karvonen
vesak at mlton.org
Mon Oct 13 14:13:51 PDT 2008
Changed generic hash to produce a Word32 hash value rather than Word.
This has the benefit that the result will be the same on all compilers and
that can be valuable for a number of purposes. The disadvantage is that
one often wants the hash value to be a Word, but it is not a big deal to
convert with Word32.toWord.
Another alternative would have been to implement a two generic hash
functions (one for producing platform independent hashes and another for
native hashes), but it does not seem worth it.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig
U mltonlib/trunk/com/ssh/generic/unstable/test/read.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/arbitrary.sml 2008-10-13 21:13:47 UTC (rev 6926)
@@ -29,6 +29,8 @@
datatype 'a t = IN of {gen : 'a G.t, cog : 'a -> Univ.t G.t UnOp.t}
fun out (IN r) = r
+ fun variantHash aT = G.variant o Word32.toWord o Arg.hash (aT ())
+
fun mkInt (Ops.I {precision, isoLarge = (_, fromLarge), ...}) aT = let
fun gen n =
map (fn i => fromLarge (i - IntInf.<< (1, Word.fromInt n - 0w1)))
@@ -37,16 +39,16 @@
IN {gen = case precision
of NONE => G.sized (0 <\ G.intInRange) >>= gen o 1 <\ op +
| SOME n => G.intInRange (1, n) >>= gen,
- cog = G.variant o Arg.hash (aT ())}
+ cog = variantHash aT}
end
fun mkReal fromReal aT =
IN {gen = G.sized ((fn r => map fromReal (G.realInRange (~r,r))) o real),
- cog = G.variant o Arg.hash (aT ())}
+ cog = variantHash aT}
fun mkWord (Ops.W {wordSize, isoLargeInt = (_, fromLargeInt), ...}) aT =
IN {gen = map fromLargeInt (G.bits wordSize),
- cog = G.variant o Arg.hash (aT ())}
+ cog = variantHash aT}
fun iso' (IN {gen, cog}) (a2b, b2a) =
IN {gen = map b2a gen, cog = cog o a2b}
@@ -122,7 +124,7 @@
val exn = IN {gen = G.return () >>= (fn () =>
G.intInRange (0, Buffer.length exns-1) >>= (fn i =>
Buffer.sub (exns, i))),
- cog = G.variant o Arg.hash (Arg.Open.exn ())}
+ cog = variantHash Arg.Open.exn}
fun regExn0 _ (e, _) = Buffer.push exns (G.return e)
fun regExn1 _ aT (a2e, _) = Buffer.push exns (map a2e (arbitrary aT))
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/hash.sml 2008-10-13 21:13:47 UTC (rev 6926)
@@ -9,22 +9,26 @@
open TopLevel
infix 4 <\
infixr 4 />
+ infix 3 <-->
infix 0 &
(* SML/NJ workaround --> *)
+ val op <--> = Iso.<-->
+ val swap = Iso.swap
+
type p = {totWidth : Int.t, maxDepth : Int.t}
- type 'a t = 'a * p -> Word.t
+ type 'a t = 'a * p -> Word32.t
fun prim f : 'a t = f o #1
fun viaWord x2V op mod (v2w, w2v) =
- prim (fn x => v2w (x2V x mod w2v Word.largestPrime))
+ prim (fn x => v2w (x2V x mod w2v Word32.largestPrime))
fun iso' bH (a2b, _) = bH o Pair.map (a2b, id)
fun sequ (Ops.S {length, sub, ...}) hashElem (s, {totWidth, maxDepth}) = let
val n = length s
- val h = Word.fromInt n
+ val h = Word32.fromInt n
in
case Int.min (Int.quot (totWidth+3, 4), Int.quot (n+1, 2))
of 0 => h
@@ -41,13 +45,13 @@
val mkReal =
fn Ops.R {isoBits = SOME (toBits, _),
bitsOps = Ops.W {isoWord, mod, ...}, ...} =>
- viaWord toBits op mod isoWord
+ viaWord toBits op mod (swap Word32.isoWord <--> isoWord)
| Ops.R {toBytes, ...} =>
prim (Word8Vector.foldl
- (fn (w, h) => h * 0wxFB + Word8.toWord w)
+ (fn (w, h) => h * 0wxFB + Word32.fromWord (Word8.toWord w))
0w0 o toBytes)
- val exns : (Exn.t * p -> Word.t Option.t) Buffer.t = Buffer.new ()
+ val exns : (Exn.t * p -> Word32.t Option.t) Buffer.t = Buffer.new ()
structure HashRep = LayerRep' (open Arg type 'a t = 'a t)
@@ -57,12 +61,12 @@
fun hashParam t = let
val h = getT t
- val th = Word32.toWord (Arg.typeHash t)
+ val th = Arg.typeHash t
in
fn p =>
if #totWidth p < 0 orelse #maxDepth p < 0
then raise Domain
- else th <\ Word.xorb o h /> p
+ else th <\ Word32.xorb o h /> p
end
fun hash t = hashParam t defaultHashParam
@@ -98,8 +102,8 @@
val aH = getS aS
val bH = getS bS
in
- fn (INL a, p) => Word.xorb (0wx04D55ADB, aH (a, p))
- | (INR b, p) => Word.xorb (0wx05B6D5A3, bH (b, p))
+ fn (INL a, p) => Word32.xorb (0wx04D55ADB, aH (a, p))
+ | (INR b, p) => Word32.xorb (0wx05B6D5A3, bH (b, p))
end
val unit = prim (Thunk.mk 0wx062DAD9B)
fun C0 _ = unit
@@ -118,7 +122,7 @@
fun refc _ = prim (fn _ => 0wx35996C53)
- val int = prim Word.fromInt
+ val int = prim Word32.fromInt
fun list xT = let
val xH = getT xT
@@ -139,15 +143,15 @@
then h
else lp (h * 0w17 + xH (x, p), n-1, xs)
in
- lp (Word.fromInt n, n, xs)
+ lp (Word32.fromInt n, n, xs)
end
end
end
- fun array _ = prim (fn a => 0wx6D52A54D * Word.fromInt (Array.length a))
+ fun array _ = prim (fn a => 0wx6D52A54D * Word32.fromInt (Array.length a))
fun vector aT = sequ VectorOps.ops (getT aT)
- val char = prim (Word.fromInt o ord)
+ val char = prim (Word32.fromInt o ord)
val string = sequ StringOps.ops char
fun exn (e, {maxDepth, totWidth}) =
@@ -166,26 +170,26 @@
(fn (e, p) =>
case e2t e
of NONE => NONE
- | SOME v => SOME (Word.xorb (c, t (v, p))))
+ | SOME v => SOME (Word32.xorb (c, t (v, p))))
val bool = prim (fn true => 0wx096DB16D | false => 0wx01B56B6D)
val real = mkReal RealOps.ops
- val word = prim id
+ val word = prim Word32.fromWord
val fixedInt =
case FixedInt.precision
of NONE => fail "FixedInt.precision = NONE"
| SOME p =>
- if p <= Word.wordSize
- then prim Word.fromFixedInt
- else viaWord id op mod (Iso.swap Word.isoFixedInt)
- val largeInt = viaWord id op mod (Iso.swap Word.isoLargeInt)
+ if p <= Word32.wordSize
+ then prim Word32.fromFixedInt
+ else viaWord id op mod (swap Word32.isoFixedInt)
+ val largeInt = viaWord id op mod (swap Word32.isoLargeInt)
val largeReal = mkReal LargeRealOps.ops
- val largeWord = viaWord id op mod LargeWord.isoWord
+ val largeWord = viaWord id op mod (swap Word32.isoLarge)
- val word8 = prim Word8.toWord
- val word32 = prim Word32.toWord
+ val word8 = prim (Word32.fromWord o Word8.toWord)
+ val word32 = prim id
(*
val word64 = viaWord id op mod Word64.isoWord
*)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2008-10-13 21:13:47 UTC (rev 6926)
@@ -39,7 +39,7 @@
end)
fun cyclic aT (IN aO) =
- case HashUniv.new {eq = op =, hash = Arg.hash aT}
+ case HashUniv.new {eq = op =, hash = Word32.toWord o Arg.hash aT}
of (to, _) =>
IN (fn (e, (l, r)) => let
val lD = to l
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2008-10-13 21:13:47 UTC (rev 6926)
@@ -306,7 +306,8 @@
val fixedInt = mkFixedInt LargeWordOps.ops LargeWord.isoFixedIntX
fun cyclic {readProxy, readBody, writeWhole, self} = let
- val (toDyn, fromDyn) = Dyn.new {eq = Arg.eq self, hash = Arg.hash self}
+ val (toDyn, fromDyn) =
+ Dyn.new {eq = Arg.eq self, hash = Word32.toWord o Arg.hash self}
open I
in
P {rd = rd size >>= (fn key => Map.get >>= (fn arr =>
@@ -330,7 +331,8 @@
end
fun share aT (P {rd = aR, wr = aW, ...}) = let
- val (toDyn, fromDyn) = Dyn.new {eq = Arg.eq aT, hash = Arg.hash aT}
+ val (toDyn, fromDyn) =
+ Dyn.new {eq = Arg.eq aT, hash = Word32.toWord o Arg.hash aT}
open I
in
P {rd = rd size >>= (fn key => Map.get >>= (fn arr =>
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pretty.sml 2008-10-13 21:13:47 UTC (rev 6926)
@@ -138,7 +138,7 @@
val ctorRef = Generics.C "ref"
fun cyclic aT aP =
- case HashUniv.new {eq = op =, hash = Arg.hash aT}
+ case HashUniv.new {eq = op =, hash = Word32.toWord o Arg.hash aT}
of (to, _) =>
fn (e as E ({map, cnt, ...}, _), v) =>
case to v
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2008-10-13 21:13:47 UTC (rev 6926)
@@ -29,7 +29,7 @@
end)
fun cyclic aT (IN aE) = let
- val (to, _) = HashUniv.new {eq = op =, hash = Arg.hash aT}
+ val (to, _) = HashUniv.new {eq = op =, hash = Word32.toWord o Arg.hash aT}
in
IN (fn (e, (l, r)) => let
val lD = to l
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2008-10-13 21:13:47 UTC (rev 6926)
@@ -30,7 +30,7 @@
foldl (fn (x, s) => s + f (e, x)) (2 * wordSize) a)
fun cyclic xT xS = let
- val (to, _) = HashUniv.new {eq = op =, hash = Arg.hash xT}
+ val (to, _) = HashUniv.new {eq = op =, hash = Word32.toWord o Arg.hash xT}
in
DYNAMIC (fn (e, x) => let
val d = to x
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/transform.sml 2008-10-13 21:13:47 UTC (rev 6926)
@@ -28,7 +28,7 @@
of c => if ID = c then default else IN (c, fs2f (aT, bT))
fun cyclic aT aF =
- case HashUniv.new {eq = op =, hash = Arg.hash aT}
+ case HashUniv.new {eq = op =, hash = Word32.toWord o Arg.hash aT}
of (to, _) => fn (x, e) => case to x of xD =>
if isSome (HashMap.find e xD) then x
else (HashMap.insert e (xD, ()) ; aF (x, e))
@@ -84,7 +84,8 @@
fun list aT = un (fn xF => fn (l, e) => map (xF /> e) l) (getT aT)
- fun vector aT = un (fn xF => fn (v, e) => Vector.map (xF /> e) v) (getT aT)
+ fun vector aT =
+ un (fn xF => fn (v, e) => Vector.map (xF /> e) v) (getT aT)
fun array aT =
un (fn xF => cyclic (Arg.Open.array ignore aT)
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/uniplate.sml 2008-10-13 21:13:47 UTC (rev 6926)
@@ -28,7 +28,7 @@
val none = IN (dummy, fn (_, c, _) => c, fn (_, c, x) => (x, c))
fun cyclic aT (IN (_, aKi, aKo)) = let
- val (to, _) = HashUniv.new {eq = op =, hash = Arg.hash aT}
+ val (to, _) = HashUniv.new {eq = op =, hash = Word32.toWord o Arg.hash aT}
in
IN (dummy,
fn args as ((_, e), c, x) => let
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/hash.sig 2008-10-13 21:13:47 UTC (rev 6926)
@@ -33,7 +33,7 @@
val hashParam : ('a, 'x) HashRep.t
-> {totWidth : Int.t,
maxDepth : Int.t}
- -> 'a -> Word.t
+ -> 'a -> Word32.t
(**
* Returns a hash function. The {totWidth} and {maxDepth} parameters
* give some control over hashing. The {totWidth} parameter controls
@@ -42,7 +42,7 @@
* function descends into a (possibly recursive) datatype.
*)
- val hash : ('a, 'x) HashRep.t -> 'a -> Word.t
+ val hash : ('a, 'x) HashRep.t -> 'a -> Word32.t
(** Returns the default hash function. *)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/test/read.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/test/read.sml 2008-10-13 21:06:17 UTC (rev 6925)
+++ mltonlib/trunk/com/ssh/generic/unstable/test/read.sml 2008-10-13 21:13:47 UTC (rev 6926)
@@ -41,7 +41,7 @@
mapPrinter
(fn p => fn x =>
p x >>= (fn (a, d) =>
- return (if Word.isOdd (hash t x)
+ return (if Word32.isOdd (hash t x)
then (a, d)
else (Fixity.ATOMIC,
txt " (* (*:-)*) *) ( (* :-( *) " <^> d <^>
More information about the MLton-commit
mailing list