Mercurial > urweb

comparison src/mono_reduce.sml @ 916:b873feb3eb52

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
dragList almost kinda works
author Adam Chlipala <adamc@hcoop.net>
date Tue, 08 Sep 2009 10:18:19 -0400
parents 8e540df3294d
children cc956020801b
comparison
equal deleted inserted replaced
915:5e8b6fa5b48f 916:b873feb3eb52
33 33
34 structure E = MonoEnv 34 structure E = MonoEnv
35 structure U = MonoUtil 35 structure U = MonoUtil
36 36
37 structure IM = IntBinaryMap 37 structure IM = IntBinaryMap
38 38 structure IS = IntBinarySet
39
40
41 fun simpleImpure syms =
42 U.Exp.exists {typ = fn _ => false,
43 exp = fn EWrite _ => true
44 | EQuery _ => true
45 | EDml _ => true
46 | ENextval _ => true
47 | EUnurlify _ => true
48 | EFfiApp (m, x, _) => Settings.isEffectful (m, x)
49 | EServerCall _ => true
50 | ERecv _ => true
51 | ESleep _ => true
52 | ENamed n => IS.member (syms, n)
53 | _ => false}
39 54
40 fun impure (e, _) = 55 fun impure (e, _) =
41 case e of 56 case e of
42 EWrite _ => true 57 EWrite _ => true
43 | EQuery _ => true 58 | EQuery _ => true
79 | ESignalBind (e1, e2) => impure e1 orelse impure e2 94 | ESignalBind (e1, e2) => impure e1 orelse impure e2
80 | ESignalSource e => impure e 95 | ESignalSource e => impure e
81 | EServerCall _ => true 96 | EServerCall _ => true
82 | ERecv _ => true 97 | ERecv _ => true
83 | ESleep _ => true 98 | ESleep _ => true
84
85 99
86 val liftExpInExp = Monoize.liftExpInExp 100 val liftExpInExp = Monoize.liftExpInExp
87 101
88 fun multiLift n e = 102 fun multiLift n e =
89 case n of 103 case n of
242 | PNone _ => 0 256 | PNone _ => 0
243 | PSome (_, p) => patBinds p 257 | PSome (_, p) => patBinds p
244 258
245 fun reduce file = 259 fun reduce file =
246 let 260 let
247 fun countAbs (e, _) = 261 val (impures, absCounts) =
248 case e of 262 foldl (fn ((d, _), (impures, absCounts)) =>
249 EAbs (_, _, _, e) => 1 + countAbs e 263 let
250 | _ => 0 264 fun countAbs (e, _) =
251 265 case e of
252 val absCounts = 266 EAbs (_, _, _, e) => 1 + countAbs e
253 foldl (fn ((d, _), absCounts) => 267 | _ => 0
254 case d of 268 in
255 DVal (_, n, _, e, _) => 269 case d of
256 IM.insert (absCounts, n, countAbs e) 270 DVal (_, n, _, e, _) =>
257 | DValRec vis => 271 (if simpleImpure impures e then
258 foldl (fn ((_, n, _, e, _), absCounts) => 272 IS.add (impures, n)
259 IM.insert (absCounts, n, countAbs e)) 273 else
260 absCounts vis 274 impures,
261 | _ => absCounts) 275 IM.insert (absCounts, n, countAbs e))
262 IM.empty file 276 | DValRec vis =>
277 (if List.exists (fn (_, _, _, e, _) => simpleImpure impures e) vis then
278 foldl (fn ((_, n, _, _, _), impures) =>
279 IS.add (impures, n)) impures vis
280 else
281 impures,
282 foldl (fn ((x, n, _, e, _), absCounts) =>
283 IM.insert (absCounts, n, countAbs e))
284 absCounts vis)
285 | _ => (impures, absCounts)
286 end)
287 (IS.empty, IM.empty) file
263 288
264 fun summarize d (e, _) = 289 fun summarize d (e, _) =
265 let 290 let
266 val s = 291 val s =
267 case e of 292 case e of
363 ("d", Print.PD.string (Int.toString d)), 388 ("d", Print.PD.string (Int.toString d)),
364 ("s", p_events s)];*) 389 ("s", p_events s)];*)
365 s 390 s
366 end 391 end
367 392
393 val impure = fn e =>
394 simpleImpure impures e andalso impure e
395 andalso not (List.null (summarize ~1 e))
396
368 fun exp env e = 397 fun exp env e =
369 let 398 let
370 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) 399 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
371 400
372 val r = 401 val r =
462 491
463 | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => 492 | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
464 if impure e' then 493 if impure e' then
465 e 494 e
466 else 495 else
467 EAbs (x', t', ran, (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) 496 EAbs (x', t', ran, reduceExp env (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
468 497
469 | ELet (x, t, e', b) => 498 | ELet (x, t, e', b) =>
470 let 499 let
471 fun doSub () = 500 fun doSub () =
472 let 501 let
477 ("r", MonoPrint.p_exp env r)];*) 506 ("r", MonoPrint.p_exp env r)];*)
478 #1 (reduceExp env r) 507 #1 (reduceExp env r)
479 end 508 end
480 509
481 fun trySub () = 510 fun trySub () =
482 case t of 511 ((*Print.prefaces "trySub"
483 (TFfi ("Basis", "string"), _) => doSub () 512 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))];*)
484 | (TSignal _, _) => e 513 case t of
485 | _ => 514 (TFfi ("Basis", "string"), _) => doSub ()
486 case e' of 515 | (TSignal _, _) => e
487 (ECase _, _) => e 516 | _ =>
488 | _ => doSub () 517 case e' of
518 (ECase _, _) => e
519 | _ => doSub ())
489 in 520 in
490 if impure e' then 521 if impure e' then
491 let 522 let
492 val effs_e' = summarize 0 e' 523 val effs_e' = summarize 0 e'
493 val effs_e' = List.filter (fn x => x <> UseRel) effs_e' 524 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
494 val effs_b = summarize 0 b 525 val effs_b = summarize 0 b
495 526
496 (*val () = Print.prefaces "Try" 527 (*val () = Print.prefaces "Try"
497 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), 528 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),
498 ("e'", p_events effs_e'), 529 ("e'", MonoPrint.p_exp env e'),
530 ("e'_eff", p_events effs_e'),
499 ("b", p_events effs_b)]*) 531 ("b", p_events effs_b)]*)
500 532
501 fun does eff = List.exists (fn eff' => eff' = eff) effs_e' 533 fun does eff = List.exists (fn eff' => eff' = eff) effs_e'
502 val writesPage = does WritePage 534 val writesPage = does WritePage
503 val readsDb = does ReadDb 535 val readsDb = does ReadDb