Mercurial > urweb
comparison src/especialize.sml @ 1314:6c2e565adca6
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}) |