[MLton-commit] r5784

Vesa Karvonen vesak at mlton.org
Fri Jul 20 14:36:01 PDT 2007


Use unit refs instead of integers in Y.
----------------------------------------------------------------------

U   mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml

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

Modified: 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 02:32:11 UTC (rev 5783)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/type-info.sml	2007-07-20 21:36:00 UTC (rev 5784)
@@ -11,55 +11,30 @@
    infix  1 orElse
    (* SML/NJ workaround --> *)
 
-   fun revMerge (xs, ys) = let
-      fun lp ([], ys, zs) = (ys, zs)
-        | lp (xs, [], zs) = (xs, zs)
-        | lp (x::xs, y::ys, zs) =
-          case Int.compare (x, y) of
-             LESS => lp (xs, y::ys, x::zs)
-           | EQUAL => lp (xs, ys, x::zs)
-           | GREATER => lp (x::xs, ys, y::zs)
-   in
-      lp (xs, ys, [])
-   end
+   type recs = Unit.t Ref.t List.t
 
-   val merge = List.revAppend o Pair.swap o revMerge
+   fun rem x : recs UnOp.t =
+    fn []  => []
+     | [y] => if x = y then [] else [y]
+     | ys  => List.filter (notEq x) ys
 
-   fun remove x ys = let
-      fun lp (zs, []) = (zs, [])
-        | lp (zs, y::ys) =
-          case Int.compare (x, y) of
-             LESS => (zs, y::ys)
-           | EQUAL => (zs, ys)
-           | GREATER => lp (y::zs, ys)
-   in
-      List.revAppend (lp ([], ys))
-   end
+   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,
-              pure : Bool.t,
-              recs : Int.t List.t}
+   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}
 
-   datatype s =
-      INS of {alts : Int.t,
-              base : Bool.t,
-              exn : Bool.t,
-              recs : Int.t List.t}
-
-   datatype p =
-      INP of {base : Bool.t,
-              elems : Int.t,
-              exn : Bool.t,
-              recs : Int.t List.t}
-
    structure TypeInfo =
       LayerGenericRep
         (structure Outer = Arg.Rep
          structure Closed = struct
-            type 'a t = t
-            type 'a s = s
+            type  'a      t = t
+            type  'a      s = s
             type ('a, 'k) p = p
          end)
 
@@ -86,37 +61,43 @@
       fun pure (INT {exn, recs, ...}) =
           INT {base = true, exn = exn, pure = true, recs = recs}
 
-      val iso = const
+      val iso        = const
       val isoProduct = const
-      val isoSum = const
+      val isoSum     = const
 
-      fun op *` (INP {base = bl, elems = el, exn = hl, recs = rl, ...},
-                 INP {base = br, elems = er, exn = hr, recs = rr, ...}) =
-          INP {base = bl andalso br, elems = el + er, exn = hl orelse hr,
-               recs = merge (rl, rr)}
+      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}
+      fun R _ = T
+      fun tuple (INP {base, exn, recs, ...}) =
+          INT {base = base, exn = exn, pure = true, recs = recs}
+      val record = tuple
 
-      fun op +` (INS {alts = al, base = bl, exn = hl, recs = rl, ...},
-                 INS {alts = ar, base = br, exn = hr, recs = rr, ...}) =
-          INS {alts = al + ar, base = bl orelse br, exn = hl orelse hr,
-               recs = merge (rl, rr)}
-
+      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)}
       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}
 
-      local
-         val id = ref 0
-      in
-         fun Y ? =
-             Tie.pure
-                (fn () => let
-                       val this = !id before id := !id + 1
-                    in
-                       (INT {base = false, exn = false, pure = true,
-                             recs = [this]},
-                        fn INT {base, exn, pure, recs} =>
-                           INT {base = base, exn = exn, pure = pure,
-                               recs = remove this recs})
-                    end) ?
-      end
+      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 op --> _ = base
 
@@ -129,13 +110,12 @@
           INT {base = base, exn = exn, pure = false, recs = recs}
 
       val vector = pure
+      val list   = pure
 
       val largeInt  = base
       val largeReal = base
       val largeWord = base
 
-      val list = pure
-
       val bool   = base
       val char   = base
       val int    = base
@@ -144,25 +124,8 @@
       val word   = base
 
       val word8  = base
-   (* val word16 = base (* Word16 not provided by SML/NJ *) *)
       val word32 = base
-      val word64 = base
+      val word64 = base)
 
-      (* Trivialities *)
-
-      fun T (INT {base, exn, recs, ...}) =
-          INP {base = base, elems = 1, exn = exn, recs = recs}
-      fun R _ = T
-
-      fun tuple (INP {base, exn, recs, ...}) =
-          INT {base = base, exn = exn, pure = true, recs = recs}
-      val record = tuple
-
-      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})
-
    open Layered
 end




More information about the MLton-commit mailing list