[MLton-commit] r5563

[Vesa Karvonen]

Added numConsecutiveAlts and hasBaseCase.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/misc-util/unstable/type-info.sml

----------------------------------------------------------------------

Modified: mltonlib/trunk/com/ssh/misc-util/unstable/type-info.sml
===================================================================
--- mltonlib/trunk/com/ssh/misc-util/unstable/type-info.sml	2007-05-18 12:35:00 UTC (rev 5562)
+++ mltonlib/trunk/com/ssh/misc-util/unstable/type-info.sml	2007-05-18 12:37:35 UTC (rev 5563)
@@ -23,6 +23,17 @@
 signature TYPE_INFO = sig
    type 'a type_info_t
 
+   val canBeCyclic : 'a type_info_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 hasBaseCase : 'a type_info_t UnPr.t
+   (** Returns true iff the type {'a} has a non-recursive variant. *)
+
    val hasExn : 'a type_info_t UnPr.t
    (** Returns true iff the type {'a} contains the type {exn}. *)
 
@@ -38,12 +49,9 @@
     * the form {'b ref}.
     *)
 
-   val canBeCyclic : 'a type_info_t UnPr.t
+   val numConsecutiveAlts : 'a type_info_t -> Int.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.
+    * Number of consecutive alternatives.
     *)
 end
 
@@ -52,40 +60,52 @@
             type 'a t
             val lift : ('a type_info_t, 'a t) Lift.t Thunk.t) : TYPE_INFO = struct
    type 'a type_info_t = 'a t
-   val hasExn       = fn ? => Lift.get lift hasExn       ?
-   val hasRecData   = fn ? => Lift.get lift hasRecData   ?
-   val isRefOrArray = fn ? => Lift.get lift isRefOrArray ?
-   val canBeCyclic  = fn ? => Lift.get lift canBeCyclic  ?
+   fun mk f = Lift.get lift f
+   val canBeCyclic        = fn ? => mk canBeCyclic        ?
+   val hasBaseCase        = fn ? => mk hasBaseCase        ?
+   val hasExn             = fn ? => mk hasExn             ?
+   val hasRecData         = fn ? => mk hasRecData         ?
+   val isRefOrArray       = fn ? => mk isRefOrArray       ?
+   val numConsecutiveAlts = fn ? => mk numConsecutiveAlts ?
 end
 
 structure TypeInfo :> sig
-   include STRUCTURAL_TYPE
-   include TYPE_INFO where type 'a type_info_t = 'a t
+   include STRUCTURAL_TYPE TYPE_INFO
+   sharing type type_info_t = t
 end = struct
-   datatype u = IN of {exn : Bool.t, pure : Bool.t, recs : Int.t List.t}
+   datatype u =
+      IN of {alts : Int.t,
+             base : Bool.t,
+             exn : Bool.t,
+             pure : Bool.t,
+             recs : Int.t List.t}
    fun out (IN t) = t
    type 'a t = u
    type 'a type_info_t = 'a t
 
+   val hasBaseCase = #base o out
    val hasExn = #exn o out
    val hasRecData = not o null o #recs o out
    val isRefOrArray = not o #pure o out
+   val numConsecutiveAlts = #alts o out
    val canBeCyclic = isRefOrArray andAlso (hasExn orElse hasRecData)
 
-   val base = IN {exn = false, pure = true, recs = []}
-   fun pure (IN {exn, recs, ...}) = IN {exn = exn, pure = true, recs = recs}
-   fun impure (IN {exn, recs, ...}) =
-       IN {exn = exn, pure = false, recs = recs}
-   fun combine (IN {exn = hl, recs = rl, ...},
-                IN {exn = hr, recs = rr, ...}) =
-       IN {exn = hl orelse hr, pure = true,
-           recs = SortedList.merge#1 Int.compare (rl, rr)}
+   val base = IN {alts = 1, base = true, exn = false, pure = true, recs = []}
+   fun pure (IN {exn, recs, ...}) =
+      IN {alts = 1, base = true, exn = exn, pure = true, recs = recs}
 
    val iso = const
 
-   val op *` = combine
-   val op +` = combine
+   fun (IN {base = bl, exn = hl, recs = rl, ...}) *`
+       (IN {base = br, exn = hr, recs = rr, ...}) =
+       IN {alts = 1, base = bl andalso br, exn = hl orelse hr, pure = true,
+           recs = SortedList.merge#1 Int.compare (rl, rr)}
 
+   fun (IN {alts = al, base = bl, exn = hl, recs = rl, ...}) +`
+       (IN {alts = ar, base = br, exn = hr, recs = rr, ...}) =
+       IN {alts = al + ar, base = bl orelse br, exn = hl orelse hr, pure = true,
+           recs = SortedList.merge#1 Int.compare (rl, rr)}
+
    val unit = base
 
    local
@@ -96,21 +116,22 @@
              (fn () => let
                  val this = !id before id += 1
               in
-                 (IN {exn = false, pure = true, recs = [this]},
-                  fn IN {exn, pure, recs} =>
-                     IN {exn = exn, pure = pure,
-                         recs = SortedList.remove
-                                   #1 Int.compare this recs})
+                 (IN {alts = 1, base = false, exn = false, pure = true, recs = [this]},
+                  fn IN {alts, base, exn, pure, recs} =>
+                     IN {alts = alts, base = base, exn = exn, pure = pure,
+                         recs = SortedList.remove #1 Int.compare this recs})
               end) ?
    end
 
    fun _ --> _ = base
 
-   val exn = IN {exn = true, pure = true, recs = []}
+   val exn = IN {alts = 1, base = true, exn = true, pure = true, recs = []}
    fun regExn _ _ = ()
 
-   val array = impure
-   val refc  = impure
+   fun array (IN {exn, recs, ...}) =
+       IN {alts = 1, base = true, exn = exn, pure = false, recs = recs}
+   fun refc (IN {base, exn, recs, ...}) =
+       IN {alts = 1, base = base, exn = exn, pure = false, recs = recs}
 
    val vector = pure