Mercurial > urweb

comparison src/mono_reduce.sml @ 1394:d328983dc5a6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Allow subqueries to reference aggregate-only columns of free tables; treat non-COUNT aggregate functions as possibly returning NULL
author Adam Chlipala <adam@chlipala.net>
date Sat, 15 Jan 2011 14:53:13 -0500
parents 802c179dac1f
children bd6c90f5a428
comparison
equal deleted inserted replaced
1393:802c179dac1f 1394:d328983dc5a6
55 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) 55 | EFfiApp (m, x, _) => Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x)
56 | EServerCall _ => true 56 | EServerCall _ => true
57 | ERecv _ => true 57 | ERecv _ => true
58 | ESleep _ => true 58 | ESleep _ => true
59 | ENamed n => IS.member (syms, n) 59 | ENamed n => IS.member (syms, n)
60 | EError _ => true
61 | ERel n => 60 | ERel n =>
62 let 61 let
63 val (_, t, _) = E.lookupERel env n 62 val (_, t, _) = E.lookupERel env n
64 in 63 in
65 simpleTypeImpure tsyms t 64 simpleTypeImpure tsyms t
396 | EFfi _ => [] 395 | EFfi _ => []
397 | EFfiApp ("Basis", "get_cookie", [e]) => 396 | EFfiApp ("Basis", "get_cookie", [e]) =>
398 summarize d e @ [ReadCookie] 397 summarize d e @ [ReadCookie]
399 | EFfiApp (m, x, es) => 398 | EFfiApp (m, x, es) =>
400 if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then 399 if Settings.isEffectful (m, x) orelse Settings.isBenignEffectful (m, x) then
401 List.concat (map (summarize d) es) @ [Unsure] 400 List.concat (map (summarize d) es) @ [if m = "Basis" andalso String.isSuffix "_w" x then
401 WritePage
402 else
403 Unsure]
402 else 404 else
403 List.concat (map (summarize d) es) 405 List.concat (map (summarize d) es)
404 | EApp ((EFfi _, _), e) => summarize d e 406 | EApp ((EFfi _, _), e) => summarize d e
405 | EApp _ => 407 | EApp _ =>
406 let 408 let
427 else 429 else
428 [Unsure]) 430 [Unsure])
429 | EApp (f, x) => 431 | EApp (f, x) =>
430 unravel (#1 f, passed + 1, List.revAppend (summarize d x, 432 unravel (#1 f, passed + 1, List.revAppend (summarize d x,
431 ls)) 433 ls))
434 | EError _ => [Abort]
432 | _ => [Unsure] 435 | _ => [Unsure]
433 in 436 in
434 unravel (e, 0, []) 437 unravel (e, 0, [])
435 end 438 end
436 439
443 | EField (e, _) => summarize d e 446 | EField (e, _) => summarize d e
444 447
445 | ECase (e, pes, _) => 448 | ECase (e, pes, _) =>
446 let 449 let
447 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes 450 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
451
452 fun splitRel ls acc =
453 case ls of
454 [] => (acc, false, ls)
455 | UseRel :: ls => (acc, true, ls)
456 | v :: ls => splitRel ls (v :: acc)
457
458 val (pre, used, post) = foldl (fn (ls, (pre, used, post)) =>
459 let
460 val (pre', used', post') = splitRel ls []
461 in
462 (pre' @ pre, used' orelse used, post' @ post)
463 end)
464 ([], false, []) lss
448 in 465 in
449 case lss of 466 summarize d e
450 [] => summarize d e 467 @ pre
451 | ls :: lss => 468 @ (if used then [UseRel] else [])
452 summarize d e 469 @ post
453 @ (if List.all (fn ls' => ls' = ls) lss then
454 ls
455 else if length (List.filter (not o List.null) (ls :: lss)) <= 1 then
456 valOf (List.find (not o List.null) (ls :: lss))
457 else
458 [Unsure])
459 end 470 end
460 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 471 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
461 472
462 | EError (e, _) => summarize d e @ [Abort] 473 | EError (e, _) => summarize d e @ [Abort]
463 | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort] 474 | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Abort]
532 let 543 let
533 val effs_e' = summarize 0 e' 544 val effs_e' = summarize 0 e'
534 val effs_e' = List.filter (fn x => x <> UseRel) effs_e' 545 val effs_e' = List.filter (fn x => x <> UseRel) effs_e'
535 val effs_b = summarize 0 b 546 val effs_b = summarize 0 b
536 547
537 (*val () = Print.prefaces "Try" 548 (*val () = Print.fprefaces outf "Try"
538 [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)), 549 [(*("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan)),*)
539 ("e'", MonoPrint.p_exp env e'), 550 ("e'", MonoPrint.p_exp env e'),
540 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), 551 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
541 ("e'_eff", p_events effs_e'), 552 ("e'_eff", p_events effs_e'),
542 ("b_eff", p_events effs_b)]*) 553 ("b_eff", p_events effs_b)]*)
543 554