[MLton-commit] r6020
Vesa Karvonen
vesak at mlton.org
Fri Sep 14 05:24:11 PDT 2007
DataRecInfo algorithms implemented against type representation
expressions.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/ty.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
U mltonlib/trunk/com/ssh/generic/unstable/public/ty.sig
U mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/ty.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/ty.sml 2007-09-13 13:04:55 UTC (rev 6019)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/ty.sml 2007-09-14 12:24:09 UTC (rev 6020)
@@ -6,23 +6,18 @@
structure Ty :> TY = struct
structure Product = struct
- datatype 'elem t = *` of 'elem t Sq.t
- | ELEM of 'elem
- | ISO of 'elem t
+ datatype 'elem t = TIMES of 'elem t Sq.t
+ | ELEM of 'elem
+ | ISO_PRODUCT of 'elem t
end
structure Sum = struct
- datatype 'ty t = +` of 'ty t Sq.t
- | C0 of Generics.Con.t
- | C1 of Generics.Con.t * 'ty
- | ISO of 'ty t
+ datatype 'ty t = PLUS of 'ty t Sq.t
+ | C0 of Generics.Con.t
+ | C1 of Generics.Con.t * 'ty
+ | ISO_SUM of 'ty t
end
- structure Var = struct
- type t = Unit.t Ref.t
- fun new () = ref ()
- end
-
structure Con0 = struct
datatype t = BOOL | CHAR | EXN | FIXED_INT | INT | LARGE_INT
| LARGE_REAL | LARGE_WORD | REAL | STRING | UNIT | WORD
@@ -37,14 +32,70 @@
datatype t = ARROW
end
- datatype 'var t =
- DATA of 'var t Sum.t
- | CON0 of Con0.t
- | CON1 of Con1.t * 'var t
- | CON2 of Con2.t * 'var t Sq.t
- | FIX of 'var * 'var t
- | ISO of 'var t
- | RECORD of (Generics.Label.t * 'var t) Product.t
- | TUPLE of 'var t Product.t
- | VAR of 'var
+ open Product Sum Con0 Con1 Con2
+
+ datatype 'var t = DATA of 'var t Sum.t
+ | CON0 of Con0.t
+ | CON1 of Con1.t * 'var t
+ | CON2 of Con2.t * 'var t Sq.t
+ | FIX of 'var * 'var t
+ | ISO of 'var t
+ | RECORD of (Generics.Label.t * 'var t) Product.t
+ | TUPLE of 'var t Product.t
+ | VAR of 'var
+
+ local
+ fun product el =
+ fn TIMES (l, r) => product el l orelse product el r
+ | ELEM t => el t
+ | ISO_PRODUCT p => product el p
+ fun sum ty =
+ fn PLUS (l, r) => sum ty l orelse sum ty r
+ | C0 _ => false
+ | C1 (_, t) => ty t
+ | ISO_SUM t => sum ty t
+ val rec ty =
+ fn DATA s => sum ty s
+ | CON0 c => c = EXN
+ | CON1 (_, t) => ty t
+ | CON2 (ARROW, _) => false
+ | FIX (_, t) => ty t
+ | ISO t => ty t
+ | RECORD r => product (ty o #2) r
+ | TUPLE t => product ty t
+ | VAR _ => false
+ in
+ val mayContainExn = ty
+ end
+
+ local
+ fun product el =
+ fn TIMES (l, r) => product el l @ product el r
+ | ELEM t => el t
+ | ISO_PRODUCT p => product el p
+ fun sum ty =
+ fn PLUS (l, r) => sum ty l @ sum ty r
+ | C0 _ => []
+ | C1 (_, t) => ty t
+ | ISO_SUM t => sum ty t
+ val rec ty =
+ fn DATA s => sum ty s
+ | CON0 _ => []
+ | CON1 (_, t) => ty t
+ | CON2 (ARROW, _) => []
+ | FIX (v, t) => List.filter (eq v) (ty t)
+ | ISO t => ty t
+ | RECORD r => product (ty o #2) r
+ | TUPLE t => product ty t
+ | VAR v => [v]
+ in
+ fun mayBeRecData t = not (null (ty t))
+ end
+
+ val isMutableType =
+ fn CON1 (c, _) => ARRAY = c orelse REF = c
+ | _ => false
+
+ fun mayBeCyclic t =
+ (isMutableType andAlso (mayContainExn orElse mayBeRecData)) t
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-09-13 13:04:55 UTC (rev 6019)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-exp.sml 2007-09-14 12:24:09 UTC (rev 6020)
@@ -9,19 +9,24 @@
open TopLevel
(* SML/NJ workaround --> *)
- open Ty Ty.Con0 Ty.Con1 Ty.Con2
+ open Generics Ty open Product Sum Con0 Con1 Con2
+ structure TypeVar = struct
+ type t = Unit.t Ref.t
+ val new = ref
+ end
+
fun mapElem f =
- fn Product.*` (a, b) => Product.*` (mapElem f a, mapElem f b)
- | Product.ISO b => Product.ISO (mapElem f b)
- | Product.ELEM e => Product.ELEM (f e)
+ fn TIMES (a, b) => TIMES (mapElem f a, mapElem f b)
+ | ISO_PRODUCT b => ISO_PRODUCT (mapElem f b)
+ | ELEM e => ELEM (f e)
structure TypeExp = LayerRep
(structure Outer = Arg.Rep
structure Closed = struct
- type 'a t = Var.t Ty.t
- type 'a s = Var.t Ty.t Ty.Sum.t
- type ('a, 'k) p = (Generics.Label.t Option.t * Var.t Ty.t) Ty.Product.t
+ type 'a t = TypeVar.t Ty.t
+ type 'a s = TypeVar.t Ty.t Sum.t
+ type ('a, 'k) p = (Label.t Option.t * TypeVar.t Ty.t) Product.t
end)
val ty = TypeExp.This.getT
@@ -29,25 +34,25 @@
structure Layered = LayerCases
(structure Outer = Arg and Result = TypeExp and Rep = TypeExp.Closed
- fun iso bT _ = ISO bT
- fun isoProduct bP _ = Product.ISO bP
- fun isoSum bS _ = Sum.ISO bS
+ fun iso bT _ = ISO bT
+ fun isoProduct bP _ = ISO_PRODUCT bP
+ fun isoSum bS _ = ISO_SUM bS
- fun op *` (aT, bT) = Product.*` (aT, bT)
- fun T aT = Product.ELEM (NONE, aT)
- fun R l aT = Product.ELEM (SOME l, aT)
+ val op *` = TIMES
+ fun T aT = ELEM (NONE, aT)
+ fun R l aT = ELEM (SOME l, aT)
fun tuple aP = TUPLE (mapElem Pair.snd aP)
fun record aP = RECORD (mapElem (Pair.map (valOf, id)) aP)
- fun op +` (aT, bT) = Sum.+` (aT, bT)
- val unit = CON0 UNIT
- fun C0 c = Sum.C0 c
+ val op +` = PLUS
+ val unit = CON0 UNIT
+ fun C0 c = Sum.C0 c
fun C1 c aT = Sum.C1 (c, aT)
val data = DATA
fun Y ? =
Tie.pure (fn () => let
- val v = Var.new ()
+ val v = TypeVar.new ()
in
(VAR v, fn e => FIX (v, e))
end) ?
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/ty.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/ty.sig 2007-09-13 13:04:55 UTC (rev 6019)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/ty.sig 2007-09-14 12:24:09 UTC (rev 6020)
@@ -10,22 +10,18 @@
*)
signature TY = sig
structure Product : sig
- datatype 'elem t = *` of 'elem t Sq.t
- | ELEM of 'elem
- | ISO of 'elem t
+ datatype 'elem t = TIMES of 'elem t Sq.t
+ | ELEM of 'elem
+ | ISO_PRODUCT of 'elem t
end
structure Sum : sig
- datatype 'ty t = +` of 'ty t Sq.t
- | C0 of Generics.Con.t
- | C1 of Generics.Con.t * 'ty
- | ISO of 'ty t
+ datatype 'ty t = PLUS of 'ty t Sq.t
+ | C0 of Generics.Con.t
+ | C1 of Generics.Con.t * 'ty
+ | ISO_SUM of 'ty t
end
- structure Var : sig
- eqtype t
- val new : t Thunk.t
- end
structure Con0 : sig
datatype t = BOOL | CHAR | EXN | FIXED_INT | INT | LARGE_INT
@@ -41,14 +37,31 @@
datatype t = ARROW
end
- datatype 'var t =
- DATA of 'var t Sum.t
- | CON0 of Con0.t
- | CON1 of Con1.t * 'var t
- | CON2 of Con2.t * 'var t Sq.t
- | FIX of 'var * 'var t
- | ISO of 'var t
- | RECORD of (Generics.Label.t * 'var t) Product.t
- | TUPLE of 'var t Product.t
- | VAR of 'var
+ datatype 'var t = DATA of 'var t Sum.t
+ | CON0 of Con0.t
+ | CON1 of Con1.t * 'var t
+ | CON2 of Con2.t * 'var t Sq.t
+ | FIX of 'var * 'var t
+ | ISO of 'var t
+ | RECORD of (Generics.Label.t * 'var t) Product.t
+ | TUPLE of 'var t Product.t
+ | VAR of 'var
+
+ (** == Data Recursion Info ==
+ *
+ * These correspond to the algorithms in the {DataRecInfo} generic
+ * and have been implemented here as recursive algorithms on type
+ * representation expressions with the intention of documenting their
+ * semantics.
+ *
+ * The {DataRecInfo} generic computes the same information
+ * incrementally during type representation construction and is likely
+ * to be better amenable to compiler optimizations such as constant
+ * folding.
+ *)
+
+ val isMutableType : 'a t UnPr.t
+ val mayBeCyclic : ''a t UnPr.t
+ val mayBeRecData : ''a t UnPr.t
+ val mayContainExn : 'a t UnPr.t
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig 2007-09-13 13:04:55 UTC (rev 6019)
+++ mltonlib/trunk/com/ssh/generic/unstable/public/value/type-exp.sig 2007-09-14 12:24:09 UTC (rev 6020)
@@ -10,7 +10,12 @@
signature TYPE_EXP = sig
structure TypeExp : OPEN_REP
- val ty : ('a, 'x) TypeExp.t -> Ty.Var.t Ty.t
+ (** A minimalistic type variable representation providing only equality. *)
+ structure TypeVar : sig
+ eqtype t
+ end
+
+ val ty : ('a, 'x) TypeExp.t -> TypeVar.t Ty.t
(** Returns the type expression given a type representation. *)
end
More information about the MLton-commit
mailing list