[MLton-commit] r5820
Vesa Karvonen
vesak at mlton.org
Sun Aug 5 02:25:08 PDT 2007
Split TypeInfo into TypeInfo and DataRecInfo. This allows one to avoid
the more costly datatype recursion analysis when it isn't needed.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm
A mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.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/data-rec-info.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.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-08-05 09:21:33 UTC (rev 5819)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ml/smlnj/unsealed.cm 2007-08-05 09:25:07 UTC (rev 5820)
@@ -22,6 +22,7 @@
../../../public/open-generic-rep.sig
../../../public/open-generic.sig
../../../public/value/arbitrary.sig
+ ../../../public/value/data-rec-info.sig
../../../public/value/dynamic.sig
../../../public/value/eq.sig
../../../public/value/hash.sig
@@ -38,6 +39,7 @@
../../root-generic.sml
../../sml-syntax.sml
../../value/arbitrary.sml
+ ../../value/data-rec-info.sml
../../value/dynamic.sml
../../value/eq.sml
../../value/hash.sml
Copied: mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml (from rev 5784, mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-07-20 21:36:00 UTC (rev 5784)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/data-rec-info.sml 2007-08-05 09:25:07 UTC (rev 5820)
@@ -0,0 +1,116 @@
+(* 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 WithDataRecInfo (Arg : OPEN_GENERIC) : DATA_REC_INFO_GENERIC = struct
+ (* <-- SML/NJ workaround *)
+ open TopLevel
+ infix 2 andAlso
+ infix 1 orElse
+ (* SML/NJ workaround --> *)
+
+ type recs = Unit.t Ref.t List.t
+
+ fun rem x : recs UnOp.t =
+ fn [] => []
+ | [y] => if x = y then [] else [y]
+ | ys => List.filter (notEq x) ys
+
+ val merge : recs BinOp.t =
+ fn ([], ys) => ys
+ | (xs, []) => xs
+ | ([x], [y]) => if x = y then [x] else [x, y]
+ | (xs, ys) =>
+ foldl (fn (x, ys) => if List.exists (eq x) ys then ys else x::ys) ys xs
+
+ datatype t = INT of {exn : Bool.t, recs : recs, pure : Bool.t}
+ datatype s = INS of {exn : Bool.t, recs : recs}
+ datatype p = INP of {exn : Bool.t, recs : recs}
+
+ val base = INT {exn = false, pure = true, recs = []}
+ fun pure (INT {exn, recs, ...}) = INT {exn = exn, pure = true, recs = recs}
+ fun mutable (INT {exn, recs, ...}) =
+ INT {exn = exn, pure = false, recs = recs}
+
+ structure DataRecInfo =
+ LayerGenericRep
+ (structure Outer = Arg.Rep
+ structure Closed = struct
+ type 'a t = t
+ type 'a s = s
+ type ('a, 'k) p = p
+ end)
+
+ open DataRecInfo.This
+
+ fun outT (INT r) = r
+
+ fun mayContainExn ? = (#exn o outT o getT) ?
+ fun mayBeRecData ? = (not o null o #recs o outT o getT) ?
+ fun isMutableType ? = (not o #pure o outT o getT) ?
+ fun mayBeCyclic ? =
+ (isMutableType andAlso (mayContainExn orElse mayBeRecData)) ?
+
+ structure Layered = LayerGeneric
+ (structure Outer=Arg and Result=DataRecInfo and Rep=DataRecInfo.Closed
+
+ val iso = const
+ val isoProduct = const
+ val isoSum = const
+
+ fun op *` (INP l, INP r) =
+ INP {exn = #exn l orelse #exn r, recs = merge (#recs l, #recs r)}
+ fun T (INT {exn, recs, ...}) = INP {exn = exn, recs = recs}
+ fun R _ = T
+ fun tuple (INP {exn, recs, ...}) =
+ INT {exn = exn, pure = true, recs = recs}
+ val record = tuple
+
+ fun op +` (INS l, INS r) =
+ INS {exn = #exn l orelse #exn r, recs = merge (#recs l, #recs r)}
+ val unit = base
+ fun C0 _ = INS {exn = false, recs = []}
+ fun C1 _ (INT {exn, recs, ...}) = INS {exn = exn, recs = recs}
+ fun data (INS {exn, recs, ...}) =
+ INT {exn = exn, pure = true, recs = recs}
+
+ fun Y ? =
+ Tie.pure
+ (fn () => let
+ val me = ref ()
+ in
+ (INT {exn = false, pure = true, recs = [me]},
+ fn INT {exn, pure, recs} =>
+ INT {exn = exn, pure = pure, recs = rem me recs})
+ end) ?
+
+ fun op --> _ = base
+
+ val exn = INT {exn = true, pure = true, recs = []}
+ fun regExn _ _ = ()
+
+ val array = mutable
+ val refc = mutable
+
+ val vector = pure
+ val list = pure
+
+ val largeInt = base
+ val largeReal = base
+ val largeWord = base
+
+ val bool = base
+ val char = base
+ val int = base
+ val real = base
+ val string = base
+ val word = base
+
+ val word8 = base
+ val word32 = base
+ val word64 = base)
+
+ open Layered
+end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-08-05 09:21:33 UTC (rev 5819)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml 2007-08-05 09:25:07 UTC (rev 5820)
@@ -7,28 +7,15 @@
functor WithTypeInfo (Arg : OPEN_GENERIC) : TYPE_INFO_GENERIC = struct
(* <-- SML/NJ workaround *)
open TopLevel
- infix 2 andAlso
- infix 1 orElse
(* SML/NJ workaround --> *)
- type recs = Unit.t Ref.t List.t
+ datatype t = INT of {base : Bool.t}
+ datatype s = INS of {base : Bool.t, alts : Int.t}
+ datatype p = INP of {base : Bool.t, elems : Int.t}
- fun rem x : recs UnOp.t =
- fn [] => []
- | [y] => if x = y then [] else [y]
- | ys => List.filter (notEq x) ys
+ val base = INT {base = true}
+ fun pure (INT {...}) = INT {base = true}
- val merge : recs BinOp.t =
- fn ([], ys) => ys
- | (xs, []) => xs
- | ([x], [y]) => if x = y then [x] else [x, y]
- | (xs, ys) =>
- foldl (fn (x, ys) => if List.exists (eq x) ys then ys else x::ys) ys xs
-
- datatype t = INT of {base : Bool.t, exn : Bool.t, recs : recs, pure : Bool.t}
- datatype s = INS of {base : Bool.t, exn : Bool.t, recs : recs, alts : Int.t}
- datatype p = INP of {base : Bool.t, exn : Bool.t, recs : recs, elems : Int.t}
-
structure TypeInfo =
LayerGenericRep
(structure Outer = Arg.Rep
@@ -40,15 +27,9 @@
open TypeInfo.This
- fun outT (INT r) = r
fun outS (INS r) = r
fun outP (INP r) = r
- fun hasExn ? = (#exn o outT o getT) ?
- fun hasRecData ? = (not o null o #recs o outT o getT) ?
- fun isRefOrArray ? = (not o #pure o outT o getT) ?
- fun canBeCyclic ? = (isRefOrArray andAlso (hasExn orElse hasRecData)) ?
-
fun hasBaseCase ? = (#base o outS o getS) ?
fun numAlts ? = (#alts o outS o getS) ?
@@ -57,57 +38,33 @@
structure Layered = LayerGeneric
(structure Outer = Arg and Result = TypeInfo and Rep = TypeInfo.Closed
- val base = INT {base = true, exn = false, pure = true, recs = []}
- fun pure (INT {exn, recs, ...}) =
- INT {base = true, exn = exn, pure = true, recs = recs}
-
val iso = const
val isoProduct = const
val isoSum = const
fun op *` (INP l, INP r) =
- INP {base = #base l andalso #base r,
- elems = #elems l + #elems r,
- exn = #exn l orelse #exn r,
- recs = merge (#recs l, #recs r)}
- fun T (INT {base, exn, recs, ...}) =
- INP {base = base, elems = 1, exn = exn, recs = recs}
+ INP {base = #base l andalso #base r, elems = #elems l + #elems r}
+ fun T (INT {base, ...}) = INP {base = base, elems = 1}
fun R _ = T
- fun tuple (INP {base, exn, recs, ...}) =
- INT {base = base, exn = exn, pure = true, recs = recs}
+ fun tuple (INP {base, ...}) = INT {base = base}
val record = tuple
fun op +` (INS l, INS r) =
- INS {alts = #alts l + #alts r,
- base = #base l orelse #base r,
- exn = #exn l orelse #exn r,
- recs = merge (#recs l, #recs r)}
+ INS {alts = #alts l + #alts r, base = #base l orelse #base r}
val unit = base
- fun C0 _ = INS {alts = 1, base = true, exn = false, recs = []}
- fun C1 _ (INT {base, exn, recs, ...}) =
- INS {alts = 1, base = base, exn = exn, recs = recs}
- fun data (INS {base, exn, recs, ...}) =
- INT {base = base, exn = exn, pure = true, recs = recs}
+ fun C0 _ = INS {alts = 1, base = true}
+ fun C1 _ (INT {base, ...}) = INS {alts = 1, base = base}
+ fun data (INS {base, ...}) = INT {base = base}
- fun Y ? =
- Tie.pure
- (fn () => let
- val me = ref ()
- in
- (INT {base=false, exn=false, pure=true, recs=[me]},
- fn INT {base, exn, pure, recs} =>
- INT {base=base, exn=exn, pure=pure, recs=rem me recs})
- end) ?
+ fun Y ? = Tie.pure (fn () => (INT {base = false}, id)) ?
fun op --> _ = base
- val exn = INT {base = true, exn = true, pure = true, recs = []}
+ val exn = INT {base = true}
fun regExn _ _ = ()
- fun array (INT {exn, recs, ...}) =
- INT {base = true, exn = exn, pure = false, recs = recs}
- fun refc (INT {base, exn, recs, ...}) =
- INT {base = base, exn = exn, pure = false, recs = recs}
+ fun array (INT {...}) = INT {base = true}
+ fun refc (INT {base, ...}) = INT {base = base}
val vector = pure
val list = pure
Modified: mltonlib/trunk/com/ssh/generic/unstable/lib.mlb
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-05 09:21:33 UTC (rev 5819)
+++ mltonlib/trunk/com/ssh/generic/unstable/lib.mlb 2007-08-05 09:25:07 UTC (rev 5820)
@@ -65,6 +65,9 @@
public/value/type-info.sig
detail/value/type-info.sml
+ public/value/data-rec-info.sig
+ detail/value/data-rec-info.sml
+
public/value/some.sig
detail/value/some.sml
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/export.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-05 09:21:33 UTC (rev 5819)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/export.sml 2007-08-05 09:25:07 UTC (rev 5820)
@@ -26,6 +26,9 @@
signature ARBITRARY = ARBITRARY
signature ARBITRARY_GENERIC = ARBITRARY_GENERIC
+signature DATA_REC_INFO = DATA_REC_INFO
+signature DATA_REC_INFO_GENERIC = DATA_REC_INFO_GENERIC
+
signature DYNAMIC = DYNAMIC
signature DYNAMIC_GENERIC = DYNAMIC_GENERIC
@@ -137,6 +140,9 @@
functor WithArbitrary (Arg : WITH_ARBITRARY_DOM) : ARBITRARY_GENERIC =
WithArbitrary (Arg)
+functor WithDataRecInfo (Arg : OPEN_GENERIC) : DATA_REC_INFO_GENERIC =
+ WithDataRecInfo (Arg)
+
functor WithDynamic (Arg : OPEN_GENERIC) : DYNAMIC_GENERIC = WithDynamic (Arg)
functor WithEq (Arg : OPEN_GENERIC) : EQ_GENERIC = WithEq (Arg)
Copied: mltonlib/trunk/com/ssh/generic/unstable/public/value/data-rec-info.sig (from rev 5753, mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig)
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2007-07-10 07:39:05 UTC (rev 5753)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/data-rec-info.sig 2007-08-05 09:25:07 UTC (rev 5820)
@@ -0,0 +1,61 @@
+(* 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.
+ *)
+
+(**
+ * Signature for a generic datatype recursion analysis.
+ *
+ * In Standard ML, cyclic data structures, ignoring closures, can only be
+ * implemented through mutable types, references and arrays. Furthermore,
+ * a mutable type can only be used to form cycles if it is a part of a
+ * strongly connected component containing a recursive datatype or
+ * contains an exception. This makes it possible to compute a simple
+ * conservative approximation as to whether a given mutable type can be
+ * part of cycle.
+ *
+ * These type properties can be useful for both optimizations and for
+ * ensuring correctness. As an optimization one could, for example,
+ * determine whether one needs to handle cyclic values (which can be
+ * costly) or not.
+ *
+ * This generic value is unlikely to be directly useful in application
+ * programs and is more likely to be used internally in the implementation
+ * of some other generics (e.g. pickling).
+ *)
+signature DATA_REC_INFO = sig
+ structure DataRecInfo : OPEN_GENERIC_REP
+
+ val mayBeCyclic : ('a, 'x) DataRecInfo.t UnPr.t
+ (**
+ * Returns true if {'a} is a mutable type and may be part of a
+ * recursive datatype or contain exceptions. This means that values of
+ * the type can form cycles.
+ *)
+
+ val mayContainExn : ('a, 'x) DataRecInfo.t UnPr.t
+ (**
+ * Returns true if a value of the type {'a} may contain exception
+ * values. Arrow types are not considered to contain exception values.
+ *)
+
+ val mayBeRecData : ('a, 'x) DataRecInfo.t UnPr.t
+ (**
+ * Returns true if a value of type {'a} may be part of a recursive
+ * datatype. Exceptions are not considered to be a recursive datatype
+ * and arrow types are not considered to be part of recursive
+ * datatypes.
+ *)
+
+ val isMutableType : ('a, 'x) DataRecInfo.t UnPr.t
+ (**
+ * Returns true iff the type {'a} is of the form {'b Array.t} or of the
+ * form {'b Ref.t}.
+ *)
+end
+
+signature DATA_REC_INFO_GENERIC = sig
+ include OPEN_GENERIC DATA_REC_INFO
+ sharing Rep = DataRecInfo
+end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2007-08-05 09:21:33 UTC (rev 5819)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-info.sig 2007-08-05 09:25:07 UTC (rev 5820)
@@ -8,44 +8,18 @@
* Signature for generic type properties.
*
* These type properties can be useful for both optimizations and for
- * ensuring correctness. As an optimization one could, for example,
- * determine whether one needs to handle cyclic values (which can be
- * costly) or not. As a correctness issue, one can avoid generating
- * infinite data structures or avoid performing non-terminating operations
- * on infinite data structures.
+ * ensuring correctness. Using {numAlts} and {numElems} one can balance
+ * resources across sums and products. Using {hasBaseCase}, one can avoid
+ * generating infinite data structures or avoid performing non-terminating
+ * operations on infinite data structures.
*
* This generic value is unlikely to be directly useful in application
* programs and is more likely to be used internally in the implementation
- * of some other generics (e.g. pickling).
+ * of some other generics (e.g. hashing).
*)
signature TYPE_INFO = sig
structure TypeInfo : OPEN_GENERIC_REP
- (** == Types == *)
-
- val canBeCyclic : ('a, 'x) TypeInfo.t UnPr.t
- (**
- * Returns true iff {'a} is of the form {'b ref} or {'b array} and
- * it can not be ruled out that values of the type can form cycles.
- *
- * Note: Functions are not considered to form cycles.
- *)
-
- val hasExn : ('a, 'x) TypeInfo.t UnPr.t
- (** Returns true iff the type {'a} contains the type {exn}. *)
-
- val hasRecData : ('a, 'x) TypeInfo.t UnPr.t
- (**
- * Returns true iff the type {'a} contains recursive references to
- * datatypes.
- *)
-
- val isRefOrArray : ('a, 'x) TypeInfo.t UnPr.t
- (**
- * Returns true iff the type {'a} is of the form {'b array} or of
- * the form {'b ref}.
- *)
-
(** == Sums == *)
val hasBaseCase : ('a, 'x) TypeInfo.s UnPr.t
More information about the MLton-commit
mailing list