Commit | Line | Data |
---|---|---|
7f918cf1 CE |
1 | (* Copyright (C) 2011,2017 Matthew Fluet. |
2 | * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh | |
3 | * Jagannathan, and Stephen Weeks. | |
4 | * Copyright (C) 1997-2000 NEC Research Institute. | |
5 | * | |
6 | * MLton is released under a BSD-style license. | |
7 | * See the file MLton-LICENSE for details. | |
8 | *) | |
9 | ||
10 | functor Analyze (S: ANALYZE_STRUCTS): ANALYZE = | |
11 | struct | |
12 | ||
13 | open S | |
14 | datatype z = datatype Exp.t | |
15 | datatype z = datatype Transfer.t | |
16 | ||
17 | fun 'a analyze | |
18 | {coerce, conApp, const, filter, filterWord, fromType, layout, primApp, | |
19 | program = Program.T {main, globals, functions, ...}, | |
20 | select, tuple, useFromTypeOnBinds} = | |
21 | let | |
22 | val unit = fromType Type.unit | |
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 ["Analyze.coerces (length mismatch: ", msg, ")"]) | |
28 | val {get = value: Var.t -> 'a, set = setValue, ...} = | |
29 | Property.getSetOnce | |
30 | (Var.plist, | |
31 | Property.initRaise ("Analyze.value", Var.layout)) | |
32 | val value = Trace.trace ("Analyze.value", Var.layout, layout) value | |
33 | fun values xs = Vector.map (xs, value) | |
34 | val {get = funcInfo, set = setFuncInfo, ...} = | |
35 | Property.getSetOnce | |
36 | (Func.plist, Property.initRaise ("Analyze.funcInfo", Func.layout)) | |
37 | val {get = labelInfo, set = setLabelInfo, ...} = | |
38 | Property.getSetOnce | |
39 | (Label.plist, Property.initRaise ("Analyze.labelInfo", Label.layout)) | |
40 | val labelArgs = #args o labelInfo | |
41 | val labelValues = #values o labelInfo | |
42 | fun loopArgs args = | |
43 | Vector.map (args, fn (x, t) => | |
44 | let val v = fromType t | |
45 | in setValue (x, v) | |
46 | ; v | |
47 | end) | |
48 | val _ = | |
49 | List.foreach | |
50 | (functions, fn f => | |
51 | let | |
52 | val {args, name, raises, returns, ...} = Function.dest f | |
53 | in | |
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))}) | |
59 | end) | |
60 | fun loopTransfer (t: Transfer.t, | |
61 | shouldReturns: 'a vector option, | |
62 | shouldRaises: 'a vector option): unit = | |
63 | (case t of | |
64 | Arith {prim, args, overflow, success, ty} => | |
65 | (coerces ("arith overflow", Vector.new0 (), labelValues overflow) | |
66 | ; coerce {from = primApp {prim = prim, | |
67 | targs = Vector.new0 (), | |
68 | args = values args, | |
69 | resultType = ty, | |
70 | resultVar = NONE}, | |
71 | to = Vector.sub (labelValues success, 0)}) | |
72 | | Bug => () | |
73 | | Call {func, args, return, ...} => | |
74 | let | |
75 | val {args = formals, raises, returns} = funcInfo func | |
76 | val _ = coerces ("call args/formals", values args, formals) | |
77 | fun noHandler () = | |
78 | case (raises, shouldRaises) of | |
79 | (NONE, NONE) => () | |
80 | | (NONE, SOME _) => () | |
81 | | (SOME _, NONE) => | |
82 | Error.bug "Analyze.loopTransfer (raise mismatch)" | |
83 | | (SOME vs, SOME vs') => coerces ("call caller/raises", vs, vs') | |
84 | datatype z = datatype Return.t | |
85 | in | |
86 | case return of | |
87 | Dead => | |
88 | if isSome returns orelse isSome raises | |
89 | then Error.bug "Analyze.loopTransfer (return mismatch at Dead)" | |
90 | else () | |
91 | | NonTail {cont, handler} => | |
92 | (Option.app (returns, fn vs => | |
93 | coerces ("call non-tail/returns", vs, labelValues cont)) | |
94 | ; (case handler of | |
95 | Handler.Caller => noHandler () | |
96 | | Handler.Dead => | |
97 | if isSome raises | |
98 | then Error.bug "Analyze.loopTransfer (raise mismatch at NonTail/Dead)" | |
99 | else () | |
100 | | Handler.Handle h => | |
101 | let | |
102 | val _ = | |
103 | case raises of | |
104 | NONE => () | |
105 | | SOME vs => | |
106 | coerces ("call handle/raises", vs, labelValues h) | |
107 | in | |
108 | () | |
109 | end)) | |
110 | | Tail => | |
111 | let | |
112 | val _ = noHandler () | |
113 | val _ = | |
114 | case (returns, shouldReturns) of | |
115 | (NONE, NONE) => () | |
116 | | (NONE, SOME _) => () | |
117 | | (SOME _, NONE) => | |
118 | Error.bug "Analyze.loopTransfer (return mismatch at Tail)" | |
119 | | (SOME vs, SOME vs') => | |
120 | coerces ("call tail/returns", vs, vs') | |
121 | in | |
122 | () | |
123 | end | |
124 | ||
125 | end | |
126 | | Case {test, cases, default, ...} => | |
127 | let | |
128 | val test = value test | |
129 | fun ensureNullary j = | |
130 | if Vector.isEmpty (labelValues j) | |
131 | then () | |
132 | else Error.bug (concat ["Analyze.loopTransfer (case ", | |
133 | Label.toString j, | |
134 | " must be nullary)"]) | |
135 | fun ensureSize (w, s) = | |
136 | if WordSize.equals (s, WordX.size w) | |
137 | then () | |
138 | else Error.bug (concat ["Analyze.loopTransfer (case ", | |
139 | WordX.toString w, | |
140 | " must be size ", | |
141 | WordSize.toString s, | |
142 | ")"]) | |
143 | fun doitWord (s, cs) = | |
144 | (ignore (filterWord (test, s)) | |
145 | ; Vector.foreach (cs, fn (w, j) => | |
146 | (ensureSize (w, s) | |
147 | ; ensureNullary j))) | |
148 | fun doitCon cs = | |
149 | Vector.foreach (cs, fn (c, j) => | |
150 | filter (test, c, labelValues j)) | |
151 | datatype z = datatype Cases.t | |
152 | val _ = | |
153 | case cases of | |
154 | Con cs => doitCon cs | |
155 | | Word (s, cs) => doitWord (s, cs) | |
156 | val _ = Option.app (default, ensureNullary) | |
157 | in () | |
158 | end | |
159 | | Goto {dst, args} => coerces ("goto", values args, labelValues dst) | |
160 | | Raise xs => | |
161 | (case shouldRaises of | |
162 | NONE => Error.bug "Analyze.loopTransfer (raise mismatch at Raise)" | |
163 | | SOME vs => coerces ("raise", values xs, vs)) | |
164 | | Return xs => | |
165 | (case shouldReturns of | |
166 | NONE => Error.bug "Analyze.loopTransfer (return mismatch at Return)" | |
167 | | SOME vs => coerces ("return", values xs, vs)) | |
168 | | Runtime {prim, args, return} => | |
169 | let | |
170 | val xts = labelArgs return | |
171 | val (resultVar, resultType) = | |
172 | if Vector.isEmpty xts | |
173 | then (NONE, Type.unit) | |
174 | else | |
175 | let | |
176 | val (x, t) = Vector.first xts | |
177 | in | |
178 | (SOME x, t) | |
179 | end | |
180 | val _ = | |
181 | primApp {prim = prim, | |
182 | targs = Vector.new0 (), | |
183 | args = values args, | |
184 | resultType = resultType, | |
185 | resultVar = resultVar} | |
186 | in | |
187 | () | |
188 | end) | |
189 | handle exn => Error.reraiseSuffix (exn, concat [" in ", Layout.toString (Transfer.layout t)]) | |
190 | val loopTransfer = | |
191 | Trace.trace3 | |
192 | ("Analyze.loopTransfer", | |
193 | Transfer.layout, | |
194 | Option.layout (Vector.layout layout), | |
195 | Option.layout (Vector.layout layout), | |
196 | Layout.ignore) | |
197 | loopTransfer | |
198 | fun loopStatement (s as Statement.T {var, exp, ty}): unit = | |
199 | let | |
200 | val v = | |
201 | case exp of | |
202 | ConApp {con, args} => conApp {con = con, args = values args} | |
203 | | Const c => const c | |
204 | | PrimApp {prim, targs, args, ...} => | |
205 | primApp {prim = prim, | |
206 | targs = targs, | |
207 | args = values args, | |
208 | resultType = ty, | |
209 | resultVar = var} | |
210 | | Profile _ => unit | |
211 | | Select {tuple, offset} => | |
212 | select {tuple = value tuple, | |
213 | offset = offset, | |
214 | resultType = ty} | |
215 | | Tuple xs => | |
216 | if 1 = Vector.length xs | |
217 | then Error.bug "Analyze.loopStatement (unary tuple)" | |
218 | else tuple (values xs) | |
219 | | Var x => value x | |
220 | in | |
221 | Option.app | |
222 | (var, fn var => | |
223 | if useFromTypeOnBinds | |
224 | then let | |
225 | val v' = fromType ty | |
226 | val _ = coerce {from = v, to = v'} | |
227 | val _ = setValue (var, v') | |
228 | in | |
229 | () | |
230 | end | |
231 | else setValue (var, v)) | |
232 | end | |
233 | handle exn => Error.reraiseSuffix (exn, concat [" in ", Layout.toString (Statement.layout s)]) | |
234 | val loopStatement = | |
235 | Trace.trace ("Analyze.loopStatement", Statement.layout, Unit.layout) | |
236 | loopStatement | |
237 | val _ = coerces ("main", Vector.new0 (), #args (funcInfo main)) | |
238 | val _ = Vector.foreach (globals, loopStatement) | |
239 | handle exn => Error.reraiseSuffix (exn, concat [" in Globals"]) | |
240 | val _ = | |
241 | List.foreach | |
242 | (functions, fn f => | |
243 | let | |
244 | val {blocks, name, start, ...} = Function.dest f | |
245 | val _ = | |
246 | Vector.foreach | |
247 | (blocks, fn b as Block.T {label, args, ...} => | |
248 | setLabelInfo (label, {args = args, | |
249 | block = b, | |
250 | values = loopArgs args, | |
251 | visited = ref false})) | |
252 | val {returns, raises, ...} = funcInfo name | |
253 | fun visit (l: Label.t) = | |
254 | let | |
255 | val {block, visited, ...} = labelInfo l | |
256 | in | |
257 | if !visited | |
258 | then () | |
259 | else | |
260 | let | |
261 | val _ = visited := true | |
262 | val Block.T {statements, transfer, ...} = block | |
263 | val _ = (Vector.foreach (statements, loopStatement) | |
264 | ; loopTransfer (transfer, returns, raises)) | |
265 | handle exn => Error.reraiseSuffix (exn, concat [" in ", Label.toString l]) | |
266 | in | |
267 | Transfer.foreachLabel (transfer, visit) | |
268 | end | |
269 | end | |
270 | ||
271 | val _ = visit start | |
272 | in | |
273 | () | |
274 | end | |
275 | handle exn => Error.reraiseSuffix (exn, concat [" in ", Func.toString (Function.name f)])) | |
276 | in | |
277 | {func = funcInfo, | |
278 | label = labelValues, | |
279 | value = value} | |
280 | end | |
281 | ||
282 | end |