[MLton-commit] r5872

[Vesa Karvonen]

Delay HashMap update after rd/wr when dealing with acyclic references.

As noted by Elsman [http://mlton.org/References#Elsman04], Standard ML
does not provide a means of extracting a hashable identity from a mutable
object.  Regardless of identity, structurally equivalent mutable objects
hash to the same value.  This increases the asymptotic complexity of
algorithms, including pickling, that need to distinguish mutable objects
by identity.  Elsman then described two optimized combinators for pickling
references whose use presents additional proof obligations to programmers.
One of the optimized combinators, ref0, simply assumes that no cycles
appear through references pickled with it.  Perhaps surprisingly, it is
possible to perform a similar optimization automatically.  Specifically,
during type representation construction, it is possible to compute a
conservative approximation as to whether values of a mutable type may be a
part of a cycle or not.  An algorithm for this boils down to tracking down
whether a value of the given mutable type may contain values of
(exceptions or) recursive datatypes that may contain a value of the
mutable type.  Our library includes the DataRecInfo generic, which
implements such an algorithm.

----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml	2007-08-14 08:18:30 UTC (rev 5871)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml	2007-08-14 11:47:16 UTC (rev 5872)
@@ -212,16 +212,21 @@
 
    val int as INT {rd=rdInt, wr=wrInt} = bits Word.ops (swap Word.isoIntX)
 
-   fun mutable {readProxy, readBody, writeWhole, hash} = let
+   fun mutable {readProxy, readBody, writeWhole, self} = let
+      val cyclic = Arg.mayBeCyclic self
       val tagD = #"\000" and tagR = #"\001"
-      val (toDyn, fromDyn) = Dyn.new {eq = op =, hash = hash}
+      val (toDyn, fromDyn) = Dyn.new {eq = op =, hash = Arg.hash self}
       open I
       val rd =
           read >>& getState >>= (fn tag & mp =>
           if tag = tagD then
              readProxy >>= (fn proxy =>
-             (HashMap.insert mp (HashMap.numItems mp, toDyn proxy)
-            ; readBody proxy >> return proxy))
+             if cyclic
+             then (HashMap.insert mp (HashMap.numItems mp, toDyn proxy)
+                 ; readBody proxy >> return proxy)
+             else (readBody proxy >>= (fn () =>
+                   (HashMap.insert mp (HashMap.numItems mp, toDyn proxy)
+                  ; return proxy))))
           else if tag = tagR then
              rdInt >>= (fn i =>
              case HashMap.find mp i
@@ -235,12 +240,13 @@
          getState >>= (fn mp =>
          case HashMap.find mp d
           of SOME i => write tagR >> wrInt i
-           | NONE   => let
-                val i = HashMap.numItems mp
-             in
-                HashMap.insert mp (d, i)
-              ; write tagD >> writeWhole v
-             end)
+           | NONE   => 
+                if cyclic
+                then (HashMap.insert mp (d, HashMap.numItems mp)
+                    ; write tagD >> writeWhole v)
+                else write tagD >> writeWhole v >>= (fn () =>
+                     (HashMap.insert mp (d, HashMap.numItems mp)
+                    ; return ())))
       end
    in
       INT {rd = rd, wr = wr}
@@ -345,7 +351,7 @@
           mutable {readProxy = I.thunk (ref o const (Arg.some t)),
                    readBody = fn proxy => I.map (fn v => proxy := v) rd,
                    writeWhole = wr o !,
-                   hash = Arg.hash (Arg.refc ignore t)}
+                   self = Arg.refc ignore t}
       end
 
       fun array t = let
@@ -370,7 +376,7 @@
           mutable {readProxy = I.map (Array.array /> Arg.some t) rdInt,
                    readBody = readBody,
                    writeWhole = writeWhole,
-                   hash = Arg.hash (Arg.array ignore t)}
+                   self = Arg.array ignore t}
       end
 
       fun list t = seq {length = List.length, toSlice = id,
@@ -418,7 +424,7 @@
          end
          fun from s = let
             val buffer = Buffer.new ()
-            fun intToHex i = chr (if i < 10 then i + ord #"0" else i - 10 + ord #"A")
+            fun intToHex i = chr (i + (if i<10 then ord #"0" else ord #"A"-10))
             fun lp s =
                 case Substring.getc s
                  of NONE        => ()