Mercurial > urweb

comparison src/mono_reduce.sml @ 941:b8d7a47b8e0c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fixed a Mono_reduce bug, which was breaking selection enabling in Grid
author Adam Chlipala <adamc@hcoop.net>
date Tue, 15 Sep 2009 12:23:42 -0400
parents 0a156bbd205f
children b03d48aac959
comparison
equal deleted inserted replaced
940:e2be476673f2 941:b8d7a47b8e0c
359 | _ => [Unsure] 359 | _ => [Unsure]
360 in 360 in
361 unravel (e, 0, []) 361 unravel (e, 0, [])
362 end 362 end
363 363
364 | EAbs (_, _, _, e) => List.filter (fn UseRel => true 364 | EAbs _ => []
365 | _ => false) (summarize (d + 1) e)
366 365
367 | EUnop (_, e) => summarize d e 366 | EUnop (_, e) => summarize d e
368 | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2 367 | EBinop (_, e1, e2) => summarize d e1 @ summarize d e2
369 368
370 | ERecord xets => List.concat (map (summarize d o #2) xets) 369 | ERecord xets => List.concat (map (summarize d o #2) xets)
371 | EField (e, _) => summarize d e 370 | EField (e, _) => summarize d e
372 371
373 | ECase (e, pes, _) => 372 | ECase (e, pes, _) => summarize d e @ [Unsure]
374 let 373 (*let
375 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes 374 val lss = map (fn (p, e) => summarize (d + patBinds p) e) pes
376 in 375 in
377 case lss of 376 case lss of
378 [] => raise Fail "Empty pattern match" 377 [] => raise Fail "Empty pattern match"
379 | ls :: lss => 378 | ls :: lss =>
380 if List.all (fn ls' => ls' = ls) lss then 379 if List.all (fn ls' => ls' = ls) lss then
381 summarize d e @ ls 380 summarize d e @ ls
382 else 381 else
383 [Unsure] 382 [Unsure]
384 end 383 end*)
385 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2 384 | EStrcat (e1, e2) => summarize d e1 @ summarize d e2
386 385
387 | EError (e, _) => summarize d e @ [Unsure] 386 | EError (e, _) => summarize d e @ [Unsure]
388 | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Unsure] 387 | EReturnBlob {blob = e1, mimeType = e2, ...} => summarize d e1 @ summarize d e2 @ [Unsure]
389 388
394 393
395 | EClosure (_, es) => List.concat (map (summarize d) es) 394 | EClosure (_, es) => List.concat (map (summarize d) es)
396 395
397 | EQuery {query, body, initial, ...} => 396 | EQuery {query, body, initial, ...} =>
398 List.concat [summarize d query, 397 List.concat [summarize d query,
399 summarize (d + 2) body,
400 summarize d initial, 398 summarize d initial,
401 [ReadDb]] 399 [ReadDb],
400 summarize (d + 2) body]
402 401
403 | EDml e => summarize d e @ [WriteDb] 402 | EDml e => summarize d e @ [WriteDb]
404 | ENextval e => summarize d e @ [WriteDb] 403 | ENextval e => summarize d e @ [WriteDb]
405 | EUnurlify (e, _) => summarize d e 404 | EUnurlify (e, _) => summarize d e
406 | EJavaScript (_, e) => summarize d e 405 | EJavaScript (_, e) => summarize d e
407 | ESignalReturn e => summarize d e 406 | ESignalReturn e => summarize d e
408 | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 407 | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2
409 | ESignalSource e => summarize d e 408 | ESignalSource e => summarize d e
410 409
411 | EServerCall (e, ek, _, _) => summarize d e @ summarize d ek @ [Unsure] 410 | EServerCall (e, _, _, _) => summarize d e @ [Unsure]
412 | ERecv (e, ek, _) => summarize d e @ summarize d ek @ [Unsure] 411 | ERecv (e, _, _) => summarize d e @ [Unsure]
413 | ESleep (e, ek) => summarize d e @ summarize d ek @ [Unsure] 412 | ESleep (e, _) => summarize d e @ [Unsure]
414 in 413 in
415 (*Print.prefaces "Summarize" 414 (*Print.prefaces "Summarize"
416 [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)), 415 [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
417 ("d", Print.PD.string (Int.toString d)), 416 ("d", Print.PD.string (Int.toString d)),
418 ("s", p_events s)];*) 417 ("s", p_events s)];*)
494 ("body", MonoPrint.p_exp env body), 493 ("body", MonoPrint.p_exp env body),
495 ("r", MonoPrint.p_exp env r)];*) 494 ("r", MonoPrint.p_exp env r)];*)
496 #1 r 495 #1 r
497 end 496 end
498 in 497 in
499 search pes 498 if impure env e' then
499 e
500 else
501 search pes
500 end 502 end
501 503
502 | EField ((ERecord xes, _), x) => 504 | EField ((ERecord xes, _), x) =>
503 (case List.find (fn (x', _, _) => x' = x) xes of 505 (case List.find (fn (x', _, _) => x' = x) xes of
504 SOME (_, e, _) => #1 e 506 SOME (_, e, _) => #1 e
530 fun doSub () = 532 fun doSub () =
531 let 533 let
532 val r = subExpInExp (0, e') b 534 val r = subExpInExp (0, e') b
533 in 535 in
534 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'), 536 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
535 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), 537 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
536 ("r", MonoPrint.p_exp env r)];*) 538 ("r", MonoPrint.p_exp env r)];*)
537 #1 (reduceExp env r) 539 #1 (reduceExp env r)
538 end 540 end
539 541
540 fun trySub () = 542 fun trySub () =
541 ((*Print.prefaces "trySub" 543 ((*Print.prefaces "trySub"
584 (*Print.prefaces "verifyCompatible" 586 (*Print.prefaces "verifyCompatible"
585 [("e'", MonoPrint.p_exp env e'), 587 [("e'", MonoPrint.p_exp env e'),
586 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b), 588 ("b", MonoPrint.p_exp (E.pushERel env x t NONE) b),
587 ("effs_e'", Print.p_list p_event effs_e'), 589 ("effs_e'", Print.p_list p_event effs_e'),
588 ("effs_b", Print.p_list p_event effs_b)];*) 590 ("effs_b", Print.p_list p_event effs_b)];*)
589 if List.null effs_e' 591 if (List.null effs_e'
590 orelse (List.all (fn eff => eff <> Unsure) effs_e' 592 orelse (List.all (fn eff => eff <> Unsure) effs_e'
591 andalso verifyCompatible effs_b) 593 andalso verifyCompatible effs_b)
592 orelse (case effs_b of 594 orelse (case effs_b of
593 UseRel :: effs => List.all verifyUnused effs 595 UseRel :: effs => List.all verifyUnused effs
594 | _ => false) then 596 | _ => false))
597 andalso countFree b = 1 then
595 trySub () 598 trySub ()
596 else 599 else
597 e 600 e
598 end 601 end
599 else 602 else