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 ImplementHandlers (S: RSSA_TRANSFORM_STRUCTS): RSSA_TRANSFORM =
14 datatype z = datatype Statement.t
15 datatype z = datatype Transfer.t
21 fun hasHandler (f: t): bool =
23 val {blocks, ...} = dest f
26 (blocks, fn Block.T {transfer, ...} =>
29 {return = (Return.NonTail
30 {handler = Handler.Handle _, ...}), ...} =>
36 structure HandlerLat = FlatLattice (structure Point = Label)
43 datatype t = Local | Slot
45 val equals: t * t -> bool = op =
51 val layout = Layout.str o toString
53 structure L = FlatLattice (structure Point = ZPoint)
56 structure Point = ZPoint
57 val locall = point Point.Local
58 val slot = point Point.Slot
62 fun flow (f: Function.t): Function.t =
63 if not (Function.hasHandler f)
68 val {args, blocks, name, raises, returns, start} =
70 val {get = labelInfo: Label.t -> {global: ExnStack.t,
71 handler: HandlerLat.t},
73 Property.get (Label.plist,
74 Property.initFun (fn _ =>
75 {global = ExnStack.new (),
76 handler = HandlerLat.new ()}))
79 (blocks, fn Block.T {label, transfer, ...} =>
81 val {global, handler} = labelInfo label
83 if Label.equals (label, start)
85 val _ = ExnStack.<= (ExnStack.slot, global)
86 val _ = HandlerLat.forceTop handler
91 fun goto' {global = g, handler = h}: unit =
93 val _ = ExnStack.<= (global, g)
94 val _ = HandlerLat.<= (handler, h)
98 val goto = goto' o labelInfo
101 Call {return, ...} =>
104 | Return.NonTail {cont, handler = h} =>
106 val li as {global = g', handler = h'} =
112 val _ = ExnStack.<= (ExnStack.slot, g')
113 val _ = HandlerLat.<= (handler, h')
117 | Handler.Dead => goto' li
118 | Handler.Handle l =>
120 fun doit {global = g'', handler = h''} =
122 val _ = ExnStack.<= (ExnStack.locall, g'')
123 val _ = HandlerLat.<= (HandlerLat.point l, h'')
133 | _ => Transfer.foreachLabel (transfer, goto)
140 (fn Block.T {label, ...} =>
142 val {global, handler} = labelInfo label
144 Layout.record [("label", Label.layout label),
145 ("global", ExnStack.layout global),
146 ("handler", HandlerLat.layout handler)]
154 fn Block.T {args, kind, label, statements, transfer} =>
156 val {global, handler} = labelInfo label
157 fun setExnStackSlot () =
158 if ExnStack.isPointEq (global, ExnStack.Point.Slot)
160 else Vector.new1 SetExnStackSlot
161 fun setExnStackLocal () =
162 if ExnStack.isPointEq (global, ExnStack.Point.Local)
164 else Vector.new1 SetExnStackLocal
165 fun setHandler (l: Label.t) =
166 if HandlerLat.isPointEq (handler, l)
168 else Vector.new1 (SetHandler l)
171 Call {return, ...} =>
173 Return.Dead => Vector.new0 ()
174 | Return.NonTail {handler, ...} =>
176 Handler.Caller => setExnStackSlot ()
177 | Handler.Dead => Vector.new0 ()
178 | Handler.Handle l =>
180 [setHandler l, setExnStackLocal ()])
181 | Return.Tail => setExnStackSlot ())
182 | Raise _ => setExnStackSlot ()
183 | Return _ => setExnStackSlot ()
184 | _ => Vector.new0 ()
185 val statements = Vector.concat [statements, post]
187 Block.T {args = args,
190 statements = statements,
193 val newStart = Label.newNoname ()
195 Block.T {args = Vector.new0 (),
198 statements = Vector.new1 SetSlotExnStack,
199 transfer = Goto {args = Vector.new0 (),
201 val blocks = Vector.concat [blocks, Vector.new1 startBlock]
202 val () = Vector.foreach (blocks, rem o Block.label)
204 Function.new {args = args,
212 fun transform (Program.T {functions, handlesSignals, main, objectTypes}) =
213 Program.T {functions = List.revMap (functions, flow),
214 handlesSignals = handlesSignals,
216 objectTypes = objectTypes}