mlton/closure-convert/closure-convert.fun

   1 (* Copyright (C) 2017 Matthew Fluet.
   2  * Copyright (C) 1999-2005, 2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 (*
  11  * All local variables in the Sxml are renamed to new variables in Ssa,
  12  * unless they are global, as determined by the Globalization pass.
  13  * Renaming must happen because an Sxml variable will be bound in the Ssa
  14  * once for each lambda it occurs in.  The main trickiness is caused because a
  15  * property is used to implement the renamer map.  Hence, a variable binding
  16  * must always be visited with "newVar" or "newScope" before it is looked up
  17  * with "getNewVar".  "newScope" also handles resetting the variable to its
  18  * old value once the processing of the lambda is done.
  19  *)
  20 functor ClosureConvert (S: CLOSURE_CONVERT_STRUCTS): CLOSURE_CONVERT =
  21 struct
  22
  23 open S
  24
  25 structure Globalize = Globalize (open Sxml)
  26
  27 local open Sxml
  28 in
  29    structure Scases = Cases
  30    structure Sexp = Exp
  31    structure Sdec = Dec
  32    structure Slambda = Lambda
  33    structure Spat = Pat
  34    structure SprimExp = PrimExp
  35    structure SvarExp = VarExp
  36    structure Stype = Type
  37    open Atoms
  38 end
  39
  40 local
  41    open Ssa
  42 in
  43    structure Block = Block
  44    structure Datatype = Datatype
  45    structure Dexp = DirectExp
  46    structure Func = Func
  47    structure Function = Function
  48    structure SourceInfo = SourceInfo
  49    structure Type = Type
  50 end
  51
  52 structure Value = AbstractValue (structure Ssa = Ssa
  53                                  structure Sxml = Sxml)
  54 local open Value
  55 in structure Lambdas = Lambdas
  56 end
  57
  58 (* Accum.t is one of the results returned internally by the converter -- an
  59  * accumulation of toplevel Ssa globals and function declarations.
  60  *)
  61 structure Accum =
  62    struct
  63       structure AL = AppendList
  64
  65       datatype t = T of {globals: {var: Var.t,
  66                                    ty: Type.t,
  67                                    exp: Dexp.t} AL.t,
  68                          functions: Function.t list}
  69
  70       val empty = T {globals = AL.empty, functions = []}
  71
  72       fun addGlobals (T {globals, functions}, gs) =
  73          T {globals = AL.append (globals, AL.fromList gs),
  74             functions = functions}
  75
  76       fun addGlobal (ac, g) = addGlobals (ac, [g])
  77
  78       fun addFunc (T {globals, functions}, f) =
  79          T {globals = globals, functions = f :: functions}
  80
  81       fun done (T {globals, functions}) =
  82          {functions = functions,
  83           globals =
  84           let
  85              (* Must shrink because coercions may be inserted at constructor
  86               * applications.  I'm pretty sure the shrinking will eliminate
  87               * any case expressions/local functions.
  88               * We must rebind eliminated variables because the shrinker is
  89               * just processing globals and hence cannot safely delete a
  90               * variable that has no occurrences, since there may still be
  91               * occurrences in functions.
  92               *)
  93              val globals = AL.toList globals
  94              val vars = Vector.fromListMap (globals, #var)
  95              val tys = Vector.fromListMap (globals, #ty)
  96              val (start, blocks) =
  97                 Dexp.linearize
  98                 (Dexp.lett
  99                  {decs = List.map (globals, fn {var, exp, ...} =>
 100                                    {var = var, exp = exp}),
 101                   body = Dexp.tuple {exps = (Vector.fromListMap
 102                                              (globals, fn {var, ty, ...} =>
 103                                               Dexp.var (var, ty))),
 104                                      ty = Type.tuple tys}},
 105                  Ssa.Handler.Caller)
 106              val {blocks, ...} =
 107                 Function.dest
 108                 (Ssa.shrinkFunction
 109                  {globals = Vector.new0 ()}
 110                  (Function.new {args = Vector.new0 (),
 111                                 blocks = Vector.fromList blocks,
 112                                 mayInline = false, (* doesn't matter *)
 113                                 name = Func.newNoname (),
 114                                 raises = NONE,
 115                                 returns = SOME (Vector.new1 (Type.tuple tys)),
 116                                 start = start}))
 117           in
 118              if 1 <> Vector.length blocks
 119                 then Error.bug (concat ["ClosureConvert.Accum.done: ",
 120                                         "shrinker didn't completely simplify"])
 121              else
 122                 let
 123                    val ss = Block.statements (Vector.first blocks)
 124                    val vs =
 125                       case Ssa.Statement.exp (Vector.last ss) of
 126                          Ssa.Exp.Tuple vs =>
 127                             if Vector.length vars = Vector.length vs
 128                                then vs
 129                             else Error.bug (concat ["ClosureConvert.Accum.done: ",
 130                                                     "shrinker didn't simplify right"])
 131                        | _ => Error.bug (concat ["ClosureConvert.Accum.done: ",
 132                                                  "shrinker didn't produce tuple"])
 133                    val ss = Vector.dropSuffix (ss, 1)
 134                    val rebinds =
 135                       Vector.keepAllMapi
 136                       (vs, fn (i, v) =>
 137                        if Var.equals (v, Vector.sub (vars, i))
 138                           then NONE
 139                           else SOME (Ssa.Statement.T
 140                                      {exp = Ssa.Exp.Var v,
 141                                       ty = Vector.sub (tys, i),
 142                                       var = SOME (Vector.sub (vars, i))}))
 143                 in
 144                    Vector.concat [ss, rebinds]
 145                 end
 146           end}
 147    end
 148
 149 (*
 150 val traceConvertExp =
 151    Trace.trace2
 152    ("ClosureConvert.convertExp",
 153     Sexp.layout, Instance.layout, Dexp.layout)
 154 *)
 155
 156 val convertPrimExpInfo = Trace.info "ClosureConvert.convertPrimExp"
 157 val valueTypeInfo = Trace.info "ClosureConvert.valueType"
 158
 159 structure LambdaFree = LambdaFree (Sxml)
 160
 161 local
 162    open LambdaFree
 163 in
 164    structure Status = Status
 165 end
 166
 167 structure LambdaInfo =
 168    struct
 169       datatype t =
 170          T of {
 171                con: Con.t ref,
 172                frees: Var.t vector ref,
 173                (* name is the original name in the source (i.e. SXML) program,
 174                 * so the closure conversion output has some readability.
 175                 *)
 176                name: Func.t,
 177                recs: Var.t vector ref,
 178                (* The type of its environment record. *)
 179                ty: Type.t option ref
 180                }
 181
 182       fun frees (T {frees, ...}) = !frees
 183    end
 184
 185 structure VarInfo =
 186    struct
 187       type t = {frees: Var.t list ref ref,
 188                 isGlobal: bool ref,
 189                 lambda: Slambda.t option,
 190                 replacement: Var.t ref,
 191                 status: Status.t ref,
 192                 value: Value.t}
 193
 194       local
 195          fun make sel (r: t) = sel r
 196       in
 197          val lambda = valOf o make #lambda
 198          val value = make #value
 199       end
 200    end
 201
 202 val traceLoopBind =
 203    Trace.trace
 204    ("ClosureConvert.loopBind",
 205     fn {exp, ty = _: Stype.t, var} =>
 206     Layout.record [("var", Var.layout var),
 207                    ("exp", SprimExp.layout exp)],
 208     Unit.layout)
 209
 210 fun closureConvert
 211    (program as Sxml.Program.T {datatypes, body, overflow}): Ssa.Program.t =
 212    let
 213       val {get = conArg: Con.t -> Value.t option, set = setConArg, ...} =
 214          Property.getSetOnce (Con.plist,
 215                               Property.initRaise ("conArg", Con.layout))
 216       val {get = varInfo: Var.t -> VarInfo.t, set = setVarInfo, ...} =
 217          Property.getSetOnce
 218          (Var.plist, Property.initRaise ("closure convert info", Var.layout))
 219       val varInfo =
 220          Trace.trace
 221          ("ClosureConvert.varInfo", Var.layout, Layout.ignore)
 222          varInfo
 223       val varExpInfo = varInfo o SvarExp.var
 224       val isGlobal = ! o #isGlobal o varInfo
 225       val isGlobal =
 226          Trace.trace
 227          ("ClosureConvert.isGlobal", Var.layout, Bool.layout)
 228          isGlobal
 229       val value = #value o varInfo
 230       val varExp = value o SvarExp.var
 231       val expValue = varExp o Sexp.result
 232       (* ---------------------------------- *)
 233       (*             lambdaInfo             *)
 234       (* ---------------------------------- *)
 235       val {get = lambdaInfo: Slambda.t -> LambdaInfo.t,
 236            set = setLambdaInfo, ...} =
 237          Property.getSetOnce
 238          (Slambda.plist,
 239           Property.initRaise ("closure convert info", Layout.ignore))
 240       val allLambdas: Slambda.t list ref = ref []
 241       (* Do the flow analysis.
 242        * Initialize lambdaInfo and varInfo.
 243        *)
 244       val _ =
 245          Vector.foreach
 246          (datatypes, fn {cons, ...} =>
 247           Vector.foreach
 248           (cons, fn {con, arg} =>
 249            setConArg (con, (case arg of
 250                                NONE => NONE
 251                              | SOME t => SOME (Value.fromType t)))))
 252       val _ =
 253          let
 254             open Sxml
 255             val bogusFrees = ref []
 256             fun newVar' (x, v, lambda) =
 257                setVarInfo (x, {frees = ref bogusFrees,
 258                                isGlobal = ref false,
 259                                lambda = lambda,
 260                                replacement = ref x,
 261                                status = ref Status.init,
 262                                value = v})
 263             fun newVar (x, v) = newVar' (x, v, NONE)
 264             val newVar =
 265                Trace.trace2
 266                ("ClosureConvert.newVar",
 267                 Var.layout, Layout.ignore, Unit.layout)
 268                newVar
 269             fun varExps xs = Vector.map (xs, varExp)
 270             fun loopExp (e: Exp.t): Value.t =
 271                let
 272                   val {decs, result} = Exp.dest e
 273                   val () = List.foreach (decs, loopDec)
 274                in
 275                   varExp result
 276                end
 277             and loopDec (d: Dec.t): unit =
 278                let
 279                   datatype z = datatype Dec.t
 280                in
 281                   case d of
 282                      Fun {decs, ...} =>
 283                         (Vector.foreach (decs, fn {var, lambda, ty, ...} =>
 284                                          newVar' (var, Value.fromType ty,
 285                                                   SOME lambda))
 286                          ; (Vector.foreach
 287                             (decs, fn {var, lambda, ...} =>
 288                              Value.unify (value var,
 289                                           loopLambda (lambda, var)))))
 290                    | MonoVal b => loopBind b
 291                    | _ => Error.bug "ClosureConvert.loopDec: strange dec"
 292                end
 293             and loopBind arg =
 294                traceLoopBind
 295                (fn {var, ty, exp} =>
 296                let
 297                   fun set v = newVar (var, v)
 298                   fun new () =
 299                      let val v = Value.fromType ty
 300                      in set v; v
 301                      end
 302                   val new' = ignore o new
 303                   datatype z = datatype PrimExp.t
 304                in
 305                   case exp of
 306                      App {func, arg} =>
 307                         let val arg = varExp arg
 308                            val result = new ()
 309                         in Value.addHandler
 310                            (varExp func, fn l =>
 311                             let
 312                                val lambda = Value.Lambda.dest l
 313                                val {arg = formal, body, ...} =
 314                                   Lambda.dest lambda
 315                             in Value.coerce {from = arg,
 316                                              to = value formal}
 317                                ; Value.coerce {from = expValue body,
 318                                                to = result}
 319                             end)
 320                         end
 321                    | Case {cases, default, ...} =>
 322                         let
 323                            val result = new ()
 324                            fun branch e =
 325                               Value.coerce {from = loopExp e, to = result}
 326                            fun handlePat (Pat.T {con, arg, ...}) =
 327                               case (arg,      conArg con) of
 328                                  (NONE,        NONE)       => ()
 329                                | (SOME (x, _), SOME v)     => newVar (x, v)
 330                                | _ => Error.bug "ClosureConvert.loopBind: Case"
 331                            val _ = Cases.foreach' (cases, branch, handlePat)
 332                            val _ = Option.app (default, branch o #1)
 333                         in ()
 334                         end
 335                    | ConApp {con, arg, ...} =>
 336                         (case (arg,    conArg con) of
 337                             (NONE,   NONE)       => ()
 338                           | (SOME x, SOME v)     =>
 339                                Value.coerce {from = varExp x, to = v}
 340                           | _ => Error.bug "ClosureConvert.loopBind: ConApp"
 341                          ; new' ())
 342                    | Const _ => new' ()
 343                    | Handle {try, catch = (x, t), handler} =>
 344                         let
 345                            val result = new ()
 346                         in Value.coerce {from = loopExp try, to = result}
 347                            ; newVar (x, Value.fromType t)
 348                            ; Value.coerce {from = loopExp handler, to = result}
 349                         end
 350                    | Lambda l => set (loopLambda (l, var))
 351                    | PrimApp {prim, args, ...} =>
 352                         set (Value.primApply {prim = prim,
 353                                               args = varExps args,
 354                                               resultTy = ty})
 355                    | Profile _ => new' ()
 356                    | Raise _ => new' ()
 357                    | Select {tuple, offset} =>
 358                         set (Value.select (varExp tuple, offset))
 359                    | Tuple xs =>
 360                         if Value.typeIsFirstOrder ty
 361                            then new' ()
 362                       else set (Value.tuple (Vector.map (xs, varExp)))
 363                    | Var x => set (varExp x)
 364                end) arg
 365             and loopLambda (lambda: Lambda.t, x: Var.t): Value.t =
 366                let
 367                   val _ = List.push (allLambdas, lambda)
 368                   val {arg, argType, body, ...} = Lambda.dest lambda
 369                   val _ =
 370                      setLambdaInfo
 371                      (lambda,
 372                       LambdaInfo.T {con = ref Con.bogus,
 373                                     frees = ref (Vector.new0 ()),
 374                                     name = Func.newString (Var.originalName x),
 375                                     recs = ref (Vector.new0 ()),
 376                                     ty = ref NONE})
 377                   val _ = newVar (arg, Value.fromType argType)
 378                in
 379                   Value.lambda (lambda,
 380                                 Type.arrow (argType, Value.ty (loopExp body)))
 381                end
 382             val _ =
 383                Control.trace (Control.Pass, "flow analysis")
 384                loopExp body
 385          in ()
 386          end
 387       val _ =
 388          Control.diagnostics
 389          (fn display =>
 390           Sexp.foreachBoundVar
 391           (body, fn (x, _, _) => display (let open Layout
 392                                           in seq [Var.layout x,
 393                                                   str " ",
 394                                                   Value.layout (value x)]
 395                                           end)))
 396       val overflow = valOf overflow
 397       val _ =
 398          Control.trace (Control.Pass, "free variables")
 399          LambdaFree.lambdaFree
 400          {program = program,
 401           overflow = overflow,
 402           varInfo = fn x => let val {frees, status, ...} = varInfo x
 403                             in {frees = frees, status = status}
 404                             end,
 405           lambdaInfo = fn l => let val LambdaInfo.T {frees, recs, ...} = lambdaInfo l
 406                                in {frees = frees, recs = recs}
 407                                end}
 408       val _ =
 409          if !Control.closureConvertGlobalize
 410             then Control.trace (Control.Pass, "globalize")
 411                  Globalize.globalize {program = program,
 412                                       lambdaFree = LambdaInfo.frees o lambdaInfo,
 413                                       varGlobal = #isGlobal o varInfo}
 414          else ()
 415       local
 416          fun removeGlobal v = Vector.keepAll (v, not o isGlobal)
 417          val _ =
 418             List.foreach (!allLambdas, fn l =>
 419                           let
 420                              val LambdaInfo.T {frees, recs, ...} = lambdaInfo l
 421                           in
 422                              frees := removeGlobal (!frees)
 423                              ; recs := removeGlobal (!recs)
 424                           end)
 425       in
 426       end
 427       val {get = lambdasInfoOpt, ...} =
 428          Property.get (Lambdas.plist, Property.initFun (fn _ => ref NONE))
 429       val (convertType, destroyConvertType) =
 430          let
 431             val {get, set, destroy, ...} =
 432                Property.destGetSetOnce (Tycon.plist, Property.initConst NONE)
 433
 434             fun nullary c v =
 435                if Vector.isEmpty v
 436                   then c
 437                else Error.bug "ClosureConvert.convertType.nullary: bogus application of nullary tycon"
 438
 439             fun unary make v =
 440                if 1 = Vector.length v
 441                   then make (Vector.first v)
 442                else Error.bug "ClosureConvert.convertType.unary: bogus application of unary tycon"
 443             val tycons =
 444                [(Tycon.arrow, fn _ => Error.bug "ClosureConvert.convertType.array"),
 445                 (Tycon.array, unary Type.array),
 446                 (Tycon.cpointer, nullary Type.cpointer),
 447                 (Tycon.intInf, nullary Type.intInf),
 448                 (Tycon.reff, unary Type.reff),
 449                 (Tycon.thread, nullary Type.thread),
 450                 (Tycon.tuple, Type.tuple),
 451                 (Tycon.vector, unary Type.vector),
 452                 (Tycon.weak, unary Type.weak)]
 453                @ Vector.toListMap (Tycon.reals, fn (t, s) => (t, nullary (Type.real s)))
 454                @ Vector.toListMap (Tycon.words, fn (t, s) => (t, nullary (Type.word s)))
 455
 456             val _ = List.foreach (tycons, fn (tycon, f) => set (tycon, SOME f))
 457
 458             val {hom = convertType, destroy = destroyConvertType} =
 459                Stype.makeMonoHom
 460                {con = fn (_, tycon, ts) =>
 461                 case get tycon of
 462                    NONE => nullary (Type.datatypee tycon) ts
 463                  | SOME f => f ts}
 464          in
 465             (convertType,
 466              fn () => (destroy () ; destroyConvertType ()))
 467          end
 468       (* newDatatypes accumulates the new datatypes built for sets of lambdas. *)
 469       val newDatatypes: Datatype.t list ref = ref []
 470       fun valueType arg: Type.t =
 471          Trace.traceInfo (valueTypeInfo,
 472                           Layout.ignore,
 473                           Type.layout,
 474                           Trace.assertTrue)
 475          (fn (v: Value.t) =>
 476          let
 477             val r = Value.ssaType v
 478          in
 479             case !r of
 480                SOME t => t
 481              | NONE =>
 482                   let
 483                      val t =
 484                         case Value.dest v of
 485                            Value.Array v => Type.array (valueType v)
 486                          | Value.Lambdas ls => #ty (lambdasInfo ls)
 487                          | Value.Ref v => Type.reff (valueType v)
 488                          | Value.Type t => convertType t
 489                          | Value.Tuple vs =>
 490                               Type.tuple (Vector.map (vs, valueType))
 491                          | Value.Vector v => Type.vector (valueType v)
 492                          | Value.Weak v => Type.weak (valueType v)
 493                   in r := SOME t; t
 494                   end
 495          end) arg
 496       and lambdasInfo (ls: Lambdas.t): {cons: {lambda: Slambda.t,
 497                                                con: Con.t} vector,
 498                                         ty: Type.t} =
 499          let
 500             val r = lambdasInfoOpt ls
 501          in
 502             case !r of
 503                SOME info => info
 504              | NONE =>
 505                   let
 506                      val tycon = Tycon.newString "lambdas"
 507                      val cons =
 508                         Vector.fromListMap
 509                         (Lambdas.toList ls, fn l =>
 510                          {lambda = Value.Lambda.dest l,
 511                           con = Con.newString "Env"})
 512                      val ty = Type.datatypee tycon
 513                      val info = {ty = ty, cons = cons}
 514                      val _ = r := SOME info
 515                      (* r must be set before the following, because calls to
 516                       * lambdaInfoType may refer to the type of this lambdasInfo.
 517                       *)
 518                      val cons =
 519                         Vector.map
 520                         (cons, fn {con, lambda} =>
 521                          {con = con,
 522                           args = Vector.new1 (lambdaInfoType
 523                                               (lambdaInfo lambda))})
 524                      val _ = List.push (newDatatypes,
 525                                         Datatype.T {tycon = tycon,
 526                                                     cons = cons})
 527                   in
 528                      info
 529                   end
 530          end
 531       and varInfoType ({value, ...}: VarInfo.t) = valueType value
 532       and lambdaInfoType (LambdaInfo.T {frees, ty, ...}): Type.t =
 533          case !ty of
 534             NONE =>
 535                let val t = Type.tuple (Vector.map
 536                                         (!frees, varInfoType o varInfo))
 537                in ty := SOME t; t
 538                end
 539           | SOME t => t
 540       fun valueLambdasInfo v =
 541          case Value.dest v of
 542             Value.Lambdas l => lambdasInfo l
 543           | _ => Error.bug "ClosureConvert.valueLambdasInfo: non-lambda"
 544       val varLambdasInfo = valueLambdasInfo o value
 545       val emptyTypes = Vector.new0 ()
 546       val datatypes =
 547          Vector.map
 548          (datatypes, fn {tycon, cons, ...} =>
 549           Datatype.T
 550           {tycon = tycon,
 551            cons = (Vector.map
 552                    (cons, fn {con, ...} =>
 553                     {con = con,
 554                      args = (case conArg con of
 555                                 NONE => emptyTypes
 556                               | SOME v => Vector.new1 (valueType v))}))})
 557       (* Variable renaming *)
 558       fun newVarInfo (x: Var.t, {isGlobal, replacement, ...}: VarInfo.t): Var.t =
 559          if !isGlobal
 560             then x
 561          else let val x' = Var.new x
 562               in replacement := x'; x'
 563               end
 564       fun newVar x = newVarInfo (x, varInfo x)
 565       val newVar = Trace.trace ("ClosureConvert.newVar", Var.layout, Var.layout) newVar
 566       fun newScope (xs: Var.t vector, f: Var.t vector -> 'a): 'a =
 567          let
 568             val old = Vector.map (xs, ! o #replacement o varInfo)
 569             val res = f (Vector.map (xs, newVar))
 570             val _ = Vector.foreach2 (xs, old, fn (x, x') =>
 571                                      #replacement (varInfo x) := x')
 572          in
 573             res
 574          end
 575       (*------------------------------------*)
 576       (*               coerce               *)
 577       (*------------------------------------*)
 578       val traceCoerce =
 579          Trace.trace3
 580          ("ClosureConvert.coerce",
 581           Dexp.layout, Value.layout, Value.layout, Dexp.layout)
 582       (*       val traceCoerceTuple =
 583        *         let val layoutValues = List.layout (", ", Value.layout)
 584        *         in Trace.trace3 ("ClosureConvert.coerceTuple", Dexp.layout,
 585        *                         layoutValues, layoutValues, Dexp.layout)
 586        *         end
 587        *)
 588       fun coerce arg: Dexp.t =
 589          traceCoerce
 590          (fn (e: Dexp.t, from: Value.t, to: Value.t) =>
 591           if Value.equals (from, to)
 592              then e
 593           else
 594              case (Value.dest from, Value.dest to) of
 595                 (Value.Tuple vs, Value.Tuple vs') =>
 596                    coerceTuple (e, valueType from, vs, valueType to, vs')
 597               | (Value.Lambdas ls, Value.Lambdas ls') =>
 598                    if Lambdas.equals (ls, ls')
 599                       then e
 600                    else
 601                       let
 602                          val {cons, ...} = lambdasInfo ls
 603                          val {cons = cons', ty, ...} = lambdasInfo ls'
 604                          val _ =
 605                             Vector.foreach
 606                             (cons', fn {lambda, con, ...} =>
 607                              let
 608                                 val LambdaInfo.T {con = r, ...} =
 609                                    lambdaInfo lambda
 610                              in r := con
 611                              end)
 612                          val exp =
 613                             Dexp.casee
 614                             {test = e,
 615                              default = NONE,
 616                              ty = ty,
 617                              cases =
 618                              Dexp.Con
 619                              (Vector.map
 620                               (cons, fn {lambda, con} =>
 621                                let
 622                                   val info as LambdaInfo.T {con = r, ...} =
 623                                      lambdaInfo lambda
 624                                   val tuple = (Var.newNoname (),
 625                                                lambdaInfoType info)
 626                                in {con = con,
 627                                    args = Vector.new1 tuple,
 628                                    body = (Dexp.conApp
 629                                            {con = !r,
 630                                             ty = ty,
 631                                             args =
 632                                             Vector.new1 (Dexp.var tuple)})}
 633                                end))}
 634                       in exp
 635                       end
 636               | _ => Error.bug "ClosureConvert.coerce") arg
 637       and coerceTuple arg =
 638          (*      traceCoerceTuple *)
 639          (fn (e: Dexp.t,
 640               ty: Type.t, vs: Value.t vector,
 641               ty': Type.t, vs': Value.t vector) =>
 642           if Type.equals (ty, ty')
 643              then e
 644           else
 645              Dexp.detuple
 646              {tuple = e,
 647               length = Vector.length vs,
 648               body =
 649               fn components =>
 650               Dexp.tuple
 651               {exps = Vector.map3 (components, vs, vs',
 652                                    fn (x, v, v') =>
 653                                    coerce (Dexp.var (x, valueType v), v, v')),
 654                ty = ty'}}) arg
 655       fun convertVarInfo (info as {replacement, ...}: VarInfo.t) =
 656          Dexp.var (!replacement, varInfoType info)
 657       val convertVar = convertVarInfo o varInfo
 658       val convertVarExp = convertVar o SvarExp.var
 659       val handlesSignals =
 660          Sexp.hasPrim (body, fn p =>
 661                        case Prim.name p of
 662                           Prim.Name.MLton_installSignalHandler => true
 663                         | _ => false)
 664       (*------------------------------------*)
 665       (*               apply                *)
 666       (*------------------------------------*)
 667       fun apply {func, arg, resultVal}: Dexp.t =
 668          let
 669             val func = varExpInfo func
 670             val arg = varExpInfo arg
 671             val funcVal = VarInfo.value func
 672             val argVal = VarInfo.value arg
 673             val argExp = convertVarInfo arg
 674             val ty = valueType resultVal
 675             val {cons, ...} = valueLambdasInfo funcVal
 676          in Dexp.casee
 677             {test = convertVarInfo func,
 678              ty = ty,
 679              default = NONE,
 680              cases =
 681              Dexp.Con
 682              (Vector.map
 683               (cons, fn {lambda, con} =>
 684                let
 685                   val {arg = param, body, ...} = Slambda.dest lambda
 686                   val info as LambdaInfo.T {name, ...} = lambdaInfo lambda
 687                   val result = expValue body
 688                   val env = (Var.newString "env", lambdaInfoType info)
 689                in {con = con,
 690                    args = Vector.new1 env,
 691                    body = coerce (Dexp.call
 692                                   {func = name,
 693                                    args = Vector.new2 (Dexp.var env,
 694                                                        coerce (argExp, argVal,
 695                                                                value param)),
 696                                    ty = valueType result},
 697                                   result, resultVal)}
 698                end))}
 699          end
 700       (*------------------------------------*)
 701       (*             convertExp             *)
 702       (*------------------------------------*)
 703       fun lambdaInfoTuple (info as LambdaInfo.T {frees, ...}): Dexp.t =
 704          Dexp.tuple {exps = Vector.map (!frees, convertVar),
 705                      ty = lambdaInfoType info}
 706       fun recursives (old: Var.t vector, new: Var.t vector, env) =
 707          Vector.fold2
 708          (old, new, [], fn (old, new, ac) =>
 709           let
 710              val {cons, ty, ...} = varLambdasInfo old
 711              val l = VarInfo.lambda (varInfo old)
 712           in
 713              case Vector.peek (cons, fn {lambda = l', ...} =>
 714                                Slambda.equals (l, l')) of
 715                 NONE => Error.bug "ClosureConvert.recursives: lambda must exist in its own set"
 716               | SOME {con, ...} =>
 717                    {var = new,
 718                     ty = ty,
 719                     exp = Dexp.conApp {con = con, ty = ty,
 720                                        args = Vector.new1 (Dexp.var env)}}
 721                    :: ac
 722           end)
 723       val recursives =
 724          Trace.trace ("ClosureConvert.recursives",
 725                       fn (a, b, _) =>
 726                       Layout.tuple [Vector.layout Var.layout a,
 727                                     Vector.layout Var.layout b],
 728                       Layout.ignore)
 729          recursives
 730       val raises: Type.t vector option =
 731          let
 732             exception Yes of Type.t vector
 733          in
 734             (Sexp.foreachPrimExp
 735              (body, fn (_, _, e) =>
 736               case e of
 737                  SprimExp.Handle {catch = (x, _), ...} =>
 738                     raise (Yes (Vector.new1 (varInfoType (varInfo x))))
 739                | _ => ())
 740              ; NONE)
 741             handle Yes ts => SOME ts
 742          end
 743       val shrinkFunction =
 744          if !Control.closureConvertShrink
 745             then Ssa.shrinkFunction {globals = Vector.new0 ()}
 746          else fn f => f
 747       fun addFunc (ac, {args, body, isMain, mayInline, name, returns}) =
 748          let
 749             val (start, blocks) =
 750                Dexp.linearize (body, Ssa.Handler.Caller)
 751             val f =
 752                shrinkFunction
 753                (Function.new {args = args,
 754                               blocks = Vector.fromList blocks,
 755                               mayInline = mayInline,
 756                               name = name,
 757                               raises = if isMain
 758                                           then NONE
 759                                           else raises,
 760                               returns = SOME returns,
 761                               start = start})
 762             val f =
 763                if isMain
 764                   then Function.profile (f, SourceInfo.main)
 765                else f
 766          in
 767             Accum.addFunc (ac, f)
 768          end
 769       (* Closure convert an expression, returning:
 770        *   - the target ssa expression
 771        *   - a list of global declarations (in order)
 772        *   - a list of function declarations
 773        * Accumulate the globals onto the end of the given ones.
 774        *)
 775       fun convertExp (e: Sexp.t, ac: Accum.t): Dexp.t * Accum.t =
 776          let
 777             val {decs, result} = Sexp.dest e
 778             (* Process decs left to right, since bindings of variables
 779              * must be visited before uses.
 780              *)
 781             val (decs, ac) =
 782                List.fold
 783                (decs, ([], ac), fn (d, (binds, ac)) =>
 784                 case d of
 785                    Sdec.MonoVal {exp, var, ...} =>
 786                       let
 787                          val info as {isGlobal, value, ...} = varInfo var
 788                          val (exp, ac) = convertPrimExp (exp, value, ac)
 789                          val bind = {var = newVarInfo (var, info),
 790                                      ty = valueType value,
 791                                      exp = exp}
 792                       in if !isGlobal
 793                             then (binds, Accum.addGlobal (ac, bind))
 794                          else (bind :: binds, ac)
 795                       end
 796                  | Sdec.Fun {decs, ...} =>
 797                       if Vector.isEmpty decs
 798                          then (binds, ac)
 799                       else
 800                          let
 801                             val {lambda, var, ...} = Vector.first decs
 802                             val info = lambdaInfo lambda
 803                             val tupleVar = Var.newString "tuple"
 804                             val tupleTy = lambdaInfoType info
 805                             val binds' =
 806                                {var = tupleVar,
 807                                 ty = tupleTy,
 808                                 exp = lambdaInfoTuple info}
 809                                :: (recursives
 810                                    (Vector.map (decs, #var),
 811                                     Vector.map (decs, newVar o #var),
 812                                     (tupleVar, tupleTy)))
 813                             val (binds, ac) =
 814                                if isGlobal var
 815                                   then (binds, Accum.addGlobals (ac, binds'))
 816                                else (List.fold (binds', binds, op ::), ac)
 817                          in (binds,
 818                              Vector.fold (decs, ac, fn ({lambda, ...}, ac) =>
 819                                           convertLambda (lambda,
 820                                                          lambdaInfo lambda,
 821                                                          ac)))
 822                          end
 823                  | _ => Error.bug "ClosureConvert.convertExp: strange dec")
 824          in (Dexp.lett {decs = List.fold (decs, [], fn ({var, exp, ...}, ac) =>
 825                                           {var = var, exp = exp} :: ac),
 826                         body = convertVarExp result},
 827              ac)
 828          end
 829       and convertPrimExp arg : Dexp.t * Accum.t =
 830          Trace.traceInfo (convertPrimExpInfo,
 831                           SprimExp.layout o #1,
 832                           Layout.ignore,
 833                           Trace.assertTrue)
 834          (fn (e: SprimExp.t, v: Value.t, ac: Accum.t) =>
 835          let
 836             val ty = valueType v
 837             fun convertJoin (e, ac) =
 838                let val (e', ac) = convertExp (e, ac)
 839                in (coerce (e', expValue e, v), ac)
 840                end
 841             fun simple e = (e, ac)
 842          in
 843             case e of
 844                SprimExp.App {func, arg} =>
 845                   (apply {func = func, arg = arg, resultVal = v},
 846                    ac)
 847              | SprimExp.Case {test, cases, default} =>
 848                   let
 849                      val (default, ac) =
 850                         case default of
 851                            NONE => (NONE, ac)
 852                          | SOME (e, _) => let
 853                                              val (e, ac) =  convertJoin (e, ac)
 854                                           in
 855                                              (SOME e, ac)
 856                                           end
 857                      fun doCases (cases, finish, make) =
 858                         let
 859                            val (cases, ac) =
 860                               Vector.mapAndFold
 861                               (cases, ac, fn ((x, e), ac) =>
 862                                let
 863                                   val make = make x
 864                                   val (body, ac) = convertJoin (e, ac)
 865                                in (make body, ac)
 866                                end)
 867                         in (finish cases, ac)
 868                         end
 869                      val (cases, ac) =
 870                         case cases of
 871                            Scases.Con cases =>
 872                               doCases
 873                               (cases, Dexp.Con,
 874                                fn Spat.T {con, arg, ...} =>
 875                                let
 876                                   val args =
 877                                      case (conArg con, arg) of
 878                                         (NONE, NONE) => Vector.new0 ()
 879                                       | (SOME v, SOME (arg, _)) =>
 880                                            Vector.new1 (newVar arg, valueType v)
 881                                       | _ => Error.bug "ClosureConvert.convertPrimExp: Case,constructor mismatch"
 882                                in
 883                                   fn body => {args = args,
 884                                               body = body,
 885                                               con = con}
 886                                end)
 887                          | Scases.Word (s, cs) =>
 888                               doCases (cs, fn cs => Dexp.Word (s, cs),
 889                                        fn i => fn e => (i, e))
 890                   in (Dexp.casee
 891                       {test = convertVarExp test,
 892                        ty = ty, cases = cases, default = default},
 893                       ac)
 894                   end
 895              | SprimExp.ConApp {con = con, arg, ...} =>
 896                   simple
 897                   (Dexp.conApp
 898                    {con = con,
 899                     ty = ty,
 900                     args = (case (arg, conArg con) of
 901                                (NONE, NONE) => Vector.new0 ()
 902                              | (SOME arg, SOME conArg) =>
 903                                   let
 904                                      val arg = varExpInfo arg
 905                                      val argVal = VarInfo.value arg
 906                                      val arg = convertVarInfo arg
 907                                   in if Value.equals (argVal, conArg)
 908                                         then Vector.new1 arg
 909                                      else Vector.new1 (coerce (arg, argVal, conArg))
 910                                   end
 911                              | _ => Error.bug "ClosureConvert.convertPrimExp: ConApp,constructor mismatch")})
 912              | SprimExp.Const c => simple (Dexp.const c)
 913              | SprimExp.Handle {try, catch = (catch, _), handler} =>
 914                   let
 915                      val catchInfo = varInfo catch
 916                      val (try, ac) = convertJoin (try, ac)
 917                      val catch = (newVarInfo (catch, catchInfo),
 918                                   varInfoType catchInfo)
 919                      val (handler, ac) = convertJoin (handler, ac)
 920                   in (Dexp.handlee {try = try, ty = ty,
 921                                     catch = catch, handler = handler},
 922                       ac)
 923                   end
 924              | SprimExp.Lambda l =>
 925                   let
 926                      val info = lambdaInfo l
 927                      val ac = convertLambda (l, info, ac)
 928                      val {cons, ...} = valueLambdasInfo v
 929                   in case Vector.peek (cons, fn {lambda = l', ...} =>
 930                                        Slambda.equals (l, l')) of
 931                      NONE => Error.bug "ClosureConvert.convertPrimExp: Lambda,lambda must exist in its own set"
 932                    | SOME {con, ...} =>
 933                         (Dexp.conApp {con = con, ty = ty,
 934                                       args = Vector.new1 (lambdaInfoTuple info)},
 935                          ac)
 936                   end
 937              | SprimExp.PrimApp {prim, targs, args} =>
 938                   let
 939                      val prim = Prim.map (prim, convertType)
 940                      open Prim.Name
 941                      fun arg i = Vector.sub (args, i)
 942                      val v1 = Vector.new1
 943                      val v2 = Vector.new2
 944                      val v3 = Vector.new3
 945                      fun primApp (targs, args) =
 946                         Dexp.primApp {args = args,
 947                                       prim = prim,
 948                                       targs = targs,
 949                                       ty = ty}
 950                   in
 951                      if Prim.mayOverflow prim
 952                         then simple (Dexp.arith
 953                                      {args = Vector.map (args, convertVarExp),
 954                                       overflow = Dexp.raisee (convertVar overflow),
 955                                       prim = prim,
 956                                       ty = ty})
 957                      else
 958                         let
 959                            datatype z = datatype Prim.Name.t
 960                         in
 961                            simple
 962                            (case Prim.name prim of
 963                                Array_update =>
 964                                   let
 965                                      val a = varExpInfo (arg 0)
 966                                      val y = varExpInfo (arg 2)
 967                                      val v = Value.deArray (VarInfo.value a)
 968                                   in
 969                                      primApp (v1 (valueType v),
 970                                               v3 (convertVarInfo a,
 971                                                   convertVarExp (arg 1),
 972                                                   coerce (convertVarInfo y,
 973                                                           VarInfo.value y, v)))
 974                                   end
 975                              | MLton_eq =>
 976                                   let
 977                                      val a0 = varExpInfo (arg 0)
 978                                      val a1 = varExpInfo (arg 1)
 979                                      fun doit () =
 980                                         primApp (v1 (valueType (VarInfo.value a0)),
 981                                                  v2 (convertVarInfo a0,
 982                                                      convertVarInfo a1))
 983                                   in
 984                                      case (Value.dest (VarInfo.value a0),
 985                                            Value.dest (VarInfo.value a1)) of
 986                                         (Value.Lambdas l, Value.Lambdas l') =>
 987                                            if Lambdas.equals (l, l')
 988                                               then doit ()
 989                                            else Dexp.falsee
 990                                       | _ => doit ()
 991                                   end
 992                              | MLton_equal =>
 993                                   let
 994                                      val a0 = varExpInfo (arg 0)
 995                                      val a1 = varExpInfo (arg 1)
 996                                      fun doit () =
 997                                         primApp (v1 (valueType (VarInfo.value a0)),
 998                                                  v2 (convertVarInfo a0,
 999                                                      convertVarInfo a1))
1000                                   in
1001                                      case (Value.dest (VarInfo.value a0),
1002                                            Value.dest (VarInfo.value a1)) of
1003                                         (Value.Lambdas l, Value.Lambdas l') =>
1004                                            if Lambdas.equals (l, l')
1005                                               then doit ()
1006                                            else Dexp.falsee
1007                                       | _ => doit ()
1008                                   end
1009                              | MLton_handlesSignals =>
1010                                   if handlesSignals
1011                                      then Dexp.truee
1012                                   else Dexp.falsee
1013                              | Ref_assign =>
1014                                   let
1015                                      val r = varExpInfo (arg 0)
1016                                      val y = varExpInfo (arg 1)
1017                                      val v = Value.deRef (VarInfo.value r)
1018                                   in
1019                                      primApp (v1 (valueType v),
1020                                               v2 (convertVarInfo r,
1021                                                   coerce (convertVarInfo y,
1022                                                           VarInfo.value y, v)))
1023                                   end
1024                              | Ref_ref =>
1025                                   let
1026                                      val y = varExpInfo (arg 0)
1027                                      val v = Value.deRef v
1028                                   in
1029                                      primApp (v1 (valueType v),
1030                                               v1 (coerce (convertVarInfo y,
1031                                                           VarInfo.value y, v)))
1032                                   end
1033                              | MLton_serialize =>
1034                                   let
1035                                      val y = varExpInfo (arg 0)
1036                                      val v =
1037                                         Value.serialValue (Vector.first targs)
1038                                   in
1039                                      primApp (v1 (valueType v),
1040                                               v1 (coerce (convertVarInfo y,
1041                                                           VarInfo.value y, v)))
1042                                   end
1043                              | Vector_vector =>
1044                                   let
1045                                      val ys = Vector.map (args, varExpInfo)
1046                                      val v = Value.deVector v
1047                                   in
1048                                      primApp (v1 (valueType v),
1049                                               Vector.map (ys, fn y =>
1050                                                           coerce (convertVarInfo y,
1051                                                                   VarInfo.value y, v)))
1052                                   end
1053                              | Weak_new =>
1054                                   let
1055                                      val y = varExpInfo (arg 0)
1056                                      val v = Value.deWeak v
1057                                   in
1058                                      primApp (v1 (valueType v),
1059                                               v1 (coerce (convertVarInfo y,
1060                                                           VarInfo.value y, v)))
1061                                   end
1062                              | _ =>
1063                                   let
1064                                      val args = Vector.map (args, varExpInfo)
1065                                   in
1066                                      primApp
1067                                      (Prim.extractTargs
1068                                       (prim,
1069                                        {args = Vector.map (args, varInfoType),
1070                                         result = ty,
1071                                         typeOps = {deArray = Type.deArray,
1072                                                    deArrow = fn _ => Error.bug "ClosureConvert.convertPrimExp: deArrow",
1073                                                    deRef = Type.deRef,
1074                                                    deVector = Type.deVector,
1075                                                    deWeak = Type.deWeak}}),
1076                                        Vector.map (args, convertVarInfo))
1077                                   end)
1078                         end
1079                   end
1080              | SprimExp.Profile e => simple (Dexp.profile e)
1081              | SprimExp.Raise {exn, ...} =>
1082                   simple (Dexp.raisee (convertVarExp exn))
1083              | SprimExp.Select {offset, tuple} =>
1084                   simple (Dexp.select {offset = offset,
1085                                        tuple = convertVarExp tuple,
1086                                        ty = ty})
1087              | SprimExp.Tuple xs =>
1088                   simple (Dexp.tuple {exps = Vector.map (xs, convertVarExp),
1089                                       ty = ty})
1090              | SprimExp.Var y => simple (convertVarExp y)
1091          end) arg
1092       and convertLambda (lambda: Slambda.t,
1093                          info as LambdaInfo.T {frees, name, recs, ...},
1094                          ac: Accum.t): Accum.t =
1095          let
1096             val {arg = argVar, body, mayInline, ...} = Slambda.dest lambda
1097             val argVarInfo = varInfo argVar
1098             val env = Var.newString "env"
1099             val envType = lambdaInfoType info
1100             val args = Vector.new2 ((env, envType),
1101                                     (newVarInfo (argVar, argVarInfo),
1102                                      varInfoType argVarInfo))
1103             val returns = Vector.new1 (valueType (expValue body))
1104             val recs = !recs
1105          in
1106             newScope
1107             (!frees, fn components =>
1108              newScope
1109              (recs, fn recs' =>
1110               let
1111                  val decs = recursives (recs, recs', (env, envType))
1112                  val (body, ac) = convertExp (body, ac)
1113                  val body =
1114                     Dexp.lett
1115                     {decs = List.fold (decs, [], fn ({var, exp, ...}, ac) =>
1116                                        {var = var, exp = exp} :: ac),
1117                      body = Dexp.detupleBind {tuple = env,
1118                                               tupleTy = envType,
1119                                               components = components,
1120                                               body = body}}
1121               in
1122                  addFunc (ac, {args = args,
1123                                body = body,
1124                                isMain = false,
1125                                mayInline = mayInline,
1126                                name = name,
1127                                returns = returns})
1128               end))
1129          end
1130       (*------------------------------------*)
1131       (*    main body of closure convert    *)
1132       (*------------------------------------*)
1133       val main = Func.newString "main"
1134       val {functions, globals} =
1135          Control.trace (Control.Pass, "convert")
1136          (fn () =>
1137           let
1138              val (body, ac) = convertExp (body, Accum.empty)
1139              val ac = addFunc (ac, {args = Vector.new0 (),
1140                                     body = body,
1141                                     mayInline = false,
1142                                     isMain = true,
1143                                     name = main,
1144                                     returns = Vector.new1 Type.unit})
1145           in Accum.done ac
1146           end) ()
1147       val datatypes = Vector.concat [datatypes, Vector.fromList (!newDatatypes)]
1148       val program =
1149          Ssa.Program.T {datatypes = datatypes,
1150                         globals = globals,
1151                         functions = functions,
1152                         main = main}
1153       val _ = destroyConvertType ()
1154       val _ = Value.destroy ()
1155       val _ = Ssa.Program.clear program
1156    in
1157       program
1158    end
1159
1160 end