Mercurial > urweb

comparison src/mono_reduce.sml @ 2126:ec1614fb97bb

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Change MonoReduce to do fixed-pointing, since it sometimes enables more optimizations for itself (e.g., yanking lambdas out of [case]s)
author Adam Chlipala <adam@chlipala.net>
date Fri, 06 Mar 2015 09:46:21 -0500
parents 9e9c915f554c
children 25874084bf1f
comparison
equal deleted inserted replaced
2125:15d46eb02570 2126:ec1614fb97bb
328 bind = fn (n, b) => 328 bind = fn (n, b) =>
329 case b of 329 case b of
330 U.Exp.RelE _ => n + 1 330 U.Exp.RelE _ => n + 1
331 | _ => n} 0 331 | _ => n} 0
332 332
333 fun reduce (file : file) = 333 val yankedCase = ref false
334
335 fun reduce' (file : file) =
334 let 336 let
335 val (timpures, impures, absCounts) = 337 val (timpures, impures, absCounts) =
336 foldl (fn ((d, _), (timpures, impures, absCounts)) => 338 foldl (fn ((d, _), (timpures, impures, absCounts)) =>
337 let 339 let
338 fun countAbs env e = 340 fun countAbs env e =
768 fun p_events' es = Print.box [Print.PD.string "{", 770 fun p_events' es = Print.box [Print.PD.string "{",
769 p_events es, 771 p_events es,
770 Print.PD.string "}"] 772 Print.PD.string "}"]
771 in 773 in
772 if List.all (safe o #2) pes then 774 if List.all (safe o #2) pes then
773 EAbs ("y", dom, result, 775 (yankedCase := true;
774 (ECase (liftExpInExp 0 e', 776 EAbs ("y", dom, result,
775 map (fn (p, (EAbs (_, _, _, e), _)) => 777 (ECase (liftExpInExp 0 e',
776 (p, swapExpVarsPat (0, patBinds p) e) 778 map (fn (p, (EAbs (_, _, _, e), _)) =>
777 | (p, (EError (e, (TFun (_, t), _)), loc)) => 779 (p, swapExpVarsPat (0, patBinds p) e)
778 (p, (EError (liftExpInExp (patBinds p) e, t), loc)) 780 | (p, (EError (e, (TFun (_, t), _)), loc)) =>
779 | (p, e) => 781 (p, (EError (liftExpInExp (patBinds p) e, t), loc))
780 (p, (EApp (liftExpInExp (patBinds p) e, 782 | (p, e) =>
781 (ERel (patBinds p), loc)), loc))) 783 (p, (EApp (liftExpInExp (patBinds p) e,
782 pes, 784 (ERel (patBinds p), loc)), loc)))
783 {disc = disc, result = result}), loc)) 785 pes,
786 {disc = disc, result = result}), loc)))
784 else 787 else
785 e 788 e
786 end 789 end
787 | _ => e 790 | _ => e
788 791
892 d) 895 d)
893 in 896 in
894 U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file 897 U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file
895 end 898 end
896 899
900 fun reduce file =
901 let
902 val () = yankedCase := false
903 val file' = reduce' file
904 in
905 if !yankedCase then
906 reduce file'
907 else
908 file'
909 end
910
911
897 end 912 end