Mercurial > urweb

comparison src/mono_reduce.sml @ 1804:62c18ecbfec4

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tweaking treatment of function application: substitute or introduce a 'let'?
author Adam Chlipala <adam@chlipala.net>
date Sun, 05 Aug 2012 14:55:28 -0400
parents 0577be31a435
children d12192c7aa3e
comparison
equal deleted inserted replaced
1803:d2383ffc18ab 1804:62c18ecbfec4
177 e 177 e
178 | _ => e, 178 | _ => e,
179 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len) 179 bind = fn ((lower, len), U.Exp.RelE _) => (lower+1, len)
180 | (st, _) => st} 180 | (st, _) => st}
181 181
182 datatype result = Yes of exp list | No | Maybe 182 datatype result = Yes of (string * typ * exp) list | No | Maybe
183 183
184 fun match (env, p : pat, e : exp) = 184 fun match (env, p : pat, e : exp) =
185 case (#1 p, #1 e) of 185 case (#1 p, #1 e) of
186 (PWild, _) => Yes env 186 (PWild, _) => Yes env
187 | (PVar (x, t), _) => Yes (e :: env) 187 | (PVar (x, t), _) => Yes ((x, t, e) :: env)
188 188
189 | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) => 189 | (PPrim (Prim.String s), EStrcat ((EPrim (Prim.String s'), _), _)) =>
190 if String.isPrefix s' s then 190 if String.isPrefix s' s then
191 Maybe 191 Maybe
192 else 192 else
517 let 517 let
518 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*) 518 (*val () = Print.prefaces "exp" [("e", MonoPrint.p_exp env (e, ErrorMsg.dummySpan))]*)
519 519
520 fun doLet (x, t, e', b) = 520 fun doLet (x, t, e', b) =
521 let 521 let
522 val notValue = U.Exp.exists {typ = fn _ => false,
523 exp = fn e =>
524 case e of
525 EPrim _ => false
526 | ECon _ => false
527 | ENone _ => false
528 | ESome _ => false
529 | ERecord _ => false
530 | _ => true}
531
532
522 fun doSub () = 533 fun doSub () =
523 let 534 let
524 val r = subExpInExp (0, e') b 535 val r = subExpInExp (0, e') b
525 in 536 in
526 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'), 537 (*Print.prefaces "doSub" [("e'", MonoPrint.p_exp env e'),
595 andalso not (freeInAbs b) then 606 andalso not (freeInAbs b) then
596 trySub () 607 trySub ()
597 else 608 else
598 e 609 e
599 end 610 end
611 else if countFree 0 0 b > 1 andalso notValue e' then
612 e
600 else 613 else
601 trySub () 614 trySub ()
602 end 615 end
603 616
604 val r = 617 val r =
657 No => search pes 670 No => search pes
658 | Maybe => push () 671 | Maybe => push ()
659 | Yes subs => 672 | Yes subs =>
660 let 673 let
661 val (body, remaining) = 674 val (body, remaining) =
662 foldl (fn (e, (body, remaining)) => 675 foldl (fn ((x, t, e), (body, remaining)) =>
663 (subExpInExp (0, multiLift remaining e) body, remaining - 1)) 676 (if countFree 0 0 body > 1 then
677 (ELet (x, t, multiLift remaining e, body), #2 e')
678 else
679 subExpInExp (0, multiLift remaining e) body, remaining - 1))
664 (body, length subs - 1) subs 680 (body, length subs - 1) subs
665 val r = reduceExp (E.patBinds env p) body 681 val r = reduceExp (E.patBinds env p) body
666 in 682 in
667 (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*) 683 (*Print.preface ("subs", Print.p_list (MonoPrint.p_exp env) subs);*)
668 (*Print.prefaces "ECase" 684 (*Print.prefaces "ECase"