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 CoreML (S: CORE_ML_STRUCTS): CORE_ML = | |
11 | struct | |
12 | ||
13 | open S | |
14 | ||
15 | structure Field = Record.Field | |
16 | ||
17 | fun maybeConstrain (x, t) = | |
18 | let | |
19 | open Layout | |
20 | in | |
21 | if !Control.showTypes | |
22 | then seq [x, str ": ", Type.layout t] | |
23 | else x | |
24 | end | |
25 | ||
26 | fun layoutTargs (ts: Type.t vector) = | |
27 | let | |
28 | open Layout | |
29 | in | |
30 | if !Control.showTypes | |
31 | andalso 0 < Vector.length ts | |
32 | then list (Vector.toListMap (ts, Type.layout)) | |
33 | else empty | |
34 | end | |
35 | ||
36 | structure Pat = | |
37 | struct | |
38 | datatype t = T of {node: node, | |
39 | ty: Type.t} | |
40 | and node = | |
41 | Con of {arg: t option, | |
42 | con: Con.t, | |
43 | targs: Type.t vector} | |
44 | | Const of unit -> Const.t | |
45 | | Layered of Var.t * t | |
46 | | List of t vector | |
47 | | Or of t vector | |
48 | | Record of t Record.t | |
49 | | Var of Var.t | |
50 | | Vector of t vector | |
51 | | Wild | |
52 | ||
53 | local | |
54 | fun make f (T r) = f r | |
55 | in | |
56 | val dest = make (fn {node, ty} => (node, ty)) | |
57 | val node = make #node | |
58 | val ty = make #ty | |
59 | end | |
60 | ||
61 | fun make (n, t) = T {node = n, ty = t} | |
62 | ||
63 | fun layout p = | |
64 | let | |
65 | val t = ty p | |
66 | open Layout | |
67 | in | |
68 | case node p of | |
69 | Con {arg, con, targs} => | |
70 | seq [Con.layout con, | |
71 | layoutTargs targs, | |
72 | case arg of | |
73 | NONE => empty | |
74 | | SOME p => seq [str " ", layout p]] | |
75 | | Const f => Const.layout (f ()) | |
76 | | Layered (x, p) => | |
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)) | |
80 | | Record r => | |
81 | let | |
82 | val extra = | |
83 | Vector.exists | |
84 | (Type.deRecord t, fn (f, _) => | |
85 | Option.isNone (Record.peek (r, f))) | |
86 | in | |
87 | Record.layout | |
88 | {extra = if extra then ", ..." else "", | |
89 | layoutElt = layout, | |
90 | layoutTuple = fn ps => tuple (Vector.toListMap (ps, layout)), | |
91 | record = r, | |
92 | separator = " = "} | |
93 | end | |
94 | | Var x => maybeConstrain (Var.layout x, t) | |
95 | | Vector ps => vector (Vector.map (ps, layout)) | |
96 | | Wild => str "_" | |
97 | end | |
98 | ||
99 | fun wild t = make (Wild, t) | |
100 | ||
101 | fun var (x, t) = make (Var x, t) | |
102 | ||
103 | fun tuple ps = | |
104 | if 1 = Vector.length ps | |
105 | then Vector.first ps | |
106 | else make (Record (Record.tuple ps), Type.tuple (Vector.map (ps, ty))) | |
107 | ||
108 | local | |
109 | fun bool c = make (Con {arg = NONE, con = c, targs = Vector.new0 ()}, | |
110 | Type.bool) | |
111 | in | |
112 | val falsee: t = bool Con.falsee | |
113 | val truee: t = bool Con.truee | |
114 | end | |
115 | ||
116 | fun isUnit (p: t): bool = | |
117 | case node p of | |
118 | Record r => Record.forall (r, fn _ => false) | |
119 | | _ => false | |
120 | ||
121 | fun isWild (p: t): bool = | |
122 | case node p of | |
123 | Wild => true | |
124 | | _ => false | |
125 | ||
126 | fun isRefutable (p: t): bool = | |
127 | case node p of | |
128 | Con _ => true | |
129 | | Const _ => true | |
130 | | Layered (_, p) => isRefutable p | |
131 | | List _ => true | |
132 | | Or ps => Vector.exists (ps, isRefutable) | |
133 | | Record r => Record.exists (r, isRefutable) | |
134 | | Var _ => false | |
135 | | Vector _ => true | |
136 | | Wild => false | |
137 | ||
138 | fun foreachVar (p: t, f: Var.t -> unit): unit = | |
139 | let | |
140 | fun loop (p: t): unit = | |
141 | case node p of | |
142 | Con _ => () | |
143 | | Const _ => () | |
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) | |
148 | | Var x => f x | |
149 | | Vector ps => Vector.foreach (ps, loop) | |
150 | | Wild => () | |
151 | in | |
152 | loop p | |
153 | end | |
154 | end | |
155 | ||
156 | structure NoMatch = | |
157 | struct | |
158 | datatype t = Impossible | RaiseAgain | RaiseBind | RaiseMatch | |
159 | end | |
160 | ||
161 | datatype noMatch = datatype NoMatch.t | |
162 | ||
163 | datatype dec = | |
164 | Datatype of {cons: {arg: Type.t option, | |
165 | con: Con.t} vector, | |
166 | tycon: Tycon.t, | |
167 | tyvars: Tyvar.t vector} vector | |
168 | | Exception of {arg: Type.t option, | |
169 | con: Con.t} | |
170 | | Fun of {decs: {lambda: lambda, | |
171 | var: Var.t} vector, | |
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, | |
177 | var: Var.t} vector, | |
178 | tyvars: unit -> Tyvar.t vector, | |
179 | vbs: {ctxt: unit -> Layout.t, | |
180 | exp: exp, | |
181 | layPat: unit -> Layout.t, | |
182 | nest: string list, | |
183 | pat: Pat.t, | |
184 | regionPat: Region.t} vector} | |
185 | and exp = Exp of {node: expNode, | |
186 | ty: Type.t} | |
187 | and expNode = | |
188 | App of exp * exp | |
189 | | Case of {ctxt: unit -> Layout.t, | |
190 | kind: string * string, | |
191 | nest: string list, | |
192 | matchDiags: {nonexhaustiveExn: Control.Elaborate.DiagDI.t, | |
193 | nonexhaustive: Control.Elaborate.DiagEIW.t, | |
194 | redundant: Control.Elaborate.DiagEIW.t}, | |
195 | noMatch: noMatch, | |
196 | region: Region.t, | |
197 | rules: {exp: exp, | |
198 | layPat: (unit -> Layout.t) option, | |
199 | pat: Pat.t, | |
200 | regionPat: Region.t} vector, | |
201 | test: exp} | |
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, | |
206 | handler: exp, | |
207 | try: exp} | |
208 | | Lambda of lambda | |
209 | | Let of dec vector * exp | |
210 | | List of exp vector | |
211 | | PrimApp of {args: exp vector, | |
212 | prim: Type.t Prim.t, | |
213 | targs: Type.t vector} | |
214 | | Raise of exp | |
215 | | Record of exp Record.t | |
216 | | Seq of exp vector | |
217 | | Var of (unit -> Var.t) * (unit -> Type.t vector) | |
218 | | Vector of exp vector | |
219 | and lambda = Lam of {arg: Var.t, | |
220 | argType: Type.t, | |
221 | body: exp, | |
222 | mayInline: bool} | |
223 | ||
224 | local | |
225 | open Layout | |
226 | in | |
227 | fun layoutTyvars (ts: Tyvar.t vector) = | |
228 | case Vector.length ts of | |
229 | 0 => empty | |
230 | | 1 => seq [str " ", Tyvar.layout (Vector.sub (ts, 0))] | |
231 | | _ => seq [str " ", tuple (Vector.toListMap (ts, Tyvar.layout))] | |
232 | ||
233 | fun layoutConArg {arg, con} = | |
234 | seq [Con.layout con, | |
235 | case arg of | |
236 | NONE => empty | |
237 | | SOME t => seq [str " of ", Type.layout t]] | |
238 | ||
239 | fun layoutDec d = | |
240 | case d of | |
241 | Datatype v => | |
242 | seq [str "datatype", | |
243 | align | |
244 | (Vector.toListMap | |
245 | (v, fn {cons, tycon, tyvars} => | |
246 | seq [layoutTyvars tyvars, | |
247 | str " ", Tycon.layout tycon, str " = ", | |
248 | align | |
249 | (separateLeft (Vector.toListMap (cons, layoutConArg), | |
250 | "| "))]))] | |
251 | | Exception ca => | |
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, ...} => | |
258 | seq [str "val", | |
259 | mayAlign [seq [layoutTyvars (tyvars ()), | |
260 | str " ", Pat.layout pat, | |
261 | str " ="], | |
262 | layoutExp exp]]))] | |
263 | and layoutExp (Exp {node, ...}) = | |
264 | case node of | |
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, | |
279 | try = layoutExp try} | |
280 | | Lambda l => layoutLambda l | |
281 | | Let (ds, e) => | |
282 | Pretty.lett (align (Vector.toListMap (ds, layoutDec)), | |
283 | layoutExp e) | |
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) | |
290 | | Record r => | |
291 | Record.layout | |
292 | {extra = "", | |
293 | layoutElt = layoutExp, | |
294 | layoutTuple = fn es => tuple (Vector.toListMap (es, layoutExp)), | |
295 | record = r, | |
296 | separator = " = "} | |
297 | | Seq es => Pretty.seq (Vector.map (es, layoutExp)) | |
298 | | Var (var, targs) => | |
299 | if !Control.showTypes | |
300 | then let | |
301 | open Layout | |
302 | val targs = targs () | |
303 | in | |
304 | if Vector.isEmpty targs | |
305 | then Var.layout (var ()) | |
306 | else seq [Var.layout (var ()), str " ", | |
307 | Vector.layout Type.layout targs] | |
308 | end | |
309 | else Var.layout (var ()) | |
310 | | Vector es => vector (Vector.map (es, layoutExp)) | |
311 | and layoutFuns (tyvars, decs) = | |
312 | if Vector.isEmpty decs | |
313 | then empty | |
314 | else | |
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)])), | |
320 | 3)] | |
321 | and layoutLambda (Lam {arg, argType, body, ...}) = | |
322 | paren (align [seq [str "fn ", | |
323 | maybeConstrain (Var.layout arg, argType), | |
324 | str " =>"], | |
325 | layoutExp body]) | |
326 | ||
327 | fun layoutExpWithType (exp as Exp {ty, ...}) = | |
328 | let | |
329 | val node = layoutExp exp | |
330 | in | |
331 | if !Control.showTypes | |
332 | then seq [node, str " : ", Type.layout ty] | |
333 | else node | |
334 | end | |
335 | end | |
336 | ||
337 | structure Lambda = | |
338 | struct | |
339 | datatype t = datatype lambda | |
340 | ||
341 | val make = Lam | |
342 | ||
343 | fun dest (Lam r) = r | |
344 | ||
345 | val bogus = make {arg = Var.newNoname (), | |
346 | argType = Type.unit, | |
347 | body = Exp {node = Seq (Vector.new0 ()), | |
348 | ty = Type.unit}, | |
349 | mayInline = true} | |
350 | end | |
351 | ||
352 | structure Exp = | |
353 | struct | |
354 | type dec = dec | |
355 | type lambda = lambda | |
356 | datatype t = datatype exp | |
357 | datatype node = datatype expNode | |
358 | ||
359 | datatype noMatch = datatype noMatch | |
360 | ||
361 | val layout = layoutExp | |
362 | val layoutWithType = layoutExpWithType | |
363 | ||
364 | local | |
365 | fun make f (Exp r) = f r | |
366 | in | |
367 | val dest = make (fn {node, ty} => (node, ty)) | |
368 | val node = make #node | |
369 | val ty = make #ty | |
370 | end | |
371 | ||
372 | fun make (n, t) = Exp {node = n, | |
373 | ty = t} | |
374 | ||
375 | fun var (x: Var.t, ty: Type.t): t = | |
376 | make (Var (fn () => x, fn () => Vector.new0 ()), ty) | |
377 | ||
378 | fun isExpansive (e: t): bool = | |
379 | case node e of | |
380 | App (e1, e2) => | |
381 | (case node e1 of | |
382 | Con (c, _) => Con.equals (c, Con.reff) orelse isExpansive e2 | |
383 | | _ => true) | |
384 | | Case _ => true | |
385 | | Con _ => false | |
386 | | Const _ => false | |
387 | | EnterLeave _ => true | |
388 | | Handle _ => true | |
389 | | Lambda _ => false | |
390 | | Let _ => true | |
391 | | List es => Vector.exists (es, isExpansive) | |
392 | | PrimApp _ => true | |
393 | | Raise _ => true | |
394 | | Record r => Record.exists (r, isExpansive) | |
395 | | Seq _ => true | |
396 | | Var _ => false | |
397 | | Vector es => Vector.exists (es, isExpansive) | |
398 | ||
399 | fun tuple es = | |
400 | if 1 = Vector.length es | |
401 | then Vector.first es | |
402 | else make (Record (Record.tuple es), | |
403 | Type.tuple (Vector.map (es, ty))) | |
404 | ||
405 | val unit = tuple (Vector.new0 ()) | |
406 | ||
407 | local | |
408 | fun bool c = make (Con (c, Vector.new0 ()), Type.bool) | |
409 | in | |
410 | val falsee: t = bool Con.falsee | |
411 | val truee: t = bool Con.truee | |
412 | end | |
413 | ||
414 | fun lambda (l as Lam {argType, body, ...}) = | |
415 | make (Lambda l, Type.arrow (argType, ty body)) | |
416 | ||
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))) | |
421 | ||
422 | fun iff (test, thenCase, elseCase): t = | |
423 | casee {ctxt = fn () => Layout.empty, | |
424 | kind = ("if", "branch"), | |
425 | nest = [], | |
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, | |
432 | layPat = NONE, | |
433 | pat = Pat.truee, | |
434 | regionPat = Region.bogus}, | |
435 | {exp = elseCase, | |
436 | layPat = NONE, | |
437 | pat = Pat.falsee, | |
438 | regionPat = Region.bogus}), | |
439 | test = test} | |
440 | ||
441 | fun andAlso (e1, e2) = iff (e1, e2, falsee) | |
442 | ||
443 | fun orElse (e1, e2) = iff (e1, truee, e2) | |
444 | ||
445 | fun whilee {expr, test} = | |
446 | let | |
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) | |
450 | val lambda = | |
451 | Lambda.make | |
452 | {arg = Var.newNoname (), | |
453 | argType = Type.unit, | |
454 | body = iff (test, | |
455 | make (Seq (Vector.new2 (expr, call)), | |
456 | Type.unit), | |
457 | unit), | |
458 | mayInline = true} | |
459 | in | |
460 | make | |
461 | (Let (Vector.new1 (Fun {decs = Vector.new1 {lambda = lambda, | |
462 | var = loop}, | |
463 | tyvars = fn () => Vector.new0 ()}), | |
464 | call), | |
465 | Type.unit) | |
466 | end | |
467 | ||
468 | fun foreachVar (e: t, f: Var.t -> unit): unit = | |
469 | let | |
470 | fun loop (e: t): unit = | |
471 | case node e of | |
472 | App (e1, e2) => (loop e1; loop e2) | |
473 | | Case {rules, test, ...} => | |
474 | (loop test | |
475 | ; Vector.foreach (rules, loop o #exp)) | |
476 | | Con _ => () | |
477 | | Const _ => () | |
478 | | EnterLeave (e, _) => loop e | |
479 | | Handle {handler, try, ...} => (loop handler; loop try) | |
480 | | Lambda l => loopLambda l | |
481 | | Let (ds, e) => | |
482 | (Vector.foreach (ds, loopDec) | |
483 | ; loop e) | |
484 | | List es => Vector.foreach (es, loop) | |
485 | | PrimApp {args, ...} => Vector.foreach (args, loop) | |
486 | | Raise e => loop e | |
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) | |
491 | and loopDec d = | |
492 | case d of | |
493 | Datatype _ => () | |
494 | | Exception _ => () | |
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 | |
500 | in | |
501 | loop e | |
502 | end | |
503 | end | |
504 | ||
505 | structure Dec = | |
506 | struct | |
507 | datatype t = datatype dec | |
508 | ||
509 | val layout = layoutDec | |
510 | end | |
511 | ||
512 | structure Program = | |
513 | struct | |
514 | datatype t = T of {decs: Dec.t vector} | |
515 | ||
516 | fun layouts (T {decs, ...}, output') = | |
517 | let | |
518 | open Layout | |
519 | (* Layout includes an output function, so we need to rebind output | |
520 | * to the one above. | |
521 | *) | |
522 | val output = output' | |
523 | in | |
524 | output (Layout.str "\n\nDecs:") | |
525 | ; Vector.foreach (decs, output o Dec.layout) | |
526 | end | |
527 | ||
528 | (* fun typeCheck (T {decs, ...}) = | |
529 | * let | |
530 | * fun checkExp (e: Exp.t): Ty.t = | |
531 | * let | |
532 | * val (n, t) = Exp.dest e | |
533 | * val | |
534 | * datatype z = datatype Exp.t | |
535 | * val t' = | |
536 | * case n of | |
537 | * App (e1, e2) => | |
538 | * let | |
539 | * val t1 = checkExp e1 | |
540 | * val t2 = checkExp e2 | |
541 | * in | |
542 | * case Type.deArrowOpt t1 of | |
543 | * NONE => error "application of non-function" | |
544 | * | SOME (u1, u2) => | |
545 | * if Type.equals (u1, t2) | |
546 | * then t2 | |
547 | * else error "function/argument mismatch" | |
548 | * end | |
549 | * | Case {rules, test} => | |
550 | * let | |
551 | * val {pat, exp} = Vector.first rules | |
552 | * in | |
553 | * Vector.foreach (rules, fn {pat, exp} => | |
554 | * Type.equals | |
555 | * (checkPat pat, | |
556 | * end | |
557 | * in | |
558 | * | |
559 | * end | |
560 | * in | |
561 | * end | |
562 | *) | |
563 | end | |
564 | ||
565 | end |