Mercurial > urweb

comparison src/especialize.sml @ 1314:6c2e565adca6

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Fixes for nasty bugs in Reduce and Especialize
author Adam Chlipala <adam@chlipala.net>
date Tue, 19 Oct 2010 17:54:49 -0400
parents 3b22c3c67f35
children ccf1d445b794
comparison
equal deleted inserted replaced
1313:0bf73c3e4563 1314:6c2e565adca6
33 structure U = CoreUtil 33 structure U = CoreUtil
34 34
35 type skey = exp 35 type skey = exp
36 36
37 structure K = struct 37 structure K = struct
38 type ord_key = exp list 38 type ord_key = con list * exp list
39 val compare = Order.joinL U.Exp.compare 39 fun compare ((cs1, es1), (cs2, es2)) = Order.join (Order.joinL U.Con.compare (cs1, cs2),
40 fn () => Order.joinL U.Exp.compare (es1, es2))
40 end 41 end
41 42
42 structure KM = BinaryMapFn(K) 43 structure KM = BinaryMapFn(K)
43 structure IM = IntBinaryMap 44 structure IM = IntBinaryMap
44 structure IS = IntBinarySet 45 structure IS = IntBinarySet
321 end 322 end
322 | _ => (rev fxs, xs, fvs, fin) 323 | _ => (rev fxs, xs, fvs, fin)
323 324
324 val (fxs, xs, fvs, fin) = findSplit true (xs, typ, [], IS.empty, false) 325 val (fxs, xs, fvs, fin) = findSplit true (xs, typ, [], IS.empty, false)
325 326
327 val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
326 val fxs' = map (squish (IS.listItems fvs)) fxs 328 val fxs' = map (squish (IS.listItems fvs)) fxs
327 in 329 in
328 (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*) 330 (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*)
329 if not fin 331 if not fin
330 orelse List.all (fn (ERel _, _) => true 332 orelse List.all (fn (ERel _, _) => true
335 ("f", Print.PD.string (Int.toString f)), 337 ("f", Print.PD.string (Int.toString f)),
336 ("fxs'", 338 ("fxs'",
337 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*) 339 Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
338 default ()) 340 default ())
339 else 341 else
340 case (KM.find (args, fxs'), 342 case (KM.find (args, (vts, fxs')),
341 SS.member (!mayNotSpec, name) (*orelse IS.member (#specialized st, f)*)) of 343 SS.member (!mayNotSpec, name) (*orelse IS.member (#specialized st, f)*)) of
342 (SOME f', _) => 344 (SOME f', _) =>
343 let 345 let
344 val e = (ENamed f', loc) 346 val e = (ENamed f', loc)
345 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc)) 347 val e = IS.foldr (fn (arg, e) => (EApp (e, (ERel arg, loc)), loc))
382 case subBody (body, typ, fxs') of 384 case subBody (body, typ, fxs') of
383 NONE => default () 385 NONE => default ()
384 | SOME (body', typ') => 386 | SOME (body', typ') =>
385 let 387 let
386 val f' = #maxName st 388 val f' = #maxName st
387 val args = KM.insert (args, fxs', f') 389 val args = KM.insert (args, (vts, fxs'), f')
388 val funcs = IM.insert (#funcs st, f, {name = name, 390 val funcs = IM.insert (#funcs st, f, {name = name,
389 args = args, 391 args = args,
390 body = body, 392 body = body,
391 typ = typ, 393 typ = typ,
392 tag = tag}) 394 tag = tag})