[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