[MLton-commit] r6099
Vesa Karvonen
vesak at mlton.org
Sat Oct 27 11:03:10 PDT 2007
Introduced datatypes for the type representations of Ord and Seq. This
seemed to considerably reduce the amount of code generated by SML/NJ.
Also some other minor tweaks.
This also seems to be an effective workaround for a bug in MLKit (rev
2287). Without the datatype, MLKit (rev 2287) fails to compile the
functor bodies.
----------------------------------------------------------------------
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
U mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
----------------------------------------------------------------------
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-10-27 16:42:44 UTC (rev 6098)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/ord.sml 2007-10-27 18:03:09 UTC (rev 6099)
@@ -11,42 +11,43 @@
(* SML/NJ workaround --> *)
type e = (HashUniv.t, HashUniv.t) HashMap.t
- type 'a t = e * 'a Sq.t -> Order.t
+ datatype 'a t = IN of e * 'a Sq.t -> Order.t
- fun lift (cmp : 'a Cmp.t) : 'a t = cmp o #2
+ fun lift (cmp : 'a Cmp.t) : 'a t = IN (cmp o #2)
- fun sequ {toSlice, getItem} aO (e, (l, r)) = let
- fun lp (e, l, r) =
- case getItem l & getItem r
- of NONE & NONE => EQUAL
- | NONE & SOME _ => LESS
- | SOME _ & NONE => GREATER
- | SOME (x, l) & SOME (y, r) =>
- case aO (e, (x, y))
- of EQUAL => lp (e, l, r)
- | res => res
- in
- lp (e, toSlice l, toSlice r)
- end
+ fun sequ {toSlice, getItem} (IN aO) =
+ IN (fn (e, (l, r)) => let
+ fun lp (e, l, r) =
+ case getItem l & getItem r
+ of NONE & NONE => EQUAL
+ | NONE & SOME _ => LESS
+ | SOME _ & NONE => GREATER
+ | SOME (x, l) & SOME (y, r) =>
+ case aO (e, (x, y))
+ of EQUAL => lp (e, l, r)
+ | res => res
+ in
+ lp (e, toSlice l, toSlice r)
+ end)
- fun cyclic aT aO =
+ fun cyclic aT (IN aO) =
case HashUniv.new {eq = op =, hash = Arg.hash aT}
of (to, _) =>
- fn (e, (l, r)) => let
- val lD = to l
- val rD = to r
- in
- if case HashMap.find e lD
- of SOME rD' => HashUniv.eq (rD, rD')
- | NONE => false
- then EQUAL
- else (HashMap.insert e (lD, rD)
- ; HashMap.insert e (rD, lD)
- ; aO (e, (l, r)))
- end
+ IN (fn (e, (l, r)) => let
+ val lD = to l
+ val rD = to r
+ in
+ if case HashMap.find e lD
+ of SOME rD' => HashUniv.eq (rD, rD')
+ | NONE => false
+ then EQUAL
+ else (HashMap.insert e (lD, rD)
+ ; HashMap.insert e (rD, lD)
+ ; aO (e, (l, r)))
+ end)
val exns : (e * Exn.t Sq.t -> Order.t Option.t) Buffer.t = Buffer.new ()
- fun regExn aO (_, e2a) =
+ fun regExn (IN aO) (_, e2a) =
(Buffer.push exns)
(fn (e, (l, r)) =>
case e2a l & e2a r
@@ -55,7 +56,7 @@
| NONE & SOME _ => SOME LESS
| NONE & NONE => NONE)
- fun iso' getX bX (a2b, _) (e, bp) = getX bX (e, Sq.map a2b bp)
+ fun iso' (IN bX) (a2b, _) = IN (fn (e, bp) => bX (e, Sq.map a2b bp))
structure OrdRep = LayerRep
(open Arg
@@ -63,26 +64,25 @@
open OrdRep.This
- fun ord t = let
- val ord = getT t
- in
- fn xy => ord (HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash}, xy)
- end
+ fun ord t =
+ case getT t
+ of IN ord => fn xy =>
+ ord (HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash}, xy)
fun withOrd cmp = mapT (const (lift cmp))
structure Open = LayerDepCases
- (fun iso ? = iso' getT ?
- fun isoProduct ? = iso' getP ?
- fun isoSum ? = iso' getS ?
+ (fun iso bT = iso' (getT bT)
+ fun isoProduct bP = iso' (getP bP)
+ fun isoSum bS = iso' (getS bS)
fun op *` (aP, bP) = let
- val aO = getP aP
- val bO = getP bP
+ val IN aO = getP aP
+ val IN bO = getP bP
in
- fn (e, (lA & lB, rA & rB)) =>
- case aO (e, (lA, rA))
- of EQUAL => bO (e, (lB, rB))
- | res => res
+ IN (fn (e, (lA & lB, rA & rB)) =>
+ case aO (e, (lA, rA))
+ of EQUAL => bO (e, (lB, rB))
+ | res => res)
end
val T = getT
fun R _ = getT
@@ -90,29 +90,29 @@
val record = getP
fun op +` (aS, bS) = let
- val aO = getS aS
- val bO = getS bS
+ val IN aO = getS aS
+ val IN bO = getS bS
in
- fn (e, (l, r)) =>
- case l & r
- of INL l & INL r => aO (e, (l, r))
- | INL _ & INR _ => LESS
- | INR _ & INL _ => GREATER
- | INR l & INR r => bO (e, (l, r))
+ IN (fn (e, (l, r)) =>
+ case l & r
+ of INL l & INL r => aO (e, (l, r))
+ | INL _ & INR _ => LESS
+ | INR _ & INL _ => GREATER
+ | INR l & INR r => bO (e, (l, r)))
end
val unit = lift (fn ((), ()) => EQUAL)
fun C0 _ = unit
fun C1 _ = getT
val data = getS
- val Y = Tie.function
+ fun Y ? = let open Tie in iso function end (fn IN ? => ?, IN) ?
- fun op --> _ = failing "Ord.--> unsupported"
+ fun op --> _ = IN (failing "Ord.--> unsupported")
- fun exn (e, lr) =
- case Buffer.findSome (pass (e, lr)) exns
- of NONE => GenericsUtil.failExnSq lr
- | SOME r => r
+ val exn = IN (fn (e, lr) =>
+ case Buffer.findSome (pass (e, lr)) exns
+ of NONE => GenericsUtil.failExnSq lr
+ | SOME r => r)
fun regExn0 _ = regExn unit
fun regExn1 _ = regExn o getT
@@ -130,12 +130,12 @@
val largeWord = lift LargeWord.compare
val largeReal =
- iso' id (lift CastLargeReal.Bits.compare) CastLargeReal.isoBits
+ iso' (lift CastLargeReal.Bits.compare) CastLargeReal.isoBits
val bool = lift Bool.compare
val char = lift Char.compare
val int = lift Int.compare
- val real = iso' id (lift CastReal.Bits.compare) CastReal.isoBits
+ val real = iso' (lift CastReal.Bits.compare) CastReal.isoBits
val string = lift String.compare
val word = lift Word.compare
@@ -145,7 +145,7 @@
val word64 = lift Word64.compare
*)
- fun hole () = undefined
+ fun hole () = IN undefined
open Arg OrdRep)
end
Modified: mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml
===================================================================
--- mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-10-27 16:42:44 UTC (rev 6098)
+++ mltonlib/trunk/com/ssh/generic/unstable/detail/value/seq.sml 2007-10-27 18:03:09 UTC (rev 6099)
@@ -11,47 +11,49 @@
(* SML/NJ workaround --> *)
type e = (HashUniv.t, HashUniv.t) HashMap.t
- type 'a t = e * 'a Sq.t -> Bool.t
+ datatype 'a t = IN of e * 'a Sq.t -> Bool.t
- fun lift (eq : 'a BinPr.t) : 'a t = eq o #2
+ fun lift (eq : 'a BinPr.t) : 'a t = IN (eq o #2)
- fun sequ {toSlice, getItem} aE (e, (l, r)) = let
- fun lp (e, l, r) =
- case getItem l & getItem r
- of NONE & NONE => true
- | NONE & SOME _ => false
- | SOME _ & NONE => false
- | SOME (x, l) & SOME (y, r) => aE (e, (x, y)) andalso lp (e, l, r)
- in
- lp (e, toSlice l, toSlice r)
- end
+ fun sequ {toSlice, getItem} (IN aE) =
+ IN (fn (e, (l, r)) => let
+ fun lp (e, l, r) =
+ case getItem l & getItem r
+ of NONE & NONE => true
+ | NONE & SOME _ => false
+ | SOME _ & NONE => false
+ | SOME (x, l) & SOME (y, r) =>
+ aE (e, (x, y)) andalso lp (e, l, r)
+ in
+ lp (e, toSlice l, toSlice r)
+ end)
- fun cyclic aT aE = let
+ fun cyclic aT (IN aE) = let
val (to, _) = HashUniv.new {eq = op =, hash = Arg.hash aT}
in
- fn (e, (l, r)) => let
- val lD = to l
- val rD = to r
- in
- case HashMap.find e lD
- of SOME rD' => HashUniv.eq (rD, rD')
- | NONE => isNone (HashMap.find e rD)
- andalso (HashMap.insert e (lD, rD)
- ; HashMap.insert e (rD, lD)
- ; aE (e, (l, r)))
- end
+ IN (fn (e, (l, r)) => let
+ val lD = to l
+ val rD = to r
+ in
+ case HashMap.find e lD
+ of SOME rD' => HashUniv.eq (rD, rD')
+ | NONE => isNone (HashMap.find e rD)
+ andalso (HashMap.insert e (lD, rD)
+ ; HashMap.insert e (rD, lD)
+ ; aE (e, (l, r)))
+ end)
end
val exns : (e * Exn.t Sq.t -> Bool.t Option.t) Buffer.t = Buffer.new ()
- fun regExn aE (_, e2a) =
- (Buffer.push exns)
- (fn (e, (l, r)) =>
- case e2a l & e2a r
- of SOME l & SOME r => SOME (aE (e, (l, r)))
- | NONE & NONE => NONE
- | _ => SOME false)
+ fun regExn (IN aE) (_, e2a) =
+ (Buffer.push exns)
+ (fn (e, (l, r)) =>
+ case e2a l & e2a r
+ of SOME l & SOME r => SOME (aE (e, (l, r)))
+ | NONE & NONE => NONE
+ | _ => SOME false)
- fun iso' bE (a2b, _) (e, bp) = bE (e, Sq.map a2b bp)
+ fun iso' (IN bE) (a2b, _) = IN (fn (e, bp) => bE (e, Sq.map a2b bp))
structure SeqRep = LayerRep
(open Arg
@@ -61,7 +63,7 @@
fun seq t =
case getT t
- of eq => fn xy =>
+ of IN eq => fn xy =>
eq (HashMap.new {eq = HashUniv.eq, hash = HashUniv.hash}, xy)
fun notSeq t = negate (seq t)
fun withSeq eq = mapT (const (lift eq))
@@ -72,11 +74,11 @@
fun isoSum bS = iso' (getS bS)
fun op *` (aP, bP) = let
- val aE = getP aP
- val bE = getP bP
+ val IN aE = getP aP
+ val IN bE = getP bP
in
- fn (e, (lA & lB, rA & rB)) =>
- aE (e, (lA, rA)) andalso bE (e, (lB, rB))
+ IN (fn (e, (lA & lB, rA & rB)) =>
+ aE (e, (lA, rA)) andalso bE (e, (lB, rB)))
end
val T = getT
fun R _ = getT
@@ -84,26 +86,26 @@
val record = getP
fun op +` (aS, bS) = let
- val aE = getS aS
- val bE = getS bS
+ val IN aE = getS aS
+ val IN bE = getS bS
in
- fn (e, (INL l, INL r)) => aE (e, (l, r))
- | (e, (INR l, INR r)) => bE (e, (l, r))
- | _ => false
+ IN (fn (e, (INL l, INL r)) => aE (e, (l, r))
+ | (e, (INR l, INR r)) => bE (e, (l, r))
+ | _ => false)
end
val unit = lift (fn ((), ()) => true)
fun C0 _ = unit
fun C1 _ = getT
val data = getS
- val Y = Tie.function
+ fun Y ? = let open Tie in iso function end (fn IN ? => ?, IN) ?
- fun op --> _ = failing "Seq.--> unsupported"
+ fun op --> _ = IN (failing "Seq.--> unsupported")
- fun exn (e, lr) =
- case Buffer.findSome (pass (e, lr)) exns
- of NONE => GenericsUtil.failExnSq lr
- | SOME r => r
+ val exn = IN (fn (e, lr) =>
+ case Buffer.findSome (pass (e, lr)) exns
+ of NONE => GenericsUtil.failExnSq lr
+ | SOME r => r)
fun regExn0 _ (e, p) = regExn unit (const e, p)
fun regExn1 _ = regExn o getT
@@ -135,7 +137,7 @@
val word64 = lift op = : Word64.t t
*)
- fun hole () = undefined
+ fun hole () = IN undefined
open Arg SeqRep)
end
More information about the MLton-commit
mailing list