[MLton-commit] r6044
Vesa Karvonen
vesak at mlton.org
Thu Sep 20 07:16:05 PDT 2007
A generic size function. The idea is to use this in the unit testing
library while searching for smaller counterexamples.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
U mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
U mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
A mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-20 14:08:06 UTC (rev 6043)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-09-20 14:16:04 UTC (rev 6044)
@@ -31,6 +31,7 @@
../../../public/value/pretty.sig
../../../public/value/reduce.sig
../../../public/value/seq.sig
+ ../../../public/value/size.sig
../../../public/value/some.sig
../../../public/value/transform.sig
../../../public/value/type-exp.sig
@@ -59,6 +60,7 @@
../../value/pretty.sml
../../value/reduce.sml
../../value/seq.sml
+ ../../value/size.sml
../../value/some.sml
../../value/transform.sml
../../value/type-exp.sml
Added: mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2007-09-20 14:08:06 UTC (rev 6043)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml 2007-09-20 14:16:04 UTC (rev 6044)
@@ -0,0 +1,169 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+functor WithSize (Arg : WITH_SIZE_DOM) : SIZE_CASES = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 0 &
+ (* SML/NJ workaround --> *)
+
+ type e = (HashUniv.t, Unit.t) HashMap.t
+
+ datatype 'a t =
+ STATIC of Int.t
+ | DYNAMIC of e * 'a -> Int.t
+
+ val sz =
+ fn STATIC s => const s
+ | DYNAMIC f => f
+
+ fun bytes i = Word.toInt (Word.>> (Word.fromInt i + 0w7, 0w3))
+
+ val wordSize = bytes Word.wordSize
+
+ fun sequ length foldl =
+ fn STATIC s => (fn (_, a) => (s * length a + 2 * wordSize))
+ | DYNAMIC f => (fn (e, a) =>
+ 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}
+ in
+ DYNAMIC (fn (e, x) => let
+ val d = to x
+ in
+ case HashMap.find e d
+ of SOME () => wordSize
+ | NONE => (HashMap.insert e (d, ()) ; xS (e, x))
+ end)
+ end
+
+ fun intSize toLarge i =
+ bytes (IntInf.log2 (abs (toLarge i) + 1))
+
+ fun mkInt toLarge =
+ fn SOME prec => STATIC (bytes prec)
+ | NONE => DYNAMIC (intSize toLarge o #2)
+
+ fun mkWord wordSize = STATIC (bytes wordSize)
+
+ val iso' =
+ fn STATIC s => const (STATIC s)
+ | DYNAMIC bS => fn (a2b, _) => DYNAMIC (bS o Pair.map (id, a2b))
+
+ structure SizeRep = LayerRep
+ (structure Outer = Arg.Rep
+ structure Closed = MkClosedRep (type 'a t = 'a t))
+
+ open SizeRep.This
+
+ fun staticSizeOf t =
+ case getT t
+ of STATIC s => SOME s
+ | _ => NONE
+
+ fun sizeOf t =
+ case getT t
+ of STATIC s => const s
+ | DYNAMIC f => fn x =>
+ f (HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash} , x)
+
+ structure Layered = LayerDepCases
+ (structure Outer = Arg and Result = SizeRep
+
+ fun iso bT = iso' (getT bT)
+ fun isoProduct bP = iso' (getP bP)
+ fun isoSum bS = iso' (getS bS)
+
+ fun op *` (xP, yP) = let
+ val xS = getP xP
+ val yS = getP yP
+ in
+ case xS & yS
+ of STATIC x & STATIC y => STATIC (x + y)
+ | _ =>
+ DYNAMIC (fn (e, x & y) => sz xS (e, x) + sz yS (e, y))
+ end
+ val T = getT
+ fun R _ = getT
+ val tuple = getP
+ val record = getP
+
+ fun op +` (xS, yS) = let
+ val xS = getS xS
+ val yS = getS yS
+ val dyn =
+ DYNAMIC (fn (e, INL x) => sz xS (e, x)
+ | (e, INR y) => sz yS (e, y))
+ in
+ case xS & yS
+ of STATIC x & STATIC y => if x = y then STATIC x else dyn
+ | _ => dyn
+ end
+
+ val unit = STATIC 0
+ fun C0 _ = unit
+ fun C1 _ = getT
+ fun data xS = let
+ val tagS = intSize Int.toLarge (Arg.numAlts xS)
+ in
+ case getS xS
+ of STATIC s => STATIC (tagS + s)
+ | DYNAMIC f => DYNAMIC (fn ex => tagS + f ex)
+ end
+
+ fun Y ? = Tie.pure (fn () => let
+ val r = ref (raising Fix.Fix)
+ val f = DYNAMIC (fn ? => !r ?)
+ in
+ (f,
+ fn DYNAMIC f' => (r := f' ; f)
+ | STATIC s => (r := const s ; STATIC s))
+ end) ?
+
+ fun op --> _ = DYNAMIC (failing "Size.--> unsupported")
+
+ val exn : Exn.t t = DYNAMIC (failing "Size.exn not yet implemented")
+ fun regExn0 _ _ = ()
+ fun regExn1 _ _ _ = ()
+
+ fun list xT =
+ case getT xT
+ of STATIC c => DYNAMIC (fn (_, xs) => (c + wordSize) * length xs)
+ | DYNAMIC f =>
+ DYNAMIC (fn (e, xs) => foldl (fn (x, s) => s + f (e, x)) 0 xs)
+
+ fun vector xT = DYNAMIC (sequ Vector.length Vector.foldl (getT xT))
+
+ fun array xT =
+ cyclic (Arg.array ignore xT)
+ (sequ Array.length Array.foldl (getT xT))
+
+ fun refc xT =
+ cyclic (Arg.refc ignore xT)
+ (case getT xT
+ of STATIC s => const (s + wordSize)
+ | DYNAMIC f => fn (e, x) => wordSize + f (e, !x))
+
+ val fixedInt = mkInt FixedInt.toLarge FixedInt.precision
+ val largeInt = mkInt LargeInt.toLarge LargeInt.precision
+
+ val largeReal = mkWord CastLargeReal.Bits.wordSize : LargeReal.t t
+ val largeWord = mkWord LargeWord.wordSize : LargeWord.t t
+
+ val bool = STATIC 1
+ val char = STATIC 1
+ val int = mkInt Int.toLarge Int.precision
+ val real = mkWord CastReal.Bits.wordSize : Real.t t
+ val string = DYNAMIC (fn (_, s) => size s + 2 * wordSize)
+ val word = mkWord Word.wordSize : Word.t t
+
+ val word8 = mkWord Word8.wordSize : Word8.t t
+ val word32 = mkWord Word32.wordSize : Word32.t t
+ val word64 = mkWord Word64.wordSize : Word64.t t)
+
+ open Layered
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/detail/value/size.sml
___________________________________________________________________
Name: svn:eol-style
+ native
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-20 14:08:06 UTC (rev 6043)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-09-20 14:16:04 UTC (rev 6044)
@@ -121,6 +121,9 @@
public/value/seq.sig
detail/value/seq.sml
+ public/value/size.sig
+ detail/value/size.sml
+
public/value/transform.sig
detail/value/transform.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-20 14:08:06 UTC (rev 6043)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-09-20 14:16:04 UTC (rev 6044)
@@ -150,6 +150,10 @@
signature SEQ = SEQ and SEQ_CASES = SEQ_CASES and WITH_SEQ_DOM = WITH_SEQ_DOM
functor WithSeq (Arg : WITH_SEQ_DOM) : SEQ_CASES = WithSeq (Arg)
+signature SIZE = SIZE and SIZE_CASES = SIZE_CASES
+ and WITH_SIZE_DOM = WITH_SIZE_DOM
+functor WithSize (Arg : WITH_SIZE_DOM) : SIZE_CASES = WithSize (Arg)
+
signature SOME = SOME and SOME_CASES = SOME_CASES
and WITH_SOME_DOM = WITH_SOME_DOM
functor WithSome (Arg : WITH_SOME_DOM) : SOME_CASES = WithSome (Arg)
Added: mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig 2007-09-20 14:08:06 UTC (rev 6043)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig 2007-09-20 14:16:04 UTC (rev 6044)
@@ -0,0 +1,40 @@
+(* Copyright (C) 2007 SSH Communications Security, Helsinki, Finland
+ *
+ * This code is released under the MLton license, a BSD-style license.
+ * See the LICENSE file or http://mlton.org/License for details.
+ *)
+
+(**
+ * A signature for a generic size function.
+ *)
+signature SIZE = sig
+ structure SizeRep : OPEN_REP
+
+ val staticSizeOf : ('a, 'x) SizeRep.t -> Int.t Option.t
+ (**
+ * Returns an abstract, statically estimated, size of values of the
+ * type {'a} in bytes.
+ *
+ * The sizes of functions (closures), sequences, arbitrary precision
+ * integers, non-trivial sums, exceptions, and recursive datatypes
+ * cannot be estimated statically.
+ *)
+
+ val sizeOf : ('a, 'x) SizeRep.t -> 'a -> Int.t
+ (**
+ * Returns an abstractly computed size of the given value in bytes.
+ *
+ * The size of a function (closure) cannot be computed in Standard ML.
+ * An attempt to compute the size of a function will fail at run-time.
+ *)
+end
+
+signature SIZE_CASES = sig
+ include OPEN_CASES SIZE
+ sharing Rep = SizeRep
+end
+
+signature WITH_SIZE_DOM = sig
+ include OPEN_CASES HASH TYPE_INFO
+ sharing Rep = HashRep = TypeInfoRep
+end
Property changes on: mltonlib/trunk/com/ssh/generic/unstable/public/value/size.sig
___________________________________________________________________
Name: svn:eol-style
+ native
More information about the MLton-commit
mailing list