HCoop / hcoop / debian / mlton.git / blame
| Commit | Line | Data |
|---|---|---|
| 7f918cf1 CE |
1 | (* Copyright (C) 2015,2017 Matthew Fluet. |
| 2 | * Copyright (C) 1999-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 | functor Defunctorize (S: DEFUNCTORIZE_STRUCTS): DEFUNCTORIZE = | |
| 11 | struct | |
| 12 | ||
| 13 | open S | |
| 14 | ||
| 15 | local | |
| 16 | open CoreML | |
| 17 | in | |
| 18 | structure Const = Const | |
| 19 | structure Cdec = Dec | |
| 20 | structure Cexp = Exp | |
| 21 | structure Clambda = Lambda | |
| 22 | structure Cpat = Pat | |
| 23 | structure Prim = Prim | |
| 24 | structure RealSize = RealSize | |
| 25 | structure Record = Record | |
| 26 | structure SortedRecord = SortedRecord | |
| 27 | structure SourceInfo = SourceInfo | |
| 28 | structure Ctype = Type | |
| 29 | structure WordSize = WordSize | |
| 30 | structure WordX = WordX | |
| 31 | end | |
| 32 | ||
| 33 | structure Field = Record.Field | |
| 34 | ||
| 35 | local | |
| 36 | open Xml | |
| 37 | in | |
| 38 | structure Xcases = Cases | |
| 39 | structure Con = Con | |
| 40 | structure Xdec = Dec | |
| 41 | structure Xexp = DirectExp | |
| 42 | structure Xlambda = Lambda | |
| 43 | structure Xpat = Pat | |
| 44 | structure XprimExp = PrimExp | |
| 45 | structure Tycon = Tycon | |
| 46 | structure Xtype = Type | |
| 47 | structure Tyvar = Tyvar | |
| 48 | structure Var = Var | |
| 49 | structure XvarExp = VarExp | |
| 50 | end | |
| 51 | ||
| 52 | structure NestedPat = NestedPat (open Xml) | |
| 53 | ||
| 54 | structure MatchCompile = | |
| 55 | MatchCompile (open CoreML | |
| 56 | structure Type = Xtype | |
| 57 | structure NestedPat = NestedPat | |
| 58 | structure Cases = | |
| 59 | struct | |
| 60 | type exp = Xexp.t | |
| 61 | ||
| 62 | open Xcases | |
| 63 | type t = exp t | |
| 64 | val word = Word | |
| 65 | fun con v = | |
| 66 | Con (Vector.map | |
| 67 | (v, fn {con, targs, arg, rhs} => | |
| 68 | (Xpat.T {con = con, | |
| 69 | targs = targs, | |
| 70 | arg = arg}, | |
| 71 | rhs))) | |
| 72 | end | |
| 73 | structure Exp = | |
| 74 | struct | |
| 75 | open Xexp | |
| 76 | val lett = let1 | |
| 77 | val var = monoVar | |
| 78 | ||
| 79 | fun detuple {tuple, body} = | |
| 80 | Xexp.detuple | |
| 81 | {tuple = tuple, | |
| 82 | body = fn xts => body (Vector.map | |
| 83 | (xts, fn (x, t) => | |
| 84 | (XvarExp.var x, t)))} | |
| 85 | ||
| 86 | fun devector {vector, length, body} = | |
| 87 | Xexp.devector | |
| 88 | {vector = vector, | |
| 89 | length = length, | |
| 90 | body = fn xts => body (Vector.map | |
| 91 | (xts, fn (x, t) => | |
| 92 | (XvarExp.var x, t)))} | |
| 93 | end) | |
| 94 | ||
| 95 | structure Xexp = | |
| 96 | struct | |
| 97 | open Xexp | |
| 98 | ||
| 99 | local | |
| 100 | fun exn (c: Con.t): Xexp.t = | |
| 101 | conApp {arg = NONE, | |
| 102 | con = c, | |
| 103 | targs = Vector.new0 (), | |
| 104 | ty = Xtype.exn} | |
| 105 | in | |
| 106 | val bind = exn Con.bind | |
| 107 | val match = exn Con.match | |
| 108 | end | |
| 109 | end | |
| 110 | ||
| 111 | fun enterLeave (e: Xexp.t, t, si): Xexp.t = | |
| 112 | Xexp.fromExp (Xml.Exp.enterLeave (Xexp.toExp e, t, si), t) | |
| 113 | ||
| 114 | local | |
| 115 | val matchDiagnostics: (unit -> unit) list ref = ref [] | |
| 116 | in | |
| 117 | fun addMatchDiagnostic (diag, mkArg) = | |
| 118 | case diag of | |
| 119 | Control.Elaborate.DiagEIW.Error => | |
| 120 | List.push (matchDiagnostics, Control.error o mkArg) | |
| 121 | | Control.Elaborate.DiagEIW.Ignore => () | |
| 122 | | Control.Elaborate.DiagEIW.Warn => | |
| 123 | List.push (matchDiagnostics, Control.warning o mkArg) | |
| 124 | fun showMatchDiagnostics () = List.foreach (!matchDiagnostics, fn th => th ()) | |
| 125 | end | |
| 126 | ||
| 127 | fun casee {ctxt: unit -> Layout.t, | |
| 128 | caseType: Xtype.t, | |
| 129 | cases: {exp: Xexp.t, | |
| 130 | layPat: (unit -> Layout.t) option, | |
| 131 | pat: NestedPat.t, | |
| 132 | regionPat: Region.t} vector, | |
| 133 | conTycon, | |
| 134 | kind: (string * string), | |
| 135 | nest: string list, | |
| 136 | matchDiags: {nonexhaustiveExn: Control.Elaborate.DiagDI.t, | |
| 137 | nonexhaustive: Control.Elaborate.DiagEIW.t, | |
| 138 | redundant: Control.Elaborate.DiagEIW.t}, | |
| 139 | noMatch, | |
| 140 | region: Region.t, | |
| 141 | test = (test: Xexp.t, testType: Xtype.t), | |
| 142 | tyconCons}: Xexp.t = | |
| 143 | let | |
| 144 | val nonexhaustiveExnDiag = #nonexhaustiveExn matchDiags | |
| 145 | val nonexhaustiveDiag = #nonexhaustive matchDiags | |
| 146 | val redundantDiag = #redundant matchDiags | |
| 147 | val cases = Vector.map (cases, fn {exp, layPat, pat, regionPat} => | |
| 148 | {exp = fn () => exp, | |
| 149 | isDefault = false, | |
| 150 | layPat = layPat, | |
| 151 | numPats = ref 0, | |
| 152 | numUses = ref 0, | |
| 153 | pat = pat, | |
| 154 | regionPat = regionPat}) | |
| 155 | fun raiseExn (f, mayWrap) = | |
| 156 | let | |
| 157 | val e = Var.newNoname () | |
| 158 | val exp = Xexp.raisee {exn = f e, extend = true, ty = caseType} | |
| 159 | val exp = | |
| 160 | fn () => | |
| 161 | if let | |
| 162 | open Control | |
| 163 | in | |
| 164 | !profile <> ProfileNone | |
| 165 | andalso !profileIL = ProfileSource | |
| 166 | andalso !profileRaise | |
| 167 | end | |
| 168 | then case mayWrap of | |
| 169 | NONE => exp | |
| 170 | | SOME kind => | |
| 171 | enterLeave | |
| 172 | (exp, caseType, | |
| 173 | SourceInfo.function | |
| 174 | {name = (concat ["<raise ", kind, ">"]) :: nest, | |
| 175 | region = region}) | |
| 176 | else exp | |
| 177 | in | |
| 178 | Vector.concat | |
| 179 | [cases, | |
| 180 | Vector.new1 {exp = exp, | |
| 181 | isDefault = true, | |
| 182 | layPat = NONE, | |
| 183 | numPats = ref 0, | |
| 184 | numUses = ref 0, | |
| 185 | pat = NestedPat.make (NestedPat.Var e, testType), | |
| 186 | regionPat = Region.bogus}] | |
| 187 | end | |
| 188 | val cases = | |
| 189 | let | |
| 190 | datatype z = datatype Cexp.noMatch | |
| 191 | in | |
| 192 | case noMatch of | |
| 193 | Impossible => cases | |
| 194 | | RaiseAgain => | |
| 195 | raiseExn (fn e => Xexp.monoVar (e, Xtype.exn), NONE) | |
| 196 | | RaiseBind => raiseExn (fn _ => Xexp.bind, SOME "Bind") | |
| 197 | | RaiseMatch => raiseExn (fn _ => Xexp.match, SOME "Match") | |
| 198 | end | |
| 199 | fun matchCompile () = | |
| 200 | let | |
| 201 | val testVar = Var.newNoname () | |
| 202 | val decs = ref [] | |
| 203 | val cases = | |
| 204 | Vector.map | |
| 205 | (cases, fn {exp = e, numPats, numUses, pat = p, ...} => | |
| 206 | let | |
| 207 | val args = Vector.fromList (NestedPat.varsAndTypes p) | |
| 208 | val (vars, tys) = Vector.unzip args | |
| 209 | val func = Var.newNoname () | |
| 210 | val arg = Var.newNoname () | |
| 211 | val argType = Xtype.tuple tys | |
| 212 | val funcType = Xtype.arrow (argType, caseType) | |
| 213 | fun dec () = | |
| 214 | Xdec.MonoVal | |
| 215 | {var = func, | |
| 216 | ty = funcType, | |
| 217 | exp = | |
| 218 | XprimExp.Lambda | |
| 219 | (Xlambda.make | |
| 220 | {arg = arg, | |
| 221 | argType = argType, | |
| 222 | body = (Xexp.toExp | |
| 223 | (Xexp.detupleBind | |
| 224 | {tuple = Xexp.monoVar (arg, argType), | |
| 225 | components = vars, | |
| 226 | body = e ()})), | |
| 227 | mayInline = true})} | |
| 228 | fun finish np = | |
| 229 | (numPats := np | |
| 230 | ; fn rename => | |
| 231 | (if 0 = !numUses then List.push (decs, dec ()) else () | |
| 232 | ; Int.inc numUses | |
| 233 | ; (Xexp.app | |
| 234 | {func = Xexp.monoVar (func, funcType), | |
| 235 | arg = | |
| 236 | Xexp.tuple {exps = (Vector.map | |
| 237 | (args, fn (x, t) => | |
| 238 | Xexp.monoVar (rename x, t))), | |
| 239 | ty = argType}, | |
| 240 | ty = caseType}))) | |
| 241 | in | |
| 242 | (p, finish) | |
| 243 | end) | |
| 244 | val (body, nonexhaustiveExamples) = | |
| 245 | MatchCompile.matchCompile {caseType = caseType, | |
| 246 | cases = cases, | |
| 247 | conTycon = conTycon, | |
| 248 | region = region, | |
| 249 | test = testVar, | |
| 250 | testType = testType, | |
| 251 | tyconCons = tyconCons} | |
| 252 | (* Must convert to a normal expression to force everything. *) | |
| 253 | val body = Xexp.toExp body | |
| 254 | val nonexhaustiveExamples = | |
| 255 | if noMatch = Cexp.Impossible | |
| 256 | then NONE | |
| 257 | else let | |
| 258 | val dropOnlyExns = | |
| 259 | case nonexhaustiveExnDiag of | |
| 260 | Control.Elaborate.DiagDI.Default => | |
| 261 | {dropOnlyExns = false} | |
| 262 | | Control.Elaborate.DiagDI.Ignore => | |
| 263 | {dropOnlyExns = true} | |
| 264 | in | |
| 265 | nonexhaustiveExamples dropOnlyExns | |
| 266 | end | |
| 267 | in | |
| 268 | (Xexp.let1 {var = testVar, | |
| 269 | exp = test, | |
| 270 | body = Xexp.lett {decs = !decs, | |
| 271 | body = Xexp.fromExp (body, caseType)}}, | |
| 272 | nonexhaustiveExamples) | |
| 273 | end | |
| 274 | datatype z = datatype NestedPat.node | |
| 275 | fun lett (x, e) = Xexp.let1 {var = x, exp = test, body = e} | |
| 276 | fun wild e = lett (Var.newNoname (), e) | |
| 277 | val (exp, nonexhaustiveExamples) = | |
| 278 | if Vector.isEmpty cases | |
| 279 | then Error.bug "Defunctorize.casee: case with no patterns" | |
| 280 | else | |
| 281 | let | |
| 282 | val {exp = e, pat = p, numPats, numUses, ...} = Vector.first cases | |
| 283 | fun use () = (numPats := 1; numUses := 1) | |
| 284 | fun exhaustive exp = (exp, NONE) | |
| 285 | fun loop p = | |
| 286 | case NestedPat.node p of | |
| 287 | Wild => (use (); exhaustive (wild (e ()))) | |
| 288 | | Var x => (use (); exhaustive (lett (x, e ()))) | |
| 289 | | Record rps => | |
| 290 | let | |
| 291 | val ps = SortedRecord.range rps | |
| 292 | fun doitRecord () = | |
| 293 | (* It's a flat record pattern. | |
| 294 | * Generate the selects. | |
| 295 | *) | |
| 296 | let | |
| 297 | val _ = use () | |
| 298 | val t = Var.newNoname () | |
| 299 | val tuple = XvarExp.mono t | |
| 300 | val tys = Xtype.deTuple testType | |
| 301 | val (_, decs) = | |
| 302 | Vector.fold2 | |
| 303 | (ps, tys, (0, []), | |
| 304 | fn (p, ty, (i, decs)) => | |
| 305 | case NestedPat.node p of | |
| 306 | Var x => | |
| 307 | (i + 1, | |
| 308 | Xdec.MonoVal | |
| 309 | {var = x, | |
| 310 | ty = ty, | |
| 311 | exp = (XprimExp.Select | |
| 312 | {tuple = tuple, | |
| 313 | offset = i})} | |
| 314 | :: decs) | |
| 315 | | Wild => (i + 1, decs) | |
| 316 | | _ => Error.bug "Defunctorize.casee: flat record") | |
| 317 | in | |
| 318 | exhaustive (Xexp.let1 | |
| 319 | {var = t, exp = test, | |
| 320 | body = Xexp.lett | |
| 321 | {decs = decs, | |
| 322 | body = e ()}}) | |
| 323 | end | |
| 324 | in | |
| 325 | if Vector.forall (ps, NestedPat.isVarOrWild) | |
| 326 | then if Vector.length ps = 1 | |
| 327 | then loop (Vector.first ps) | |
| 328 | else doitRecord () | |
| 329 | else matchCompile () | |
| 330 | end | |
| 331 | | _ => matchCompile () | |
| 332 | in | |
| 333 | loop p | |
| 334 | end | |
| 335 | (* diagnoseRedundant *) | |
| 336 | val _ = | |
| 337 | Vector.foreachr | |
| 338 | (cases, fn {isDefault, layPat = layPat, | |
| 339 | numPats, numUses, regionPat = regionPat, ...} => | |
| 340 | let | |
| 341 | fun doit (msg1, msg2) = | |
| 342 | let | |
| 343 | open Layout | |
| 344 | in | |
| 345 | addMatchDiagnostic | |
| 346 | (redundantDiag, | |
| 347 | fn () => | |
| 348 | (regionPat, | |
| 349 | str (concat [#1 kind, msg1]), | |
| 350 | align [seq [str (concat [msg2, ": "]), | |
| 351 | case layPat of | |
| 352 | NONE => Error.bug "Defunctorize.casee: redundant match with no lay" | |
| 353 | | SOME layPat => layPat ()], | |
| 354 | ctxt ()])) | |
| 355 | end | |
| 356 | in | |
| 357 | if not isDefault andalso !numUses = 0 | |
| 358 | then ((* Rule with no uses; fully redundant. *) | |
| 359 | doit (" has redundant " ^ #2 kind, | |
| 360 | "redundant pattern")) | |
| 361 | else if not isDefault andalso !numUses > 0 andalso !numUses < !numPats | |
| 362 | then ((* Rule with some uses but fewer uses than pats; partially redundant. *) | |
| 363 | doit (" has " ^ #2 kind ^ " with redundancy", | |
| 364 | "pattern with redundancy")) | |
| 365 | else () | |
| 366 | end) | |
| 367 | (* diagnoseNonexhaustive *) | |
| 368 | val _ = | |
| 369 | Option.app | |
| 370 | (nonexhaustiveExamples, fn es => | |
| 371 | let | |
| 372 | open Layout | |
| 373 | in | |
| 374 | addMatchDiagnostic | |
| 375 | (nonexhaustiveDiag, | |
| 376 | fn () => | |
| 377 | (region, | |
| 378 | str (concat [#1 kind, " is not exhaustive"]), | |
| 379 | align [seq [str "missing pattern: ", es], | |
| 380 | ctxt ()])) | |
| 381 | end) | |
| 382 | in | |
| 383 | exp | |
| 384 | end | |
| 385 | ||
| 386 | val casee = | |
| 387 | Trace.trace ("Defunctorize.casee", | |
| 388 | Region.layout o #region, | |
| 389 | Xml.Exp.layout o Xexp.toExp) | |
| 390 | casee | |
| 391 | ||
| 392 | fun 'a sortByField (v: (Field.t * 'a) vector): 'a vector = | |
| 393 | Vector.map (QuickSort.sortVector (v, fn ((f, _), (f', _)) => | |
| 394 | Field.<= (f, f')), | |
| 395 | #2) | |
| 396 | ||
| 397 | fun valDec (tyvars: Tyvar.t vector, | |
| 398 | x: Var.t, | |
| 399 | e: Xexp.t, | |
| 400 | et: Xtype.t, | |
| 401 | e': Xexp.t): Xexp.t = | |
| 402 | Xexp.lett {body = e', | |
| 403 | decs = [Xdec.PolyVal {exp = Xexp.toExp e, | |
| 404 | ty = et, | |
| 405 | tyvars = tyvars, | |
| 406 | var = x}]} | |
| 407 | ||
| 408 | structure Xexp = | |
| 409 | struct | |
| 410 | open Xexp | |
| 411 | ||
| 412 | fun list (es: Xexp.t vector, ty: Xtype.t, {forceLeftToRight: bool}) | |
| 413 | : Xexp.t = | |
| 414 | let | |
| 415 | val targs = #2 (valOf (Xtype.deConOpt ty)) | |
| 416 | val eltTy = Vector.first targs | |
| 417 | val nill: Xexp.t = | |
| 418 | Xexp.conApp {arg = NONE, | |
| 419 | con = Con.nill, | |
| 420 | targs = targs, | |
| 421 | ty = ty} | |
| 422 | val consArgTy = Xtype.tuple (Vector.new2 (eltTy, ty)) | |
| 423 | val cons: Xexp.t * Xexp.t -> Xexp.t = | |
| 424 | fn (e1, e2) => | |
| 425 | Xexp.conApp | |
| 426 | {arg = SOME (Xexp.tuple {exps = Vector.new2 (e1, e2), | |
| 427 | ty = consArgTy}), | |
| 428 | con = Con.cons, | |
| 429 | targs = targs, | |
| 430 | ty = ty} | |
| 431 | in | |
| 432 | if not forceLeftToRight | |
| 433 | then | |
| 434 | (* Build the list right to left. *) | |
| 435 | Vector.foldr (es, nill, fn (e, rest) => | |
| 436 | let | |
| 437 | val var = Var.newNoname () | |
| 438 | in | |
| 439 | Xexp.let1 {body = cons (e, monoVar (var, ty)), | |
| 440 | exp = rest, | |
| 441 | var = var} | |
| 442 | end) | |
| 443 | else if Vector.length es < 20 | |
| 444 | then Vector.foldr (es, nill, cons) | |
| 445 | else | |
| 446 | let | |
| 447 | val revArgTy = Xtype.tuple (Vector.new2 (ty, ty)) | |
| 448 | val revTy = Xtype.arrow (revArgTy, ty) | |
| 449 | val revVar = Var.newString "rev" | |
| 450 | fun rev (e1, e2) = | |
| 451 | Xexp.app | |
| 452 | {func = Xexp.monoVar (revVar, revTy), | |
| 453 | arg = Xexp.tuple {exps = Vector.new2 (e1, e2), | |
| 454 | ty = revArgTy}, | |
| 455 | ty = ty} | |
| 456 | fun detuple2 (tuple: Xexp.t, | |
| 457 | f: XvarExp.t * XvarExp.t -> Xexp.t): Xexp.t = | |
| 458 | Xexp.detuple {body = fn xs => let | |
| 459 | fun x i = #1 (Vector.sub (xs, i)) | |
| 460 | in | |
| 461 | f (x 0, x 1) | |
| 462 | end, | |
| 463 | tuple = tuple} | |
| 464 | val revArg = Var.newNoname () | |
| 465 | val revLambda = | |
| 466 | Xlambda.make | |
| 467 | {arg = revArg, | |
| 468 | argType = revArgTy, | |
| 469 | mayInline = true, | |
| 470 | body = | |
| 471 | Xexp.toExp | |
| 472 | (detuple2 | |
| 473 | (Xexp.monoVar (revArg, revArgTy), fn (l, ac) => | |
| 474 | let | |
| 475 | val ac = Xexp.varExp (ac, ty) | |
| 476 | val consArg = Var.newNoname () | |
| 477 | in | |
| 478 | Xexp.casee | |
| 479 | {cases = | |
| 480 | Xcases.Con | |
| 481 | (Vector.new2 | |
| 482 | ((Xpat.T {arg = NONE, | |
| 483 | con = Con.nill, | |
| 484 | targs = targs}, | |
| 485 | ac), | |
| 486 | (Xpat.T {arg = SOME (consArg, consArgTy), | |
| 487 | con = Con.cons, | |
| 488 | targs = targs}, | |
| 489 | detuple2 | |
| 490 | (Xexp.monoVar (consArg, consArgTy), | |
| 491 | fn (x, l) => | |
| 492 | rev (Xexp.varExp (l, ty), | |
| 493 | cons (Xexp.varExp (x, eltTy), | |
| 494 | ac)))))), | |
| 495 | default = NONE, | |
| 496 | test = Xexp.varExp (l, ty), | |
| 497 | ty = ty} | |
| 498 | end))} | |
| 499 | val revDec = | |
| 500 | Xdec.Fun | |
| 501 | {decs = Vector.new1 {lambda = revLambda, | |
| 502 | ty = revTy, | |
| 503 | var = revVar}, | |
| 504 | tyvars = Vector.new0 ()} | |
| 505 | val l = Var.newNoname () | |
| 506 | val (l, body) = | |
| 507 | Vector.foldr | |
| 508 | (es, (l, Xexp.lett {decs = [revDec], | |
| 509 | body = rev (Xexp.monoVar (l, ty), | |
| 510 | nill)}), | |
| 511 | fn (e, (l, body)) => | |
| 512 | let | |
| 513 | val l' = Var.newNoname () | |
| 514 | in | |
| 515 | (l', | |
| 516 | Xexp.let1 {body = body, | |
| 517 | exp = cons (e, Xexp.monoVar (l', ty)), | |
| 518 | var = l}) | |
| 519 | end) | |
| 520 | in | |
| 521 | Xexp.let1 {body = body, | |
| 522 | exp = nill, | |
| 523 | var = l} | |
| 524 | end | |
| 525 | end | |
| 526 | end | |
| 527 | ||
| 528 | fun defunctorize (CoreML.Program.T {decs}) = | |
| 529 | let | |
| 530 | val {get = conExtraArgs: Con.t -> Xtype.t vector option, | |
| 531 | set = setConExtraArgs, destroy = destroy1, ...} = | |
| 532 | Property.destGetSetOnce (Con.plist, Property.initConst NONE) | |
| 533 | val {get = tyconExtraArgs: Tycon.t -> Xtype.t vector option, | |
| 534 | set = setTyconExtraArgs, destroy = destroy2, ...} = | |
| 535 | Property.destGetSetOnce (Tycon.plist, Property.initConst NONE) | |
| 536 | val {destroy = destroy3, hom = loopTy} = | |
| 537 | let | |
| 538 | fun con (c, ts) = | |
| 539 | let | |
| 540 | val ts = | |
| 541 | case tyconExtraArgs c of | |
| 542 | NONE => ts | |
| 543 | | SOME ts' => Vector.concat [ts', ts] | |
| 544 | in | |
| 545 | Xtype.con (c, ts) | |
| 546 | end | |
| 547 | in | |
| 548 | Ctype.makeHom {con = con, var = Xtype.var} | |
| 549 | end | |
| 550 | val loopTy = | |
| 551 | Trace.trace | |
| 552 | ("Defunctorize.loopTy", Ctype.layout, Xtype.layout) | |
| 553 | loopTy | |
| 554 | fun conTargs (c: Con.t, ts: Ctype.t vector): Xtype.t vector = | |
| 555 | let | |
| 556 | val ts = Vector.map (ts, loopTy) | |
| 557 | in | |
| 558 | case conExtraArgs c of | |
| 559 | NONE => ts | |
| 560 | | SOME ts' => Vector.concat [ts', ts] | |
| 561 | end | |
| 562 | val {get = conTycon, set = setConTycon, ...} = | |
| 563 | Property.getSetOnce (Con.plist, | |
| 564 | Property.initRaise ("conTycon", Con.layout)) | |
| 565 | val {get = tyconCons: Tycon.t -> {con: Con.t, | |
| 566 | hasArg: bool} vector, | |
| 567 | set = setTyconCons, ...} = | |
| 568 | Property.getSetOnce (Tycon.plist, | |
| 569 | Property.initRaise ("tyconCons", Tycon.layout)) | |
| 570 | val setConTycon = | |
| 571 | Trace.trace2 | |
| 572 | ("Defunctorize.setConTycon", | |
| 573 | Con.layout, Tycon.layout, Unit.layout) | |
| 574 | setConTycon | |
| 575 | val datatypes = ref [] | |
| 576 | (* Process all the datatypes. *) | |
| 577 | fun loopDec (d: Cdec.t) = | |
| 578 | let | |
| 579 | datatype z = datatype Cdec.t | |
| 580 | in | |
| 581 | case d of | |
| 582 | Datatype dbs => | |
| 583 | let | |
| 584 | val frees: Tyvar.t list ref = ref [] | |
| 585 | val _ = | |
| 586 | Vector.foreach | |
| 587 | (dbs, fn {cons, tyvars, ...} => | |
| 588 | let | |
| 589 | fun var (a: Tyvar.t): unit = | |
| 590 | let | |
| 591 | fun eq a' = Tyvar.equals (a, a') | |
| 592 | in | |
| 593 | if Vector.exists (tyvars, eq) | |
| 594 | orelse List.exists (!frees, eq) | |
| 595 | then () | |
| 596 | else List.push (frees, a) | |
| 597 | end | |
| 598 | val {destroy, hom} = | |
| 599 | Ctype.makeHom {con = fn _ => (), | |
| 600 | var = var} | |
| 601 | val _ = | |
| 602 | Vector.foreach (cons, fn {arg, ...} => | |
| 603 | Option.app (arg, hom)) | |
| 604 | val _ = destroy () | |
| 605 | in | |
| 606 | () | |
| 607 | end) | |
| 608 | val frees = !frees | |
| 609 | val dbs = | |
| 610 | if List.isEmpty frees | |
| 611 | then dbs | |
| 612 | else | |
| 613 | let | |
| 614 | val frees = Vector.fromList frees | |
| 615 | val extra = Vector.map (frees, Xtype.var) | |
| 616 | in | |
| 617 | Vector.map | |
| 618 | (dbs, fn {cons, tycon, tyvars} => | |
| 619 | let | |
| 620 | val _ = setTyconExtraArgs (tycon, SOME extra) | |
| 621 | val _ = | |
| 622 | Vector.foreach | |
| 623 | (cons, fn {con, ...} => | |
| 624 | setConExtraArgs (con, SOME extra)) | |
| 625 | in | |
| 626 | {cons = cons, | |
| 627 | tycon = tycon, | |
| 628 | tyvars = Vector.concat [frees, tyvars]} | |
| 629 | end) | |
| 630 | end | |
| 631 | in | |
| 632 | Vector.foreach | |
| 633 | (dbs, fn {cons, tycon, tyvars} => | |
| 634 | let | |
| 635 | val _ = | |
| 636 | setTyconCons (tycon, | |
| 637 | Vector.map (cons, fn {arg, con} => | |
| 638 | {con = con, | |
| 639 | hasArg = isSome arg})) | |
| 640 | val cons = | |
| 641 | Vector.map | |
| 642 | (cons, fn {arg, con} => | |
| 643 | (setConTycon (con, tycon) | |
| 644 | ; {arg = Option.map (arg, loopTy), | |
| 645 | con = con})) | |
| 646 | ||
| 647 | val _ = | |
| 648 | if Tycon.equals (tycon, Tycon.reff) | |
| 649 | then () | |
| 650 | else | |
| 651 | List.push (datatypes, {cons = cons, | |
| 652 | tycon = tycon, | |
| 653 | tyvars = tyvars}) | |
| 654 | in | |
| 655 | () | |
| 656 | end) | |
| 657 | end | |
| 658 | | Exception {con, ...} => setConTycon (con, Tycon.exn) | |
| 659 | | Fun {decs, ...} => Vector.foreach (decs, loopLambda o #lambda) | |
| 660 | | Val {rvbs, vbs, ...} => | |
| 661 | (Vector.foreach (rvbs, loopLambda o #lambda) | |
| 662 | ; Vector.foreach (vbs, loopExp o #exp)) | |
| 663 | end | |
| 664 | and loopExp (e: Cexp.t): unit = | |
| 665 | let | |
| 666 | datatype z = datatype Cexp.node | |
| 667 | in | |
| 668 | case Cexp.node e of | |
| 669 | App (e, e') => (loopExp e; loopExp e') | |
| 670 | | Case {rules, test, ...} => | |
| 671 | (loopExp test | |
| 672 | ; Vector.foreach (rules, loopExp o #exp)) | |
| 673 | | Con _ => () | |
| 674 | | Const _ => () | |
| 675 | | EnterLeave (e, _) => loopExp e | |
| 676 | | Handle {handler, try, ...} => (loopExp handler; loopExp try) | |
| 677 | | Lambda l => loopLambda l | |
| 678 | | Let (ds, e) => (Vector.foreach (ds, loopDec); loopExp e) | |
| 679 | | List es => Vector.foreach (es, loopExp) | |
| 680 | | PrimApp {args, ...} => Vector.foreach (args, loopExp) | |
| 681 | | Raise e => loopExp e | |
| 682 | | Record r => Record.foreach (r, loopExp) | |
| 683 | | Seq es => Vector.foreach (es, loopExp) | |
| 684 | | Var _ => () | |
| 685 | | Vector es => Vector.foreach (es, loopExp) | |
| 686 | end | |
| 687 | and loopLambda (l: Clambda.t): unit = | |
| 688 | loopExp (#body (Clambda.dest l)) | |
| 689 | fun loopPat (p: Cpat.t): NestedPat.t = | |
| 690 | let | |
| 691 | val (p, t) = Cpat.dest p | |
| 692 | val t' = loopTy t | |
| 693 | datatype z = datatype Cpat.node | |
| 694 | val p = | |
| 695 | case p of | |
| 696 | Con {arg, con, targs} => | |
| 697 | NestedPat.Con {arg = Option.map (arg, loopPat), | |
| 698 | con = con, | |
| 699 | targs = conTargs (con, targs)} | |
| 700 | | Const f => | |
| 701 | NestedPat.Const {const = f (), | |
| 702 | isChar = Ctype.isCharX t, | |
| 703 | isInt = Ctype.isInt t} | |
| 704 | | Layered (x, p) => NestedPat.Layered (x, loopPat p) | |
| 705 | | List ps => | |
| 706 | let | |
| 707 | val targs = Vector.map (#2 (valOf (Ctype.deConOpt t)), | |
| 708 | loopTy) | |
| 709 | in | |
| 710 | Vector.foldr | |
| 711 | (ps, | |
| 712 | NestedPat.Con {arg = NONE, | |
| 713 | con = Con.nill, | |
| 714 | targs = targs}, | |
| 715 | fn (p, np) => | |
| 716 | NestedPat.Con {arg = SOME (NestedPat.tuple | |
| 717 | (Vector.new2 | |
| 718 | (loopPat p, | |
| 719 | NestedPat.make (np, t')))), | |
| 720 | con = Con.cons, | |
| 721 | targs = targs}) | |
| 722 | end | |
| 723 | | Record r => | |
| 724 | NestedPat.Record | |
| 725 | (SortedRecord.fromVector | |
| 726 | (Vector.map | |
| 727 | (Ctype.deRecord t, fn (f, t: Ctype.t) => | |
| 728 | (f, | |
| 729 | case Record.peek (r, f) of | |
| 730 | NONE => NestedPat.make (NestedPat.Wild, loopTy t) | |
| 731 | | SOME p => loopPat p)))) | |
| 732 | | Or ps => NestedPat.Or (Vector.map (ps, loopPat)) | |
| 733 | | Var x => NestedPat.Var x | |
| 734 | | Vector ps => NestedPat.Vector (Vector.map (ps, loopPat)) | |
| 735 | | Wild => NestedPat.Wild | |
| 736 | in | |
| 737 | NestedPat.make (p, t') | |
| 738 | end | |
| 739 | val _ = Vector.foreach (decs, loopDec) | |
| 740 | (* Now, do the actual defunctorization. *) | |
| 741 | fun loopDec (d: Cdec.t, e: Xexp.t, et: Xtype.t): Xexp.t = | |
| 742 | let | |
| 743 | fun prefix (d: Xdec.t) = | |
| 744 | Xexp.lett {decs = [d], body = e} | |
| 745 | fun processLambdas v = | |
| 746 | Vector.map | |
| 747 | (Vector.rev v, fn {lambda, var} => | |
| 748 | let | |
| 749 | val {arg, argType, body, bodyType, mayInline} = | |
| 750 | loopLambda lambda | |
| 751 | in | |
| 752 | {lambda = Xlambda.make {arg = arg, | |
| 753 | argType = argType, | |
| 754 | body = Xexp.toExp body, | |
| 755 | mayInline = mayInline}, | |
| 756 | ty = Xtype.arrow (argType, bodyType), | |
| 757 | var = var} | |
| 758 | end) | |
| 759 | datatype z = datatype Cdec.t | |
| 760 | in | |
| 761 | case d of | |
| 762 | Datatype _ => e | |
| 763 | | Exception {arg, con} => | |
| 764 | prefix (Xdec.Exception {arg = Option.map (arg, loopTy), | |
| 765 | con = con}) | |
| 766 | | Fun {decs, tyvars} => | |
| 767 | prefix (Xdec.Fun {decs = processLambdas decs, | |
| 768 | tyvars = tyvars ()}) | |
| 769 | | Val {matchDiags, rvbs, tyvars, vbs} => | |
| 770 | let | |
| 771 | val tyvars = tyvars () | |
| 772 | val bodyType = et | |
| 773 | val e = | |
| 774 | Vector.foldr | |
| 775 | (vbs, e, fn ({ctxt, exp, layPat, nest, pat, regionPat}, e) => | |
| 776 | let | |
| 777 | fun patDec (p: NestedPat.t, | |
| 778 | e: Xexp.t, | |
| 779 | body: Xexp.t, | |
| 780 | bodyType: Xtype.t, | |
| 781 | mayWarn: bool) = | |
| 782 | casee {ctxt = ctxt, | |
| 783 | caseType = bodyType, | |
| 784 | cases = Vector.new1 {exp = body, | |
| 785 | layPat = SOME layPat, | |
| 786 | pat = p, | |
| 787 | regionPat = regionPat}, | |
| 788 | conTycon = conTycon, | |
| 789 | kind = ("declaration", "pattern"), | |
| 790 | nest = nest, | |
| 791 | matchDiags = if mayWarn | |
| 792 | then matchDiags | |
| 793 | else {nonexhaustiveExn = Control.Elaborate.DiagDI.Default, | |
| 794 | nonexhaustive = Control.Elaborate.DiagEIW.Ignore, | |
| 795 | redundant = Control.Elaborate.DiagEIW.Ignore}, | |
| 796 | noMatch = Cexp.RaiseBind, | |
| 797 | region = regionPat, | |
| 798 | test = (e, NestedPat.ty p), | |
| 799 | tyconCons = tyconCons} | |
| 800 | val isExpansive = Cexp.isExpansive exp | |
| 801 | val (exp, expType) = loopExp exp | |
| 802 | val pat = loopPat pat | |
| 803 | fun vd (x: Var.t) = valDec (tyvars, x, exp, expType, e) | |
| 804 | in | |
| 805 | if Vector.isEmpty tyvars | |
| 806 | then patDec (pat, exp, e, bodyType, true) | |
| 807 | else if isExpansive | |
| 808 | then | |
| 809 | let | |
| 810 | val x = Var.newNoname () | |
| 811 | val thunk = | |
| 812 | let | |
| 813 | open Xexp | |
| 814 | in | |
| 815 | toExp | |
| 816 | (lambda | |
| 817 | {arg = Var.newNoname (), | |
| 818 | argType = Xtype.unit, | |
| 819 | body = exp, | |
| 820 | bodyType = expType, | |
| 821 | mayInline = true}) | |
| 822 | end | |
| 823 | val thunkTy = | |
| 824 | Xtype.arrow (Xtype.unit, expType) | |
| 825 | fun subst t = | |
| 826 | Xtype.substitute | |
| 827 | (t, Vector.map (tyvars, fn a => | |
| 828 | (a, Xtype.unit))) | |
| 829 | val body = | |
| 830 | Xexp.app | |
| 831 | {arg = Xexp.unit (), | |
| 832 | func = | |
| 833 | Xexp.var | |
| 834 | {targs = (Vector.map | |
| 835 | (tyvars, fn _ => | |
| 836 | Xtype.unit)), | |
| 837 | ty = subst thunkTy, | |
| 838 | var = x}, | |
| 839 | ty = subst expType} | |
| 840 | val decs = | |
| 841 | [Xdec.PolyVal {exp = thunk, | |
| 842 | ty = thunkTy, | |
| 843 | tyvars = tyvars, | |
| 844 | var = x}] | |
| 845 | in | |
| 846 | patDec (NestedPat.replaceTypes (pat, subst), | |
| 847 | Xexp.lett {body = body, decs = decs}, | |
| 848 | e, bodyType, true) | |
| 849 | end | |
| 850 | else | |
| 851 | case NestedPat.node pat of | |
| 852 | NestedPat.Wild => vd (Var.newNoname ()) | |
| 853 | | NestedPat.Var x => vd x | |
| 854 | | _ => | |
| 855 | (* Polymorphic pattern. | |
| 856 | * val 'a Foo (y1, y2) = e | |
| 857 | * Expands to | |
| 858 | * val 'a x = e | |
| 859 | * val Foo (_, _) = x (* for match warnings *) | |
| 860 | * val 'a y1 = case x of Foo (y1', _) => y1' | |
| 861 | * val 'a y2 = case x of Foo (_, y2') => y2' | |
| 862 | *) | |
| 863 | let | |
| 864 | val x = Var.newNoname () | |
| 865 | val xt = expType | |
| 866 | val targs = Vector.map (tyvars, Xtype.var) | |
| 867 | val e = | |
| 868 | List.fold | |
| 869 | (NestedPat.varsAndTypes pat, e, | |
| 870 | fn ((y, yt), e) => | |
| 871 | let | |
| 872 | val y' = Var.new y | |
| 873 | val pat = | |
| 874 | NestedPat.removeOthersReplace | |
| 875 | (pat, {old = y, new = y'}) | |
| 876 | in | |
| 877 | valDec | |
| 878 | (tyvars, | |
| 879 | y, | |
| 880 | patDec (pat, | |
| 881 | Xexp.var {targs = targs, | |
| 882 | ty = xt, | |
| 883 | var = x}, | |
| 884 | Xexp.monoVar (y', yt), | |
| 885 | yt, | |
| 886 | false), | |
| 887 | yt, | |
| 888 | e) | |
| 889 | end) | |
| 890 | fun instantiatePat () = | |
| 891 | let | |
| 892 | val pat = NestedPat.removeVars pat | |
| 893 | fun con (_, c, ts) = Xtype.con (c, ts) | |
| 894 | fun var (t, a) = | |
| 895 | if (Vector.exists | |
| 896 | (tyvars, fn a' => | |
| 897 | Tyvar.equals (a, a'))) | |
| 898 | then Xtype.unit | |
| 899 | else t | |
| 900 | val {destroy, hom} = | |
| 901 | Xtype.makeHom {con = con, | |
| 902 | var = var} | |
| 903 | val pat = | |
| 904 | NestedPat.replaceTypes | |
| 905 | (pat, hom) | |
| 906 | val _ = destroy () | |
| 907 | in | |
| 908 | pat | |
| 909 | end | |
| 910 | val e = | |
| 911 | if NestedPat.isRefutable pat | |
| 912 | then | |
| 913 | let | |
| 914 | val targs = | |
| 915 | Vector.map (tyvars, fn _ => | |
| 916 | Xtype.unit) | |
| 917 | val pat = instantiatePat () | |
| 918 | in | |
| 919 | patDec | |
| 920 | (pat, | |
| 921 | Xexp.var | |
| 922 | {targs = targs, | |
| 923 | ty = NestedPat.ty pat, | |
| 924 | var = x}, | |
| 925 | e, | |
| 926 | bodyType, | |
| 927 | true) | |
| 928 | end | |
| 929 | else e | |
| 930 | in | |
| 931 | valDec (tyvars, x, exp, expType, e) | |
| 932 | end | |
| 933 | end) | |
| 934 | in | |
| 935 | if Vector.isEmpty rvbs | |
| 936 | then e | |
| 937 | else | |
| 938 | Xexp.lett {decs = [Xdec.Fun {decs = processLambdas rvbs, | |
| 939 | tyvars = tyvars}], | |
| 940 | body = e} | |
| 941 | end | |
| 942 | end | |
| 943 | and loopDecs (ds: Cdec.t vector, (e: Xexp.t, t: Xtype.t)): Xexp.t = | |
| 944 | loopDecsList (Vector.toList ds, (e, t)) | |
| 945 | (* Convert vector->list to allow processed Cdecs to be GC'ed. *) | |
| 946 | and loopDecsList (ds: Cdec.t list, (e: Xexp.t, t: Xtype.t)): Xexp.t = | |
| 947 | List.foldr (ds, e, fn (d, e) => loopDec (d, e, t)) | |
| 948 | and loopExp (e: Cexp.t): Xexp.t * Xtype.t = | |
| 949 | let | |
| 950 | val (n, ty) = Cexp.dest e | |
| 951 | val ty = loopTy ty | |
| 952 | fun conApp {arg, con, targs, ty} = | |
| 953 | if Con.equals (con, Con.reff) | |
| 954 | then Xexp.primApp {args = Vector.new1 arg, | |
| 955 | prim = Prim.reff, | |
| 956 | targs = targs, | |
| 957 | ty = ty} | |
| 958 | else Xexp.conApp {arg = SOME arg, | |
| 959 | con = con, | |
| 960 | targs = targs, | |
| 961 | ty = ty} | |
| 962 | datatype z = datatype Cexp.node | |
| 963 | val exp = | |
| 964 | case n of | |
| 965 | App (e1, e2) => | |
| 966 | let | |
| 967 | val (e2, _) = loopExp e2 | |
| 968 | in | |
| 969 | case Cexp.node e1 of | |
| 970 | Con (con, targs) => | |
| 971 | conApp {arg = e2, | |
| 972 | con = con, | |
| 973 | targs = conTargs (con, targs), | |
| 974 | ty = ty} | |
| 975 | | _ => | |
| 976 | Xexp.app {arg = e2, | |
| 977 | func = #1 (loopExp e1), | |
| 978 | ty = ty} | |
| 979 | end | |
| 980 | | Case {ctxt, kind, nest, matchDiags, noMatch, region, rules, test, ...} => | |
| 981 | casee {ctxt = ctxt, | |
| 982 | caseType = ty, | |
| 983 | cases = Vector.map (rules, fn {exp, layPat, pat, regionPat} => | |
| 984 | {exp = #1 (loopExp exp), | |
| 985 | layPat = layPat, | |
| 986 | pat = loopPat pat, | |
| 987 | regionPat = regionPat}), | |
| 988 | conTycon = conTycon, | |
| 989 | kind = kind, | |
| 990 | nest = nest, | |
| 991 | matchDiags = matchDiags, | |
| 992 | noMatch = noMatch, | |
| 993 | region = region, | |
| 994 | test = loopExp test, | |
| 995 | tyconCons = tyconCons} | |
| 996 | | Con (con, targs) => | |
| 997 | let | |
| 998 | val targs = conTargs (con, targs) | |
| 999 | in | |
| 1000 | case Xtype.deArrowOpt ty of | |
| 1001 | NONE => | |
| 1002 | Xexp.conApp {arg = NONE, | |
| 1003 | con = con, | |
| 1004 | targs = targs, | |
| 1005 | ty = ty} | |
| 1006 | | SOME (argType, bodyType) => | |
| 1007 | let | |
| 1008 | val arg = Var.newNoname () | |
| 1009 | in | |
| 1010 | Xexp.lambda | |
| 1011 | {arg = arg, | |
| 1012 | argType = argType, | |
| 1013 | body = (conApp | |
| 1014 | {arg = Xexp.monoVar (arg, argType), | |
| 1015 | con = con, | |
| 1016 | targs = targs, | |
| 1017 | ty = bodyType}), | |
| 1018 | bodyType = bodyType, | |
| 1019 | mayInline = true} | |
| 1020 | end | |
| 1021 | end | |
| 1022 | | Const f => | |
| 1023 | let | |
| 1024 | val c = f () | |
| 1025 | in | |
| 1026 | if Xtype.equals (ty, Xtype.bool) | |
| 1027 | then | |
| 1028 | (case c of | |
| 1029 | Const.Word w => | |
| 1030 | if WordX.isZero w | |
| 1031 | then Xexp.falsee () | |
| 1032 | else Xexp.truee () | |
| 1033 | | _ => Error.bug "Defunctorize.loopExp: Const:strange boolean constant") | |
| 1034 | else Xexp.const c | |
| 1035 | end | |
| 1036 | | EnterLeave (e, si) => | |
| 1037 | let | |
| 1038 | val (e, t) = loopExp e | |
| 1039 | in | |
| 1040 | enterLeave (e, t, si) | |
| 1041 | end | |
| 1042 | | Handle {catch = (x, t), handler, try} => | |
| 1043 | Xexp.handlee {catch = (x, loopTy t), | |
| 1044 | handler = #1 (loopExp handler), | |
| 1045 | try = #1 (loopExp try), | |
| 1046 | ty = ty} | |
| 1047 | | Lambda l => Xexp.lambda (loopLambda l) | |
| 1048 | | Let (ds, e) => loopDecs (ds, loopExp e) | |
| 1049 | | List es => | |
| 1050 | let | |
| 1051 | (* Must evaluate list components left-to-right if there | |
| 1052 | * is more than one expansive expression. | |
| 1053 | *) | |
| 1054 | val numExpansive = | |
| 1055 | Vector.fold (es, 0, fn (e, n) => | |
| 1056 | if Cexp.isExpansive e then n + 1 else n) | |
| 1057 | in | |
| 1058 | Xexp.list (Vector.map (es, #1 o loopExp), ty, | |
| 1059 | {forceLeftToRight = 2 <= numExpansive}) | |
| 1060 | end | |
| 1061 | | PrimApp {args, prim, targs} => | |
| 1062 | let | |
| 1063 | val args = Vector.map (args, #1 o loopExp) | |
| 1064 | datatype z = datatype Prim.Name.t | |
| 1065 | in | |
| 1066 | if (case Prim.name prim of | |
| 1067 | Real_rndToReal (s1, s2) => | |
| 1068 | RealSize.equals (s1, s2) | |
| 1069 | | String_toWord8Vector => true | |
| 1070 | | Word_extdToWord (s1, s2, _) => | |
| 1071 | WordSize.equals (s1, s2) | |
| 1072 | | Word8Vector_toString => true | |
| 1073 | | _ => false) | |
| 1074 | then Vector.first args | |
| 1075 | else | |
| 1076 | Xexp.primApp {args = args, | |
| 1077 | prim = Prim.map (prim, loopTy), | |
| 1078 | targs = Vector.map (targs, loopTy), | |
| 1079 | ty = ty} | |
| 1080 | ||
| 1081 | end | |
| 1082 | | Raise e => Xexp.raisee {exn = #1 (loopExp e), extend = true, ty = ty} | |
| 1083 | | Record r => | |
| 1084 | (* The components of the record have to be evaluated left to | |
| 1085 | * right as they appeared in the source program, but then | |
| 1086 | * ordered according to sorted field name within the tuple. | |
| 1087 | *) | |
| 1088 | let | |
| 1089 | val fes = Record.toVector r | |
| 1090 | in | |
| 1091 | Xexp.seq | |
| 1092 | (Vector.map (fes, #1 o loopExp o #2), fn es => | |
| 1093 | Xexp.tuple {exps = (sortByField | |
| 1094 | (Vector.map2 | |
| 1095 | (fes, es, fn ((f, _), e) => (f, e)))), | |
| 1096 | ty = ty}) | |
| 1097 | end | |
| 1098 | | Seq es => Xexp.sequence (Vector.map (es, #1 o loopExp)) | |
| 1099 | | Var (var, targs) => | |
| 1100 | Xexp.var {targs = Vector.map (targs (), loopTy), | |
| 1101 | ty = ty, | |
| 1102 | var = var ()} | |
| 1103 | | Vector es => | |
| 1104 | Xexp.primApp {args = Vector.map (es, #1 o loopExp), | |
| 1105 | prim = Prim.vector, | |
| 1106 | targs = Vector.new1 (Xtype.deVector ty), | |
| 1107 | ty = ty} | |
| 1108 | in | |
| 1109 | (exp, ty) | |
| 1110 | end | |
| 1111 | and loopLambda (l: Clambda.t) = | |
| 1112 | let | |
| 1113 | val {arg, argType, body, mayInline} = Clambda.dest l | |
| 1114 | val (body, bodyType) = loopExp body | |
| 1115 | in | |
| 1116 | {arg = arg, | |
| 1117 | argType = loopTy argType, | |
| 1118 | body = body, | |
| 1119 | bodyType = bodyType, | |
| 1120 | mayInline = mayInline} | |
| 1121 | end | |
| 1122 | val body = Xexp.toExp (loopDecs (decs, (Xexp.unit (), Xtype.unit))) | |
| 1123 | val _ = showMatchDiagnostics () | |
| 1124 | val _ = (destroy1 (); destroy2 (); destroy3 ()) | |
| 1125 | in | |
| 1126 | Xml.Program.T {body = body, | |
| 1127 | datatypes = Vector.fromList (!datatypes), | |
| 1128 | overflow = NONE} | |
| 1129 | end | |
| 1130 | ||
| 1131 | end |