summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--src/cjrize.sml2
-rw-r--r--src/corify.sml6
-rw-r--r--src/especialize.sml10
-rw-r--r--src/mono_util.sml2
-rw-r--r--src/reduce.sml2
5 files changed, 12 insertions, 10 deletions
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 2e7afa43..2915b0ca 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -112,7 +112,7 @@ fun cifyTyp x =
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 --git a/src/corify.sml b/src/corify.sml
index 27e6c4c7..c3a53094 100644
--- a/src/corify.sml
+++ b/src/corify.sml
@@ -271,11 +271,11 @@ fun lookupValByName ({current, ...} : t) x =
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 --git a/src/especialize.sml b/src/especialize.sml
index a43652d0..d7a5014b 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -35,8 +35,9 @@ structure U = CoreUtil
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 @@ fun specialize' (funcs, specialized) file =
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 @@ fun specialize' (funcs, specialized) file =
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 @@ fun specialize' (funcs, specialized) file =
| 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 --git a/src/mono_util.sml b/src/mono_util.sml
index d75b8300..56472155 100644
--- a/src/mono_util.sml
+++ b/src/mono_util.sml
@@ -80,7 +80,7 @@ and compareFields ((x1, t1), (x2, t2)) =
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 --git a/src/reduce.sml b/src/reduce.sml
index 7a962926..c18c698b 100644
--- a/src/reduce.sml
+++ b/src/reduce.sml
@@ -658,7 +658,7 @@ fun kindConAndExp (namedC, namedE) =
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)