Mercurial > urweb

comparison src/especialize.sml @ 1766:92cfc69419bd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Be more conservative in choosing candidates for Especialize, re: mutual recursion
author Adam Chlipala <adam@chlipala.net>
date Thu, 17 May 2012 10:20:24 -0400
parents 3cfc79f92db7
children 62c18ecbfec4
comparison
equal deleted inserted replaced
1765:be114e170b77 1766:92cfc69419bd
147 v as SOME (_, _ :: _) => v 147 v as SOME (_, _ :: _) => v
148 | _ => NONE 148 | _ => NONE
149 149
150 val maxInt = Option.getOpt (Int.maxInt, 9999) 150 val maxInt = Option.getOpt (Int.maxInt, 9999)
151 151
152 fun calcConstArgs enclosingFunction e = 152 fun calcConstArgs enclosingFunctions e =
153 let 153 let
154 fun ca depth e = 154 fun ca depth e =
155 case #1 e of 155 case #1 e of
156 EPrim _ => maxInt 156 EPrim _ => maxInt
157 | ERel _ => maxInt 157 | ERel _ => maxInt
158 | ENamed n => if n = enclosingFunction then 0 else maxInt 158 | ENamed n => if IS.member (enclosingFunctions, n) then 0 else maxInt
159 | ECon (_, _, _, NONE) => maxInt 159 | ECon (_, _, _, NONE) => maxInt
160 | ECon (_, _, _, SOME e) => ca depth e 160 | ECon (_, _, _, SOME e) => ca depth e
161 | EFfi _ => maxInt 161 | EFfi _ => maxInt
162 | EFfiApp (_, _, ecs) => foldl (fn ((e, _), d) => Int.min (ca depth e, d)) maxInt ecs 162 | EFfiApp (_, _, ecs) => foldl (fn ((e, _), d) => Int.min (ca depth e, d)) maxInt ecs
163 | EApp (e1, e2) => 163 | EApp (e1, e2) =>
165 fun default () = Int.min (ca depth e1, ca depth e2) 165 fun default () = Int.min (ca depth e1, ca depth e2)
166 in 166 in
167 case getApp e of 167 case getApp e of
168 NONE => default () 168 NONE => default ()
169 | SOME (f, args) => 169 | SOME (f, args) =>
170 if f <> enclosingFunction then 170 if not (IS.member (enclosingFunctions, f)) then
171 default () 171 default ()
172 else 172 else
173 let 173 let
174 fun visitArgs (count, args) = 174 fun visitArgs (count, args) =
175 case args of 175 case args of
418 (*val () = Print.prefaces "New one" 418 (*val () = Print.prefaces "New one"
419 [("name", Print.PD.string name), 419 [("name", Print.PD.string name),
420 ("f", Print.PD.string (Int.toString f)), 420 ("f", Print.PD.string (Int.toString f)),
421 ("|fvs|", Print.PD.string (Int.toString (IS.numItems fvs))), 421 ("|fvs|", Print.PD.string (Int.toString (IS.numItems fvs))),
422 ("|fxs|", Print.PD.string (Int.toString (length fxs))), 422 ("|fxs|", Print.PD.string (Int.toString (length fxs))),
423 ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs'),
423 ("spec", Print.PD.string (Bool.toString (IS.member (#specialized st, f))))]*) 424 ("spec", Print.PD.string (Bool.toString (IS.member (#specialized st, f))))]*)
424 425
425 (*val () = Print.prefaces ("Yes(" ^ name ^ ")") 426 (*val () = Print.prefaces ("Yes(" ^ name ^ ")")
426 [("fxs'", 427 [("fxs'",
427 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*) 428 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')]*)
454 val funcs = IM.insert (#funcs st, f, {name = name, 455 val funcs = IM.insert (#funcs st, f, {name = name,
455 args = args, 456 args = args,
456 body = body, 457 body = body,
457 typ = typ, 458 typ = typ,
458 tag = tag, 459 tag = tag,
459 constArgs = calcConstArgs f body}) 460 constArgs = calcConstArgs (IS.singleton f) body})
460 461
461 val st = { 462 val st = {
462 maxName = f' + 1, 463 maxName = f' + 1,
463 funcs = funcs, 464 funcs = funcs,
464 decls = #decls st, 465 decls = #decls st,
513 514
514 val funcs = #funcs st 515 val funcs = #funcs st
515 val funcs = 516 val funcs =
516 case #1 d of 517 case #1 d of
517 DValRec vis => 518 DValRec vis =>
518 foldl (fn ((x, n, c, e, tag), funcs) => 519 let
519 IM.insert (funcs, n, {name = x, 520 val fs = foldl (fn ((_, n, _, _, _), fs) => IS.add (fs, n)) IS.empty vis
520 args = KM.empty, 521 val constArgs = foldl (fn ((_, _, _, e, _), constArgs) =>
521 body = e, 522 Int.min (constArgs, calcConstArgs fs e))
522 typ = c, 523 maxInt vis
523 tag = tag, 524 in
524 constArgs = calcConstArgs n e})) 525 foldl (fn ((x, n, c, e, tag), funcs) =>
525 funcs vis 526 IM.insert (funcs, n, {name = x,
527 args = KM.empty,
528 body = e,
529 typ = c,
530 tag = tag,
531 constArgs = constArgs}))
532 funcs vis
533 end
526 | _ => funcs 534 | _ => funcs
527 535
528 val st = {maxName = #maxName st, 536 val st = {maxName = #maxName st,
529 funcs = funcs, 537 funcs = funcs,
530 decls = [], 538 decls = [],
601 IM.insert (funcs, n, {name = x, 609 IM.insert (funcs, n, {name = x,
602 args = KM.empty, 610 args = KM.empty,
603 body = e, 611 body = e,
604 typ = c, 612 typ = c,
605 tag = tag, 613 tag = tag,
606 constArgs = calcConstArgs n e}) 614 constArgs = calcConstArgs (IS.singleton n) e})
607 | DVal (_, n, _, (ENamed n', _), _) => 615 | DVal (_, n, _, (ENamed n', _), _) =>
608 (case IM.find (funcs, n') of 616 (case IM.find (funcs, n') of
609 NONE => funcs 617 NONE => funcs
610 | SOME v => IM.insert (funcs, n, v)) 618 | SOME v => IM.insert (funcs, n, v))
611 | _ => funcs 619 | _ => funcs