[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