1 (* Copyright (C) 1999-2006 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 DirectExp2 (S: DIRECT_EXP2_STRUCTS): DIRECT_EXP2 =
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
83 val word = Const o Const.word
85 fun tuple (r as {exps, ...}) =
86 if 1 = Vector.length exps
87 then Vector.first exps
92 fun primApp {args, prim, targs, ty} =
99 case Prim.name prim of
100 Prim.Name.MLton_halt => runtime ()
101 | Prim.Name.Thread_copyCurrent => runtime ()
102 | _ => PrimApp {args = args,
109 fun make c = conApp {con = c, args = Vector.new0 (), ty = Type.bool}
111 val truee = make Con.truee
112 val falsee = make Con.falsee
115 fun eq (e1, e2, ty) =
116 primApp {prim = Prim.eq,
117 targs = Vector.new1 ty,
118 args = Vector.new2 (e1, e2),
123 fun lett (decs, body) =
124 align [seq [str "let ", decs],
125 seq [str "in ", body],
128 fun layout e : Layout.t =
130 Arith {prim, args, overflow, ...} =>
131 align [Prim.layoutApp (prim, args, layout),
132 seq [str "Overflow => ", layout overflow]]
133 | Call {func, args, ty} =>
134 seq [Func.layout func, str " ", layouts args,
135 str ": ", Type.layout ty]
136 | Case {cases, default, test, ...} =>
138 [seq [str "case ", layout test, str " of"],
147 seq [str "| ", x, str " => ", layout e]
151 doit (v, (fn (x, e) => (f x, e)))
155 doit (v, fn {con, args, body} =>
156 (seq [Con.layout con,
157 Vector.layout (Var.layout o #1) args],
159 | Word (_, v) => simple (v, WordX.layout)
163 | SOME e => seq [str " _ => ", layout e]],
165 | ConApp {con, args, ty} =>
166 seq [Con.layout con, layouts args, str ": ", Type.layout ty]
167 | Const c => Const.layout c
168 | Detuple {tuple, ...} => seq [str "detuple ", layout tuple]
169 | DetupleBind {body, components, tuple, ...} =>
170 lett (seq [Vector.layout Var.layout components,
171 str " = ", Var.layout tuple],
173 | Handle {try, catch, handler, ...} =>
175 seq [str "handle ", Var.layout (#1 catch),
176 str " => ", layout handler]]
177 | Let {decs, body} =>
179 (List.map (decs, fn {var, exp} =>
180 seq [Var.layout var, str " = ", layout exp])),
182 | Name _ => str "Name"
183 | PrimApp {args, prim, ...} =>
184 Prim.layoutApp (prim, args, layout)
185 | Profile e => ProfileExp.layout e
186 | Raise e => seq [str "raise ", layout e]
187 | Runtime {args, prim, ...} =>
188 Prim.layoutApp (prim, args, layout)
189 | Select {tuple, offset, ...} =>
190 seq [str "#", str (Int.toString (1 + offset)), str " ",
192 | Seq (e1, e2) => seq [layout e1, str "; ", layout e2]
193 | Tuple {exps, ...} => layouts exps
195 seq [Var.layout x, str ": ", Type.layout t]
196 and layouts es = Vector.layout layout es
201 type t = {statements: Statement.t list,
202 transfer: Transfer.t}
204 fun layout {statements, transfer} =
208 align [align (List.map (statements, Statement.layout)),
209 Transfer.layout transfer]
212 fun prefix ({statements, transfer}: t, s: Statement.t): t =
213 {statements = s :: statements,
221 val bind: Var.t * Res.t -> t
222 val goto: Label.t -> t
223 val layout: t -> Layout.t
224 val receiveExp: (Exp.t * Type.t -> Res.t) -> t
225 val receiveVar: (Var.t * Type.t -> Res.t) -> t
227 val sendExp: t * Type.t * Exp.t -> Res.t
228 val sendVar: t * Type.t * Var.t -> Res.t
229 val toBlock: t * Type.t -> Block.t
232 type bind = {arg: Var.t,
233 statements: Statement.t list,
234 transfer: Transfer.t}
239 | Prefix of t * Statement.t
240 | ReceiveExp of Exp.t * Type.t -> Res.t
241 | ReceiveVar of Var.t * Type.t -> Res.t
244 fun layout (k: t): Layout.t =
249 Bind {arg, statements, transfer} =>
251 record [("arg", Var.layout arg),
253 List.layout Statement.layout statements),
254 ("transfer", Transfer.layout transfer)]]
255 | Goto l => seq [str "Goto ", Label.layout l]
256 | Prefix (k, s) => seq [str "Prefix ",
257 tuple [layout k, Statement.layout s]]
258 | ReceiveExp _ => str "ReceiveExp"
259 | ReceiveVar _ => str "ReceiveVar"
260 | Return => str "Return"
263 fun bind (arg, {statements, transfer}) =
265 statements = statements,
269 val receiveExp = ReceiveExp
270 val receiveVar = ReceiveVar
273 fun toBind (k: t, ty: Type.t): bind =
278 val arg = Var.newNoname ()
279 val {statements, transfer} = sendVar (k, ty, arg)
282 statements = statements,
285 and sendVar (k: t, ty: Type.t, x: Var.t): Res.t =
287 Bind b => sendBindExp (b, ty, Exp.Var x)
288 | Goto dst => {statements = [],
289 transfer = Transfer.Goto {dst = dst,
290 args = Vector.new1 x}}
291 | ReceiveExp f => f (Exp.Var x, ty)
292 | ReceiveVar f => f (x, ty)
293 | Prefix (k, s) => Res.prefix (sendVar (k, ty, x), s)
294 | Return => {statements = [],
295 transfer = Transfer.Return (Vector.new1 x)}
296 and sendBindExp ({arg, statements, transfer}, ty, e: Exp.t) =
297 {statements = Statement.T {var = SOME arg,
299 exp = e} :: statements,
303 Trace.trace3 ("DirectExp2.Cont.sendVar", layout, Type.layout, Var.layout,
307 val sendExp: t * Type.t * Exp.t -> Res.t =
310 ReceiveExp f => f (e, ty)
311 | _ => sendBindExp (toBind (k, ty), ty, e)
314 Trace.trace3 ("DirectExp2.Cont.sendExp", layout, Type.layout, Exp.layout,
318 fun toBlock (k: t, ty: Type.t): Block.t =
320 val {arg, statements, transfer} = toBind (k, ty)
321 val label = Label.newNoname ()
323 Block.T {label = label,
324 args = Vector.new1 (arg, ty),
325 statements = Vector.fromList statements,
330 Trace.trace2 ("DirectExp2.Cont.toBlock", layout, Type.layout, Block.layout)
334 fun selects (tuple: Var.t, ty: Type.t, components: Var.t vector)
337 val ts = Type.deTuple ty
340 (ts, [], fn (i, t, ss) =>
341 Statement.T {var = SOME (Vector.sub (components, i)),
343 exp = Exp.Select {tuple = tuple,
348 fun linearize' (e: t, h: Handler.t, k: Cont.t): Label.t * Block.t list =
350 val traceLinearizeLoop =
351 Trace.trace3 ("DirectExp.linearize'.loop", layout, Handler.layout, Cont.layout,
353 val blocks: Block.t list ref = ref []
354 fun newBlock (args: (Var.t * Type.t) vector,
355 {statements: Statement.t list,
356 transfer: Transfer.t}): Label.t =
358 val label = Label.newNoname ()
359 val _ = List.push (blocks,
360 Block.T {label = label,
362 statements = Vector.fromList statements,
363 transfer = transfer})
367 fun reify (k: Cont.t, ty: Type.t): Label.t =
369 val b = Cont.toBlock (k, ty)
370 val _ = List.push (blocks, b)
374 fun newLabel (args: (Var.t * Type.t) vector,
377 k: Cont.t): Label.t =
378 newBlock (args, loop (e, h, k))
379 and newLabel0 (e, h, k) = newLabel (Vector.new0 (), e, h, k)
380 and loopf (e: t, h: Handler.t, f: Var.t * Type.t -> Res.t) =
381 loop (e, h, Cont.receiveVar f)
382 and loop arg : Res.t =
384 (fn (e: t, h: Handler.t, k: Cont.t) =>
386 Arith {prim, args, overflow, ty} =>
390 val l = reify (k, ty)
395 Transfer.Arith {prim = prim,
397 overflow = newLabel0 (overflow, h, k),
401 | Call {func, args, ty} =>
405 transfer = (Transfer.Call
408 return = Return.NonTail {cont = reify (k, ty),
410 | Case {cases, default, test, ty} =>
412 val k = Cont.goto (reify (k, ty))
414 loopf (test, h, fn (x, _) =>
419 default = Option.map (default, fn e =>
420 newLabel0 (e, h, k)),
424 Vector.map (v, fn (c, e) =>
425 (c, newLabel0 (e, h, k)))
431 (v, fn {con, args, body} =>
433 newLabel (args, body, h, k))))
434 | Word (s, v) => Cases.Word (s, doit v)
437 | ConApp {con, args, ty} =>
438 loops (args, h, fn xs =>
439 Cont.sendExp (k, ty, Exp.ConApp {con = con, args = xs}))
440 | Const c => Cont.sendExp (k, Type.ofConst c, Exp.Const c)
441 | Detuple {tuple, length, body} =>
446 fun doit (tuple: Var.t): Res.t =
450 0 => ([], Vector.new0 ())
451 | 1 => ([], Vector.new1 tuple)
456 (length, fn _ => Var.newNoname ())
457 in (selects (tuple, ty, xs), xs)
459 val {statements, transfer} = loop (body xs, h, k)
461 {statements = List.appendRev (ss, statements),
466 Exp.Tuple xs => loop (body xs, h, k)
467 | Exp.Var x => doit x
470 val tuple = Var.newNoname ()
472 Res.prefix (doit tuple,
473 Statement.T {var = SOME tuple,
478 | DetupleBind {body, components, tuple, tupleTy} =>
480 val {statements, transfer} = loop (body, h, k)
482 case Vector.length components of
485 {var = SOME (Vector.first components),
487 exp = Exp.Var tuple}]
488 | _ => selects (tuple, tupleTy, components)
490 {statements = List.appendRev (ss, statements),
493 | Handle {try, catch, handler, ty} =>
495 val k = Cont.goto (reify (k, ty))
496 val hl = Label.newNoname ()
497 val {statements, transfer} = loop (handler, h, k)
501 args = Vector.new1 catch,
502 statements = Vector.fromList statements,
503 transfer = transfer})
505 loop (try, Handler.Handle hl, k)
507 | Let {decs, body} =>
511 [] => loop (body, h, k)
512 | {var, exp} :: decs =>
513 loop (exp, h, Cont.bind (var, each decs))
517 | Name (e, f) => loopf (e, h, fn (x, _) => loop (f x, h, k))
518 | PrimApp {prim, targs, args, ty} =>
521 Cont.sendExp (k, ty, Exp.PrimApp {prim = prim,
524 | Profile e => Cont.sendExp (k, Type.unit, Exp.Profile e)
526 loopf (e, h, fn (x, _) =>
530 Handler.Caller => Transfer.Raise (Vector.new1 x)
531 | Handler.Dead => Error.bug "DirectExp2.linearize'.loop: Raise:to dead handler"
532 | Handler.Handle l =>
533 Transfer.Goto {args = Vector.new1 x,
535 | Runtime {args, prim, ty} =>
539 val l = reify (k, ty)
542 case Type.deTupleOpt ty of
545 val res = Var.newNoname ()
547 (Vector.new1 (res, ty),
548 Vector.new1 (Var (res, ty)))
552 then (Vector.new0 (), Vector.new0 ())
555 (concat ["DirectExp2.linearlize'.loop: Runtime:with multiple return values: ",
563 return = newLabel (args,
568 | Select {tuple, offset, ty} =>
569 loopf (tuple, h, fn (tuple, _) =>
570 Cont.sendExp (k, ty, Exp.Select {tuple = tuple,
572 | Seq (e1, e2) => loopf (e1, h, fn _ => loop (e2, h, k))
573 | Tuple {exps, ty} =>
574 loops (exps, h, fn xs => Cont.sendExp (k, ty, Exp.Tuple xs))
575 | Var (x, ty) => Cont.sendVar (k, ty, x)) arg
576 and loops (es: t vector, h: Handler.t, k: Var.t vector -> Res.t): Res.t =
578 val n = Vector.length es
581 then k (Vector.fromListRev ac)
582 else loopf (Vector.sub (es, i), h, fn (x, _) =>
583 each (i + 1, x :: ac))
587 val l = newLabel0 (e, h, k)
592 fun linearize (e: t, h) = linearize' (e, h, Cont.return)
595 Trace.trace2 ("DirectExp2.linearize", layout, Handler.layout,
596 Layout.tuple2 (Label.layout,
597 List.layout (Label.layout o Block.label)))
600 fun linearizeGoto (e: t, h, l) = linearize' (e, h, Cont.goto l)