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