[MLton-commit] r6056

Matthew Fluet fluet at mlton.org
Fri Sep 28 15:31:57 PDT 2007


A whole-program cps-transform on the SXML IL
----------------------------------------------------------------------

A   mlton/trunk/mlton/xml/cps-transform.fun
A   mlton/trunk/mlton/xml/cps-transform.sig
U   mlton/trunk/mlton/xml/sources.cm
U   mlton/trunk/mlton/xml/sources.mlb
U   mlton/trunk/mlton/xml/sxml-simplify.fun
U   mlton/trunk/mlton/xml/xml-tree.fun
U   mlton/trunk/mlton/xml/xml-tree.sig

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

Added: mlton/trunk/mlton/xml/cps-transform.fun
===================================================================
--- mlton/trunk/mlton/xml/cps-transform.fun	2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/cps-transform.fun	2007-09-28 22:31:56 UTC (rev 6056)
@@ -0,0 +1,594 @@
+(* Copyright (C) 2007-2007 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+functor CPSTransform (S: CPS_TRANSFORM_STRUCTS): CPS_TRANSFORM = 
+struct
+
+open S
+datatype z = datatype Dec.t
+datatype z = datatype PrimExp.t
+
+fun doit (prog: Program.t): Program.t =
+   let
+      val Program.T {datatypes, body, overflow} = prog
+
+      (* Answer type is always unit in an XML IL program. *)
+      val ansTy = Type.unit
+      (* Exception type is always exn in an XML IL program. *)
+      val exnTy = Type.exn
+
+
+      (* Style of function-type translation. *)
+      datatype style = Curried | Mixed | Uncurried
+      val style = Uncurried
+
+      val {hom = transType, destroy = destroyTransType} =
+         Type.makeMonoHom
+         {con = fn (_, c, tys) =>
+          if Tycon.equals (c, Tycon.arrow)
+             then let
+                     val argTy = Vector.sub (tys, 0)
+                     val resTy = Vector.sub (tys, 1)
+                  in
+                     case style of
+                        Curried =>
+                           Type.arrow 
+                           (Type.arrow (resTy, ansTy),
+                            Type.arrow
+                            (Type.arrow (exnTy, ansTy),
+                             Type.arrow (argTy, ansTy)))
+                      | Mixed =>
+                           Type.arrow 
+                           ((Type.tuple o Vector.new2)
+                            (Type.arrow (resTy, ansTy),
+                             Type.arrow (exnTy, ansTy)),
+                            Type.arrow (argTy, ansTy))
+                      | Uncurried => 
+                           Type.arrow
+                           ((Type.tuple o Vector.new3)
+                            (Type.arrow (resTy, ansTy),
+                             Type.arrow (exnTy, ansTy),
+                             argTy), 
+                            ansTy)
+                  end
+          else Type.con (c, tys)}
+
+      (* A property to record (original) type of each bound variable. *)
+      val {get = getVarOrigType: Var.t -> Type.t, set = setVarOrigType, ...} =
+         Property.getSetOnce 
+         (Var.plist, Property.initRaise ("getVarOrigType", Var.layout))
+      val getVarExpOrigType = getVarOrigType o VarExp.var
+
+      (* A mayOverflow primitive needs a special translation with a wrapper
+       * datatype.  See transPrimExp:PrimApp.
+       *)
+      val wrapDatatypes = ref []
+      val {get = getWrap, destroy = destroyWrap, ...} =
+         Property.destGet
+         (Type.plist, Property.initFun (fn ty =>
+          let
+             val successCon = Con.newString "Success"
+             val failureCon = Con.newString "Failure"
+             val wrapTycon = Tycon.newString "Wrap"
+             val wrapTy = Type.con (wrapTycon, Vector.new0 ())
+             val wrapDatatype = 
+                {cons = Vector.new2
+                        ({arg = SOME ty, con = successCon},
+                         {arg = SOME exnTy, con = failureCon}),
+                 tycon = wrapTycon,
+                 tyvars = Vector.new0 ()}
+             val () = List.push (wrapDatatypes, wrapDatatype)
+          in
+             {successCon = successCon, 
+              failureCon = failureCon, 
+              wrapTy = wrapTy}
+          end))
+
+      fun transVarExpWithType (x: VarExp.t) : DirectExp.t * Type.t =
+         let
+            val xTy = transType (getVarExpOrigType x)
+         in
+            (DirectExp.varExp (x, xTy), xTy)
+         end
+      val transVarExp = #1 o transVarExpWithType
+
+      fun transLambda (l: Lambda.t): Lambda.t =
+         let
+            val {arg = argVar, argType = argTy, body, mayInline} = Lambda.dest l
+            val resTy = getVarExpOrigType (Exp.result body)
+
+            val argTy = transType argTy
+            val resTy = transType resTy
+            val kVar = Var.newString "k"
+            val kTy = Type.arrow (resTy, ansTy)
+            val hVar = Var.newString "h"
+            val hTy = Type.arrow (exnTy, ansTy) 
+            val bodyKHA = transExp (body, kVar, kTy, hVar, hTy)
+         in
+            case style of
+               Curried => 
+                  let
+                     val bodyKH =
+                        DirectExp.lambda
+                        {arg = argVar,
+                         argType = argTy,
+                         body = bodyKHA,
+                         bodyType = ansTy,
+                         mayInline = mayInline}
+                     val bodyK =
+                        DirectExp.lambda
+                        {arg = hVar,
+                         argType = hTy,
+                         body = bodyKH,
+                         bodyType = Type.arrow (argTy, ansTy),
+                         mayInline = true}
+                  in
+                     Lambda.make
+                     {arg = kVar,
+                      argType = kTy,
+                      body = DirectExp.toExp bodyK,
+                      mayInline = true}
+                  end
+             | Mixed => 
+                  let
+                     val xVar = Var.newNoname ()
+                     val xTy = Type.tuple (Vector.new2 (kTy, hTy))
+                     val x = DirectExp.monoVar (xVar, xTy)
+                     val bodyKH =
+                        DirectExp.lambda
+                        {arg = argVar,
+                         argType = argTy,
+                         body = bodyKHA,
+                         bodyType = ansTy,
+                         mayInline = mayInline}
+                     val bodyXK =
+                        DirectExp.let1 
+                        {var = hVar, 
+                         exp = (DirectExp.select {tuple = x,
+                                                  offset = 1,
+                                                  ty = hTy}), 
+                         body = bodyKH}
+                     val bodyX =
+                        DirectExp.let1 
+                        {var = kVar, 
+                         exp = (DirectExp.select {tuple = x,
+                                                  offset = 0,
+                                                  ty = kTy}), 
+                         body = bodyXK}
+                  in
+                     Lambda.make
+                     {arg = xVar,
+                      argType = xTy,
+                      body = DirectExp.toExp bodyX,
+                      mayInline = mayInline}
+                  end
+             | Uncurried =>
+                  let
+                     val xVar = Var.newNoname ()
+                     val xTy = Type.tuple (Vector.new3 (kTy, hTy, argTy))
+                     val x = DirectExp.monoVar (xVar, xTy)
+                     val bodyXKH =
+                        DirectExp.let1 
+                        {var = argVar, 
+                         exp = (DirectExp.select {tuple = x,
+                                                  offset = 2,
+                                                  ty = argTy}), 
+                         body = bodyKHA}
+                     val bodyXK =
+                        DirectExp.let1 
+                        {var = hVar, 
+                         exp = (DirectExp.select {tuple = x,
+                                                  offset = 1,
+                                                  ty = hTy}), 
+                         body = bodyXKH}
+                     val bodyX =
+                        DirectExp.let1 
+                        {var = kVar, 
+                         exp = (DirectExp.select {tuple = x,
+                                                  offset = 0,
+                                                  ty = kTy}), 
+                         body = bodyXK}
+                  in
+                     Lambda.make
+                     {arg = xVar,
+                      argType = xTy,
+                      body = DirectExp.toExp bodyX,
+                      mayInline = mayInline}
+                  end
+         end
+      and transPrimExp (e: PrimExp.t, eTy: Type.t,
+                        kVar: Var.t, kTy: Type.t,
+                        hVar: Var.t, hTy: Type.t): DirectExp.t =
+         let
+            val eTy = transType eTy
+            val k = DirectExp.monoVar (kVar, kTy)
+            val h = DirectExp.monoVar (hVar, hTy)
+            fun return x = DirectExp.app {func = k, arg = x, ty = ansTy}
+         in 
+            case e of
+               App {arg, func} =>
+                  let
+                     val (arg, argTy) = transVarExpWithType arg
+                     val func = transVarExp func
+                  in
+                     case style of
+                        Curried => 
+                           let
+                              val app1 =
+                                 DirectExp.app
+                                 {func = func,
+                                  arg = k,
+                                  ty = Type.arrow (hTy, Type.arrow (argTy, ansTy))}
+                              val app2 =
+                                 DirectExp.app
+                                 {func = app1,
+                                  arg = h,
+                                  ty = Type.arrow (argTy, ansTy)}
+                              val app3 =
+                                 DirectExp.app
+                                 {func = app2,
+                                  arg = arg,
+                                  ty = ansTy}
+                           in
+                              app3
+                           end
+                      | Mixed => 
+                           let
+                              val arg2 =
+                                 DirectExp.tuple 
+                                 {exps = Vector.new2 (k, h),
+                                  ty = (Type.tuple o Vector.new2) (kTy, hTy)}
+                              val app2 = 
+                                 DirectExp.app
+                                 {func = func,
+                                  arg = arg2,
+                                  ty = Type.arrow (argTy, ansTy)}
+                              val app3 =
+                                 DirectExp.app
+                                 {func = app2,
+                                  arg = arg,
+                                  ty = ansTy}
+                           in
+                              app3
+                           end
+                      | Uncurried =>
+                           let
+                              val arg3 =
+                                 DirectExp.tuple 
+                                 {exps = Vector.new3 (k, h, arg),
+                                  ty = (Type.tuple o Vector.new3) (kTy, hTy, argTy)}
+                              val app3 =
+                                 DirectExp.app
+                                 {func = func,
+                                  arg = arg3,
+                                  ty = ansTy}
+                           in
+                              app3
+                           end
+                  end
+             | Case {cases, default, test} =>
+                  let
+                     val cases = 
+                        case cases of
+                           Cases.Con cases =>
+                              let
+                                 val cases =
+                                    Vector.map
+                                    (cases, fn (Pat.T {arg, con, targs}, e) =>
+                                     let
+                                        val arg =
+                                           Option.map
+                                           (arg, fn (arg, argTy) =>
+                                            (arg, transType argTy))
+                                        val targs = Vector.map (targs, transType)
+                                     in
+                                        (Pat.T {arg = arg, con = con, targs = targs},
+                                         transExp (e, kVar, kTy, hVar, hTy))
+                                     end)
+                              in
+                                 Cases.Con cases
+                              end
+                         | Cases.Word (ws, cases) =>
+                              let
+                                 val cases =
+                                    Vector.map
+                                    (cases, fn (w, e) => 
+                                     (w, transExp (e, kVar, kTy, hVar, hTy)))
+                              in
+                                 Cases.Word (ws, cases)
+                              end
+                     val default =
+                        Option.map
+                        (default, fn (e, r) =>
+                         (transExp (e, kVar, kTy, hVar, hTy), r))
+                  in
+                     DirectExp.casee
+                     {cases = cases,
+                      default = default,
+                      test = transVarExp test,
+                      ty = ansTy}
+                  end
+             | ConApp {arg, con, targs} =>
+                  (return o DirectExp.conApp)
+                  {arg = Option.map (arg, transVarExp),
+                   con = con,
+                   targs = Vector.map (targs, transType), 
+                   ty = eTy}
+             | Const c => return (DirectExp.const c)
+             | Handle {catch = (cVar, _), handler, try} =>
+                  let
+                     val h'Var = Var.newString "h"
+                     val h'Ty = Type.arrow (exnTy, ansTy)
+                     val h'Body =
+                        DirectExp.lambda
+                        {arg = cVar,
+                         argType = exnTy,
+                         body = transExp (handler, kVar, kTy, hVar, hTy),
+                         bodyType = ansTy,
+                         mayInline = true}
+                  in
+                     DirectExp.let1 {var = h'Var, exp = h'Body, body =
+                     transExp (try, kVar, kTy, h'Var, h'Ty)}
+                  end
+             | Lambda l => 
+                  let
+                     val l = transLambda l
+                  in 
+                     return (DirectExp.fromLambda (l, eTy))
+                  end
+             | PrimApp {args, prim, targs} => 
+                  let
+                     val primAppExp =
+                        DirectExp.primApp
+                        {args = Vector.map (args, transVarExp),
+                         prim = prim,
+                         targs = Vector.map (targs, transType),
+                         ty = eTy}
+                  in
+                     if Prim.mayOverflow prim
+                        then let
+                                (* A mayOverflow primitive has an
+                                 * implicit raise, which is introduced
+                                 * explicitly by closure-convert
+                                 * (transformation from SXML to SSA).
+                                 *
+                                 * We leave an explicit Handle around
+                                 * the primitive to catch the
+                                 * exception.  The non-exceptional
+                                 * result goes to the (normal)
+                                 * continuation, while the exception
+                                 * goes to the exception continuation.
+                                 *
+                                 * Naively, we would do:
+                                 *   (k (primApp)) handle x => h x
+                                 * But, this evaluates the (normal)
+                                 * continuation in the context of the
+                                 * handler.
+                                 * 
+                                 * Rather, we do:
+                                 *   case ((Success (primApp)) 
+                                 *         handle x => Failure x) of
+                                 *     Success x => k x
+                                 *     Failure x => h x
+                                 * This evaluates the (normal)
+                                 * continuation outside the context of
+                                 * the handler.  
+                                 * 
+                                 * See <src>/lib/mlton/basic/exn0.sml
+                                 * and "Exceptional Syntax" by Benton
+                                 * and Kennedy.
+                                 * 
+                                 *)
+
+                                val {successCon, failureCon, wrapTy} = 
+                                   getWrap eTy
+
+                                val testExp =
+                                   let
+                                      val xVar = Var.newNoname ()
+                                      val x = DirectExp.monoVar (xVar, exnTy)
+                                   in
+                                      DirectExp.handlee
+                                      {try = DirectExp.conApp
+                                             {arg = SOME primAppExp,
+                                              con = successCon,
+                                              targs = Vector.new0 (),
+                                              ty = wrapTy},
+                                       catch = (xVar, exnTy),
+                                       handler = DirectExp.conApp
+                                                 {arg = SOME x,
+                                                  con = failureCon,
+                                                  targs = Vector.new0 (),
+                                                  ty = wrapTy},
+                                       ty = wrapTy}
+                                   end
+
+                                val successCase =
+                                   let
+                                      val xVar = Var.newNoname ()
+                                   in
+                                      (Pat.T {arg = SOME (xVar, eTy),
+                                              con = successCon,
+                                              targs = Vector.new0 ()},
+                                       DirectExp.app
+                                       {func = k,
+                                        arg = DirectExp.monoVar (xVar, eTy),
+                                        ty = ansTy})
+                                   end
+                                val failureCase =
+                                   let
+                                      val xVar = Var.newNoname ()
+                                   in
+                                      (Pat.T 
+                                       {arg = SOME (xVar, exnTy),
+                                        con = failureCon,
+                                        targs = Vector.new0 ()},
+                                       DirectExp.app
+                                       {func = h,
+                                        arg = DirectExp.monoVar (xVar, exnTy),
+                                        ty = ansTy})
+                                   end
+                                val cases =
+                                   Cases.Con (Vector.new2 (successCase, failureCase))
+                             in
+                                DirectExp.casee
+                                {test = testExp,
+                                 cases = cases,
+                                 default = NONE,
+                                 ty = ansTy}
+                             end
+                     else return primAppExp
+                  end
+             | Profile _ => 
+                  let
+                     (* Profile statements won't properly nest after
+                      * CPS conversion.
+                      *)
+                  in 
+                     Error.bug "ImplementContinuations.transPrimExp: Profile"
+                  end
+             | Raise {exn, extend} => 
+                  DirectExp.app
+                  {func = h,
+                   arg = transVarExp exn,
+                   ty = ansTy}
+             | Select {offset, tuple} => 
+                  (return o DirectExp.select)
+                  {tuple = transVarExp tuple,
+                   offset = offset,
+                   ty = eTy}
+             | Tuple xs =>
+                  (return o DirectExp.tuple)
+                  {exps = Vector.map (xs, transVarExp),
+                   ty = eTy}
+             | Var x => return (transVarExp x)
+         end
+      and transDec (d: Dec.t,
+                    kBody: DirectExp.t, 
+                    hVar: Var.t, hTy: Type.t): DirectExp.t =
+         let
+         in
+            case d of
+               Exception _ => Error.bug "ImplementContinuations.transDec: Exception"
+             | Fun {decs, tyvars} => 
+                  let
+                     val decs =
+                        Vector.map
+                        (decs, fn {var, ty, lambda} =>
+                         {var = var,
+                          ty = transType ty,
+                          lambda = transLambda lambda})
+                     val d = Fun {decs = decs, tyvars = tyvars}
+                  in
+                     DirectExp.lett {decs = [d], body = kBody}
+                  end
+             | MonoVal {var, ty, exp} => 
+                  let
+                     val expTy = ty
+                     val argVar = var
+                     val argTy = transType ty
+                     val k'Var = Var.newString "k"
+                     val k'Ty = Type.arrow (argTy, ansTy)
+                     val k'Body =
+                        DirectExp.lambda
+                        {arg = argVar,
+                         argType = argTy,
+                         body = kBody,
+                         bodyType = ansTy,
+                         mayInline = true}
+                  in
+                     DirectExp.let1 {var = k'Var, exp = k'Body, body =
+                     transPrimExp (exp, expTy, k'Var, k'Ty, hVar, hTy)}
+                  end
+             | PolyVal _ => Error.bug "ImplementContinuations.transDec: PolyVal"
+         end
+      and transExp (e: Exp.t, 
+                    kVar: Var.t, kTy: Type.t, 
+                    hVar: Var.t, hTy: Type.t): DirectExp.t =
+         let
+            val {decs, result} = Exp.dest e
+            val k = DirectExp.monoVar (kVar, kTy)
+            val k'Body =
+               DirectExp.app
+               {func = k, arg = transVarExp result, ty = ansTy}
+         in
+            List.foldr
+            (decs, k'Body, fn (dec, kBody) =>
+             transDec (dec, kBody, hVar, hTy))
+         end
+
+      (* Set (original) type of each bound variable. *)
+      val () =
+         Exp.foreachBoundVar
+         (body, fn (v, _, ty) => 
+          setVarOrigType (v, ty))
+
+      (* Translate datatypes. *)
+      val datatypes =
+         Vector.map
+         (datatypes, fn {cons, tycon, tyvars} =>
+          {cons = Vector.map (cons, fn {arg, con} =>
+                              {arg = Option.map (arg, transType),
+                               con = con}),
+           tycon = tycon,
+           tyvars = tyvars})
+
+      (* Initial continuation. *)
+      val k0 = Var.newString "k0"
+      val k0Body =
+         DirectExp.lambda
+         {arg = Var.newNoname (),
+          argType = ansTy,
+          body = DirectExp.unit (),
+          bodyType = ansTy,
+          mayInline = true}
+      val k0Ty = Type.arrow (ansTy, Type.unit)
+      (* Initial exception continuation. *)
+      val h0 = Var.newString "h0"
+      val h0Body =
+         DirectExp.lambda
+         {arg = Var.newNoname (),
+          argType = exnTy,
+          body = DirectExp.unit (),
+          bodyType = ansTy,
+          mayInline = true}
+      val h0Ty = Type.arrow (exnTy, Type.unit)
+
+      (* Translate body, in context of initial continuations. *)
+      val body = DirectExp.let1 {var = k0, exp = k0Body, body =
+                 DirectExp.let1 {var = h0, exp = h0Body, body =
+                 transExp (body, k0, k0Ty, h0, h0Ty)}}
+
+      (* Closure-convert (transformation from SXML to SSA) introduces 
+       * every (non-main) SSA function with "raises = [exn]"; 
+       * we need a top-level handler to avoid a "raise mismatch" type
+       * error in the SSA IL. 
+       *)
+      val body = DirectExp.handlee
+                 {try = body,
+                  catch = (Var.newNoname (), exnTy),
+                  handler = DirectExp.unit (),
+                  ty = ansTy}
+      val body = DirectExp.toExp body
+
+      (* Fetch accumulated wrap datatypes. *)
+      val wrapDatatypes = Vector.fromList (!wrapDatatypes)
+      val datatypes = Vector.concat [datatypes, wrapDatatypes]
+
+      val prog = Program.T {datatypes = datatypes, 
+                            body = body, 
+                            overflow = overflow}
+
+      (* Clear and destroy properties. *)
+      val () = Exp.clear body
+      val () = destroyTransType ()
+      val () = destroyWrap ()
+   in
+      prog
+   end
+
+end

Added: mlton/trunk/mlton/xml/cps-transform.sig
===================================================================
--- mlton/trunk/mlton/xml/cps-transform.sig	2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/cps-transform.sig	2007-09-28 22:31:56 UTC (rev 6056)
@@ -0,0 +1,18 @@
+(* Copyright (C) 2007-2007 Henry Cejtin, Matthew Fluet, Suresh
+ *    Jagannathan, and Stephen Weeks.
+ *
+ * MLton is released under a BSD-style license.
+ * See the file MLton-LICENSE for details.
+ *)
+
+signature CPS_TRANSFORM_STRUCTS = 
+   sig
+      include SXML_TREE
+   end
+
+signature CPS_TRANSFORM = 
+   sig
+      include CPS_TRANSFORM_STRUCTS
+
+      val doit: Program.t -> Program.t
+   end

Modified: mlton/trunk/mlton/xml/sources.cm
===================================================================
--- mlton/trunk/mlton/xml/sources.cm	2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/sources.cm	2007-09-28 22:31:56 UTC (rev 6056)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -47,6 +47,8 @@
 implement-suffix.fun
 polyvariance.sig
 polyvariance.fun
+cps-transform.sig
+cps-transform.fun
 sxml-simplify.sig
 sxml-simplify.fun
 sxml.sig

Modified: mlton/trunk/mlton/xml/sources.mlb
===================================================================
--- mlton/trunk/mlton/xml/sources.mlb	2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/sources.mlb	2007-09-28 22:31:56 UTC (rev 6056)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2005 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -36,6 +36,8 @@
    implement-suffix.fun
    polyvariance.sig
    polyvariance.fun
+   cps-transform.sig
+   cps-transform.fun
    sxml-simplify.sig
    sxml-simplify.fun
    sxml.sig

Modified: mlton/trunk/mlton/xml/sxml-simplify.fun
===================================================================
--- mlton/trunk/mlton/xml/sxml-simplify.fun	2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/sxml-simplify.fun	2007-09-28 22:31:56 UTC (rev 6056)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
  *    Jagannathan, and Stephen Weeks.
  * Copyright (C) 1997-2000 NEC Research Institute.
  *
@@ -15,6 +15,7 @@
 structure ImplementSuffix = ImplementSuffix (open S)
 structure Polyvariance = Polyvariance (open S)
 (* structure Uncurry = Uncurry (open S) *)
+structure CPSTransform = CPSTransform (open S)
 
 fun polyvariance (rounds, small, product) p =
    Ref.fluidLet

Modified: mlton/trunk/mlton/xml/xml-tree.fun
===================================================================
--- mlton/trunk/mlton/xml/xml-tree.fun	2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/xml-tree.fun	2007-09-28 22:31:56 UTC (rev 6056)
@@ -771,6 +771,9 @@
                                       mayInline = mayInline}),
                  Type.arrow (argType, bodyType))
 
+      fun fromLambda (l, ty) =
+         simple (Lambda l, ty)
+
       fun detupleGen (e: PrimExp.t,
                       t: Type.t,
                       components: Var.t vector,

Modified: mlton/trunk/mlton/xml/xml-tree.sig
===================================================================
--- mlton/trunk/mlton/xml/xml-tree.sig	2007-09-28 11:17:53 UTC (rev 6055)
+++ mlton/trunk/mlton/xml/xml-tree.sig	2007-09-28 22:31:56 UTC (rev 6056)
@@ -198,6 +198,7 @@
             val equal: t * t -> t
             val falsee: unit -> t
             val fromExp: Exp.t * Type.t -> t
+            val fromLambda: Lambda.t * Type.t -> t
             val handlee: {catch: Var.t * Type.t,
                           handler: t,
                           try: t,




More information about the MLton-commit mailing list