Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh |
2 | * Jagannathan, and Stephen Weeks. | |
3 | * Copyright (C) 1997-2000 NEC Research Institute. | |
4 | * | |
5 | * MLton is released under a BSD-style license. | |
6 | * See the file MLton-LICENSE for details. | |
7 | *) | |
8 | ||
9 | functor DirectExp (S: DIRECT_EXP_STRUCTS): DIRECT_EXP = | |
10 | struct | |
11 | ||
12 | open S | |
13 | ||
14 | structure DirectExp = | |
15 | struct | |
16 | ||
17 | datatype t = | |
18 | Arith of {prim: Type.t Prim.t, | |
19 | args: t vector, | |
20 | overflow: t, | |
21 | ty: Type.t} | |
22 | | Call of {func: Func.t, | |
23 | args: t vector, | |
24 | ty: Type.t} | |
25 | | Case of {cases: cases, | |
26 | default: t option, | |
27 | test: t, | |
28 | ty: Type.t} | |
29 | | ConApp of {con: Con.t, | |
30 | args: t vector, | |
31 | ty: Type.t} | |
32 | | Const of Const.t | |
33 | | Detuple of {body: Var.t vector -> t, | |
34 | length: int, | |
35 | tuple: t} | |
36 | | DetupleBind of {body: t, | |
37 | components: Var.t vector, | |
38 | tuple: Var.t, | |
39 | tupleTy: Type.t} | |
40 | | Handle of {try: t, | |
41 | catch: Var.t * Type.t, | |
42 | handler: t, | |
43 | ty: Type.t} | |
44 | | Let of {decs: {var: Var.t, exp: t} list, | |
45 | body: t} | |
46 | | Name of t * (Var.t -> t) | |
47 | | PrimApp of {prim: Type.t Prim.t, | |
48 | targs: Type.t vector, | |
49 | args: t vector, | |
50 | ty: Type.t} | |
51 | | Profile of ProfileExp.t | |
52 | | Raise of t | |
53 | | Runtime of {args: t vector, | |
54 | prim: Type.t Prim.t, | |
55 | ty: Type.t} | |
56 | | Select of {tuple: t, | |
57 | offset: int, | |
58 | ty: Type.t} | |
59 | | Seq of t * t | |
60 | | Tuple of {exps: t vector, | |
61 | ty: Type.t} | |
62 | | Var of Var.t * Type.t | |
63 | and cases = | |
64 | Con of {con: Con.t, | |
65 | args: (Var.t * Type.t) vector, | |
66 | body: t} vector | |
67 | | Word of WordSize.t * (WordX.t * t) vector | |
68 | ||
69 | val arith = Arith | |
70 | val call = Call | |
71 | val casee = Case | |
72 | val conApp = ConApp | |
73 | val const = Const | |
74 | val detuple = Detuple | |
75 | val detupleBind = DetupleBind | |
76 | val handlee = Handle | |
77 | val lett = Let | |
78 | val name = Name | |
79 | val profile = Profile | |
80 | val raisee = Raise | |
81 | val select = Select | |
82 | val word = Const o Const.word | |
83 | ||
84 | fun tuple (r as {exps, ...}) = | |
85 | if 1 = Vector.length exps | |
86 | then Vector.first exps | |
87 | else Tuple r | |
88 | ||
89 | val var = Var | |
90 | ||
91 | fun primApp {args, prim, targs, ty} = | |
92 | let | |
93 | fun runtime () = | |
94 | Runtime {args = args, | |
95 | prim = prim, | |
96 | ty = ty} | |
97 | in | |
98 | case Prim.name prim of | |
99 | Prim.Name.MLton_halt => runtime () | |
100 | | Prim.Name.Thread_copyCurrent => runtime () | |
101 | | _ => PrimApp {args = args, | |
102 | prim = prim, | |
103 | targs = targs, | |
104 | ty = ty} | |
105 | end | |
106 | ||
107 | local | |
108 | fun make c = conApp {con = c, args = Vector.new0 (), ty = Type.bool} | |
109 | in | |
110 | val truee = make Con.truee | |
111 | val falsee = make Con.falsee | |
112 | end | |
113 | ||
114 | fun eq (e1, e2, ty) = | |
115 | primApp {prim = Prim.eq, | |
116 | targs = Vector.new1 ty, | |
117 | args = Vector.new2 (e1, e2), | |
118 | ty = Type.bool} | |
119 | ||
120 | local | |
121 | open Layout | |
122 | fun lett (decs, body) = | |
123 | align [seq [str "let ", decs], | |
124 | seq [str "in ", body], | |
125 | str "end"] | |
126 | in | |
127 | fun layout e : Layout.t = | |
128 | case e of | |
129 | Arith {prim, args, overflow, ...} => | |
130 | align [Prim.layoutApp (prim, args, layout), | |
131 | seq [str "Overflow => ", layout overflow]] | |
132 | | Call {func, args, ty} => | |
133 | seq [Func.layout func, str " ", layouts args, | |
134 | str ": ", Type.layout ty] | |
135 | | Case {cases, default, test, ...} => | |
136 | align | |
137 | [seq [str "case ", layout test, str " of"], | |
138 | indent | |
139 | (align [let | |
140 | fun doit (v, f) = | |
141 | Vector.layout | |
142 | (fn z => | |
143 | let | |
144 | val (x, e) = f z | |
145 | in | |
146 | seq [str "| ", x, str " => ", layout e] | |
147 | end) | |
148 | v | |
149 | fun simple (v, f) = | |
150 | doit (v, (fn (x, e) => (f x, e))) | |
151 | in | |
152 | case cases of | |
153 | Con v => | |
154 | doit (v, fn {con, args, body} => | |
155 | (seq [Con.layout con, | |
156 | Vector.layout (Var.layout o #1) args], | |
157 | body)) | |
158 | | Word (_, v) => simple (v, WordX.layout) | |
159 | end, | |
160 | case default of | |
161 | NONE => empty | |
162 | | SOME e => seq [str " _ => ", layout e]], | |
163 | 2)] | |
164 | | ConApp {con, args, ty} => | |
165 | seq [Con.layout con, layouts args, str ": ", Type.layout ty] | |
166 | | Const c => Const.layout c | |
167 | | Detuple {tuple, ...} => seq [str "detuple ", layout tuple] | |
168 | | DetupleBind {body, components, tuple, ...} => | |
169 | lett (seq [Vector.layout Var.layout components, | |
170 | str " = ", Var.layout tuple], | |
171 | layout body) | |
172 | | Handle {try, catch, handler, ...} => | |
173 | align [layout try, | |
174 | seq [str "handle ", Var.layout (#1 catch), | |
175 | str " => ", layout handler]] | |
176 | | Let {decs, body} => | |
177 | lett (align | |
178 | (List.map (decs, fn {var, exp} => | |
179 | seq [Var.layout var, str " = ", layout exp])), | |
180 | layout body) | |
181 | | Name _ => str "Name" | |
182 | | PrimApp {args, prim, ...} => | |
183 | Prim.layoutApp (prim, args, layout) | |
184 | | Profile e => ProfileExp.layout e | |
185 | | Raise e => seq [str "raise ", layout e] | |
186 | | Runtime {args, prim, ...} => | |
187 | Prim.layoutApp (prim, args, layout) | |
188 | | Select {tuple, offset, ...} => | |
189 | seq [str "#", str (Int.toString (1 + offset)), str " ", | |
190 | layout tuple] | |
191 | | Seq (e1, e2) => seq [layout e1, str "; ", layout e2] | |
192 | | Tuple {exps, ...} => layouts exps | |
193 | | Var (x, t) => | |
194 | seq [Var.layout x, str ": ", Type.layout t] | |
195 | and layouts es = Vector.layout layout es | |
196 | end | |
197 | ||
198 | structure Res = | |
199 | struct | |
200 | type t = {statements: Statement.t list, | |
201 | transfer: Transfer.t} | |
202 | ||
203 | fun layout {statements, transfer} = | |
204 | let | |
205 | open Layout | |
206 | in | |
207 | align [align (List.map (statements, Statement.layout)), | |
208 | Transfer.layout transfer] | |
209 | end | |
210 | ||
211 | fun prefix ({statements, transfer}: t, s: Statement.t): t = | |
212 | {statements = s :: statements, | |
213 | transfer = transfer} | |
214 | end | |
215 | ||
216 | structure Cont: | |
217 | sig | |
218 | type t | |
219 | ||
220 | val bind: Var.t * Res.t -> t | |
221 | val goto: Label.t -> t | |
222 | val layout: t -> Layout.t | |
223 | val receiveExp: (Exp.t * Type.t -> Res.t) -> t | |
224 | val receiveVar: (Var.t * Type.t -> Res.t) -> t | |
225 | val return: t | |
226 | val sendExp: t * Type.t * Exp.t -> Res.t | |
227 | val sendVar: t * Type.t * Var.t -> Res.t | |
228 | val toBlock: t * Type.t -> Block.t | |
229 | end = | |
230 | struct | |
231 | type bind = {arg: Var.t, | |
232 | statements: Statement.t list, | |
233 | transfer: Transfer.t} | |
234 | ||
235 | datatype t = | |
236 | Bind of bind | |
237 | | Goto of Label.t | |
238 | | Prefix of t * Statement.t | |
239 | | ReceiveExp of Exp.t * Type.t -> Res.t | |
240 | | ReceiveVar of Var.t * Type.t -> Res.t | |
241 | | Return | |
242 | ||
243 | fun layout (k: t): Layout.t = | |
244 | let | |
245 | open Layout | |
246 | in | |
247 | case k of | |
248 | Bind {arg, statements, transfer} => | |
249 | seq [str "Bind ", | |
250 | record [("arg", Var.layout arg), | |
251 | ("statements", | |
252 | List.layout Statement.layout statements), | |
253 | ("transfer", Transfer.layout transfer)]] | |
254 | | Goto l => seq [str "Goto ", Label.layout l] | |
255 | | Prefix (k, s) => seq [str "Prefix ", | |
256 | tuple [layout k, Statement.layout s]] | |
257 | | ReceiveExp _ => str "ReceiveExp" | |
258 | | ReceiveVar _ => str "ReceiveVar" | |
259 | | Return => str "Return" | |
260 | end | |
261 | ||
262 | fun bind (arg, {statements, transfer}) = | |
263 | Bind {arg = arg, | |
264 | statements = statements, | |
265 | transfer = transfer} | |
266 | ||
267 | val goto = Goto | |
268 | val receiveExp = ReceiveExp | |
269 | val receiveVar = ReceiveVar | |
270 | val return = Return | |
271 | ||
272 | fun toBind (k: t, ty: Type.t): bind = | |
273 | case k of | |
274 | Bind b => b | |
275 | | _ => | |
276 | let | |
277 | val arg = Var.newNoname () | |
278 | val {statements, transfer} = sendVar (k, ty, arg) | |
279 | in | |
280 | {arg = arg, | |
281 | statements = statements, | |
282 | transfer = transfer} | |
283 | end | |
284 | and sendVar (k: t, ty: Type.t, x: Var.t): Res.t = | |
285 | case k of | |
286 | Bind b => sendBindExp (b, ty, Exp.Var x) | |
287 | | Goto dst => {statements = [], | |
288 | transfer = Transfer.Goto {dst = dst, | |
289 | args = Vector.new1 x}} | |
290 | | ReceiveExp f => f (Exp.Var x, ty) | |
291 | | ReceiveVar f => f (x, ty) | |
292 | | Prefix (k, s) => Res.prefix (sendVar (k, ty, x), s) | |
293 | | Return => {statements = [], | |
294 | transfer = Transfer.Return (Vector.new1 x)} | |
295 | and sendBindExp ({arg, statements, transfer}, ty, e: Exp.t) = | |
296 | {statements = Statement.T {var = SOME arg, | |
297 | ty = ty, | |
298 | exp = e} :: statements, | |
299 | transfer = transfer} | |
300 | ||
301 | val sendVar = | |
302 | Trace.trace3 ("DirectExp.Cont.sendVar", layout, Type.layout, Var.layout, | |
303 | Res.layout) | |
304 | sendVar | |
305 | ||
306 | val sendExp: t * Type.t * Exp.t -> Res.t = | |
307 | fn (k, ty, e) => | |
308 | case k of | |
309 | ReceiveExp f => f (e, ty) | |
310 | | _ => sendBindExp (toBind (k, ty), ty, e) | |
311 | ||
312 | val sendExp = | |
313 | Trace.trace3 ("DirectExp.Cont.sendExp", layout, Type.layout, Exp.layout, | |
314 | Res.layout) | |
315 | sendExp | |
316 | ||
317 | fun toBlock (k: t, ty: Type.t): Block.t = | |
318 | let | |
319 | val {arg, statements, transfer} = toBind (k, ty) | |
320 | val label = Label.newNoname () | |
321 | in | |
322 | Block.T {label = label, | |
323 | args = Vector.new1 (arg, ty), | |
324 | statements = Vector.fromList statements, | |
325 | transfer = transfer} | |
326 | end | |
327 | ||
328 | val toBlock = | |
329 | Trace.trace2 ("DirectExp.Cont.toBlock", layout, Type.layout, Block.layout) | |
330 | toBlock | |
331 | end | |
332 | ||
333 | fun selects (tuple: Var.t, ty: Type.t, components: Var.t vector) | |
334 | : Statement.t list = | |
335 | let | |
336 | val ts = Type.deTuple ty | |
337 | in | |
338 | Vector.foldi | |
339 | (ts, [], fn (i, t, ss) => | |
340 | Statement.T {var = SOME (Vector.sub (components, i)), | |
341 | ty = t, | |
342 | exp = Exp.Select {tuple = tuple, | |
343 | offset = i}} | |
344 | :: ss) | |
345 | end | |
346 | ||
347 | fun linearize' (e: t, h: Handler.t, k: Cont.t): Label.t * Block.t list = | |
348 | let | |
349 | val traceLinearizeLoop = | |
350 | Trace.trace3 ("DirectExp.linearize'.loop", layout, Handler.layout, Cont.layout, | |
351 | Res.layout) | |
352 | val blocks: Block.t list ref = ref [] | |
353 | fun newBlock (args: (Var.t * Type.t) vector, | |
354 | {statements: Statement.t list, | |
355 | transfer: Transfer.t}): Label.t = | |
356 | let | |
357 | val label = Label.newNoname () | |
358 | val _ = List.push (blocks, | |
359 | Block.T {label = label, | |
360 | args = args, | |
361 | statements = Vector.fromList statements, | |
362 | transfer = transfer}) | |
363 | in | |
364 | label | |
365 | end | |
366 | fun reify (k: Cont.t, ty: Type.t): Label.t = | |
367 | let | |
368 | val b = Cont.toBlock (k, ty) | |
369 | val _ = List.push (blocks, b) | |
370 | in | |
371 | Block.label b | |
372 | end | |
373 | fun newLabel (args: (Var.t * Type.t) vector, | |
374 | e: t, | |
375 | h: Handler.t, | |
376 | k: Cont.t): Label.t = | |
377 | newBlock (args, loop (e, h, k)) | |
378 | and newLabel0 (e, h, k) = newLabel (Vector.new0 (), e, h, k) | |
379 | and loopf (e: t, h: Handler.t, f: Var.t * Type.t -> Res.t) = | |
380 | loop (e, h, Cont.receiveVar f) | |
381 | and loop arg : Res.t = | |
382 | traceLinearizeLoop | |
383 | (fn (e: t, h: Handler.t, k: Cont.t) => | |
384 | case e of | |
385 | Arith {prim, args, overflow, ty} => | |
386 | loops | |
387 | (args, h, fn xs => | |
388 | let | |
389 | val l = reify (k, ty) | |
390 | val k = Cont.goto l | |
391 | in | |
392 | {statements = [], | |
393 | transfer = | |
394 | Transfer.Arith {prim = prim, | |
395 | args = xs, | |
396 | overflow = newLabel0 (overflow, h, k), | |
397 | success = l, | |
398 | ty = ty}} | |
399 | end) | |
400 | | Call {func, args, ty} => | |
401 | loops | |
402 | (args, h, fn xs => | |
403 | {statements = [], | |
404 | transfer = (Transfer.Call | |
405 | {func = func, | |
406 | args = xs, | |
407 | return = Return.NonTail {cont = reify (k, ty), | |
408 | handler = h}})}) | |
409 | | Case {cases, default, test, ty} => | |
410 | let | |
411 | val k = Cont.goto (reify (k, ty)) | |
412 | in | |
413 | loopf (test, h, fn (x, _) => | |
414 | {statements = [], | |
415 | transfer = | |
416 | Transfer.Case | |
417 | {test = x, | |
418 | default = Option.map (default, fn e => | |
419 | newLabel0 (e, h, k)), | |
420 | cases = | |
421 | let | |
422 | fun doit v = | |
423 | Vector.map (v, fn (c, e) => | |
424 | (c, newLabel0 (e, h, k))) | |
425 | in | |
426 | case cases of | |
427 | Con v => | |
428 | Cases.Con | |
429 | (Vector.map | |
430 | (v, fn {con, args, body} => | |
431 | (con, | |
432 | newLabel (args, body, h, k)))) | |
433 | | Word (s, v) => Cases.Word (s, doit v) | |
434 | end}}) | |
435 | end | |
436 | | ConApp {con, args, ty} => | |
437 | loops (args, h, fn xs => | |
438 | Cont.sendExp (k, ty, Exp.ConApp {con = con, args = xs})) | |
439 | | Const c => Cont.sendExp (k, Type.ofConst c, Exp.Const c) | |
440 | | Detuple {tuple, length, body} => | |
441 | loop (tuple, h, | |
442 | Cont.receiveExp | |
443 | (fn (e, ty) => | |
444 | let | |
445 | fun doit (tuple: Var.t): Res.t = | |
446 | let | |
447 | val (ss, xs) = | |
448 | case length of | |
449 | 0 => ([], Vector.new0 ()) | |
450 | | 1 => ([], Vector.new1 tuple) | |
451 | | _ => | |
452 | let | |
453 | val xs = | |
454 | Vector.tabulate | |
455 | (length, fn _ => Var.newNoname ()) | |
456 | in (selects (tuple, ty, xs), xs) | |
457 | end | |
458 | val {statements, transfer} = loop (body xs, h, k) | |
459 | in | |
460 | {statements = List.appendRev (ss, statements), | |
461 | transfer = transfer} | |
462 | end | |
463 | in | |
464 | case e of | |
465 | Exp.Tuple xs => loop (body xs, h, k) | |
466 | | Exp.Var x => doit x | |
467 | | _ => | |
468 | let | |
469 | val tuple = Var.newNoname () | |
470 | in | |
471 | Res.prefix (doit tuple, | |
472 | Statement.T {var = SOME tuple, | |
473 | ty = ty, | |
474 | exp = e}) | |
475 | end | |
476 | end)) | |
477 | | DetupleBind {body, components, tuple, tupleTy} => | |
478 | let | |
479 | val {statements, transfer} = loop (body, h, k) | |
480 | val ss = | |
481 | case Vector.length components of | |
482 | 0 => [] | |
483 | | 1 => [Statement.T | |
484 | {var = SOME (Vector.first components), | |
485 | ty = tupleTy, | |
486 | exp = Exp.Var tuple}] | |
487 | | _ => selects (tuple, tupleTy, components) | |
488 | in | |
489 | {statements = List.appendRev (ss, statements), | |
490 | transfer = transfer} | |
491 | end | |
492 | | Handle {try, catch, handler, ty} => | |
493 | let | |
494 | val k = Cont.goto (reify (k, ty)) | |
495 | val hl = Label.newNoname () | |
496 | val {statements, transfer} = loop (handler, h, k) | |
497 | val _ = | |
498 | List.push (blocks, | |
499 | Block.T {label = hl, | |
500 | args = Vector.new1 catch, | |
501 | statements = Vector.fromList statements, | |
502 | transfer = transfer}) | |
503 | in | |
504 | loop (try, Handler.Handle hl, k) | |
505 | end | |
506 | | Let {decs, body} => | |
507 | let | |
508 | fun each decs = | |
509 | case decs of | |
510 | [] => loop (body, h, k) | |
511 | | {var, exp} :: decs => | |
512 | loop (exp, h, Cont.bind (var, each decs)) | |
513 | in | |
514 | each decs | |
515 | end | |
516 | | Name (e, f) => loopf (e, h, fn (x, _) => loop (f x, h, k)) | |
517 | | PrimApp {prim, targs, args, ty} => | |
518 | loops | |
519 | (args, h, fn xs => | |
520 | Cont.sendExp (k, ty, Exp.PrimApp {prim = prim, | |
521 | targs = targs, | |
522 | args = xs})) | |
523 | | Profile e => Cont.sendExp (k, Type.unit, Exp.Profile e) | |
524 | | Raise e => | |
525 | loopf (e, h, fn (x, _) => | |
526 | {statements = [], | |
527 | transfer = | |
528 | (case h of | |
529 | Handler.Caller => Transfer.Raise (Vector.new1 x) | |
530 | | Handler.Dead => Error.bug "DirectExp.linearize'.loop: Raise:to dead handler" | |
531 | | Handler.Handle l => | |
532 | Transfer.Goto {args = Vector.new1 x, | |
533 | dst = l})}) | |
534 | | Runtime {args, prim, ty} => | |
535 | loops | |
536 | (args, h, fn xs => | |
537 | let | |
538 | val l = reify (k, ty) | |
539 | val k = Cont.goto l | |
540 | val (args, exps) = | |
541 | case Type.deTupleOpt ty of | |
542 | NONE => | |
543 | let | |
544 | val res = Var.newNoname () | |
545 | in | |
546 | (Vector.new1 (res, ty), | |
547 | Vector.new1 (Var (res, ty))) | |
548 | end | |
549 | | SOME ts => | |
550 | if Vector.isEmpty ts | |
551 | then (Vector.new0 (), Vector.new0 ()) | |
552 | else | |
553 | Error.bug | |
554 | (concat ["DirectExp.linearize'.loop: Runtime:with multiple return values: ", | |
555 | Prim.toString prim]) | |
556 | in | |
557 | {statements = [], | |
558 | transfer = | |
559 | Transfer.Runtime | |
560 | {prim = prim, | |
561 | args = xs, | |
562 | return = newLabel (args, | |
563 | tuple {exps = exps, | |
564 | ty = ty}, | |
565 | h, k)}} | |
566 | end) | |
567 | | Select {tuple, offset, ty} => | |
568 | loopf (tuple, h, fn (tuple, _) => | |
569 | Cont.sendExp (k, ty, Exp.Select {tuple = tuple, | |
570 | offset = offset})) | |
571 | | Seq (e1, e2) => loopf (e1, h, fn _ => loop (e2, h, k)) | |
572 | | Tuple {exps, ty} => | |
573 | loops (exps, h, fn xs => Cont.sendExp (k, ty, Exp.Tuple xs)) | |
574 | | Var (x, ty) => Cont.sendVar (k, ty, x)) arg | |
575 | and loops (es: t vector, h: Handler.t, k: Var.t vector -> Res.t): Res.t = | |
576 | let | |
577 | val n = Vector.length es | |
578 | fun each (i, ac) = | |
579 | if i = n | |
580 | then k (Vector.fromListRev ac) | |
581 | else loopf (Vector.sub (es, i), h, fn (x, _) => | |
582 | each (i + 1, x :: ac)) | |
583 | in | |
584 | each (0, []) | |
585 | end | |
586 | val l = newLabel0 (e, h, k) | |
587 | in | |
588 | (l, !blocks) | |
589 | end | |
590 | ||
591 | fun linearize (e: t, h) = linearize' (e, h, Cont.return) | |
592 | ||
593 | val linearize = | |
594 | Trace.trace2 ("DirectExp.linearize", layout, Handler.layout, | |
595 | Layout.tuple2 (Label.layout, | |
596 | List.layout (Label.layout o Block.label))) | |
597 | linearize | |
598 | ||
599 | fun linearizeGoto (e: t, h, l) = linearize' (e, h, Cont.goto l) | |
600 | ||
601 | end | |
602 | end |