Mercurial > urweb

comparison src/mono_reduce.sml @ 948:b03d48aac959

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Find more opportunities for 'let' inlining with better purity information
author Adam Chlipala <adamc@hcoop.net>
date Thu, 17 Sep 2009 12:55:22 -0400
parents b8d7a47b8e0c
children 8fe576c0bee9
comparison
equal deleted inserted replaced
947:e2305dcc3965 948:b03d48aac959
36 36
37 structure IM = IntBinaryMap 37 structure IM = IntBinaryMap
38 structure IS = IntBinarySet 38 structure IS = IntBinarySet
39 39
40 40
41 val simpleTypeImpure = 41 fun simpleTypeImpure tsyms =
42 U.Typ.exists (fn TFun _ => true 42 U.Typ.exists (fn TFun _ => true
43 | TDatatype _ => true 43 | TDatatype (n, _) => IS.member (tsyms, n)
44 | _ => false) 44 | _ => false)
45 45
46 fun simpleImpure syms = 46 fun simpleImpure (tsyms, syms) =
47 U.Exp.existsB {typ = fn _ => false, 47 U.Exp.existsB {typ = fn _ => false,
48 exp = fn (env, e) => 48 exp = fn (env, e) =>
49 case e of 49 case e of
50 EWrite _ => true 50 EWrite _ => true
51 | EQuery _ => true 51 | EQuery _ => true
52 | EDml _ => true 52 | EDml _ => true
53 | ENextval _ => true 53 | ENextval _ => true
54 | EUnurlify _ => true
55 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) 54 | EFfiApp (m, x, _) => Settings.isEffectful (m, x)
56 | EServerCall _ => true 55 | EServerCall _ => true
57 | ERecv _ => true 56 | ERecv _ => true
58 | ESleep _ => true 57 | ESleep _ => true
59 | ENamed n => IS.member (syms, n) 58 | ENamed n => IS.member (syms, n)
60 | ERel n => 59 | ERel n =>
61 let 60 let
62 val (_, t, _) = E.lookupERel env n 61 val (_, t, _) = E.lookupERel env n
63 in 62 in
64 simpleTypeImpure t 63 simpleTypeImpure tsyms t
65 end 64 end
66 | _ => false, 65 | _ => false,
67 bind = fn (env, b) => 66 bind = fn (env, b) =>
68 case b of 67 case b of
69 U.Exp.RelE (x, t) => E.pushERel env x t NONE 68 U.Exp.RelE (x, t) => E.pushERel env x t NONE
285 U.Exp.RelE _ => n + 1 284 U.Exp.RelE _ => n + 1
286 | _ => n} 0 0 285 | _ => n} 0 0
287 286
288 fun reduce file = 287 fun reduce file =
289 let 288 let
290 val (impures, absCounts) = 289 val (timpures, impures, absCounts) =
291 foldl (fn ((d, _), (impures, absCounts)) => 290 foldl (fn ((d, _), (timpures, impures, absCounts)) =>
292 let 291 let
293 fun countAbs (e, _) = 292 fun countAbs (e, _) =
294 case e of 293 case e of
295 EAbs (_, _, _, e) => 1 + countAbs e 294 EAbs (_, _, _, e) => 1 + countAbs e
296 | _ => 0 295 | _ => 0
297 in 296 in
298 case d of 297 case d of
299 DVal (_, n, _, e, _) => 298 DDatatype dts =>
300 (if simpleImpure impures E.empty e then 299 (if List.exists (fn (_, _, cs) =>
300 List.exists (fn (_, _, NONE) => false
301 | (_, _, SOME t) => simpleTypeImpure timpures t) cs)
302 dts then
303 IS.addList (timpures, map #2 dts)
304 else
305 timpures,
306 impures,
307 absCounts)
308 | DVal (_, n, _, e, _) =>
309 (timpures,
310 if simpleImpure (timpures, impures) E.empty e then
301 IS.add (impures, n) 311 IS.add (impures, n)
302 else 312 else
303 impures, 313 impures,
304 IM.insert (absCounts, n, countAbs e)) 314 IM.insert (absCounts, n, countAbs e))
305 | DValRec vis => 315 | DValRec vis =>
306 (if List.exists (fn (_, _, _, e, _) => simpleImpure impures E.empty e) vis then 316 (timpures,
317 if List.exists (fn (_, _, _, e, _) => simpleImpure (timpures, impures) E.empty e) vis then
307 foldl (fn ((_, n, _, _, _), impures) => 318 foldl (fn ((_, n, _, _, _), impures) =>
308 IS.add (impures, n)) impures vis 319 IS.add (impures, n)) impures vis
309 else 320 else
310 impures, 321 impures,
311 foldl (fn ((x, n, _, e, _), absCounts) => 322 foldl (fn ((x, n, _, e, _), absCounts) =>
312 IM.insert (absCounts, n, countAbs e)) 323 IM.insert (absCounts, n, countAbs e))
313 absCounts vis) 324 absCounts vis)
314 | _ => (impures, absCounts) 325 | _ => (timpures, impures, absCounts)
315 end) 326 end)
316 (IS.empty, IM.empty) file 327 (IS.empty, IS.empty, IM.empty) file
317 328
318 fun summarize d (e, _) = 329 fun summarize d (e, _) =
319 let 330 let
320 val s = 331 val s =
321 case e of 332 case e of
339 case e of 350 case e of
340 ENamed n => 351 ENamed n =>
341 let 352 let
342 val ls = rev ls 353 val ls = rev ls
343 in 354 in
344 case IM.find (absCounts, n) of 355 if IS.member (impures, n) then
345 NONE => [Unsure] 356 case IM.find (absCounts, n) of
346 | SOME len => 357 NONE => [Unsure]
347 if passed < len then 358 | SOME len =>
348 ls 359 if passed < len then
349 else 360 ls
350 ls @ [Unsure] 361 else
362 ls @ [Unsure]
363 else
364 ls
351 end 365 end
352 | ERel n => List.revAppend (ls, 366 | ERel n => List.revAppend (ls,
353 if n = d then 367 if n = d then
354 [UseRel, Unsure] 368 [UseRel, Unsure]
355 else 369 else
417 ("s", p_events s)];*) 431 ("s", p_events s)];*)
418 s 432 s
419 end 433 end
420 434
421 val impure = fn env => fn e => 435 val impure = fn env => fn e =>
422 simpleImpure impures env e andalso impure e 436 simpleImpure (timpures, impures) env e andalso impure e
423 andalso not (List.null (summarize ~1 e)) 437 andalso not (List.null (summarize ~1 e))
424 438
425 fun exp env e = 439 fun exp env e =
426 let 440 let
427 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) 441 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)