adamc@133
|
1 (* Copyright (c) 2008, Adam Chlipala
|
adamc@133
|
2 * All rights reserved.
|
adamc@133
|
3 *
|
adamc@133
|
4 * Redistribution and use in source and binary forms, with or without
|
adamc@133
|
5 * modification, are permitted provided that the following conditions are met:
|
adamc@133
|
6 *
|
adamc@133
|
7 * - Redistributions of source code must retain the above copyright notice,
|
adamc@133
|
8 * this list of conditions and the following disclaimer.
|
adamc@133
|
9 * - Redistributions in binary form must reproduce the above copyright notice,
|
adamc@133
|
10 * this list of conditions and the following disclaimer in the documentation
|
adamc@133
|
11 * and/or other materials provided with the distribution.
|
adamc@133
|
12 * - The names of contributors may not be used to endorse or promote products
|
adamc@133
|
13 * derived from this software without specific prior written permission.
|
adamc@133
|
14 *
|
adamc@133
|
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
|
adamc@133
|
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
|
adamc@133
|
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
|
adamc@133
|
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
|
adamc@133
|
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
|
adamc@133
|
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
|
adamc@133
|
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
|
adamc@133
|
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
|
adamc@133
|
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
|
adamc@133
|
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
|
adamc@133
|
25 * POSSIBILITY OF SUCH DAMAGE.
|
adamc@133
|
26 *)
|
adamc@133
|
27
|
adamc@133
|
28 (* Simplify a Mono program algebraically *)
|
adamc@133
|
29
|
adamc@133
|
30 structure MonoReduce :> MONO_REDUCE = struct
|
adamc@133
|
31
|
adamc@133
|
32 open Mono
|
adamc@133
|
33
|
adamc@133
|
34 structure E = MonoEnv
|
adamc@133
|
35 structure U = MonoUtil
|
adamc@133
|
36
|
adamc@470
|
37 structure IM = IntBinaryMap
|
adamc@916
|
38 structure IS = IntBinarySet
|
adamc@470
|
39
|
adamc@133
|
40
|
adamc@948
|
41 fun simpleTypeImpure tsyms =
|
adamc@919
|
42 U.Typ.exists (fn TFun _ => true
|
adamc@948
|
43 | TDatatype (n, _) => IS.member (tsyms, n)
|
adamc@919
|
44 | _ => false)
|
adamc@919
|
45
|
adamc@948
|
46 fun simpleImpure (tsyms, syms) =
|
adamc@919
|
47 U.Exp.existsB {typ = fn _ => false,
|
adamc@919
|
48 exp = fn (env, e) =>
|
adamc@919
|
49 case e of
|
adamc@919
|
50 EWrite _ => true
|
adamc@919
|
51 | EQuery _ => true
|
adamc@919
|
52 | EDml _ => true
|
adamc@919
|
53 | ENextval _ => true
|
adamc@1073
|
54 | ESetval _ => true
|
adamc@1171
|
55 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
|
adamc@919
|
56 | EServerCall _ => true
|
adamc@919
|
57 | ERecv _ => true
|
adamc@919
|
58 | ESleep _ => true
|
adamc@919
|
59 | ENamed n => IS.member (syms, n)
|
adamc@919
|
60 | ERel n =>
|
adamc@919
|
61 let
|
adamc@919
|
62 val (_, t, _) = E.lookupERel env n
|
adamc@919
|
63 in
|
adamc@948
|
64 simpleTypeImpure tsyms t
|
adamc@919
|
65 end
|
adamc@919
|
66 | _ => false,
|
adamc@919
|
67 bind = fn (env, b) =>
|
adamc@919
|
68 case b of
|
adamc@919
|
69 U.Exp.RelE (x, t) => E.pushERel env x t NONE
|
adamc@919
|
70 | _ => env}
|
adamc@916
|
71
|
adamc@252
|
72 fun impure (e, _) =
|
adamc@252
|
73 case e of
|
adamc@252
|
74 EWrite _ => true
|
adamc@252
|
75 | EQuery _ => true
|
adamc@307
|
76 | EDml _ => true
|
adamc@338
|
77 | ENextval _ => true
|
adamc@1073
|
78 | ESetval _ => true
|
adam@1423
|
79 | EUnurlify (e, _, _) => impure e
|
adamc@252
|
80 | EAbs _ => false
|
adamc@252
|
81
|
adamc@252
|
82 | EPrim _ => false
|
adamc@252
|
83 | ERel _ => false
|
adamc@252
|
84 | ENamed _ => false
|
adamc@252
|
85 | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e)
|
adamc@297
|
86 | ENone _ => false
|
adamc@290
|
87 | ESome (_, e) => impure e
|
adamc@252
|
88 | EFfi _ => false
|
adamc@1171
|
89 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
|
adamc@252
|
90 | EApp ((EFfi _, _), _) => false
|
adamc@252
|
91 | EApp _ => true
|
adamc@252
|
92
|
adamc@387
|
93 | EUnop (_, e) => impure e
|
adam@1360
|
94 | EBinop (_, _, e1, e2) => impure e1 orelse impure e2
|
adamc@387
|
95
|
adamc@252
|
96 | ERecord xes => List.exists (fn (_, e, _) => impure e) xes
|
adamc@252
|
97 | EField (e, _) => impure e
|
adamc@252
|
98
|
adamc@252
|
99 | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
|
adamc@252
|
100
|
adamc@1069
|
101 | EError _ => true
|
adamc@741
|
102 | EReturnBlob {blob = e1, mimeType = e2, ...} => impure e1 orelse impure e2
|
adamc@1065
|
103 | ERedirect (e, _) => impure e
|
adamc@283
|
104
|
adamc@252
|
105 | EStrcat (e1, e2) => impure e1 orelse impure e2
|
adamc@252
|
106
|
adamc@252
|
107 | ESeq (e1, e2) => impure e1 orelse impure e2
|
adamc@252
|
108 | ELet (_, _, e1, e2) => impure e1 orelse impure e2
|
adamc@252
|
109
|
adamc@252
|
110 | EClosure (_, es) => List.exists impure es
|
adamc@815
|
111 | EJavaScript (_, e) => impure e
|
adamc@568
|
112 | ESignalReturn e => impure e
|
adamc@572
|
113 | ESignalBind (e1, e2) => impure e1 orelse impure e2
|
adamc@574
|
114 | ESignalSource e => impure e
|
adamc@608
|
115 | EServerCall _ => true
|
adamc@670
|
116 | ERecv _ => true
|
adamc@695
|
117 | ESleep _ => true
|
adamc@1021
|
118 | ESpawn _ => true
|
adamc@252
|
119
|
adamc@252
|
120 val liftExpInExp = Monoize.liftExpInExp
|
adamc@252
|
121
|
adamc@829
|
122 fun multiLift n e =
|
adamc@829
|
123 case n of
|
adamc@829
|
124 0 => e
|
adamc@829
|
125 | _ => multiLift (n - 1) (liftExpInExp 0 e)
|
adamc@829
|
126
|
adamc@252
|
127 val subExpInExp' =
|
adamc@133
|
128 U.Exp.mapB {typ = fn t => t,
|
adamc@133
|
129 exp = fn (xn, rep) => fn e =>
|
adamc@133
|
130 case e of
|
adamc@133
|
131 ERel xn' =>
|
adamc@133
|
132 (case Int.compare (xn', xn) of
|
adamc@133
|
133 EQUAL => #1 rep
|
adamc@133
|
134 | GREATER=> ERel (xn' - 1)
|
adamc@133
|
135 | LESS => e)
|
adamc@133
|
136 | _ => e,
|
adamc@133
|
137 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
|
adamc@133
|
138 | (ctx, _) => ctx}
|
adamc@133
|
139
|
adamc@252
|
140 fun subExpInExp (n, e1) e2 =
|
adamc@252
|
141 let
|
adamc@252
|
142 val r = subExpInExp' (n, e1) e2
|
adamc@252
|
143 in
|
adamc@252
|
144 (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1),
|
adamc@252
|
145 ("e2", MonoPrint.p_exp MonoEnv.empty e2),
|
adamc@252
|
146 ("r", MonoPrint.p_exp MonoEnv.empty r)];*)
|
adamc@252
|
147 r
|
adamc@252
|
148 end
|
adamc@133
|
149
|
adamc@133
|
150 fun typ c = c
|
adamc@133
|
151
|
adamc@316
|
152 val swapExpVars =
|
adamc@316
|
153 U.Exp.mapB {typ = fn t => t,
|
adamc@316
|
154 exp = fn lower => fn e =>
|
adamc@316
|
155 case e of
|
adamc@316
|
156 ERel xn =>
|
adamc@316
|
157 if xn = lower then
|
adamc@316
|
158 ERel (lower + 1)
|
adamc@316
|
159 else if xn = lower + 1 then
|
adamc@316
|
160 ERel lower
|
adamc@316
|
161 else
|
adamc@316
|
162 e
|
adamc@316
|
163 | _ => e,
|
adamc@316
|
164 bind = fn (lower, U.Exp.RelE _) => lower+1
|
adamc@316
|
165 | (lower, _) => lower}
|
adamc@316
|
166
|
adamc@341
|
167 val swapExpVarsPat =
|
adamc@341
|
168 U.Exp.mapB {typ = fn t => t,
|
adamc@341
|
169 exp = fn (lower, len) => fn e =>
|
adamc@341
|
170 case e of
|
adamc@341
|
171 ERel xn =>
|
adamc@341
|
172 if xn = lower then
|
adamc@827
|
173 ERel (lower + len)
|
adamc@341
|
174 else if xn >= lower + 1 andalso xn < lower + 1 + len then
|
adamc@341
|
175 ERel (xn - 1)
|
adamc@341
|
176 else
|
adamc@341
|
177 e
|
adamc@341
|
178 | _ => e,
|
adamc@341
|
179 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
|
adamc@341
|
180 | (st, _) => st}
|
adamc@341
|
181
|
adamc@814
|
182 datatype result = Yes of exp list | No | Maybe
|
adamc@258
|
183
|
adamc@183
|
184 fun match (env, p : pat, e : exp) =
|
adamc@183
|
185 case (#1 p, #1 e) of
|
adamc@258
|
186 (PWild, _) => Yes env
|
adamc@814
|
187 | (PVar (x, t), _) => Yes (e :: env)
|
adamc@183
|
188
|
adamc@280
|
189 | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
|
adamc@280
|
190 if String.isPrefix s' s then
|
adamc@280
|
191 Maybe
|
adamc@280
|
192 else
|
adamc@280
|
193 No
|
adamc@280
|
194
|
adamc@1207
|
195 | (PPrim (Prim.String s), EStrcat (_, (EPrim (Prim.String s'), _))) =>
|
adamc@1207
|
196 if String.isSuffix s' s then
|
adamc@1207
|
197 Maybe
|
adamc@1207
|
198 else
|
adamc@1207
|
199 No
|
adamc@1207
|
200
|
adamc@183
|
201 | (PPrim p, EPrim p') =>
|
adamc@183
|
202 if Prim.equal (p, p') then
|
adamc@258
|
203 Yes env
|
adamc@183
|
204 else
|
adamc@258
|
205 No
|
adamc@183
|
206
|
kkallio@1489
|
207 | (PCon (_, PConVar n1, po), ECon (_, PConVar n2, eo)) =>
|
adamc@183
|
208 if n1 = n2 then
|
kkallio@1489
|
209 case (po, eo) of
|
kkallio@1489
|
210 (NONE, NONE) => Yes env
|
kkallio@1489
|
211 | (SOME p, SOME e) => match (env, p, e)
|
kkallio@1489
|
212 | _ => Maybe
|
adamc@183
|
213 else
|
adamc@258
|
214 No
|
adamc@183
|
215
|
adamc@188
|
216 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, NONE), ECon (_, PConFfi {mod = m2, con = con2, ...}, NONE)) =>
|
adamc@185
|
217 if m1 = m2 andalso con1 = con2 then
|
adamc@258
|
218 Yes env
|
adamc@185
|
219 else
|
adamc@258
|
220 No
|
adamc@185
|
221
|
adamc@188
|
222 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, SOME ep), ECon (_, PConFfi {mod = m2, con = con2, ...}, SOME e)) =>
|
adamc@185
|
223 if m1 = m2 andalso con1 = con2 then
|
adamc@185
|
224 match (env, p, e)
|
adamc@185
|
225 else
|
adamc@258
|
226 No
|
adamc@185
|
227
|
adamc@183
|
228 | (PRecord xps, ERecord xes) =>
|
adamc@183
|
229 let
|
adamc@183
|
230 fun consider (xps, env) =
|
adamc@183
|
231 case xps of
|
adamc@258
|
232 [] => Yes env
|
adamc@183
|
233 | (x, p, _) :: rest =>
|
adamc@183
|
234 case List.find (fn (x', _, _) => x' = x) xes of
|
adamc@258
|
235 NONE => No
|
adamc@183
|
236 | SOME (_, e, _) =>
|
adamc@183
|
237 case match (env, p, e) of
|
adamc@258
|
238 No => No
|
adamc@258
|
239 | Maybe => Maybe
|
adamc@258
|
240 | Yes env => consider (rest, env)
|
adamc@183
|
241 in
|
adamc@183
|
242 consider (xps, env)
|
adamc@183
|
243 end
|
adamc@183
|
244
|
adamc@726
|
245 | (PNone _, ENone _) => Yes env
|
adamc@921
|
246 | (PNone _, ESome _) => No
|
adamc@726
|
247 | (PSome (_, p), ESome (_, e)) => match (env, p, e)
|
adamc@921
|
248 | (PSome _, ENone _) => No
|
adamc@726
|
249
|
adamc@258
|
250 | _ => Maybe
|
adamc@183
|
251
|
adamc@318
|
252 datatype event =
|
adamc@318
|
253 WritePage
|
adamc@318
|
254 | ReadDb
|
adamc@318
|
255 | WriteDb
|
adamc@1225
|
256 | ReadCookie
|
adamc@1225
|
257 | WriteCookie
|
adamc@481
|
258 | UseRel
|
adamc@318
|
259 | Unsure
|
adamc@1225
|
260 | Abort
|
adamc@318
|
261
|
adamc@318
|
262 fun p_event e =
|
adamc@318
|
263 let
|
adamc@318
|
264 open Print.PD
|
adamc@318
|
265 in
|
adamc@318
|
266 case e of
|
adamc@318
|
267 WritePage => string "WritePage"
|
adamc@318
|
268 | ReadDb => string "ReadDb"
|
adamc@318
|
269 | WriteDb => string "WriteDb"
|
adamc@1225
|
270 | ReadCookie => string "ReadCookie"
|
adamc@1225
|
271 | WriteCookie => string "WriteCookie"
|
adamc@481
|
272 | UseRel => string "UseRel"
|
adamc@318
|
273 | Unsure => string "Unsure"
|
adamc@1225
|
274 | Abort => string "Abort"
|
adamc@318
|
275 end
|
adamc@318
|
276
|
adamc@470
|
277 val p_events = Print.p_list p_event
|
adamc@470
|
278
|
adamc@318
|
279 fun patBinds (p, _) =
|
adamc@318
|
280 case p of
|
adamc@318
|
281 PWild => 0
|
adamc@318
|
282 | PVar _ => 1
|
adamc@318
|
283 | PPrim _ => 0
|
adamc@318
|
284 | PCon (_, _, NONE) => 0
|
adamc@318
|
285 | PCon (_, _, SOME p) => patBinds p
|
adamc@318
|
286 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
|
adamc@318
|
287 | PNone _ => 0
|
adamc@318
|
288 | PSome (_, p) => patBinds p
|
adamc@318
|
289
|
adamc@932
|
290 val countFree = U.Exp.foldB {typ = fn (_, n) => n,
|
adamc@932
|
291 exp = fn (x, e, n) =>
|
adamc@932
|
292 case e of
|
adamc@932
|
293 ERel x' => if x = x' then n + 1 else n
|
adamc@932
|
294 | _ => n,
|
adamc@932
|
295 bind = fn (n, b) =>
|
adamc@932
|
296 case b of
|
adamc@932
|
297 U.Exp.RelE _ => n + 1
|
adamc@975
|
298 | _ => n}
|
adamc@975
|
299
|
adamc@975
|
300 val freeInAbs = U.Exp.existsB {typ = fn _ => false,
|
adamc@975
|
301 exp = fn (n, e) =>
|
adamc@975
|
302 case e of
|
adamc@975
|
303 EAbs (_, _, _, b) => countFree n 0 b > 0
|
adamc@975
|
304 | EJavaScript (_, b) => countFree n 0 b > 0
|
adamc@975
|
305 | _ => false,
|
adamc@975
|
306 bind = fn (n, b) =>
|
adamc@975
|
307 case b of
|
adamc@975
|
308 U.Exp.RelE _ => n + 1
|
adamc@975
|
309 | _ => n} 0
|
adamc@932
|
310
|
adamc@470
|
311 fun reduce file =
|
adamc@470
|
312 let
|
adamc@948
|
313 val (timpures, impures, absCounts) =
|
adamc@948
|
314 foldl (fn ((d, _), (timpures, impures, absCounts)) =>
|
adamc@916
|
315 let
|
adamc@916
|
316 fun countAbs (e, _) =
|
adamc@916
|
317 case e of
|
adamc@916
|
318 EAbs (_, _, _, e) => 1 + countAbs e
|
adamc@916
|
319 | _ => 0
|
adamc@916
|
320 in
|
adamc@916
|
321 case d of
|
adamc@948
|
322 DDatatype dts =>
|
adamc@948
|
323 (if List.exists (fn (_, _, cs) =>
|
adamc@948
|
324 List.exists (fn (_, _, NONE) => false
|
adamc@948
|
325 | (_, _, SOME t) => simpleTypeImpure timpures t) cs)
|
adamc@948
|
326 dts then
|
adamc@948
|
327 IS.addList (timpures, map #2 dts)
|
adamc@948
|
328 else
|
adamc@948
|
329 timpures,
|
adamc@948
|
330 impures,
|
adamc@948
|
331 absCounts)
|
adamc@948
|
332 | DVal (_, n, _, e, _) =>
|
adamc@948
|
333 (timpures,
|
adamc@948
|
334 if simpleImpure (timpures, impures) E.empty e then
|
adamc@916
|
335 IS.add (impures, n)
|
adamc@916
|
336 else
|
adamc@916
|
337 impures,
|
adamc@916
|
338 IM.insert (absCounts, n, countAbs e))
|
adamc@916
|
339 | DValRec vis =>
|
adamc@948
|
340 (timpures,
|
adamc@948
|
341 if List.exists (fn (_, _, _, e, _) => simpleImpure (timpures, impures) E.empty e) vis then
|
adamc@916
|
342 foldl (fn ((_, n, _, _, _), impures) =>
|
adamc@916
|
343 IS.add (impures, n)) impures vis
|
adamc@916
|
344 else
|
adamc@916
|
345 impures,
|
adamc@916
|
346 foldl (fn ((x, n, _, e, _), absCounts) =>
|
adamc@916
|
347 IM.insert (absCounts, n, countAbs e))
|
adamc@916
|
348 absCounts vis)
|
adamc@948
|
349 | _ => (timpures, impures, absCounts)
|
adamc@916
|
350 end)
|
adamc@948
|
351 (IS.empty, IS.empty, IM.empty) file
|
adamc@387
|
352
|
adamc@1017
|
353 val uses = U.File.fold {typ = fn (_, m) => m,
|
adamc@1017
|
354 exp = fn (e, m) =>
|
adamc@1017
|
355 case e of
|
adamc@1017
|
356 ENamed n => IM.insert (m, n, 1 + Option.getOpt (IM.find (m, n), 0))
|
adamc@1017
|
357 | _ => m,
|
adamc@1017
|
358 decl = fn (_, m) => m}
|
adamc@1017
|
359 IM.empty file
|
adamc@1017
|
360
|
adamc@1017
|
361 val size = U.Exp.fold {typ = fn (_, n) => n,
|
adamc@1017
|
362 exp = fn (_, n) => n + 1} 0
|
adamc@1017
|
363
|
adam@1360
|
364 val functionInside' = U.Typ.exists (fn c => case c of
|
adam@1360
|
365 TFun _ => true
|
adam@1360
|
366 | _ => false)
|
adam@1360
|
367
|
adam@1360
|
368 fun functionInside t =
|
adam@1360
|
369 case #1 t of
|
adam@1360
|
370 TFun (t1, t2) => functionInside' t1 orelse functionInside t2
|
adam@1360
|
371 | _ => functionInside' t
|
adam@1360
|
372
|
adam@1393
|
373 fun mayInline (n, e, t, s) =
|
adamc@1017
|
374 case IM.find (uses, n) of
|
adamc@1017
|
375 NONE => false
|
adamc@1017
|
376 | SOME count => count <= 1
|
adamc@1017
|
377 orelse size e <= Settings.getMonoInline ()
|
adam@1360
|
378 orelse functionInside t
|
adam@1393
|
379 orelse Settings.checkAlwaysInline s
|
adamc@1017
|
380
|
adamc@470
|
381 fun summarize d (e, _) =
|
adamc@579
|
382 let
|
adamc@579
|
383 val s =
|
adamc@579
|
384 case e of
|
adamc@579
|
385 EPrim _ => []
|
adamc@579
|
386 | ERel n => if n = d then [UseRel] else []
|
adamc@579
|
387 | ENamed _ => []
|
adamc@579
|
388 | ECon (_, _, NONE) => []
|
adamc@579
|
389 | ECon (_, _, SOME e) => summarize d e
|
adamc@579
|
390 | ENone _ => []
|
adamc@579
|
391 | ESome (_, e) => summarize d e
|
adamc@579
|
392 | EFfi _ => []
|
adam@1663
|
393 | EFfiApp ("Basis", "get_cookie", [(e, _)]) =>
|
adamc@1225
|
394 summarize d e @ [ReadCookie]
|
adam@1423
|
395 | EFfiApp ("Basis", "set_cookie", es) =>
|
adam@1663
|
396 List.concat (map (summarize d o #1) es) @ [WriteCookie]
|
adam@1423
|
397 | EFfiApp ("Basis", "clear_cookie", es) =>
|
adam@1663
|
398 List.concat (map (summarize d o #1) es) @ [WriteCookie]
|
adamc@765
|
399 | EFfiApp (m, x, es) =>
|
adamc@1171
|
400 if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then
|
adam@1663
|
401 List.concat (map (summarize d o #1) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then
|
adam@1663
|
402 WritePage
|
adam@1663
|
403 else
|
adam@1663
|
404 Unsure]
|
adamc@765
|
405 else
|
adam@1663
|
406 List.concat (map (summarize d o #1) es)
|
adamc@579
|
407 | EApp ((EFfi _, _), e) => summarize d e
|
adamc@579
|
408 | EApp _ =>
|
adamc@579
|
409 let
|
adamc@694
|
410 fun unravel (e, passed, ls) =
|
adamc@579
|
411 case e of
|
adamc@579
|
412 ENamed n =>
|
adamc@579
|
413 let
|
adamc@579
|
414 val ls = rev ls
|
adamc@579
|
415 in
|
adamc@948
|
416 if IS.member (impures, n) then
|
adamc@948
|
417 case IM.find (absCounts, n) of
|
adamc@948
|
418 NONE => [Unsure]
|
adamc@948
|
419 | SOME len =>
|
adamc@948
|
420 if passed < len then
|
adamc@948
|
421 ls
|
adamc@948
|
422 else
|
adamc@948
|
423 ls @ [Unsure]
|
adamc@948
|
424 else
|
adamc@948
|
425 ls
|
adamc@579
|
426 end
|
adamc@579
|
427 | ERel n => List.revAppend (ls,
|
adamc@579
|
428 if n = d then
|
adamc@579
|
429 [UseRel, Unsure]
|
adamc@579
|
430 else
|
adamc@579
|
431 [Unsure])
|
adamc@579
|
432 | EApp (f, x) =>
|
adamc@995
|
433 unravel (#1 f, passed + 1, List.revAppend (summarize d x,
|
adamc@995
|
434 ls))
|
adam@1394
|
435 | EError _ => [Abort]
|
adamc@579
|
436 | _ => [Unsure]
|
adamc@579
|
437 in
|
adamc@694
|
438 unravel (e, 0, [])
|
adamc@579
|
439 end
|
adamc@252
|
440
|
adamc@941
|
441 | EAbs _ => []
|
adamc@316
|
442
|
adamc@579
|
443 | EUnop (_, e) => summarize d e
|
adam@1360
|
444 | EBinop (_, _, e1, e2) => summarize d e1 @ summarize d e2
|
adamc@470
|
445
|
adamc@579
|
446 | ERecord xets => List.concat (map (summarize d o #2) xets)
|
adamc@579
|
447 | EField (e, _) => summarize d e
|
adamc@470
|
448
|
adamc@1214
|
449 | ECase (e, pes, _) =>
|
adamc@1214
|
450 let
|
adamc@579
|
451 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
|
adam@1394
|
452
|
adam@1394
|
453 fun splitRel ls acc =
|
adam@1394
|
454 case ls of
|
adam@1394
|
455 [] => (acc, false, ls)
|
adam@1394
|
456 | UseRel :: ls => (acc, true, ls)
|
adam@1394
|
457 | v :: ls => splitRel ls (v :: acc)
|
adam@1394
|
458
|
adam@1394
|
459 val (pre, used, post) = foldl (fn (ls, (pre, used, post)) =>
|
adam@1394
|
460 let
|
adam@1394
|
461 val (pre', used', post') = splitRel ls []
|
adam@1394
|
462 in
|
adam@1394
|
463 (pre' @ pre, used' orelse used, post' @ post)
|
adam@1394
|
464 end)
|
adam@1394
|
465 ([], false, []) lss
|
adamc@579
|
466 in
|
adam@1394
|
467 summarize d e
|
adam@1394
|
468 @ pre
|
adam@1394
|
469 @ (if used then [UseRel] else [])
|
adam@1394
|
470 @ post
|
adamc@1214
|
471 end
|
adamc@579
|
472 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
|
adamc@316
|
473
|
adamc@1225
|
474 | EError (e, _) => summarize d e @ [Abort]
|
adamc@1225
|
475 | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
|
adamc@1225
|
476 | ERedirect (e, _) => summarize d e @ [Abort]
|
adamc@318
|
477
|
adamc@579
|
478 | EWrite e => summarize d e @ [WritePage]
|
adamc@579
|
479
|
adamc@579
|
480 | ESeq (e1, e2) => summarize d e1 @ summarize d e2
|
adamc@579
|
481 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
|
adamc@456
|
482
|
adamc@579
|
483 | EClosure (_, es) => List.concat (map (summarize d) es)
|
adamc@470
|
484
|
adamc@579
|
485 | EQuery {query, body, initial, ...} =>
|
adamc@579
|
486 List.concat [summarize d query,
|
adamc@579
|
487 summarize d initial,
|
adamc@941
|
488 [ReadDb],
|
adamc@941
|
489 summarize (d + 2) body]
|
adamc@470
|
490
|
adam@1293
|
491 | EDml (e, _) => summarize d e @ [WriteDb]
|
adamc@579
|
492 | ENextval e => summarize d e @ [WriteDb]
|
adamc@1073
|
493 | ESetval (e1, e2) => summarize d e1 @ summarize d e2 @ [WriteDb]
|
adamc@1112
|
494 | EUnurlify (e, _, _) => summarize d e
|
adamc@815
|
495 | EJavaScript (_, e) => summarize d e
|
adamc@579
|
496 | ESignalReturn e => summarize d e
|
adamc@579
|
497 | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
|
adamc@579
|
498 | ESignalSource e => summarize d e
|
adamc@608
|
499
|
adamc@1020
|
500 | EServerCall (e, _, _) => summarize d e @ [Unsure]
|
adamc@1021
|
501 | ERecv (e, _) => summarize d e @ [Unsure]
|
adamc@1021
|
502 | ESleep e => summarize d e @ [Unsure]
|
adamc@1021
|
503 | ESpawn e => summarize d e @ [Unsure]
|
adamc@579
|
504 in
|
adamc@579
|
505 (*Print.prefaces "Summarize"
|
adamc@579
|
506 [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
|
adamc@579
|
507 ("d", Print.PD.string (Int.toString d)),
|
adamc@579
|
508 ("s", p_events s)];*)
|
adamc@579
|
509 s
|
adamc@579
|
510 end
|
adamc@470
|
511
|
adamc@919
|
512 val impure = fn env => fn e =>
|
adamc@948
|
513 simpleImpure (timpures, impures) env e andalso impure e
|
adamc@916
|
514 andalso not (List.null (summarize ~1 e))
|
adamc@916
|
515
|
adamc@470
|
516 fun exp env e =
|
adamc@470
|
517 let
|
adamc@470
|
518 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
|
adamc@470
|
519
|
adamc@1017
|
520 fun doLet (x, t, e', b) =
|
adamc@1017
|
521 let
|
adamc@1017
|
522 fun doSub () =
|
adamc@1017
|
523 let
|
adamc@1017
|
524 val r = subExpInExp (0, e') b
|
adamc@1017
|
525 in
|
adamc@1017
|
526 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
|
adam@1423
|
527 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
|
adam@1423
|
528 ("r", MonoPrint.p_exp env r)];*)
|
adamc@1017
|
529 #1 (reduceExp env r)
|
adamc@1017
|
530 end
|
adamc@1017
|
531
|
adamc@1017
|
532 fun trySub () =
|
adamc@1017
|
533 ((*Print.prefaces "trySub"
|
adamc@1017
|
534 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
|
adamc@1017
|
535 case t of
|
adamc@1017
|
536 (TFfi ("Basis", "string"), _) => doSub ()
|
adamc@1017
|
537 | (TSignal _, _) => e
|
adamc@1017
|
538 | _ =>
|
adamc@1017
|
539 case e' of
|
adamc@1017
|
540 (ECase _, _) => e
|
adamc@1017
|
541 | _ => doSub ())
|
adamc@1017
|
542 in
|
adamc@1017
|
543 if impure env e' then
|
adamc@1017
|
544 let
|
adamc@1017
|
545 val effs_e' = summarize 0 e'
|
adamc@1017
|
546 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
|
adamc@1017
|
547 val effs_b = summarize 0 b
|
adamc@1017
|
548
|
adam@1394
|
549 (*val () = Print.fprefaces outf "Try"
|
adam@1394
|
550 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
|
adamc@1017
|
551 ("e'", MonoPrint.p_exp env e'),
|
adamc@1017
|
552 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
|
adamc@1017
|
553 ("e'_eff", p_events effs_e'),
|
adamc@1017
|
554 ("b_eff", p_events effs_b)]*)
|
adamc@1017
|
555
|
adamc@1017
|
556 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
|
adamc@1017
|
557 val writesPage = does WritePage
|
adamc@1017
|
558 val readsDb = does ReadDb
|
adamc@1017
|
559 val writesDb = does WriteDb
|
adamc@1225
|
560 val readsCookie = does ReadCookie
|
adamc@1225
|
561 val writesCookie = does ReadCookie
|
adamc@1017
|
562
|
adamc@1017
|
563 fun verifyUnused eff =
|
adamc@1017
|
564 case eff of
|
adamc@1017
|
565 UseRel => false
|
adamc@1017
|
566 | _ => true
|
adamc@1017
|
567
|
adamc@1017
|
568 fun verifyCompatible effs =
|
adamc@1017
|
569 case effs of
|
adamc@1017
|
570 [] => false
|
adamc@1017
|
571 | eff :: effs =>
|
adamc@1017
|
572 case eff of
|
adamc@1017
|
573 Unsure => false
|
adamc@1017
|
574 | UseRel => List.all verifyUnused effs
|
adamc@1017
|
575 | WritePage => not writesPage andalso verifyCompatible effs
|
adamc@1017
|
576 | ReadDb => not writesDb andalso verifyCompatible effs
|
adamc@1017
|
577 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
|
adamc@1225
|
578 | ReadCookie => not writesCookie andalso verifyCompatible effs
|
adamc@1225
|
579 | WriteCookie => not writesCookie andalso not readsCookie
|
adamc@1225
|
580 andalso verifyCompatible effs
|
adamc@1225
|
581 | Abort => true
|
adamc@1017
|
582 in
|
adamc@1017
|
583 (*Print.prefaces "verifyCompatible"
|
adamc@1017
|
584 [("e'", MonoPrint.p_exp env e'),
|
adamc@1017
|
585 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
|
adamc@1017
|
586 ("effs_e'", Print.p_list p_event effs_e'),
|
adamc@1017
|
587 ("effs_b", Print.p_list p_event effs_b)];*)
|
adamc@1017
|
588 if (List.null effs_e'
|
adamc@1017
|
589 orelse (List.all (fn eff => eff <> Unsure) effs_e'
|
adamc@1017
|
590 andalso verifyCompatible effs_b)
|
adamc@1017
|
591 orelse (case effs_b of
|
adamc@1017
|
592 UseRel :: effs => List.all verifyUnused effs
|
adamc@1017
|
593 | _ => false))
|
adamc@1017
|
594 andalso countFree 0 0 b = 1
|
adamc@1017
|
595 andalso not (freeInAbs b) then
|
adamc@1017
|
596 trySub ()
|
adamc@1017
|
597 else
|
adamc@1017
|
598 e
|
adamc@1017
|
599 end
|
adamc@1017
|
600 else
|
adamc@1017
|
601 trySub ()
|
adamc@1017
|
602 end
|
adamc@1017
|
603
|
adamc@470
|
604 val r =
|
adamc@470
|
605 case e of
|
adamc@470
|
606 ERel n =>
|
adamc@470
|
607 (case E.lookupERel env n of
|
adamc@470
|
608 (_, _, SOME e') => #1 e'
|
adamc@470
|
609 | _ => e)
|
adamc@470
|
610 | ENamed n =>
|
adamc@470
|
611 (case E.lookupENamed env n of
|
adamc@470
|
612 (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)),
|
adamc@470
|
613 ("e'", MonoPrint.p_exp env e')];*)
|
adamc@470
|
614 #1 e')
|
adamc@470
|
615 | _ => e)
|
adamc@470
|
616
|
adamc@470
|
617 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
|
adamc@470
|
618 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
|
adamc@694
|
619 ("e2", MonoPrint.p_exp env e2),
|
adamc@694
|
620 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
|
adamc@975
|
621 if impure env e2 orelse countFree 0 0 e1 > 1 then
|
adamc@470
|
622 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
|
adamc@470
|
623 else
|
adamc@470
|
624 #1 (reduceExp env (subExpInExp (0, e2) e1)))
|
adamc@470
|
625
|
adamc@470
|
626 | ECase (e', pes, {disc, result}) =>
|
adamc@442
|
627 let
|
adamc@470
|
628 fun push () =
|
adamc@470
|
629 case result of
|
adamc@470
|
630 (TFun (dom, result), loc) =>
|
adamc@1107
|
631 let
|
adamc@1107
|
632 fun safe (e, _) =
|
adamc@1107
|
633 case e of
|
adamc@1107
|
634 EAbs _ => true
|
adam@1445
|
635 | EError _ => true
|
adamc@1107
|
636 | _ => false
|
adamc@1107
|
637 in
|
adamc@1107
|
638 if List.all (safe o #2) pes then
|
adamc@1107
|
639 EAbs ("y", dom, result,
|
adamc@1107
|
640 (ECase (liftExpInExp 0 e',
|
adamc@1107
|
641 map (fn (p, (EAbs (_, _, _, e), _)) =>
|
adamc@1107
|
642 (p, swapExpVarsPat (0, patBinds p) e)
|
adam@1445
|
643 | (p, (EError (e, (TFun (_, t), _)), loc)) =>
|
adam@1445
|
644 (p, (EError (e, t), loc))
|
adamc@1107
|
645 | _ => raise Fail "MonoReduce ECase") pes,
|
adamc@1107
|
646 {disc = disc, result = result}), loc))
|
adamc@1107
|
647 else
|
adamc@1107
|
648 e
|
adamc@1107
|
649 end
|
adamc@470
|
650 | _ => e
|
adamc@318
|
651
|
adamc@470
|
652 fun search pes =
|
adamc@470
|
653 case pes of
|
adamc@470
|
654 [] => push ()
|
adamc@470
|
655 | (p, body) :: pes =>
|
adamc@814
|
656 case match ([], p, e') of
|
adamc@470
|
657 No => search pes
|
adamc@470
|
658 | Maybe => push ()
|
adamc@814
|
659 | Yes subs =>
|
adamc@800
|
660 let
|
adamc@829
|
661 val (body, remaining) =
|
adamc@829
|
662 foldl (fn (e, (body, remaining)) =>
|
adamc@829
|
663 (subExpInExp (0, multiLift remaining e) body, remaining - 1))
|
adamc@829
|
664 (body, length subs - 1) subs
|
adamc@920
|
665 val r = reduceExp (E.patBinds env p) body
|
adamc@800
|
666 in
|
adamc@829
|
667 (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*)
|
adamc@800
|
668 (*Print.prefaces "ECase"
|
adamc@829
|
669 [("old", MonoPrint.p_exp env body),
|
adamc@829
|
670 ("body", MonoPrint.p_exp env body),
|
adamc@800
|
671 ("r", MonoPrint.p_exp env r)];*)
|
adamc@800
|
672 #1 r
|
adamc@800
|
673 end
|
adamc@470
|
674 in
|
adamc@941
|
675 if impure env e' then
|
adamc@941
|
676 e
|
adamc@941
|
677 else
|
adamc@941
|
678 search pes
|
adamc@470
|
679 end
|
adamc@318
|
680
|
adamc@470
|
681 | EField ((ERecord xes, _), x) =>
|
adamc@470
|
682 (case List.find (fn (x', _, _) => x' = x) xes of
|
adamc@470
|
683 SOME (_, e, _) => #1 e
|
adamc@470
|
684 | NONE => e)
|
adamc@398
|
685
|
adamc@470
|
686 | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
|
adamc@470
|
687 let
|
adamc@470
|
688 val e' = (ELet (x2, t2, e1,
|
adamc@470
|
689 (ELet (x1, t1, b1,
|
adamc@470
|
690 liftExpInExp 1 b2), loc)), loc)
|
adamc@442
|
691 in
|
adamc@470
|
692 (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
|
adamc@470
|
693 ("e'", MonoPrint.p_exp env e')];*)
|
adamc@470
|
694 #1 (reduceExp env e')
|
adamc@470
|
695 end
|
adamc@470
|
696 | EApp ((ELet (x, t, e, b), loc), e') =>
|
adamc@470
|
697 #1 (reduceExp env (ELet (x, t, e,
|
adamc@470
|
698 (EApp (b, liftExpInExp 0 e'), loc)), loc))
|
adamc@470
|
699
|
adamc@1017
|
700 | ELet (x, t, e', b as (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
|
adamc@919
|
701 if impure env e' then
|
adamc@1017
|
702 doLet (x, t, e', b)
|
adamc@848
|
703 else
|
adamc@920
|
704 EAbs (x', t', ran, reduceExp (E.pushERel env x' t' NONE)
|
adamc@920
|
705 (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
|
adamc@470
|
706
|
adamc@1017
|
707 | ELet (x, t, e', b) => doLet (x, t, e', b)
|
adamc@252
|
708
|
adamc@470
|
709 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
|
adamc@470
|
710 EPrim (Prim.String (s1 ^ s2))
|
adamc@268
|
711
|
adamc@572
|
712 | ESignalBind ((ESignalReturn e1, loc), e2) =>
|
adamc@572
|
713 #1 (reduceExp env (EApp (e2, e1), loc))
|
adamc@572
|
714
|
adamc@470
|
715 | _ => e
|
adamc@470
|
716 in
|
adamc@829
|
717 (*Print.prefaces "exp'" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
|
adamc@829
|
718 ("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
|
adamc@470
|
719 r
|
adamc@470
|
720 end
|
adamc@470
|
721
|
adamc@470
|
722 and bind (env, b) =
|
adamc@470
|
723 case b of
|
adamc@470
|
724 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
|
adamc@470
|
725 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
|
adamc@1017
|
726 | U.Decl.NamedE (x, n, t, eo, s) =>
|
adamc@1017
|
727 let
|
adamc@1017
|
728 val eo = case eo of
|
adamc@1017
|
729 NONE => NONE
|
adam@1393
|
730 | SOME e => if mayInline (n, e, t, s) then
|
adamc@1017
|
731 SOME e
|
adamc@1017
|
732 else
|
adamc@1017
|
733 NONE
|
adamc@1017
|
734 in
|
adamc@1017
|
735 E.pushENamed env x n t (Option.map (reduceExp env) eo) s
|
adamc@1017
|
736 end
|
adamc@470
|
737
|
adamc@470
|
738 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
|
adamc@470
|
739
|
adamc@801
|
740 fun decl env d = ((*Print.preface ("d", MonoPrint.p_decl env (d, ErrorMsg.dummySpan));*)
|
adamc@801
|
741 d)
|
adamc@398
|
742 in
|
adamc@470
|
743 U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
|
adamc@398
|
744 end
|
adamc@133
|
745
|
adamc@133
|
746 end
|