Mercurial > urweb

comparison src/mono_reduce.sml @ 318:60907c06b4c4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Optimization removes linear let-bindings of impure expressions
author Adam Chlipala <adamc@hcoop.net>
date Thu, 11 Sep 2008 11:30:39 -0400
parents 04ebfe929a98
children 1fd2a29a7c85
comparison
equal deleted inserted replaced
317:6a4e365db60c 318:60907c06b4c4
170 consider (xps, env) 170 consider (xps, env)
171 end 171 end
172 172
173 | _ => Maybe 173 | _ => Maybe
174 174
175 datatype event =
176 WritePage
177 | ReadDb
178 | WriteDb
179 | UseRel of int
180 | Unsure
181
182 fun p_event e =
183 let
184 open Print.PD
185 in
186 case e of
187 WritePage => string "WritePage"
188 | ReadDb => string "ReadDb"
189 | WriteDb => string "WriteDb"
190 | UseRel n => string ("UseRel" ^ Int.toString n)
191 | Unsure => string "Unsure"
192 end
193
194 fun patBinds (p, _) =
195 case p of
196 PWild => 0
197 | PVar _ => 1
198 | PPrim _ => 0
199 | PCon (_, _, NONE) => 0
200 | PCon (_, _, SOME p) => patBinds p
201 | PRecord xpts => foldl (fn ((_, p, _), n) => n + patBinds p) 0 xpts
202 | PNone _ => 0
203 | PSome (_, p) => patBinds p
204
205 fun summarize d (e, _) =
206 case e of
207 EPrim _ => []
208 | ERel n => if n >= d then [UseRel (n - d)] else []
209 | ENamed _ => []
210 | ECon (_, _, NONE) => []
211 | ECon (_, _, SOME e) => summarize d e
212 | ENone _ => []
213 | ESome (_, e) => summarize d e
214 | EFfi _ => []
215 | EFfiApp (_, _, es) => List.concat (map (summarize d) es)
216 | EApp _ => [Unsure]
217 | EAbs _ => []
218
219 | ERecord xets => List.concat (map (summarize d o #2) xets)
220 | EField (e, _) => summarize d e
221
222 | ECase (e, pes, _) =>
223 let
224 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
225 in
226 case lss of
227 [] => raise Fail "Empty pattern match"
228 | ls :: lss =>
229 if List.all (fn ls' => ls' = ls) lss then
230 summarize d e @ ls
231 else
232 [Unsure]
233 end
234 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
235
236 | EError (e, _) => summarize d e @ [Unsure]
237
238 | EWrite e => summarize d e @ [WritePage]
239
240 | ESeq (e1, e2) => summarize d e1 @ summarize d e2
241 | ELet (_, _, e1, e2) => summarize d e1 @ summarize (d + 1) e2
242
243 | EClosure (_, es) => List.concat (map (summarize d) es)
244
245 | EQuery {query, body, initial, ...} =>
246 List.concat [summarize d query,
247 summarize d body,
248 summarize d initial,
249 [ReadDb]]
250
251 | EDml e => summarize d e @ [WriteDb]
252
175 fun exp env e = 253 fun exp env e =
176 case e of 254 case e of
177 ERel n => 255 ERel n =>
178 (case E.lookupERel env n of 256 (case E.lookupERel env n of
179 (_, _, SOME e') => #1 e' 257 (_, _, SOME e') => #1 e'
227 | ELet (x, t, e, (EAbs (x', t' as (TRecord [], _), ran, e'), loc)) => 305 | ELet (x, t, e, (EAbs (x', t' as (TRecord [], _), ran, e'), loc)) =>
228 EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e, swapExpVars 0 e'), loc)) 306 EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e, swapExpVars 0 e'), loc))
229 307
230 | ELet (x, t, e', b) => 308 | ELet (x, t, e', b) =>
231 if impure e' then 309 if impure e' then
232 e 310 let
311 val effs_e' = summarize 0 e'
312 val effs_b = summarize 0 b
313
314 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
315 val writesPage = does WritePage
316 val readsDb = does ReadDb
317 val writesDb = does WriteDb
318
319 fun verifyUnused eff =
320 case eff of
321 UseRel r => r <> 0
322 | Unsure => false
323 | _ => true
324
325 fun verifyCompatible effs =
326 case effs of
327 [] => false
328 | eff :: effs =>
329 case eff of
330 Unsure => false
331 | UseRel r =>
332 if r = 0 then
333 List.all verifyUnused effs
334 else
335 verifyCompatible effs
336 | WritePage => not writesPage andalso verifyCompatible effs
337 | ReadDb => not writesDb andalso verifyCompatible effs
338 | WriteDb => not writesDb andalso not readsDb andalso verifyCompatible effs
339 in
340 (*Print.prefaces "verifyCompatible"
341 [("e'", MonoPrint.p_exp env e'),
342 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
343 ("effs_e'", Print.p_list p_event effs_e'),
344 ("effs_b", Print.p_list p_event effs_b)];*)
345 if verifyCompatible effs_b then
346 #1 (reduceExp env (subExpInExp (0, e') b))
347 else
348 e
349 end
233 else 350 else
234 #1 (reduceExp env (subExpInExp (0, e') b)) 351 #1 (reduceExp env (subExpInExp (0, e') b))
235 352
236 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) => 353 | EStrcat ((EPrim (Prim.String s1), _), (EPrim (Prim.String s2), _)) =>
237 EPrim (Prim.String (s1 ^ s2)) 354 EPrim (Prim.String (s1 ^ s2))