[MLton-commit] r5729
Matthew Fluet
fluet at mlton.org
Fri Jul 6 14:26:54 PDT 2007
Formatting and additional tracing functions
----------------------------------------------------------------------
U mlton/trunk/mlton/xml/monomorphise.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/xml/monomorphise.fun
===================================================================
--- mlton/trunk/mlton/xml/monomorphise.fun 2007-07-06 21:14:57 UTC (rev 5728)
+++ mlton/trunk/mlton/xml/monomorphise.fun 2007-07-06 21:26:53 UTC (rev 5729)
@@ -75,7 +75,7 @@
fun monomorphise (Xprogram.T {datatypes, body, ...}): Sprogram.t =
let
- val {get = getVar: Var.t -> Stype.t vector -> SvarExp.t,
+ val {get = getVar: Var.t -> (Stype.t vector -> SvarExp.t),
set = setVar, ...} =
Property.getSet (Var.plist, Property.initRaise ("var", Var.layout))
val setVar =
@@ -108,6 +108,10 @@
("Monomorphise.setTyvar", Tyvar.layout, Stype.layout, Unit.layout)
setTyvar
fun setTyvars (tyvs, tys) = Vector.foreach2 (tyvs, tys, setTyvar)
+ val setTyvars =
+ Trace.trace2
+ ("Monomorphise.setTyvars", Vector.layout Tyvar.layout, Vector.layout Stype.layout, Unit.layout)
+ setTyvars
fun monoType (t: Xtype.t): Stype.t =
Xtype.hom {ty = t,
var = getTyvar,
@@ -121,6 +125,12 @@
NONE => NONE
| SOME t => SOME (monoType t)
fun monoTypes ts = Vector.map (ts, monoType)
+ fun monoVar (x: Var.t, ts: Xtype.t vector): SvarExp.t = getVar x (monoTypes ts)
+ val monoVar =
+ Trace.trace2
+ ("Monomorphise.monoVar",
+ Var.layout, Vector.layout Xtype.layout, SvarExp.layout)
+ monoVar
fun monoCon (c: Con.t, ts: Xtype.t vector): Con.t = getCon c (monoTypes ts)
val monoCon =
Trace.trace2
@@ -258,7 +268,7 @@
(* monoExp *)
(*------------------------------------*)
fun monoVarExp (XvarExp.T {var, targs}) =
- getVar var (monoTypes targs)
+ monoVar (var, targs)
val monoVarExp =
Trace.trace
("Monomorphise.monoVarExp", XvarExp.layout, SvarExp.layout)
@@ -269,8 +279,8 @@
(fn (e: Xexp.t) =>
let
val {decs, result} = Xexp.dest e
- val thunks = List.fold (decs, [], fn (d, thunks) =>
- monoDec d :: thunks)
+ val thunks =
+ List.fold (decs, [], fn (dec, thunks) => monoDec dec :: thunks)
val result = monoVarExp result
val decs =
List.fold (thunks, [], fn (thunk, decs) => thunk () @ decs)
@@ -337,78 +347,86 @@
(*------------------------------------*)
and monoDec arg: unit -> Sdec.t list =
traceMonoDec
- (fn Xdec.MonoVal {var, ty, exp} =>
- let
- val (var, _) = renameMono (var, ty)
- in fn () => [Sdec.MonoVal {var = var,
- ty = monoType ty,
- exp = monoPrimExp exp}]
- end
- | Xdec.PolyVal {var, tyvars, ty, exp} =>
- let
- val cache = Cache.new ()
- val _ =
- setVar (var, fn ts =>
- (setTyvars (tyvars, ts)
- ; Cache.getOrAdd (cache, ts, fn () =>
- SvarExp.mono (Var.new var))))
- in
- fn () =>
- List.fold
- (Cache.toList cache, [], fn ((ts, ve), decs) =>
- (setTyvars (tyvars, ts)
- ; let val {decs = decs', result} = Sexp.dest (monoExp exp)
- in decs'
- @ (Sdec.MonoVal {var = SvarExp.var ve,
- ty = monoType ty,
- exp = SprimExp.Var result} :: decs)
- end))
- end
- | Xdec.Fun {tyvars, decs} =>
- let
- val cache = Cache.new ()
- val _ =
- Vector.foreachi
- (decs, fn (n, {var, ...}) =>
- setVar
- (var, fn ts =>
+ (fn (d: Xdec.t) =>
+ case d of
+ Xdec.MonoVal {var, ty, exp} =>
+ let
+ val (var, _) = renameMono (var, ty)
+ in
+ fn () =>
+ [Sdec.MonoVal {var = var,
+ ty = monoType ty,
+ exp = monoPrimExp exp}]
+ end
+ | Xdec.PolyVal {var, tyvars, ty, exp} =>
+ let
+ val cache = Cache.new ()
+ val _ =
+ setVar
+ (var, fn ts =>
+ (setTyvars (tyvars, ts)
+ ; Cache.getOrAdd (cache, ts, fn () =>
+ SvarExp.mono (Var.new var))))
+ in
+ fn () =>
+ List.fold
+ (Cache.toList cache, [], fn ((ts, ve), decs) =>
(setTyvars (tyvars, ts)
- ; Vector.sub (Cache.getOrAdd
- (cache, ts, fn () =>
- Vector.map (decs,
- SvarExp.mono o Var.new o #var)),
- n))))
- in fn () =>
- List.revMap
- (Cache.toList cache, fn (ts, xs) =>
- (setTyvars (tyvars, ts)
- ; Vector.foreach2 (decs, xs, fn ({var, ...}, var') =>
- setVar (var, fn _ => var'))
- ; (Sdec.Fun
- {tyvars = Vector.new0 (),
- decs = (Vector.map2
- (decs, xs, fn ({ty, lambda, ...}, ve) =>
- {var = SvarExp.var ve,
- ty = monoType ty,
- lambda = monoLambda lambda}))})))
- end
- | Xdec.Exception {con, arg} =>
- let
- val con' =
- if Con.equals (con, Con.overflow)
- then
- (* We avoid renaming Overflow because the closure
- * converter needs to recognize it. This is not
- * safe in general, but is OK in this case because
- * we know there is only one Overflow excon.
- *)
- con
- else Con.new con
- val _ = setCon (con, fn _ => con')
- in
- fn () => [Sdec.Exception {con = con',
- arg = monoTypeOpt arg}]
- end) arg
+ ; let
+ val {decs = decs', result} = Sexp.dest (monoExp exp)
+ in
+ decs'
+ @ (Sdec.MonoVal {var = SvarExp.var ve,
+ ty = monoType ty,
+ exp = SprimExp.Var result} :: decs)
+ end))
+ end
+ | Xdec.Fun {tyvars, decs} =>
+ let
+ val cache = Cache.new ()
+ val _ =
+ Vector.foreachi
+ (decs, fn (n, {var, ...}) =>
+ setVar
+ (var, fn ts =>
+ (setTyvars (tyvars, ts)
+ ; Vector.sub (Cache.getOrAdd
+ (cache, ts, fn () =>
+ Vector.map (decs, SvarExp.mono o Var.new o #var)),
+ n))))
+ in
+ fn () =>
+ List.revMap
+ (Cache.toList cache, fn (ts, xs) =>
+ (setTyvars (tyvars, ts)
+ ; Vector.foreach2 (decs, xs, fn ({var, ...}, var') =>
+ setVar (var, fn _ => var'))
+ ; (Sdec.Fun
+ {tyvars = Vector.new0 (),
+ decs = (Vector.map2
+ (decs, xs, fn ({ty, lambda, ...}, ve) =>
+ {var = SvarExp.var ve,
+ ty = monoType ty,
+ lambda = monoLambda lambda}))})))
+ end
+ | Xdec.Exception {con, arg} =>
+ let
+ val con' =
+ if Con.equals (con, Con.overflow)
+ then
+ (* We avoid renaming Overflow because the closure
+ * converter needs to recognize it. This is not
+ * safe in general, but is OK in this case because
+ * we know there is only one Overflow excon.
+ *)
+ con
+ else Con.new con
+ val _ = setCon (con, fn _ => con')
+ in
+ fn () =>
+ [Sdec.Exception {con = con',
+ arg = monoTypeOpt arg}]
+ end) arg
(*------------------------------------*)
(* main code for monomorphise *)
(*------------------------------------*)
More information about the MLton-commit
mailing list