Mercurial > urweb

comparison src/especialize.sml @ 1120:74f2eb3b0606

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Basis.debug; more restrictive type for Basis.form; weaken definition of polymorphic-ness for especialization
author Adam Chlipala <adamc@hcoop.net>
date Thu, 07 Jan 2010 14:02:58 -0500
parents 2eb585274501
children ac3dbbc85c6e
comparison
equal deleted inserted replaced
1119:951fced704d6 1120:74f2eb3b0606
57 case b of 57 case b of
58 U.Exp.RelE _ => bound + 1 58 U.Exp.RelE _ => bound + 1
59 | _ => bound} 59 | _ => bound}
60 0 IS.empty 60 0 IS.empty
61 61
62 val isPoly = U.Decl.exists {kind = fn _ => false, 62 fun isPolyT (t, _) =
63 con = fn _ => false, 63 case t of
64 exp = fn ECAbs _ => true 64 TFun (_, ran) => isPolyT ran
65 | EKAbs _ => true 65 | TCFun _ => true
66 | _ => false, 66 | TKFun _ => true
67 decl = fn _ => false} 67 | _ => false
68
69 fun isPoly (d, _) =
70 case d of
71 DVal (_, _, t, _, _) => isPolyT t
72 | DValRec vis => List.exists (isPolyT o #3) vis
73 | _ => false
68 74
69 fun positionOf (v : int, ls) = 75 fun positionOf (v : int, ls) =
70 let 76 let
71 fun pof (pos, ls) = 77 fun pof (pos, ls) =
72 case ls of 78 case ls of
182 let 188 let
183 val (e, st) = exp (env, e, st) 189 val (e, st) = exp (env, e, st)
184 in 190 in
185 ((ECApp (e, c), loc), st) 191 ((ECApp (e, c), loc), st)
186 end 192 end
187 | ECAbs _ => raise Fail "Especialize: Impossible ECAbs" 193 | ECAbs _ => (e, st)
188 | EKAbs _ => raise Fail "Especialize: Impossible EKAbs" 194 | EKAbs _ => (e, st)
189 | EKApp (e, k) => 195 | EKApp (e, k) =>
190 let 196 let
191 val (e, st) = exp (env, e, st) 197 val (e, st) = exp (env, e, st)
192 in 198 in
193 ((EKApp (e, k), loc), st) 199 ((EKApp (e, k), loc), st)
323 orelse List.all (fn (ERel _, _) => true 329 orelse List.all (fn (ERel _, _) => true
324 | _ => false) fxs' 330 | _ => false) fxs'
325 orelse (IS.numItems fvs >= length fxs 331 orelse (IS.numItems fvs >= length fxs
326 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then 332 andalso IS.exists (fn n => functionInside (#2 (List.nth (env, n)))) fvs) then
327 ((*Print.prefaces "No" [("name", Print.PD.string name), 333 ((*Print.prefaces "No" [("name", Print.PD.string name),
334 ("f", Print.PD.string (Int.toString f)),
328 ("fxs'", 335 ("fxs'",
329 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*) 336 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
330 default ()) 337 default ())
331 else 338 else
332 case (KM.find (args, fxs'), 339 case (KM.find (args, fxs'),
415 val e' = (ENamed f', loc) 422 val e' = (ENamed f', loc)
416 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) 423 val e' = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
417 e' fvs 424 e' fvs
418 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc)) 425 val e' = foldl (fn (arg, e) => (EApp (e, arg), loc))
419 e' xs 426 e' xs
427 (*val () = print ("NEW: " ^ name ^ "__" ^ Int.toString f' ^ "\n");*)
420 (*val () = Print.prefaces "Brand new" 428 (*val () = Print.prefaces "Brand new"
421 [("e'", CorePrint.p_exp CoreEnv.empty e'), 429 [("e'", CorePrint.p_exp CoreEnv.empty e'),
422 ("e", CorePrint.p_exp CoreEnv.empty e), 430 ("e", CorePrint.p_exp CoreEnv.empty e),
423 ("body'", CorePrint.p_exp CoreEnv.empty body')]*) 431 ("body'", CorePrint.p_exp CoreEnv.empty body')]*)
424 in 432 in
469 in 477 in
470 ((DVal (x, n, t, e, s), #2 d), st) 478 ((DVal (x, n, t, e, s), #2 d), st)
471 end 479 end
472 | DValRec vis => 480 | DValRec vis =>
473 let 481 let
482 (*val () = Print.preface ("Visiting", Print.p_list (fn vi =>
483 Print.PD.string (#1 vi ^ "__"
484 ^ Int.toString
485 (#2 vi)))
486 vis)*)
487
474 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) => 488 val (vis, st) = ListUtil.foldlMap (fn ((x, n, t, e, s), st) =>
475 let 489 let
490 val () = mayNotSpec := SS.empty
476 val (e, st) = exp ([], e, st) 491 val (e, st) = exp ([], e, st)
477 in 492 in
478 ((x, n, t, e, s), st) 493 ((x, n, t, e, s), st)
479 end) st vis 494 end) st vis
480 in 495 in
535 funcs = funcs, 550 funcs = funcs,
536 decls = [], 551 decls = [],
537 specialized = #specialized st}, changed)) 552 specialized = #specialized st}, changed))
538 end 553 end
539 554
555 (*val () = Print.preface ("RESET", CorePrint.p_file CoreEnv.empty file)*)
540 val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl 556 val (ds, (st, changed)) = ListUtil.foldlMapConcat doDecl
541 ({maxName = U.File.maxName file + 1, 557 ({maxName = U.File.maxName file + 1,
542 funcs = funcs, 558 funcs = funcs,
543 decls = [], 559 decls = [],
544 specialized = specialized}, 560 specialized = specialized},
545 false) 561 false)
546 file 562 file
547 in 563 in
564 (*print ("Changed = " ^ Bool.toString changed ^ "\n");*)
548 (changed, ds, #funcs st, #specialized st) 565 (changed, ds, #funcs st, #specialized st)
549 end 566 end
550 567
551 fun specializeL (funcs, specialized) file = 568 fun specializeL (funcs, specialized) file =
552 let 569 let