Mercurial > urweb

comparison src/mono_reduce.sml @ 919:cc956020801b

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
'more' demos working after optimizer fix
author Adam Chlipala <adamc@hcoop.net>
date Tue, 08 Sep 2009 19:42:12 -0400
parents b873feb3eb52
children 7accd4546cf9
comparison
equal deleted inserted replaced
918:6a77c3e33908 919:cc956020801b
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 =
42 U.Typ.exists (fn TFun _ => true
43 | TDatatype _ => true
44 | _ => false)
45
41 fun simpleImpure syms = 46 fun simpleImpure syms =
42 U.Exp.exists {typ = fn _ => false, 47 U.Exp.existsB {typ = fn _ => false,
43 exp = fn EWrite _ => true 48 exp = fn (env, e) =>
44 | EQuery _ => true 49 case e of
45 | EDml _ => true 50 EWrite _ => true
46 | ENextval _ => true 51 | EQuery _ => true
47 | EUnurlify _ => true 52 | EDml _ => true
48 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) 53 | ENextval _ => true
49 | EServerCall _ => true 54 | EUnurlify _ => true
50 | ERecv _ => true 55 | EFfiApp (m, x, _) => Settings.isEffectful (m, x)
51 | ESleep _ => true 56 | EServerCall _ => true
52 | ENamed n => IS.member (syms, n) 57 | ERecv _ => true
53 | _ => false} 58 | ESleep _ => true
59 | ENamed n => IS.member (syms, n)
60 | ERel n =>
61 let
62 val (_, t, _) = E.lookupERel env n
63 in
64 simpleTypeImpure t
65 end
66 | _ => false,
67 bind = fn (env, b) =>
68 case b of
69 U.Exp.RelE (x, t) => E.pushERel env x t NONE
70 | _ => env}
54 71
55 fun impure (e, _) = 72 fun impure (e, _) =
56 case e of 73 case e of
57 EWrite _ => true 74 EWrite _ => true
58 | EQuery _ => true 75 | EQuery _ => true
266 EAbs (_, _, _, e) => 1 + countAbs e 283 EAbs (_, _, _, e) => 1 + countAbs e
267 | _ => 0 284 | _ => 0
268 in 285 in
269 case d of 286 case d of
270 DVal (_, n, _, e, _) => 287 DVal (_, n, _, e, _) =>
271 (if simpleImpure impures e then 288 (if simpleImpure impures E.empty e then
272 IS.add (impures, n) 289 IS.add (impures, n)
273 else 290 else
274 impures, 291 impures,
275 IM.insert (absCounts, n, countAbs e)) 292 IM.insert (absCounts, n, countAbs e))
276 | DValRec vis => 293 | DValRec vis =>
277 (if List.exists (fn (_, _, _, e, _) => simpleImpure impures e) vis then 294 (if List.exists (fn (_, _, _, e, _) => simpleImpure impures E.empty e) vis then
278 foldl (fn ((_, n, _, _, _), impures) => 295 foldl (fn ((_, n, _, _, _), impures) =>
279 IS.add (impures, n)) impures vis 296 IS.add (impures, n)) impures vis
280 else 297 else
281 impures, 298 impures,
282 foldl (fn ((x, n, _, e, _), absCounts) => 299 foldl (fn ((x, n, _, e, _), absCounts) =>
388 ("d", Print.PD.string (Int.toString d)), 405 ("d", Print.PD.string (Int.toString d)),
389 ("s", p_events s)];*) 406 ("s", p_events s)];*)
390 s 407 s
391 end 408 end
392 409
393 val impure = fn e => 410 val impure = fn env => fn e =>
394 simpleImpure impures e andalso impure e 411 simpleImpure impures env e andalso impure e
395 andalso not (List.null (summarize ~1 e)) 412 andalso not (List.null (summarize ~1 e))
396 413
397 fun exp env e = 414 fun exp env e =
398 let 415 let
399 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) 416 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
413 430
414 | EApp ((EAbs (x, t, _, e1), loc), e2) => 431 | EApp ((EAbs (x, t, _, e1), loc), e2) =>
415 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1), 432 ((*Print.prefaces "Considering" [("e1", MonoPrint.p_exp (E.pushERel env x t NONE) e1),
416 ("e2", MonoPrint.p_exp env e2), 433 ("e2", MonoPrint.p_exp env e2),
417 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*) 434 ("sub", MonoPrint.p_exp env (reduceExp env (subExpInExp (0, e2) e1)))];*)
418 if impure e2 then 435 if impure env e2 then
419 #1 (reduceExp env (ELet (x, t, e2, e1), loc)) 436 #1 (reduceExp env (ELet (x, t, e2, e1), loc))
420 else 437 else
421 #1 (reduceExp env (subExpInExp (0, e2) e1))) 438 #1 (reduceExp env (subExpInExp (0, e2) e1)))
422 439
423 | ECase (e', pes, {disc, result}) => 440 | ECase (e', pes, {disc, result}) =>
488 | EApp ((ELet (x, t, e, b), loc), e') => 505 | EApp ((ELet (x, t, e, b), loc), e') =>
489 #1 (reduceExp env (ELet (x, t, e, 506 #1 (reduceExp env (ELet (x, t, e,
490 (EApp (b, liftExpInExp 0 e'), loc)), loc)) 507 (EApp (b, liftExpInExp 0 e'), loc)), loc))
491 508
492 | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) => 509 | ELet (x, t, e', (EAbs (x', t' as (TRecord [], _), ran, e''), loc)) =>
493 if impure e' then 510 if impure env e' then
494 e 511 e
495 else 512 else
496 EAbs (x', t', ran, reduceExp env (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc)) 513 EAbs (x', t', ran, reduceExp env (ELet (x, t, liftExpInExp 0 e', swapExpVars 0 e''), loc))
497 514
498 | ELet (x, t, e', b) => 515 | ELet (x, t, e', b) =>
516 | _ => 533 | _ =>
517 case e' of 534 case e' of
518 (ECase _, _) => e 535 (ECase _, _) => e
519 | _ => doSub ()) 536 | _ => doSub ())
520 in 537 in
521 if impure e' then 538 if impure env e' then
522 let 539 let
523 val effs_e' = summarize 0 e' 540 val effs_e' = summarize 0 e'
524 val effs_e' = List.filter (fn x => x <> UseRel) effs_e' 541 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
525 val effs_b = summarize 0 b 542 val effs_b = summarize 0 b
526 543