1 (* Copyright (C) 2011,2017 Matthew Fluet.
2 * Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
3 * Jagannathan, and Stephen Weeks.
4 * Copyright (C) 1997-2000 NEC Research Institute.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor Analyze2 (S: ANALYZE2_STRUCTS): ANALYZE2 =
14 datatype z = datatype Exp.t
15 datatype z = datatype Statement.t
16 datatype z = datatype Transfer.t
19 {base, coerce, const, filter, filterWord, fromType, inject, layout, object, primApp,
20 program = Program.T {functions, globals, main, ...},
21 select, update, useFromTypeOnBinds} =
23 fun coerces (msg, from, to) =
24 if Vector.length from = Vector.length to
25 then Vector.foreach2 (from, to, fn (from, to) =>
26 coerce {from = from, to = to})
27 else Error.bug (concat ["Analyze2.coerces (length mismatch: ", msg, ")"])
28 val {get = value: Var.t -> 'a, set = setValue, ...} =
31 Property.initRaise ("Analyze2.value", Var.layout))
32 val value = Trace.trace ("Analyze2.value", Var.layout, layout) value
33 fun values xs = Vector.map (xs, value)
34 val {get = funcInfo, set = setFuncInfo, ...} =
36 (Func.plist, Property.initRaise ("Analyze2.funcInfo", Func.layout))
37 val {get = labelInfo, set = setLabelInfo, ...} =
39 (Label.plist, Property.initRaise ("Analyze2.labelInfo", Label.layout))
40 val labelArgs = #args o labelInfo
41 val labelValues = #values o labelInfo
43 Vector.map (args, fn (x, t) =>
44 let val v = fromType t
52 val {args, name, raises, returns, ...} = Function.dest f
54 setFuncInfo (name, {args = loopArgs args,
55 raises = Option.map (raises, fn ts =>
56 Vector.map (ts, fromType)),
57 returns = Option.map (returns, fn ts =>
58 Vector.map (ts, fromType))})
60 fun loopTransfer (t: Transfer.t,
61 shouldReturns: 'a vector option,
62 shouldRaises: 'a vector option): unit =
64 Arith {prim, args, overflow, success, ty} =>
65 (coerces ("arith overflow", Vector.new0 (), labelValues overflow)
66 ; coerce {from = primApp {prim = prim,
70 to = Vector.sub (labelValues success, 0)})
72 | Call {func, args, return, ...} =>
74 val {args = formals, raises, returns} = funcInfo func
75 val _ = coerces ("call args/formals", values args, formals)
77 case (raises, shouldRaises) of
79 | (NONE, SOME _) => ()
81 Error.bug "Analyze2.loopTransfer (raise mismatch)"
82 | (SOME vs, SOME vs') => coerces ("call caller/raises", vs, vs')
83 datatype z = datatype Return.t
87 if isSome returns orelse isSome raises
88 then Error.bug "Analyze2.loopTransfer (return mismatch at Dead)"
90 | NonTail {cont, handler} =>
91 (Option.app (returns, fn vs =>
92 coerces ("call non-tail/returns", vs, labelValues cont))
94 Handler.Caller => noHandler ()
97 then Error.bug "Analyze2.loopTransfer (raise mismatch at NonTail/Dead)"
105 coerces ("call handle/raises", vs, labelValues h)
113 case (returns, shouldReturns) of
115 | (NONE, SOME _) => ()
117 Error.bug "Analyze2.loopTransfer (return mismatch at Tail)"
118 | (SOME vs, SOME vs') =>
119 coerces ("call tail/return", vs, vs')
125 | Case {test, cases, default, ...} =>
127 val test = value test
128 fun ensureSize (w, s) =
129 if WordSize.equals (s, WordX.size w)
131 else Error.bug (concat ["Analyze.loopTransfer (case ",
136 fun ensureNullary j =
137 if Vector.isEmpty (labelValues j)
139 else Error.bug (concat ["Analyze2.loopTransfer (case:",
141 " must be nullary)"])
142 fun doitWord (s, cs) =
143 (ignore (filterWord (test, s))
144 ; Vector.foreach (cs, fn (w, j) =>
151 val v = labelValues j
153 case Vector.length v of
155 | 1 => SOME (Vector.first v)
156 | _ => Error.bug "Analyze2.loopTransfer (case conApp with >1 arg)"
162 datatype z = datatype Cases.t
166 | Word (s, cs) => doitWord (s, cs)
167 val _ = Option.app (default, ensureNullary)
170 | Goto {dst, args} => coerces ("goto", values args, labelValues dst)
172 (case shouldRaises of
173 NONE => Error.bug "Analyze2.loopTransfer (raise mismatch at Raise)"
174 | SOME vs => coerces ("raise", values xs, vs))
176 (case shouldReturns of
177 NONE => Error.bug "Analyze2.loopTransfer (return mismatch at Return)"
178 | SOME vs => coerces ("return", values xs, vs))
179 | Runtime {prim, args, return} =>
181 val xts = labelArgs return
182 val (resultVar, resultType) =
183 if Vector.isEmpty xts
184 then (NONE, Type.unit)
187 val (x, t) = Vector.first xts
192 primApp {prim = prim,
194 resultType = resultType,
195 resultVar = resultVar}
199 handle exn => Error.reraiseSuffix (exn, concat [" in ", Layout.toString (Transfer.layout t)])
202 ("Analyze2.loopTransfer",
204 Option.layout (Vector.layout layout),
205 Option.layout (Vector.layout layout),
208 fun baseValue b = base (Base.map (b, value))
209 fun loopBind {exp, ty, var}: 'a =
212 | Inject {sum, variant} =>
214 variant = value variant}
215 | Object {args, con} =>
219 Type.Object {args = ts, ...} =>
223 fn (x, {isMutable, ...}) =>
225 isMutable = isMutable}))
226 | _ => Error.bug "Analyze2.loopBind (strange object)"
232 | PrimApp {prim, args, ...} =>
233 primApp {prim = prim,
237 | Select {base, offset} =>
238 select {base = baseValue base,
242 fun loopStatement (s: Statement.t): unit =
244 Bind (b as {ty, var, ...}) =>
250 if useFromTypeOnBinds
253 val _ = coerce {from = v, to = v'}
254 val _ = setValue (var, v')
258 else setValue (var, v))
261 | Update {base, offset, value = v} =>
262 update {base = baseValue base,
265 handle exn => Error.reraiseSuffix (exn, concat [" in ", Layout.toString (Statement.layout s)])
267 Trace.trace ("Analyze2.loopStatement",
271 val _ = coerces ("main", Vector.new0 (), #args (funcInfo main))
272 val _ = Vector.foreach (globals, loopStatement)
273 handle exn => Error.reraiseSuffix (exn, concat [" in Globals"])
278 val {blocks, name, start, ...} = Function.dest f
281 (blocks, fn b as Block.T {label, args, ...} =>
282 setLabelInfo (label, {args = args,
284 values = loopArgs args,
285 visited = ref false}))
286 val {returns, raises, ...} = funcInfo name
287 fun visit (l: Label.t) =
289 val {block, visited, ...} = labelInfo l
295 val _ = visited := true
296 val Block.T {statements, transfer, ...} = block
297 val _ = (Vector.foreach (statements, loopStatement)
298 ; loopTransfer (transfer, returns, raises))
299 handle exn => Error.reraiseSuffix (exn, concat [" in ", Label.toString l])
301 Transfer.foreachLabel (transfer, visit)
308 handle exn => Error.reraiseSuffix (exn, concat [" in ", Func.toString (Function.name f)]))