1 (* Copyright (C) 2007-2007 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
4 * MLton is released under a BSD-style license.
5 * See the file MLton-LICENSE for details.
8 functor CPSTransform (S: XML_TRANSFORM_STRUCTS): XML_TRANSFORM =
12 datatype z = datatype Dec.t
13 datatype z = datatype PrimExp.t
15 fun transform (prog: Program.t): Program.t =
17 val Program.T {datatypes, body, overflow} = prog
19 (* Answer type is always unit in an XML IL program. *)
21 (* Exception type is always exn in an XML IL program. *)
25 (* Style of function-type translation. *)
26 datatype style = Curried | Mixed | Uncurried
29 val {hom = transType, destroy = destroyTransType} =
31 {con = fn (_, c, tys) =>
32 if Tycon.equals (c, Tycon.arrow)
34 val argTy = Vector.sub (tys, 0)
35 val resTy = Vector.sub (tys, 1)
40 (Type.arrow (resTy, ansTy),
42 (Type.arrow (exnTy, ansTy),
43 Type.arrow (argTy, ansTy)))
46 ((Type.tuple o Vector.new2)
47 (Type.arrow (resTy, ansTy),
48 Type.arrow (exnTy, ansTy)),
49 Type.arrow (argTy, ansTy))
52 ((Type.tuple o Vector.new3)
53 (Type.arrow (resTy, ansTy),
54 Type.arrow (exnTy, ansTy),
58 else Type.con (c, tys)}
60 (* A property to record (original) type of each bound variable. *)
61 val {get = getVarOrigType: Var.t -> Type.t, set = setVarOrigType, ...} =
63 (Var.plist, Property.initRaise ("getVarOrigType", Var.layout))
64 val getVarExpOrigType = getVarOrigType o VarExp.var
66 (* A mayOverflow primitive needs a special translation with a wrapper
67 * datatype. See transPrimExp:PrimApp.
69 val wrapDatatypes = ref []
70 val {get = getWrap, destroy = destroyWrap, ...} =
72 (Type.plist, Property.initFun (fn ty =>
74 val successCon = Con.newString "Success"
75 val failureCon = Con.newString "Failure"
76 val wrapTycon = Tycon.newString "Wrap"
77 val wrapTy = Type.con (wrapTycon, Vector.new0 ())
80 ({arg = SOME ty, con = successCon},
81 {arg = SOME exnTy, con = failureCon}),
83 tyvars = Vector.new0 ()}
84 val () = List.push (wrapDatatypes, wrapDatatype)
86 {successCon = successCon,
87 failureCon = failureCon,
91 fun transVarExpWithType (x: VarExp.t) : DirectExp.t * Type.t =
93 val xTy = transType (getVarExpOrigType x)
95 (DirectExp.varExp (x, xTy), xTy)
97 val transVarExp = #1 o transVarExpWithType
99 fun transLambda (l: Lambda.t): Lambda.t =
101 val {arg = argVar, argType = argTy, body, mayInline} = Lambda.dest l
102 val resTy = getVarExpOrigType (Exp.result body)
104 val argTy = transType argTy
105 val resTy = transType resTy
106 val kVar = Var.newString "k"
107 val kTy = Type.arrow (resTy, ansTy)
108 val hVar = Var.newString "h"
109 val hTy = Type.arrow (exnTy, ansTy)
110 val bodyKHA = transExp (body, kVar, kTy, hVar, hTy)
121 mayInline = mayInline}
127 bodyType = Type.arrow (argTy, ansTy),
133 body = DirectExp.toExp bodyK,
138 val xVar = Var.newNoname ()
139 val xTy = Type.tuple (Vector.new2 (kTy, hTy))
140 val x = DirectExp.monoVar (xVar, xTy)
147 mayInline = mayInline}
151 exp = (DirectExp.select {tuple = x,
158 exp = (DirectExp.select {tuple = x,
166 body = DirectExp.toExp bodyX,
171 val xVar = Var.newNoname ()
172 val xTy = Type.tuple (Vector.new3 (kTy, hTy, argTy))
173 val x = DirectExp.monoVar (xVar, xTy)
177 exp = (DirectExp.select {tuple = x,
184 exp = (DirectExp.select {tuple = x,
191 exp = (DirectExp.select {tuple = x,
199 body = DirectExp.toExp bodyX,
200 mayInline = mayInline}
203 and transPrimExp (e: PrimExp.t, eTy: Type.t,
204 kVar: Var.t, kTy: Type.t,
205 hVar: Var.t, hTy: Type.t): DirectExp.t =
207 val eTy = transType eTy
208 val k = DirectExp.monoVar (kVar, kTy)
209 val h = DirectExp.monoVar (hVar, hTy)
210 fun return x = DirectExp.app {func = k, arg = x, ty = ansTy}
215 val (arg, argTy) = transVarExpWithType arg
216 val func = transVarExp func
225 ty = Type.arrow (hTy, Type.arrow (argTy, ansTy))}
230 ty = Type.arrow (argTy, ansTy)}
243 {exps = Vector.new2 (k, h),
244 ty = (Type.tuple o Vector.new2) (kTy, hTy)}
249 ty = Type.arrow (argTy, ansTy)}
262 {exps = Vector.new3 (k, h, arg),
263 ty = (Type.tuple o Vector.new3) (kTy, hTy, argTy)}
273 | Case {cases, default, test} =>
281 (cases, fn (Pat.T {arg, con, targs}, e) =>
285 (arg, fn (arg, argTy) =>
286 (arg, transType argTy))
287 val targs = Vector.map (targs, transType)
289 (Pat.T {arg = arg, con = con, targs = targs},
290 transExp (e, kVar, kTy, hVar, hTy))
295 | Cases.Word (ws, cases) =>
300 (w, transExp (e, kVar, kTy, hVar, hTy)))
302 Cases.Word (ws, cases)
306 (default, fn (e, r) =>
307 (transExp (e, kVar, kTy, hVar, hTy), r))
312 test = transVarExp test,
315 | ConApp {arg, con, targs} =>
316 (return o DirectExp.conApp)
317 {arg = Option.map (arg, transVarExp),
319 targs = Vector.map (targs, transType),
321 | Const c => return (DirectExp.const c)
322 | Handle {catch = (cVar, _), handler, try} =>
324 val h'Var = Var.newString "h"
325 val h'Ty = Type.arrow (exnTy, ansTy)
330 body = transExp (handler, kVar, kTy, hVar, hTy),
334 DirectExp.let1 {var = h'Var, exp = h'Body, body =
335 transExp (try, kVar, kTy, h'Var, h'Ty)}
339 val l = transLambda l
341 return (DirectExp.fromLambda (l, eTy))
343 | PrimApp {args, prim, targs} =>
347 {args = Vector.map (args, transVarExp),
349 targs = Vector.map (targs, transType),
352 if Prim.mayOverflow prim
354 (* A mayOverflow primitive has an
355 * implicit raise, which is introduced
356 * explicitly by closure-convert
357 * (transformation from SXML to SSA).
359 * We leave an explicit Handle around
360 * the primitive to catch the
361 * exception. The non-exceptional
362 * result goes to the (normal)
363 * continuation, while the exception
364 * goes to the exception continuation.
366 * Naively, we would do:
367 * (k (primApp)) handle x => h x
368 * But, this evaluates the (normal)
369 * continuation in the context of the
373 * case ((Success (primApp))
374 * handle x => Failure x) of
377 * This evaluates the (normal)
378 * continuation outside the context of
381 * See <src>/lib/mlton/basic/exn0.sml
382 * and "Exceptional Syntax" by Benton
387 val {successCon, failureCon, wrapTy} =
392 val xVar = Var.newNoname ()
393 val x = DirectExp.monoVar (xVar, exnTy)
396 {try = DirectExp.conApp
397 {arg = SOME primAppExp,
399 targs = Vector.new0 (),
401 catch = (xVar, exnTy),
402 handler = DirectExp.conApp
405 targs = Vector.new0 (),
412 val xVar = Var.newNoname ()
414 (Pat.T {arg = SOME (xVar, eTy),
416 targs = Vector.new0 ()},
419 arg = DirectExp.monoVar (xVar, eTy),
424 val xVar = Var.newNoname ()
427 {arg = SOME (xVar, exnTy),
429 targs = Vector.new0 ()},
432 arg = DirectExp.monoVar (xVar, exnTy),
436 Cases.Con (Vector.new2 (successCase, failureCase))
444 else return primAppExp
448 (* Profile statements won't properly nest after
452 Error.bug "CPSTransform.transPrimExp: Profile"
454 | Raise {exn, ...} =>
457 arg = transVarExp exn,
459 | Select {offset, tuple} =>
460 (return o DirectExp.select)
461 {tuple = transVarExp tuple,
465 (return o DirectExp.tuple)
466 {exps = Vector.map (xs, transVarExp),
468 | Var x => return (transVarExp x)
470 and transDec (d: Dec.t,
472 hVar: Var.t, hTy: Type.t): DirectExp.t =
476 Exception _ => Error.bug "CPSTransform.transDec: Exception"
477 | Fun {decs, tyvars} =>
481 (decs, fn {var, ty, lambda} =>
484 lambda = transLambda lambda})
485 val d = Fun {decs = decs, tyvars = tyvars}
487 DirectExp.lett {decs = [d], body = kBody}
489 | MonoVal {var, ty, exp} =>
493 val argTy = transType ty
494 val k'Var = Var.newString "k"
495 val k'Ty = Type.arrow (argTy, ansTy)
504 DirectExp.let1 {var = k'Var, exp = k'Body, body =
505 transPrimExp (exp, expTy, k'Var, k'Ty, hVar, hTy)}
507 | PolyVal _ => Error.bug "CPSTransform.transDec: PolyVal"
509 and transExp (e: Exp.t,
510 kVar: Var.t, kTy: Type.t,
511 hVar: Var.t, hTy: Type.t): DirectExp.t =
513 val {decs, result} = Exp.dest e
514 val k = DirectExp.monoVar (kVar, kTy)
517 {func = k, arg = transVarExp result, ty = ansTy}
520 (decs, k'Body, fn (dec, kBody) =>
521 transDec (dec, kBody, hVar, hTy))
524 (* Set (original) type of each bound variable. *)
527 (body, fn (v, _, ty) =>
528 setVarOrigType (v, ty))
530 (* Translate datatypes. *)
533 (datatypes, fn {cons, tycon, tyvars} =>
534 {cons = Vector.map (cons, fn {arg, con} =>
535 {arg = Option.map (arg, transType),
540 (* Initial continuation. *)
541 val k0 = Var.newString "k0"
544 {arg = Var.newNoname (),
546 body = DirectExp.unit (),
549 val k0Ty = Type.arrow (ansTy, Type.unit)
550 (* Initial exception continuation. *)
551 val h0 = Var.newString "h0"
554 {arg = Var.newNoname (),
556 body = DirectExp.unit (),
559 val h0Ty = Type.arrow (exnTy, Type.unit)
561 (* Translate body, in context of initial continuations. *)
562 val body = DirectExp.let1 {var = k0, exp = k0Body, body =
563 DirectExp.let1 {var = h0, exp = h0Body, body =
564 transExp (body, k0, k0Ty, h0, h0Ty)}}
566 (* Closure-convert (transformation from SXML to SSA) introduces
567 * every (non-main) SSA function with "raises = [exn]";
568 * we need a top-level handler to avoid a "raise mismatch" type
569 * error in the SSA IL.
571 val body = DirectExp.handlee
573 catch = (Var.newNoname (), exnTy),
574 handler = DirectExp.unit (),
576 val body = DirectExp.toExp body
578 (* Fetch accumulated wrap datatypes. *)
579 val wrapDatatypes = Vector.fromList (!wrapDatatypes)
580 val datatypes = Vector.concat [datatypes, wrapDatatypes]
582 val prog = Program.T {datatypes = datatypes,
586 (* Clear and destroy properties. *)
587 val () = Exp.clear body
588 val () = destroyTransType ()
589 val () = destroyWrap ()