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