# HG changeset patch
# User Adam Chlipala <adam@chlipala.net>
# Date 1287525289 14400
# Node ID 6c2e565adca6306afc3c8cd859bdd11157d3ef98
# Parent  0bf73c3e4563e986954dae523ba596399c2e6ec2
Fixes for nasty bugs in Reduce and Especialize

diff -r 0bf73c3e4563 -r 6c2e565adca6 src/cjrize.sml
--- a/src/cjrize.sml	Tue Oct 19 15:26:12 2010 -0400
+++ b/src/cjrize.sml	Tue Oct 19 17:54:49 2010 -0400
@@ -112,7 +112,7 @@
                 end
               | L.TRecord xts =>
                 let
-                    val xts = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts
+                    val xts = MonoUtil.Typ.sortFields xts
                     val old_xts = xts
                     val (xts, sm) = ListUtil.foldlMap (fn ((x, t), sm) =>
                                                           let
diff -r 0bf73c3e4563 -r 6c2e565adca6 src/corify.sml
--- a/src/corify.sml	Tue Oct 19 15:26:12 2010 -0400
+++ b/src/corify.sml	Tue Oct 19 17:54:49 2010 -0400
@@ -271,11 +271,11 @@
     case current of
         FFfi {mod = m, vals, ...} =>
         (case SM.find (vals, x) of
-             NONE => raise Fail "Corify.St.lookupValByName: no type for FFI val"
+             NONE => raise Fail ("Corify.St.lookupValByName: no type for FFI val " ^ x)
            | SOME t => EFfi (m, t))
-      | FNormal {vals, ...} =>
+      | FNormal {name, vals, ...} =>
         case SM.find (vals, x) of
-            NONE => raise Fail "Corify.St.lookupValByName"
+            NONE => raise Fail ("Corify.St.lookupValByName " ^ String.concatWith "." name ^ "." ^ x)
           | SOME n => ENormal n
 
 fun bindConstructor {basis, cons, constructors, vals, strs, funs, current, nested} s n n' =
diff -r 0bf73c3e4563 -r 6c2e565adca6 src/especialize.sml
--- a/src/especialize.sml	Tue Oct 19 15:26:12 2010 -0400
+++ b/src/especialize.sml	Tue Oct 19 17:54:49 2010 -0400
@@ -35,8 +35,9 @@
 type skey = exp
 
 structure K = struct
-type ord_key = exp list
-val compare = Order.joinL U.Exp.compare
+type ord_key = con list * exp list
+fun compare ((cs1, es1), (cs2, es2)) = Order.join (Order.joinL U.Con.compare (cs1, cs2),
+                                                   fn () => Order.joinL U.Exp.compare (es1, es2))
 end
 
 structure KM = BinaryMapFn(K)
@@ -323,6 +324,7 @@
 
                             val (fxs, xs, fvs, fin) = findSplit true (xs, typ, [], IS.empty, false)
 
+                            val vts = map (fn n => #2 (List.nth (env, n))) (IS.listItems fvs)
                             val fxs' = map (squish (IS.listItems fvs)) fxs
                         in
                             (*Print.preface ("fxs'", Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs');*)
@@ -337,7 +339,7 @@
                                                        Print.p_list (CorePrint.p_exp CoreEnv.empty) fxs')];*)
                                  default ())
                             else
-                                case (KM.find (args, fxs'),
+                                case (KM.find (args, (vts, fxs')),
                                       SS.member (!mayNotSpec, name) (*orelse IS.member (#specialized st, f)*)) of
                                     (SOME f', _) =>
                                     let
@@ -384,7 +386,7 @@
                                           | SOME (body', typ') =>
                                             let
                                                 val f' = #maxName st
-                                                val args = KM.insert (args, fxs', f')
+                                                val args = KM.insert (args, (vts, fxs'), f')
                                                 val funcs = IM.insert (#funcs st, f, {name = name,
                                                                                       args = args,
                                                                                       body = body,
diff -r 0bf73c3e4563 -r 6c2e565adca6 src/mono_util.sml
--- a/src/mono_util.sml	Tue Oct 19 15:26:12 2010 -0400
+++ b/src/mono_util.sml	Tue Oct 19 17:54:49 2010 -0400
@@ -80,7 +80,7 @@
     join (String.compare (x1, x2),
           fn () => compare (t1, t2))
 
-and sortFields xts = ListMergeSort.sort (fn (x, y) => compareFields (x, y) = GREATER) xts
+and sortFields xts = ListMergeSort.sort (fn ((x, _), (y, _)) => String.compare (x, y) = GREATER) xts
 
 fun mapfold fc =
     let
diff -r 0bf73c3e4563 -r 6c2e565adca6 src/reduce.sml
--- a/src/reduce.sml	Tue Oct 19 15:26:12 2010 -0400
+++ b/src/reduce.sml	Tue Oct 19 17:54:49 2010 -0400
@@ -658,7 +658,7 @@
                                 if ESpecialize.functionInside t then
                                     exp (KnownE e1 :: env) e2
                                 else
-                                    (ELet (x, con env t, exp env e1, exp (UnknownE :: env) e2), loc)
+                                    (ELet (x, t, exp env e1, exp (UnknownE :: env) e2), loc)
                             end
 
                           | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc)