1 (* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
2 * Jagannathan, and Stephen Weeks.
3 * Copyright (C) 1997-2000 NEC Research Institute.
5 * MLton is released under a BSD-style license.
6 * See the file MLton-LICENSE for details.
9 functor DirectExp (S: DIRECT_EXP_STRUCTS): DIRECT_EXP =
18 Arith of {prim: Type.t Prim.t,
22 | Call of {func: Func.t,
25 | Case of {cases: cases,
29 | ConApp of {con: Con.t,
33 | Detuple of {body: Var.t vector -> t,
36 | DetupleBind of {body: t,
37 components: Var.t vector,
41 catch: Var.t * Type.t,
44 | Let of {decs: {var: Var.t, exp: t} list,
46 | Name of t * (Var.t -> t)
47 | PrimApp of {prim: Type.t Prim.t,
51 | Profile of ProfileExp.t
53 | Runtime of {args: t vector,
56 | Select of {tuple: t,
60 | Tuple of {exps: t vector,
62 | Var of Var.t * Type.t
65 args: (Var.t * Type.t) vector,
67 | Word of WordSize.t * (WordX.t * t) vector
75 val detupleBind = DetupleBind
82 val word = Const o Const.word
84 fun tuple (r as {exps, ...}) =
85 if 1 = Vector.length exps
86 then Vector.first exps
91 fun primApp {args, prim, targs, ty} =
98 case Prim.name prim of
99 Prim.Name.MLton_halt => runtime ()
100 | Prim.Name.Thread_copyCurrent => runtime ()
101 | _ => PrimApp {args = args,
108 fun make c = conApp {con = c, args = Vector.new0 (), ty = Type.bool}
110 val truee = make Con.truee
111 val falsee = make Con.falsee
114 fun eq (e1, e2, ty) =
115 primApp {prim = Prim.eq,
116 targs = Vector.new1 ty,
117 args = Vector.new2 (e1, e2),
122 fun lett (decs, body) =
123 align [seq [str "let ", decs],
124 seq [str "in ", body],
127 fun layout e : Layout.t =
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, ...} =>
137 [seq [str "case ", layout test, str " of"],
146 seq [str "| ", x, str " => ", layout e]
150 doit (v, (fn (x, e) => (f x, e)))
154 doit (v, fn {con, args, body} =>
155 (seq [Con.layout con,
156 Vector.layout (Var.layout o #1) args],
158 | Word (_, v) => simple (v, WordX.layout)
162 | SOME e => seq [str " _ => ", layout e]],
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],
172 | Handle {try, catch, handler, ...} =>
174 seq [str "handle ", Var.layout (#1 catch),
175 str " => ", layout handler]]
176 | Let {decs, body} =>
178 (List.map (decs, fn {var, exp} =>
179 seq [Var.layout var, str " = ", layout exp])),
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 " ",
191 | Seq (e1, e2) => seq [layout e1, str "; ", layout e2]
192 | Tuple {exps, ...} => layouts exps
194 seq [Var.layout x, str ": ", Type.layout t]
195 and layouts es = Vector.layout layout es
200 type t = {statements: Statement.t list,
201 transfer: Transfer.t}
203 fun layout {statements, transfer} =
207 align [align (List.map (statements, Statement.layout)),
208 Transfer.layout transfer]
211 fun prefix ({statements, transfer}: t, s: Statement.t): t =
212 {statements = s :: statements,
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
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
231 type bind = {arg: Var.t,
232 statements: Statement.t list,
233 transfer: Transfer.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
243 fun layout (k: t): Layout.t =
248 Bind {arg, statements, transfer} =>
250 record [("arg", Var.layout arg),
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"
262 fun bind (arg, {statements, transfer}) =
264 statements = statements,
268 val receiveExp = ReceiveExp
269 val receiveVar = ReceiveVar
272 fun toBind (k: t, ty: Type.t): bind =
277 val arg = Var.newNoname ()
278 val {statements, transfer} = sendVar (k, ty, arg)
281 statements = statements,
284 and sendVar (k: t, ty: Type.t, x: Var.t): Res.t =
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,
298 exp = e} :: statements,
302 Trace.trace3 ("DirectExp.Cont.sendVar", layout, Type.layout, Var.layout,
306 val sendExp: t * Type.t * Exp.t -> Res.t =
309 ReceiveExp f => f (e, ty)
310 | _ => sendBindExp (toBind (k, ty), ty, e)
313 Trace.trace3 ("DirectExp.Cont.sendExp", layout, Type.layout, Exp.layout,
317 fun toBlock (k: t, ty: Type.t): Block.t =
319 val {arg, statements, transfer} = toBind (k, ty)
320 val label = Label.newNoname ()
322 Block.T {label = label,
323 args = Vector.new1 (arg, ty),
324 statements = Vector.fromList statements,
329 Trace.trace2 ("DirectExp.Cont.toBlock", layout, Type.layout, Block.layout)
333 fun selects (tuple: Var.t, ty: Type.t, components: Var.t vector)
336 val ts = Type.deTuple ty
339 (ts, [], fn (i, t, ss) =>
340 Statement.T {var = SOME (Vector.sub (components, i)),
342 exp = Exp.Select {tuple = tuple,
347 fun linearize' (e: t, h: Handler.t, k: Cont.t): Label.t * Block.t list =
349 val traceLinearizeLoop =
350 Trace.trace3 ("DirectExp.linearize'.loop", layout, Handler.layout, Cont.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 =
357 val label = Label.newNoname ()
358 val _ = List.push (blocks,
359 Block.T {label = label,
361 statements = Vector.fromList statements,
362 transfer = transfer})
366 fun reify (k: Cont.t, ty: Type.t): Label.t =
368 val b = Cont.toBlock (k, ty)
369 val _ = List.push (blocks, b)
373 fun newLabel (args: (Var.t * Type.t) vector,
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 =
383 (fn (e: t, h: Handler.t, k: Cont.t) =>
385 Arith {prim, args, overflow, ty} =>
389 val l = reify (k, ty)
394 Transfer.Arith {prim = prim,
396 overflow = newLabel0 (overflow, h, k),
400 | Call {func, args, ty} =>
404 transfer = (Transfer.Call
407 return = Return.NonTail {cont = reify (k, ty),
409 | Case {cases, default, test, ty} =>
411 val k = Cont.goto (reify (k, ty))
413 loopf (test, h, fn (x, _) =>
418 default = Option.map (default, fn e =>
419 newLabel0 (e, h, k)),
423 Vector.map (v, fn (c, e) =>
424 (c, newLabel0 (e, h, k)))
430 (v, fn {con, args, body} =>
432 newLabel (args, body, h, k))))
433 | Word (s, v) => Cases.Word (s, doit v)
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} =>
445 fun doit (tuple: Var.t): Res.t =
449 0 => ([], Vector.new0 ())
450 | 1 => ([], Vector.new1 tuple)
455 (length, fn _ => Var.newNoname ())
456 in (selects (tuple, ty, xs), xs)
458 val {statements, transfer} = loop (body xs, h, k)
460 {statements = List.appendRev (ss, statements),
465 Exp.Tuple xs => loop (body xs, h, k)
466 | Exp.Var x => doit x
469 val tuple = Var.newNoname ()
471 Res.prefix (doit tuple,
472 Statement.T {var = SOME tuple,
477 | DetupleBind {body, components, tuple, tupleTy} =>
479 val {statements, transfer} = loop (body, h, k)
481 case Vector.length components of
484 {var = SOME (Vector.first components),
486 exp = Exp.Var tuple}]
487 | _ => selects (tuple, tupleTy, components)
489 {statements = List.appendRev (ss, statements),
492 | Handle {try, catch, handler, ty} =>
494 val k = Cont.goto (reify (k, ty))
495 val hl = Label.newNoname ()
496 val {statements, transfer} = loop (handler, h, k)
500 args = Vector.new1 catch,
501 statements = Vector.fromList statements,
502 transfer = transfer})
504 loop (try, Handler.Handle hl, k)
506 | Let {decs, body} =>
510 [] => loop (body, h, k)
511 | {var, exp} :: decs =>
512 loop (exp, h, Cont.bind (var, each decs))
516 | Name (e, f) => loopf (e, h, fn (x, _) => loop (f x, h, k))
517 | PrimApp {prim, targs, args, ty} =>
520 Cont.sendExp (k, ty, Exp.PrimApp {prim = prim,
523 | Profile e => Cont.sendExp (k, Type.unit, Exp.Profile e)
525 loopf (e, h, fn (x, _) =>
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,
534 | Runtime {args, prim, ty} =>
538 val l = reify (k, ty)
541 case Type.deTupleOpt ty of
544 val res = Var.newNoname ()
546 (Vector.new1 (res, ty),
547 Vector.new1 (Var (res, ty)))
551 then (Vector.new0 (), Vector.new0 ())
554 (concat ["DirectExp.linearize'.loop: Runtime:with multiple return values: ",
562 return = newLabel (args,
567 | Select {tuple, offset, ty} =>
568 loopf (tuple, h, fn (tuple, _) =>
569 Cont.sendExp (k, ty, Exp.Select {tuple = tuple,
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 =
577 val n = Vector.length es
580 then k (Vector.fromListRev ac)
581 else loopf (Vector.sub (es, i), h, fn (x, _) =>
582 each (i + 1, x :: ac))
586 val l = newLabel0 (e, h, k)
591 fun linearize (e: t, h) = linearize' (e, h, Cont.return)
594 Trace.trace2 ("DirectExp.linearize", layout, Handler.layout,
595 Layout.tuple2 (Label.layout,
596 List.layout (Label.layout o Block.label)))
599 fun linearizeGoto (e: t, h, l) = linearize' (e, h, Cont.goto l)