comparison src/elaborate.sml @ 1658:de0a34e28bfa

Tweak new unification heuristic
author Adam Chlipala <adam@chlipala.net>
date Thu, 05 Jan 2012 19:13:31 -0500
parents 2b7d3d99dc42
children b46c93ce7be2
comparison
equal deleted inserted replaced
1657:2b7d3d99dc42 1658:de0a34e28bfa
863 (*val () = eprefaces "Summaries2" [("#1", p_summary env {fields = fs1, unifs = #unifs s1, others = #others s1}), 863 (*val () = eprefaces "Summaries2" [("#1", p_summary env {fields = fs1, unifs = #unifs s1, others = #others s1}),
864 ("#2", p_summary env {fields = fs2, unifs = #unifs s2, others = #others s2})]*) 864 ("#2", p_summary env {fields = fs2, unifs = #unifs s2, others = #others s2})]*)
865 865
866 val (unifs1, unifs2) = eatMatching (fn ((_, r1), (_, r2)) => r1 = r2) (#unifs s1, #unifs s2) 866 val (unifs1, unifs2) = eatMatching (fn ((_, r1), (_, r2)) => r1 = r2) (#unifs s1, #unifs s2)
867 867
868 val hasUnifs = U.Con.exists {kind = fn _ => false, 868 fun isMappy (c, _) =
869 con = fn L'.CUnif _ => true 869 case c of
870 | _ => false} 870 L'.CApp ((L'.CMap _, _), c) => isMappy c
871 | L'.CUnif _ => true
872 | _ => false
871 873
872 val (others1, others2) = eatMatching (fn (c1, c2) => 874 val (others1, others2) = eatMatching (fn (c1, c2) =>
873 not (hasUnifs c1 andalso hasUnifs c2) 875 not (isMappy c1 andalso isMappy c2)
876 (* I guess this is a pretty bad hack, based on one pattern of bad unification I've seen! *)
874 andalso consEq env loc (c1, c2)) (#others s1, #others s2) 877 andalso consEq env loc (c1, c2)) (#others s1, #others s2)
875 (*val () = eprefaces "Summaries3" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}), 878 (*val () = eprefaces "Summaries3" [("#1", p_summary env {fields = fs1, unifs = unifs1, others = others1}),
876 ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*) 879 ("#2", p_summary env {fields = fs2, unifs = unifs2, others = others2})]*)
877 880
878 fun unsummarize {fields, unifs, others} = 881 fun unsummarize {fields, unifs, others} =