diff options
| -rw-r--r-- | src/cjrize.sml | 2 | ||||
| -rw-r--r-- | src/corify.sml | 6 | ||||
| -rw-r--r-- | src/especialize.sml | 10 | ||||
| -rw-r--r-- | src/mono_util.sml | 2 | ||||
| -rw-r--r-- | src/reduce.sml | 2 |
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) |