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.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor CoreML (S: CORE_ML_STRUCTS): CORE_ML =
15 structure Field = Record.Field
17 fun maybeConstrain (x, t) =
22 then seq [x, str ": ", Type.layout t]
26 fun layoutTargs (ts: Type.t vector) =
31 andalso 0 < Vector.length ts
32 then list (Vector.toListMap (ts, Type.layout))
38 datatype t = T of {node: node,
41 Con of {arg: t option,
44 | Const of unit -> Const.t
45 | Layered of Var.t * t
48 | Record of t Record.t
54 fun make f (T r) = f r
56 val dest = make (fn {node, ty} => (node, ty))
61 fun make (n, t) = T {node = n, ty = t}
69 Con {arg, con, targs} =>
74 | SOME p => seq [str " ", layout p]]
75 | Const f => Const.layout (f ())
77 seq [maybeConstrain (Var.layout x, t), str " as ", layout p]
78 | List ps => list (Vector.toListMap (ps, layout))
79 | Or ps => list (Vector.toListMap (ps, layout))
84 (Type.deRecord t, fn (f, _) =>
85 Option.isNone (Record.peek (r, f)))
88 {extra = if extra then ", ..." else "",
90 layoutTuple = fn ps => tuple (Vector.toListMap (ps, layout)),
94 | Var x => maybeConstrain (Var.layout x, t)
95 | Vector ps => vector (Vector.map (ps, layout))
99 fun wild t = make (Wild, t)
101 fun var (x, t) = make (Var x, t)
104 if 1 = Vector.length ps
106 else make (Record (Record.tuple ps), Type.tuple (Vector.map (ps, ty)))
109 fun bool c = make (Con {arg = NONE, con = c, targs = Vector.new0 ()},
112 val falsee: t = bool Con.falsee
113 val truee: t = bool Con.truee
116 fun isUnit (p: t): bool =
118 Record r => Record.forall (r, fn _ => false)
121 fun isWild (p: t): bool =
126 fun isRefutable (p: t): bool =
130 | Layered (_, p) => isRefutable p
132 | Or ps => Vector.exists (ps, isRefutable)
133 | Record r => Record.exists (r, isRefutable)
138 fun foreachVar (p: t, f: Var.t -> unit): unit =
140 fun loop (p: t): unit =
144 | Layered (x, p) => (f x; loop p)
145 | List ps => Vector.foreach (ps, loop)
146 | Or ps => Vector.foreach (ps, loop)
147 | Record r => Record.foreach (r, loop)
149 | Vector ps => Vector.foreach (ps, loop)
158 datatype t = Impossible | RaiseAgain | RaiseBind | RaiseMatch
161 datatype noMatch = datatype NoMatch.t
164 Datatype of {cons: {arg: Type.t option,
167 tyvars: Tyvar.t vector} vector
168 | Exception of {arg: Type.t option,
170 | Fun of {decs: {lambda: lambda,
172 tyvars: unit -> Tyvar.t vector}
173 | Val of {matchDiags: {nonexhaustiveExn: Control.Elaborate.DiagDI.t,
174 nonexhaustive: Control.Elaborate.DiagEIW.t,
175 redundant: Control.Elaborate.DiagEIW.t},
176 rvbs: {lambda: lambda,
178 tyvars: unit -> Tyvar.t vector,
179 vbs: {ctxt: unit -> Layout.t,
181 layPat: unit -> Layout.t,
184 regionPat: Region.t} vector}
185 and exp = Exp of {node: expNode,
189 | Case of {ctxt: unit -> Layout.t,
190 kind: string * string,
192 matchDiags: {nonexhaustiveExn: Control.Elaborate.DiagDI.t,
193 nonexhaustive: Control.Elaborate.DiagEIW.t,
194 redundant: Control.Elaborate.DiagEIW.t},
198 layPat: (unit -> Layout.t) option,
200 regionPat: Region.t} vector,
202 | Con of Con.t * Type.t vector
203 | Const of unit -> Const.t
204 | EnterLeave of exp * SourceInfo.t
205 | Handle of {catch: Var.t * Type.t,
209 | Let of dec vector * exp
211 | PrimApp of {args: exp vector,
213 targs: Type.t vector}
215 | Record of exp Record.t
217 | Var of (unit -> Var.t) * (unit -> Type.t vector)
218 | Vector of exp vector
219 and lambda = Lam of {arg: Var.t,
227 fun layoutTyvars (ts: Tyvar.t vector) =
228 case Vector.length ts of
230 | 1 => seq [str " ", Tyvar.layout (Vector.sub (ts, 0))]
231 | _ => seq [str " ", tuple (Vector.toListMap (ts, Tyvar.layout))]
233 fun layoutConArg {arg, con} =
237 | SOME t => seq [str " of ", Type.layout t]]
245 (v, fn {cons, tycon, tyvars} =>
246 seq [layoutTyvars tyvars,
247 str " ", Tycon.layout tycon, str " = ",
249 (separateLeft (Vector.toListMap (cons, layoutConArg),
252 seq [str "exception ", layoutConArg ca]
253 | Fun {decs, tyvars, ...} => layoutFuns (tyvars, decs)
254 | Val {rvbs, tyvars, vbs, ...} =>
255 align [layoutFuns (tyvars, rvbs),
256 align (Vector.toListMap
257 (vbs, fn {exp, pat, ...} =>
259 mayAlign [seq [layoutTyvars (tyvars ()),
260 str " ", Pat.layout pat,
263 and layoutExp (Exp {node, ...}) =
265 App (e1, e2) => paren (seq [layoutExp e1, str " ", layoutExp e2])
266 | Case {rules, test, ...} =>
267 Pretty.casee {default = NONE,
268 rules = Vector.map (rules, fn {exp, pat, ...} =>
269 (Pat.layout pat, layoutExp exp)),
270 test = layoutExp test}
271 | Con (c, targs) => seq [Con.layout c, layoutTargs targs]
272 | Const f => Const.layout (f ())
273 | EnterLeave (e, si) =>
274 seq [str "EnterLeave ",
275 tuple [layoutExp e, SourceInfo.layout si]]
276 | Handle {catch, handler, try} =>
277 Pretty.handlee {catch = Var.layout (#1 catch),
278 handler = layoutExp handler,
280 | Lambda l => layoutLambda l
282 Pretty.lett (align (Vector.toListMap (ds, layoutDec)),
284 | List es => list (Vector.toListMap (es, layoutExp))
285 | PrimApp {args, prim, targs} =>
286 Pretty.primApp {args = Vector.map (args, layoutExp),
287 prim = Prim.layout prim,
288 targs = Vector.map (targs, Type.layout)}
289 | Raise e => Pretty.raisee (layoutExp e)
293 layoutElt = layoutExp,
294 layoutTuple = fn es => tuple (Vector.toListMap (es, layoutExp)),
297 | Seq es => Pretty.seq (Vector.map (es, layoutExp))
298 | Var (var, targs) =>
299 if !Control.showTypes
304 if Vector.isEmpty targs
305 then Var.layout (var ())
306 else seq [Var.layout (var ()), str " ",
307 Vector.layout Type.layout targs]
309 else Var.layout (var ())
310 | Vector es => vector (Vector.map (es, layoutExp))
311 and layoutFuns (tyvars, decs) =
312 if Vector.isEmpty decs
315 align [seq [str "val rec", layoutTyvars (tyvars ())],
316 indent (align (Vector.toListMap
317 (decs, fn {lambda as Lam {argType, body = Exp {ty = bodyType, ...}, ...}, var} =>
318 align [seq [maybeConstrain (Var.layout var, Type.arrow (argType, bodyType)), str " = "],
319 indent (layoutLambda lambda, 3)])),
321 and layoutLambda (Lam {arg, argType, body, ...}) =
322 paren (align [seq [str "fn ",
323 maybeConstrain (Var.layout arg, argType),
327 fun layoutExpWithType (exp as Exp {ty, ...}) =
329 val node = layoutExp exp
331 if !Control.showTypes
332 then seq [node, str " : ", Type.layout ty]
339 datatype t = datatype lambda
345 val bogus = make {arg = Var.newNoname (),
347 body = Exp {node = Seq (Vector.new0 ()),
356 datatype t = datatype exp
357 datatype node = datatype expNode
359 datatype noMatch = datatype noMatch
361 val layout = layoutExp
362 val layoutWithType = layoutExpWithType
365 fun make f (Exp r) = f r
367 val dest = make (fn {node, ty} => (node, ty))
368 val node = make #node
372 fun make (n, t) = Exp {node = n,
375 fun var (x: Var.t, ty: Type.t): t =
376 make (Var (fn () => x, fn () => Vector.new0 ()), ty)
378 fun isExpansive (e: t): bool =
382 Con (c, _) => Con.equals (c, Con.reff) orelse isExpansive e2
387 | EnterLeave _ => true
391 | List es => Vector.exists (es, isExpansive)
394 | Record r => Record.exists (r, isExpansive)
397 | Vector es => Vector.exists (es, isExpansive)
400 if 1 = Vector.length es
402 else make (Record (Record.tuple es),
403 Type.tuple (Vector.map (es, ty)))
405 val unit = tuple (Vector.new0 ())
408 fun bool c = make (Con (c, Vector.new0 ()), Type.bool)
410 val falsee: t = bool Con.falsee
411 val truee: t = bool Con.truee
414 fun lambda (l as Lam {argType, body, ...}) =
415 make (Lambda l, Type.arrow (argType, ty body))
417 fun casee (z as {rules, ...}) =
418 if Vector.isEmpty rules
419 then Error.bug "CoreML.Exp.casee"
420 else make (Case z, ty (#exp (Vector.first rules)))
422 fun iff (test, thenCase, elseCase): t =
423 casee {ctxt = fn () => Layout.empty,
424 kind = ("if", "branch"),
426 matchDiags = {nonexhaustiveExn = Control.Elaborate.DiagDI.Default,
427 nonexhaustive = Control.Elaborate.DiagEIW.Ignore,
428 redundant = Control.Elaborate.DiagEIW.Ignore},
429 noMatch = Impossible,
430 region = Region.bogus,
431 rules = Vector.new2 ({exp = thenCase,
434 regionPat = Region.bogus},
438 regionPat = Region.bogus}),
441 fun andAlso (e1, e2) = iff (e1, e2, falsee)
443 fun orElse (e1, e2) = iff (e1, truee, e2)
445 fun whilee {expr, test} =
447 val loop = Var.newNoname ()
448 val loopTy = Type.arrow (Type.unit, Type.unit)
449 val call = make (App (var (loop, loopTy), unit), Type.unit)
452 {arg = Var.newNoname (),
455 make (Seq (Vector.new2 (expr, call)),
461 (Let (Vector.new1 (Fun {decs = Vector.new1 {lambda = lambda,
463 tyvars = fn () => Vector.new0 ()}),
468 fun foreachVar (e: t, f: Var.t -> unit): unit =
470 fun loop (e: t): unit =
472 App (e1, e2) => (loop e1; loop e2)
473 | Case {rules, test, ...} =>
475 ; Vector.foreach (rules, loop o #exp))
478 | EnterLeave (e, _) => loop e
479 | Handle {handler, try, ...} => (loop handler; loop try)
480 | Lambda l => loopLambda l
482 (Vector.foreach (ds, loopDec)
484 | List es => Vector.foreach (es, loop)
485 | PrimApp {args, ...} => Vector.foreach (args, loop)
487 | Record r => Record.foreach (r, loop)
488 | Seq es => Vector.foreach (es, loop)
489 | Var (x, _) => f (x ())
490 | Vector es => Vector.foreach (es, loop)
495 | Fun {decs, ...} => Vector.foreach (decs, loopLambda o #lambda)
496 | Val {rvbs, vbs, ...} =>
497 (Vector.foreach (rvbs, loopLambda o #lambda)
498 ; Vector.foreach (vbs, loop o #exp))
499 and loopLambda (Lam {body, ...}) = loop body
507 datatype t = datatype dec
509 val layout = layoutDec
514 datatype t = T of {decs: Dec.t vector}
516 fun layouts (T {decs, ...}, output') =
519 (* Layout includes an output function, so we need to rebind output
524 output (Layout.str "\n\nDecs:")
525 ; Vector.foreach (decs, output o Dec.layout)
528 (* fun typeCheck (T {decs, ...}) =
530 * fun checkExp (e: Exp.t): Ty.t =
532 * val (n, t) = Exp.dest e
534 * datatype z = datatype Exp.t
539 * val t1 = checkExp e1
540 * val t2 = checkExp e2
542 * case Type.deArrowOpt t1 of
543 * NONE => error "application of non-function"
545 * if Type.equals (u1, t2)
547 * else error "function/argument mismatch"
549 * | Case {rules, test} =>
551 * val {pat, exp} = Vector.first rules
553 * Vector.foreach (rules, fn {pat, exp} =>