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@470
|
38
|
adamc@133
|
39
|
adamc@252
|
40 fun impure (e, _) =
|
adamc@252
|
41 case e of
|
adamc@252
|
42 EWrite _ => true
|
adamc@252
|
43 | EQuery _ => true
|
adamc@307
|
44 | EDml _ => true
|
adamc@338
|
45 | ENextval _ => true
|
adamc@463
|
46 | EUnurlify _ => true
|
adamc@252
|
47 | EAbs _ => false
|
adamc@252
|
48
|
adamc@252
|
49 | EPrim _ => false
|
adamc@252
|
50 | ERel _ => false
|
adamc@252
|
51 | ENamed _ => false
|
adamc@252
|
52 | ECon (_, _, eo) => (case eo of NONE => false | SOME e => impure e)
|
adamc@297
|
53 | ENone _ => false
|
adamc@290
|
54 | ESome (_, e) => impure e
|
adamc@252
|
55 | EFfi _ => false
|
adamc@462
|
56 | EFfiApp ("Basis", "set_cookie", _) => true
|
adamc@252
|
57 | EFfiApp _ => false
|
adamc@252
|
58 | EApp ((EFfi _, _), _) => false
|
adamc@252
|
59 | EApp _ => true
|
adamc@252
|
60
|
adamc@387
|
61 | EUnop (_, e) => impure e
|
adamc@387
|
62 | EBinop (_, e1, e2) => impure e1 orelse impure e2
|
adamc@387
|
63
|
adamc@252
|
64 | ERecord xes => List.exists (fn (_, e, _) => impure e) xes
|
adamc@252
|
65 | EField (e, _) => impure e
|
adamc@252
|
66
|
adamc@252
|
67 | ECase (e, pes, _) => impure e orelse List.exists (fn (_, e) => impure e) pes
|
adamc@252
|
68
|
adamc@283
|
69 | EError (e, _) => impure e
|
adamc@283
|
70
|
adamc@252
|
71 | EStrcat (e1, e2) => impure e1 orelse impure e2
|
adamc@252
|
72
|
adamc@252
|
73 | ESeq (e1, e2) => impure e1 orelse impure e2
|
adamc@252
|
74 | ELet (_, _, e1, e2) => impure e1 orelse impure e2
|
adamc@252
|
75
|
adamc@252
|
76 | EClosure (_, es) => List.exists impure es
|
adamc@252
|
77
|
adamc@252
|
78
|
adamc@252
|
79 val liftExpInExp = Monoize.liftExpInExp
|
adamc@252
|
80
|
adamc@252
|
81 val subExpInExp' =
|
adamc@133
|
82 U.Exp.mapB {typ = fn t => t,
|
adamc@133
|
83 exp = fn (xn, rep) => fn e =>
|
adamc@133
|
84 case e of
|
adamc@133
|
85 ERel xn' =>
|
adamc@133
|
86 (case Int.compare (xn', xn) of
|
adamc@133
|
87 EQUAL => #1 rep
|
adamc@133
|
88 | GREATER=> ERel (xn' - 1)
|
adamc@133
|
89 | LESS => e)
|
adamc@133
|
90 | _ => e,
|
adamc@133
|
91 bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, liftExpInExp 0 rep)
|
adamc@133
|
92 | (ctx, _) => ctx}
|
adamc@133
|
93
|
adamc@252
|
94 fun subExpInExp (n, e1) e2 =
|
adamc@252
|
95 let
|
adamc@252
|
96 val r = subExpInExp' (n, e1) e2
|
adamc@252
|
97 in
|
adamc@252
|
98 (*Print.prefaces "subExpInExp" [("e1", MonoPrint.p_exp MonoEnv.empty e1),
|
adamc@252
|
99 ("e2", MonoPrint.p_exp MonoEnv.empty e2),
|
adamc@252
|
100 ("r", MonoPrint.p_exp MonoEnv.empty r)];*)
|
adamc@252
|
101 r
|
adamc@252
|
102 end
|
adamc@133
|
103
|
adamc@133
|
104 fun typ c = c
|
adamc@133
|
105
|
adamc@316
|
106 val swapExpVars =
|
adamc@316
|
107 U.Exp.mapB {typ = fn t => t,
|
adamc@316
|
108 exp = fn lower => fn e =>
|
adamc@316
|
109 case e of
|
adamc@316
|
110 ERel xn =>
|
adamc@316
|
111 if xn = lower then
|
adamc@316
|
112 ERel (lower + 1)
|
adamc@316
|
113 else if xn = lower + 1 then
|
adamc@316
|
114 ERel lower
|
adamc@316
|
115 else
|
adamc@316
|
116 e
|
adamc@316
|
117 | _ => e,
|
adamc@316
|
118 bind = fn (lower, U.Exp.RelE _) => lower+1
|
adamc@316
|
119 | (lower, _) => lower}
|
adamc@316
|
120
|
adamc@341
|
121 val swapExpVarsPat =
|
adamc@341
|
122 U.Exp.mapB {typ = fn t => t,
|
adamc@341
|
123 exp = fn (lower, len) => fn e =>
|
adamc@341
|
124 case e of
|
adamc@341
|
125 ERel xn =>
|
adamc@341
|
126 if xn = lower then
|
adamc@341
|
127 ERel (lower + 1)
|
adamc@341
|
128 else if xn >= lower + 1 andalso xn < lower + 1 + len then
|
adamc@341
|
129 ERel (xn - 1)
|
adamc@341
|
130 else
|
adamc@341
|
131 e
|
adamc@341
|
132 | _ => e,
|
adamc@341
|
133 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
|
adamc@341
|
134 | (st, _) => st}
|
adamc@341
|
135
|
adamc@258
|
136 datatype result = Yes of E.env | No | Maybe
|
adamc@258
|
137
|
adamc@183
|
138 fun match (env, p : pat, e : exp) =
|
adamc@183
|
139 case (#1 p, #1 e) of
|
adamc@258
|
140 (PWild, _) => Yes env
|
adamc@258
|
141 | (PVar (x, t), _) => Yes (E.pushERel env x t (SOME e))
|
adamc@183
|
142
|
adamc@280
|
143 | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
|
adamc@280
|
144 if String.isPrefix s' s then
|
adamc@280
|
145 Maybe
|
adamc@280
|
146 else
|
adamc@280
|
147 No
|
adamc@280
|
148
|
adamc@183
|
149 | (PPrim p, EPrim p') =>
|
adamc@183
|
150 if Prim.equal (p, p') then
|
adamc@258
|
151 Yes env
|
adamc@183
|
152 else
|
adamc@258
|
153 No
|
adamc@183
|
154
|
adamc@188
|
155 | (PCon (_, PConVar n1, NONE), ECon (_, PConVar n2, NONE)) =>
|
adamc@183
|
156 if n1 = n2 then
|
adamc@258
|
157 Yes env
|
adamc@183
|
158 else
|
adamc@258
|
159 No
|
adamc@183
|
160
|
adamc@188
|
161 | (PCon (_, PConVar n1, SOME p), ECon (_, PConVar n2, SOME e)) =>
|
adamc@183
|
162 if n1 = n2 then
|
adamc@183
|
163 match (env, p, e)
|
adamc@183
|
164 else
|
adamc@258
|
165 No
|
adamc@183
|
166
|
adamc@188
|
167 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, NONE), ECon (_, PConFfi {mod = m2, con = con2, ...}, NONE)) =>
|
adamc@185
|
168 if m1 = m2 andalso con1 = con2 then
|
adamc@258
|
169 Yes env
|
adamc@185
|
170 else
|
adamc@258
|
171 No
|
adamc@185
|
172
|
adamc@188
|
173 | (PCon (_, PConFfi {mod = m1, con = con1, ...}, SOME ep), ECon (_, PConFfi {mod = m2, con = con2, ...}, SOME e)) =>
|
adamc@185
|
174 if m1 = m2 andalso con1 = con2 then
|
adamc@185
|
175 match (env, p, e)
|
adamc@185
|
176 else
|
adamc@258
|
177 No
|
adamc@185
|
178
|
adamc@183
|
179 | (PRecord xps, ERecord xes) =>
|
adamc@183
|
180 let
|
adamc@183
|
181 fun consider (xps, env) =
|
adamc@183
|
182 case xps of
|
adamc@258
|
183 [] => Yes env
|
adamc@183
|
184 | (x, p, _) :: rest =>
|
adamc@183
|
185 case List.find (fn (x', _, _) => x' = x) xes of
|
adamc@258
|
186 NONE => No
|
adamc@183
|
187 | SOME (_, e, _) =>
|
adamc@183
|
188 case match (env, p, e) of
|
adamc@258
|
189 No => No
|
adamc@258
|
190 | Maybe => Maybe
|
adamc@258
|
191 | Yes env => consider (rest, env)
|
adamc@183
|
192 in
|
adamc@183
|
193 consider (xps, env)
|
adamc@183
|
194 end
|
adamc@183
|
195
|
adamc@258
|
196 | _ => Maybe
|
adamc@183
|
197
|
adamc@318
|
198 datatype event =
|
adamc@318
|
199 WritePage
|
adamc@318
|
200 | ReadDb
|
adamc@318
|
201 | WriteDb
|
adamc@481
|
202 | UseRel
|
adamc@318
|
203 | Unsure
|
adamc@318
|
204
|
adamc@318
|
205 fun p_event e =
|
adamc@318
|
206 let
|
adamc@318
|
207 open Print.PD
|
adamc@318
|
208 in
|
adamc@318
|
209 case e of
|
adamc@318
|
210 WritePage => string "WritePage"
|
adamc@318
|
211 | ReadDb => string "ReadDb"
|
adamc@318
|
212 | WriteDb => string "WriteDb"
|
adamc@481
|
213 | UseRel => string "UseRel"
|
adamc@318
|
214 | Unsure => string "Unsure"
|
adamc@318
|
215 end
|
adamc@318
|
216
|
adamc@470
|
217 val p_events = Print.p_list p_event
|
adamc@470
|
218
|
adamc@318
|
219 fun patBinds (p, _) =
|
adamc@318
|
220 case p of
|
adamc@318
|
221 PWild => 0
|
adamc@318
|
222 | PVar _ => 1
|
adamc@318
|
223 | PPrim _ => 0
|
adamc@318
|
224 | PCon (_, _, NONE) => 0
|
adamc@318
|
225 | PCon (_, _, SOME p) => patBinds p
|
adamc@318
|
226 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
|
adamc@318
|
227 | PNone _ => 0
|
adamc@318
|
228 | PSome (_, p) => patBinds p
|
adamc@318
|
229
|
adamc@470
|
230 fun reduce file =
|
adamc@470
|
231 let
|
adamc@470
|
232 fun countAbs (e, _) =
|
adamc@470
|
233 case e of
|
adamc@470
|
234 EAbs (_, _, _, e) => 1 + countAbs e
|
adamc@470
|
235 | _ => 0
|
adamc@318
|
236
|
adamc@470
|
237 val absCounts =
|
adamc@470
|
238 foldl (fn ((d, _), absCounts) =>
|
adamc@470
|
239 case d of
|
adamc@470
|
240 DVal (_, n, _, e, _) =>
|
adamc@470
|
241 IM.insert (absCounts, n, countAbs e)
|
adamc@470
|
242 | DValRec vis =>
|
adamc@470
|
243 foldl (fn ((_, n, _, e, _), absCounts) =>
|
adamc@470
|
244 IM.insert (absCounts, n, countAbs e))
|
adamc@470
|
245 absCounts vis
|
adamc@470
|
246 | _ => absCounts)
|
adamc@470
|
247 IM.empty file
|
adamc@387
|
248
|
adamc@470
|
249 fun summarize d (e, _) =
|
adamc@398
|
250 case e of
|
adamc@470
|
251 EPrim _ => []
|
adamc@481
|
252 | ERel n => if n = d then [UseRel] else []
|
adamc@470
|
253 | ENamed _ => []
|
adamc@470
|
254 | ECon (_, _, NONE) => []
|
adamc@470
|
255 | ECon (_, _, SOME e) => summarize d e
|
adamc@470
|
256 | ENone _ => []
|
adamc@470
|
257 | ESome (_, e) => summarize d e
|
adamc@470
|
258 | EFfi _ => []
|
adamc@470
|
259 | EFfiApp ("Basis", "set_cookie", _) => [Unsure]
|
adamc@470
|
260 | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
|
adamc@470
|
261 | EApp ((EFfi _, _), e) => summarize d e
|
adamc@470
|
262 | EApp _ =>
|
adamc@398
|
263 let
|
adamc@470
|
264 fun unravel (e, ls) =
|
adamc@470
|
265 case e of
|
adamc@470
|
266 ENamed n =>
|
adamc@470
|
267 let
|
adamc@470
|
268 val ls = rev ls
|
adamc@470
|
269 in
|
adamc@470
|
270 case IM.find (absCounts, n) of
|
adamc@470
|
271 NONE => [Unsure]
|
adamc@470
|
272 | SOME len =>
|
adamc@470
|
273 if length ls < len then
|
adamc@470
|
274 ls
|
adamc@470
|
275 else
|
adamc@470
|
276 [Unsure]
|
adamc@470
|
277 end
|
adamc@481
|
278 | ERel n => List.revAppend (ls,
|
adamc@481
|
279 if n = d then
|
adamc@481
|
280 [UseRel, Unsure]
|
adamc@481
|
281 else
|
adamc@481
|
282 [Unsure])
|
adamc@470
|
283 | EApp (f, x) =>
|
adamc@470
|
284 unravel (#1 f, summarize d x @ ls)
|
adamc@470
|
285 | _ => [Unsure]
|
adamc@398
|
286 in
|
adamc@470
|
287 unravel (e, [])
|
adamc@398
|
288 end
|
adamc@252
|
289
|
adamc@470
|
290 | EAbs _ => []
|
adamc@316
|
291
|
adamc@470
|
292 | EUnop (_, e) => summarize d e
|
adamc@470
|
293 | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2
|
adamc@470
|
294
|
adamc@470
|
295 | ERecord xets => List.concat (map (summarize d o #2) xets)
|
adamc@470
|
296 | EField (e, _) => summarize d e
|
adamc@470
|
297
|
adamc@470
|
298 | ECase (e, pes, _) =>
|
adamc@398
|
299 let
|
adamc@470
|
300 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
|
adamc@398
|
301 in
|
adamc@470
|
302 case lss of
|
adamc@470
|
303 [] => raise Fail "Empty pattern match"
|
adamc@470
|
304 | ls :: lss =>
|
adamc@470
|
305 if List.all (fn ls' => ls' = ls) lss then
|
adamc@470
|
306 summarize d e @ ls
|
adamc@470
|
307 else
|
adamc@470
|
308 [Unsure]
|
adamc@398
|
309 end
|
adamc@470
|
310 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
|
adamc@316
|
311
|
adamc@470
|
312 | EError (e, _) => summarize d e @ [Unsure]
|
adamc@318
|
313
|
adamc@470
|
314 | EWrite e => summarize d e @ [WritePage]
|
adamc@470
|
315
|
adamc@470
|
316 | ESeq (e1, e2) => summarize d e1 @ summarize d e2
|
adamc@470
|
317 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
|
adamc@456
|
318
|
adamc@470
|
319 | EClosure (_, es) => List.concat (map (summarize d) es)
|
adamc@470
|
320
|
adamc@470
|
321 | EQuery {query, body, initial, ...} =>
|
adamc@470
|
322 List.concat [summarize d query,
|
adamc@470
|
323 summarize (d + 2) body,
|
adamc@470
|
324 summarize d initial,
|
adamc@470
|
325 [ReadDb]]
|
adamc@470
|
326
|
adamc@470
|
327 | EDml e => summarize d e @ [WriteDb]
|
adamc@470
|
328 | ENextval e => summarize d e @ [WriteDb]
|
adamc@470
|
329 | EUnurlify (e, _) => summarize d e
|
adamc@470
|
330
|
adamc@470
|
331
|
adamc@470
|
332 fun exp env e =
|
adamc@470
|
333 let
|
adamc@470
|
334 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
|
adamc@470
|
335
|
adamc@470
|
336 val r =
|
adamc@470
|
337 case e of
|
adamc@470
|
338 ERel n =>
|
adamc@470
|
339 (case E.lookupERel env n of
|
adamc@470
|
340 (_, _, SOME e') => #1 e'
|
adamc@470
|
341 | _ => e)
|
adamc@470
|
342 | ENamed n =>
|
adamc@470
|
343 (case E.lookupENamed env n of
|
adamc@470
|
344 (_, _, SOME e', _) => ((*Print.prefaces "Switch" [("n", Print.PD.string (Int.toString n)),
|
adamc@470
|
345 ("e'", MonoPrint.p_exp env e')];*)
|
adamc@470
|
346 #1 e')
|
adamc@470
|
347 | _ => e)
|
adamc@470
|
348
|
adamc@470
|
349 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
|
adamc@470
|
350 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
|
adamc@470
|
351 ("e2", MonoPrint.p_exp env e2),
|
adamc@470
|
352 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
|
adamc@470
|
353 if impure e2 then
|
adamc@470
|
354 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
|
adamc@470
|
355 else
|
adamc@470
|
356 #1 (reduceExp env (subExpInExp (0, e2) e1)))
|
adamc@470
|
357
|
adamc@470
|
358 | ECase (e', pes, {disc, result}) =>
|
adamc@442
|
359 let
|
adamc@470
|
360 fun push () =
|
adamc@470
|
361 case result of
|
adamc@470
|
362 (TFun (dom, result), loc) =>
|
adamc@470
|
363 if List.all (fn (_, (EAbs _, _)) => true | _ => false) pes then
|
adamc@470
|
364 EAbs ("_", dom, result,
|
adamc@470
|
365 (ECase (liftExpInExp 0 e',
|
adamc@470
|
366 map (fn (p, (EAbs (_, _, _, e), _)) =>
|
adamc@470
|
367 (p, swapExpVarsPat (0, patBinds p) e)
|
adamc@470
|
368 | _ => raise Fail "MonoReduce ECase") pes,
|
adamc@470
|
369 {disc = disc, result = result}), loc))
|
adamc@470
|
370 else
|
adamc@470
|
371 e
|
adamc@470
|
372 | _ => e
|
adamc@318
|
373
|
adamc@470
|
374 fun search pes =
|
adamc@470
|
375 case pes of
|
adamc@470
|
376 [] => push ()
|
adamc@470
|
377 | (p, body) :: pes =>
|
adamc@470
|
378 case match (env, p, e') of
|
adamc@470
|
379 No => search pes
|
adamc@470
|
380 | Maybe => push ()
|
adamc@470
|
381 | Yes env => #1 (reduceExp env body)
|
adamc@470
|
382 in
|
adamc@470
|
383 search pes
|
adamc@470
|
384 end
|
adamc@318
|
385
|
adamc@470
|
386 | EField ((ERecord xes, _), x) =>
|
adamc@470
|
387 (case List.find (fn (x', _, _) => x' = x) xes of
|
adamc@470
|
388 SOME (_, e, _) => #1 e
|
adamc@470
|
389 | NONE => e)
|
adamc@398
|
390
|
adamc@470
|
391 | ELet (x1, t1, (ELet (x2, t2, e1, b1), loc), b2) =>
|
adamc@470
|
392 let
|
adamc@470
|
393 val e' = (ELet (x2, t2, e1,
|
adamc@470
|
394 (ELet (x1, t1, b1,
|
adamc@470
|
395 liftExpInExp 1 b2), loc)), loc)
|
adamc@442
|
396 in
|
adamc@470
|
397 (*Print.prefaces "ELet commute" [("e", MonoPrint.p_exp env (e, loc)),
|
adamc@470
|
398 ("e'", MonoPrint.p_exp env e')];*)
|
adamc@470
|
399 #1 (reduceExp env e')
|
adamc@470
|
400 end
|
adamc@470
|
401 | EApp ((ELet (x, t, e, b), loc), e') =>
|
adamc@470
|
402 #1 (reduceExp env (ELet (x, t, e,
|
adamc@470
|
403 (EApp (b, liftExpInExp 0 e'), loc)), loc))
|
adamc@470
|
404
|
adamc@470
|
405 | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
|
adamc@470
|
406 (*if impure e' then
|
adamc@470
|
407 e
|
adamc@470
|
408 else*)
|
adamc@470
|
409 (* Seems unsound in general without the check... should revisit later *)
|
adamc@470
|
410 EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
|
adamc@470
|
411
|
adamc@470
|
412 | ELet (x, t, e', b) =>
|
adamc@470
|
413 let
|
adamc@470
|
414 fun doSub () =
|
adamc@470
|
415 #1 (reduceExp env (subExpInExp (0, e') b))
|
adamc@470
|
416
|
adamc@470
|
417 fun trySub () =
|
adamc@470
|
418 case t of
|
adamc@470
|
419 (TFfi ("Basis", "string"), _) => doSub ()
|
adamc@470
|
420 | _ =>
|
adamc@470
|
421 case e' of
|
adamc@470
|
422 (ECase _, _) => e
|
adamc@470
|
423 | _ => doSub ()
|
adamc@470
|
424 in
|
adamc@470
|
425 if impure e' then
|
adamc@470
|
426 let
|
adamc@470
|
427 val effs_e' = summarize 0 e'
|
adamc@470
|
428 val effs_b = summarize 0 b
|
adamc@470
|
429
|
adamc@470
|
430 (*val () = Print.prefaces "Try"
|
adamc@470
|
431 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
|
adamc@470
|
432 ("e'", p_events effs_e'),
|
adamc@470
|
433 ("b", p_events effs_b)]*)
|
adamc@470
|
434
|
adamc@470
|
435 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
|
adamc@470
|
436 val writesPage = does WritePage
|
adamc@470
|
437 val readsDb = does ReadDb
|
adamc@470
|
438 val writesDb = does WriteDb
|
adamc@470
|
439
|
adamc@470
|
440 fun verifyUnused eff =
|
adamc@470
|
441 case eff of
|
adamc@481
|
442 UseRel => false
|
adamc@470
|
443 | _ => true
|
adamc@470
|
444
|
adamc@470
|
445 fun verifyCompatible effs =
|
adamc@470
|
446 case effs of
|
adamc@470
|
447 [] => false
|
adamc@470
|
448 | eff :: effs =>
|
adamc@470
|
449 case eff of
|
adamc@470
|
450 Unsure => false
|
adamc@481
|
451 | UseRel => List.all verifyUnused effs
|
adamc@470
|
452 | WritePage => not writesPage andalso verifyCompatible effs
|
adamc@470
|
453 | ReadDb => not writesDb andalso verifyCompatible effs
|
adamc@470
|
454 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
|
adamc@470
|
455 in
|
adamc@470
|
456 (*Print.prefaces "verifyCompatible"
|
adamc@470
|
457 [("e'", MonoPrint.p_exp env e'),
|
adamc@470
|
458 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
|
adamc@470
|
459 ("effs_e'", Print.p_list p_event effs_e'),
|
adamc@470
|
460 ("effs_b", Print.p_list p_event effs_b)];*)
|
adamc@481
|
461 if List.null effs_e' orelse verifyCompatible effs_b then
|
adamc@470
|
462 trySub ()
|
adamc@470
|
463 else
|
adamc@470
|
464 e
|
adamc@470
|
465 end
|
adamc@470
|
466 else
|
adamc@442
|
467 trySub ()
|
adamc@442
|
468 end
|
adamc@252
|
469
|
adamc@470
|
470 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
|
adamc@470
|
471 EPrim (Prim.String (s1 ^ s2))
|
adamc@268
|
472
|
adamc@470
|
473 | _ => e
|
adamc@470
|
474 in
|
adamc@470
|
475 (*Print.prefaces "exp'" [("r", MonoPrint.p_exp env (r, ErrorMsg.dummySpan))];*)
|
adamc@470
|
476 r
|
adamc@470
|
477 end
|
adamc@470
|
478
|
adamc@470
|
479 and bind (env, b) =
|
adamc@470
|
480 case b of
|
adamc@470
|
481 U.Decl.Datatype (x, n, xncs) => E.pushDatatype env x n xncs
|
adamc@470
|
482 | U.Decl.RelE (x, t) => E.pushERel env x t NONE
|
adamc@470
|
483 | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t (Option.map (reduceExp env) eo) s
|
adamc@470
|
484
|
adamc@470
|
485 and reduceExp env = U.Exp.mapB {typ = typ, exp = exp, bind = bind} env
|
adamc@470
|
486
|
adamc@470
|
487 fun decl env d = d
|
adamc@398
|
488 in
|
adamc@470
|
489 U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
|
adamc@398
|
490 end
|
adamc@133
|
491
|
adamc@133
|
492 end
|