[MLton-commit] r5881
Vesa Karvonen
vesak at mlton.org
Wed Aug 15 06:09:31 PDT 2007
Track estimate of pickled size and share only if the size estimate is
larger than the size estimate of a sharing reference. This improves
performance, because the number of elements stored in a HashMap for
sharing is reduced, and usually also reduces the size of pickles. For
example, this means that simple enumerations like the standard Order.t
will be represented (relatively) compactly using just a single byte.
----------------------------------------------------------------------
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-15 11:28:07 UTC (rev 5880)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/pickle.sml 2007-08-15 13:09:31 UTC (rev 5881)
@@ -161,11 +161,24 @@
structure I = MkIstream (type t = (Int.t, Dyn.t) HashMap.t)
structure O = MkOstream (type t = (Dyn.t, Int.t) HashMap.t)
- type 'a t = {rd : 'a I.t, wr : 'a -> Unit.t O.t}
+ structure OptInt = struct
+ type t = Int.t Option.t
+ local
+ fun mk bop =
+ fn (SOME l, SOME r) => SOME (bop (l, r))
+ | _ => NONE
+ in
+ val op + = mk op +
+ val op div = mk op div
+ end
+ end
+
+ type 'a t = {rd : 'a I.t, wr : 'a -> Unit.t O.t, sz : OptInt.t}
type 'a s = Int.t -> {rd : Int.t -> 'a I.t,
- wr : (Int.t -> Unit.t O.t) -> 'a -> Unit.t O.t}
+ wr : (Int.t -> Unit.t O.t) -> 'a -> Unit.t O.t,
+ sz : OptInt.t}
- fun fake msg = {rd = I.thunk (failing msg), wr = failing msg}
+ fun fake msg = {rd = I.thunk (failing msg), wr = failing msg, sz = NONE}
val op <--> = Iso.<-->
val swap = Iso.swap
@@ -191,16 +204,17 @@
val bits = toBits v
in
alts (fn n => O.write (toChar (bits >> Word.fromInt n))) O.>>
- end}
+ end,
+ sz = SOME ((n + 7) div 8)}
end
fun iso' get bT (a2b, b2a) = let
- val {rd, wr} = get bT
+ val {rd, wr, sz} = get bT
in
- {rd = I.map b2a rd, wr = wr o a2b}
+ {rd = I.map b2a rd, wr = wr o a2b, sz = sz}
end
- val char = {rd = I.read, wr = O.write}
+ val char = {rd = I.read, wr = O.write, sz = SOME 1}
val int = bits Word.ops (swap Word.isoIntX)
val bool = iso' id char (swap Char.isoInt <--> Bool.isoInt)
@@ -226,10 +240,11 @@
of SOME i => #wr bool false >> #wr int i
| NONE => (HashMap.insert mp (d, HashMap.numItems mp)
; #wr bool true >> writeWhole v))
- end}
+ end,
+ sz = NONE}
end
- fun share t {rd=rdE, wr=wrE} = let
+ fun share t {rd = rdE, wr = wrE, sz = _} = let
val (toDyn, fromDyn) = Dyn.new {eq = Arg.eq t, hash = Arg.hash t}
open I
in
@@ -252,7 +267,8 @@
| NONE => #wr bool true >> wrE v >>= (fn () =>
(HashMap.insert mp (d, HashMap.numItems mp)
; return ())))
- end}
+ end,
+ sz = SOME 5}
end
fun mutable (methods as {readProxy, readBody, writeWhole, self}) =
@@ -260,9 +276,10 @@
then cyclic methods
else share self {rd = let open I in readProxy >>= (fn p =>
readBody p >> return p) end,
- wr = writeWhole}
+ wr = writeWhole,
+ sz = NONE}
- fun seq {length, toSlice, getItem, fromList} {rd = rdE, wr = wrE} =
+ fun seq {length, toSlice, getItem, fromList} {rd = rdE, wr = wrE, sz = _} =
{rd = let
open I
in
@@ -281,7 +298,8 @@
| SOME (e, sl) => wrE e >>= (fn () => lp sl)
in
fn seq => #wr int (length seq) >>= (fn () => lp (toSlice seq))
- end}
+ end,
+ sz = NONE : OptInt.t}
val string' = seq {length = String.length, toSlice = Substring.full,
getItem = Substring.getc, fromList = String.fromList}
@@ -303,22 +321,29 @@
structure Layered = LayerDepCases
(structure Outer = Arg and Result = Pickle
- fun iso b aIb = share (Arg.iso (fn _ => fn _ => ()) b aIb) (iso' getT b aIb)
+ fun iso b aIb = let
+ val a = iso' getT b aIb
+ in
+ if case #sz (getT b) of NONE => true | SOME n => 5 < n
+ then share (Arg.iso (fn _ => fn _ => ()) b aIb) a
+ else a
+ end
fun isoProduct ? = iso' getP ?
fun isoSum bS (a2b, b2a) i = let
- val {rd, wr} = getS bS i
+ val {rd, wr, sz} = getS bS i
in
- {rd = I.map b2a o rd, wr = fn wrTag => wr wrTag o a2b}
+ {rd = I.map b2a o rd, wr = fn wrTag => wr wrTag o a2b, sz = sz}
end
fun op *` (lT, rT) = let
- val {rd = rL, wr = wL} = getP lT
- val {rd = rR, wr = wR} = getP rT
+ val {rd = rL, wr = wL, sz = sL} = getP lT
+ val {rd = rR, wr = wR, sz = sR} = getP rT
in
{rd = let open I in rL >>& rR end,
- wr = let open O in fn l & r => wL l >> wR r end}
+ wr = let open O in fn l & r => wL l >> wR r end,
+ sz = OptInt.+ (sL, sR)}
end
val T = getT
@@ -333,45 +358,50 @@
in
fn i => let
val j = i+lN
- val {rd = rL, wr = wL} = lS i
- val {rd = rR, wr = wR} = rS j
+ val {rd = rL, wr = wL, sz = sL} = lS i
+ val {rd = rR, wr = wR, sz = sR} = rS j
in
{rd = fn i => if i < j
then I.map INL (rL i)
else I.map INR (rR i),
- wr = Sum.sum o Pair.map (wL, wR) o Sq.mk}
+ wr = Sum.sum o Pair.map (wL, wR) o Sq.mk,
+ sz = OptInt.+ (sL, sR)}
end
end
- val unit = {rd = I.return (), wr = fn () => O.return ()}
- fun C0 _ i = {rd = const (I.return ()), wr = fn wrTag => const (wrTag i)}
+ val unit = {rd = I.return (), wr = fn () => O.return (), sz = SOME 0}
+ fun C0 _ i = {rd = const (I.return ()),
+ wr = fn wrTag => const (wrTag i),
+ sz = SOME 0}
fun C1 _ t = let
- val {rd, wr} = getT t
+ val {rd, wr, sz} = getT t
in
- fn i => {rd = const rd, wr = fn wrTag => wrTag i <\ O.>> o wr}
+ fn i => {rd = const rd, wr = fn wrTag => wrTag i <\ O.>> o wr, sz = sz}
end
fun data s = let
val n = Arg.numAlts s
- val (rdTag, wrTag) =
+ val (rdTag, wrTag, szTag) =
if n <= Char.maxOrd + 1
- then (I.map ord I.read, O.write o chr)
- else (#rd int, #wr int)
- val {rd, wr} = getS s 0
+ then (I.map ord I.read, O.write o chr, SOME 1)
+ else (#rd int, #wr int, #sz int)
+ val {rd, wr, sz} = getS s 0
open I
in
{rd = rdTag >>= (fn i =>
if n <= i
then fail "Corrupted pickle"
else rd i),
- wr = wr wrTag}
+ wr = wr wrTag,
+ sz = let open OptInt in sz div SOME n + szTag end}
end
- fun Y ? = let open Tie in iso (I.Y *` function) end
- (fn {rd, wr} => rd & wr, fn rd & wr => {rd = rd, wr = wr}) ?
+ fun Y ? = let open Tie in iso (I.Y *` function *` id NONE) end
+ (fn {rd, wr, sz} => rd & wr & sz,
+ fn rd & wr & sz => {rd = rd, wr = wr, sz = sz}) ?
fun op --> _ = fake "Pickle.--> unsupported"
fun refc t = let
- val {rd, wr} = getT t
+ val {rd, wr, sz = _} = getT t
in
mutable {readProxy = I.thunk (ref o const (Arg.some t)),
readBody = fn proxy => I.map (fn v => proxy := v) rd,
@@ -380,7 +410,7 @@
end
fun array t = let
- val {rd, wr} = getT t
+ val {rd, wr, sz = _} = getT t
in
mutable {readProxy = I.map (Array.array /> Arg.some t) (#rd int),
readBody = fn a => let
More information about the MLton-commit
mailing list