1 (* Copyright (C) 1999-2008 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 ImplementSuffix (S: XML_TRANSFORM_STRUCTS): XML_TRANSFORM =
13 datatype z = datatype Dec.t
14 datatype z = datatype PrimExp.t
15 structure Dexp = DirectExp
17 fun transform (Program.T {datatypes, body, overflow, ...}): Program.t =
19 (* topLevelSuffix holds the ref cell containing the function of
20 * type unit -> unit that should be called on program exit.
22 val topLevelSuffixType = Type.arrow (Type.unit, Type.unit)
23 val topLevelSuffixVar = Var.newNoname ()
25 fun loop (e: Exp.t): Exp.t =
27 val {decs, result} = Exp.dest e
28 val decs = List.rev (List.fold (decs, [], fn (d, ds) =>
31 Exp.make {decs = decs,
34 and loopDec (dec: Dec.t): Dec.t =
36 MonoVal b => loopMonoVal b
38 Fun {tyvars = Vector.new0 (),
39 decs = Vector.map (decs, fn {var, ty, lambda} =>
42 lambda = loopLambda lambda})}
43 | Exception {...} => dec
44 | _ => Error.bug "ImplementSuffix: saw unexpected dec"
45 and loopMonoVal {var, ty, exp} : Dec.t =
47 fun primExp e = MonoVal {var = var, ty = ty, exp = e}
48 fun keep () = primExp exp
51 Case {test, cases, default} =>
52 primExp (Case {cases = Cases.map (cases, loop),
54 (default, fn (e, r) =>
57 | ConApp {...} => keep ()
58 | Handle {try, catch = (catch, ty), handler} =>
59 primExp (Handle {try = loop try,
61 handler = loop handler})
62 | Lambda l => primExp (Lambda (loopLambda l))
63 | PrimApp {args, prim, ...} =>
65 datatype z = datatype Prim.Name.t
68 (PrimApp {prim = Prim.deref,
69 targs = Vector.new1 ty,
70 args = Vector.new1 (VarExp.mono var)})
71 fun assign (var, ty) =
73 (PrimApp {prim = Prim.assign,
74 targs = Vector.new1 ty,
75 args = Vector.new2 (VarExp.mono var,
78 case Prim.name prim of
80 deref (topLevelSuffixVar,
82 | TopLevel_setSuffix =>
83 assign (topLevelSuffixVar,
91 val {arg, argType, body, mayInline} = Lambda.dest l
93 Lambda.make {arg = arg,
96 mayInline = mayInline}
98 val body = Dexp.fromExp (loop body, Type.unit)
100 (Dexp.sequence o Vector.new2)
102 Dexp.app {func = (Dexp.deref
105 Type.reff topLevelSuffixType))),
110 {var = topLevelSuffixVar,
111 exp = Dexp.reff (Dexp.lambda
112 {arg = Var.newNoname (),
114 body = Dexp.bug "toplevel suffix not installed",
115 bodyType = Type.unit,
118 val body = Dexp.toExp body
120 Program.T {datatypes = datatypes,