Mercurial > urweb
changeset 2126:ec1614fb97bb
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 | 15d46eb02570 |
| children | 8beeb4f761b5 |
| files | src/mono_reduce.sml |
| diffstat | 1 files changed, 27 insertions(+), 12 deletions(-) [+] |
line wrap: on
line diff
--- a/src/mono_reduce.sml Thu Mar 05 15:05:53 2015 -0500 +++ b/src/mono_reduce.sml Fri Mar 06 09:46:21 2015 -0500 @@ -330,7 +330,9 @@ U.Exp.RelE _ => n + 1 | _ => n} 0 -fun reduce (file : file) = +val yankedCase = ref false + +fun reduce' (file : file) = let val (timpures, impures, absCounts) = foldl (fn ((d, _), (timpures, impures, absCounts)) => @@ -770,17 +772,18 @@ Print.PD.string "}"] in if List.all (safe o #2) pes then - EAbs ("y", dom, result, - (ECase (liftExpInExp 0 e', - map (fn (p, (EAbs (_, _, _, e), _)) => - (p, swapExpVarsPat (0, patBinds p) e) - | (p, (EError (e, (TFun (_, t), _)), loc)) => - (p, (EError (liftExpInExp (patBinds p) e, t), loc)) - | (p, e) => - (p, (EApp (liftExpInExp (patBinds p) e, - (ERel (patBinds p), loc)), loc))) - pes, - {disc = disc, result = result}), loc)) + (yankedCase := true; + EAbs ("y", dom, result, + (ECase (liftExpInExp 0 e', + map (fn (p, (EAbs (_, _, _, e), _)) => + (p, swapExpVarsPat (0, patBinds p) e) + | (p, (EError (e, (TFun (_, t), _)), loc)) => + (p, (EError (liftExpInExp (patBinds p) e, t), loc)) + | (p, e) => + (p, (EApp (liftExpInExp (patBinds p) e, + (ERel (patBinds p), loc)), loc))) + pes, + {disc = disc, result = result}), loc))) else e end @@ -894,4 +897,16 @@ U.File.mapB {typ = typ, exp = exp, decl = decl, bind = bind} E.empty file end +fun reduce file = + let + val () = yankedCase := false + val file' = reduce' file + in + if !yankedCase then + reduce file' + else + file' + end + + end