summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/core_print.sml2
-rw-r--r--src/elab_env.sig1
-rw-r--r--src/especialize.sml21
-rw-r--r--src/unnest.sml129
4 files changed, 111 insertions, 42 deletions
diff --git a/src/core_print.sml b/src/core_print.sml
index af43e401..f209b84f 100644
--- a/src/core_print.sml
+++ b/src/core_print.sml
@@ -227,7 +227,7 @@ fun p_exp' par env (e, _) =
string "(",
p_list (p_exp env) es,
string "))"]
- | EApp (e1, e2) => parenIf par (box [p_exp env e1,
+ | EApp (e1, e2) => parenIf par (box [p_exp' true env e1,
space,
p_exp' true env e2])
| EAbs (x, t, _, e) => parenIf par (box [string "fn",
diff --git a/src/elab_env.sig b/src/elab_env.sig
index 926837e1..0b436106 100644
--- a/src/elab_env.sig
+++ b/src/elab_env.sig
@@ -30,6 +30,7 @@ signature ELAB_ENV = sig
exception SynUnif
val liftConInCon : int -> Elab.con -> Elab.con
+ val liftConInExp : int -> Elab.exp -> Elab.exp
val liftExpInExp : int -> Elab.exp -> Elab.exp
val subExpInExp : (int * Elab.exp) -> Elab.exp -> Elab.exp
diff --git a/src/especialize.sml b/src/especialize.sml
index f9c7c388..ffd4745b 100644
--- a/src/especialize.sml
+++ b/src/especialize.sml
@@ -188,9 +188,14 @@ fun specialize' file =
andalso List.exists (fn (ERecord [], _) => false | _ => true) xs'
andalso not (IS.member (actionable, f))
andalso hasFunarg (typ, xs') then
- (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan))
- body xs'),
- st)
+ let
+ val e = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan))
+ body xs'
+ in
+ (*Print.prefaces "Unfolded"
+ [("e", CorePrint.p_exp CoreEnv.empty e)];*)
+ (#1 e, st)
+ end
else
(e, st)
end)
@@ -221,6 +226,9 @@ fun specialize' file =
NONE => (e, st)
| SOME (body', typ') =>
let
+ (*val () = Print.prefaces "sub'd"
+ [("body'", CorePrint.p_exp CoreEnv.empty body')]*)
+
val f' = #maxName st
val funcs = IM.insert (#funcs st, f, {name = name,
args = KM.insert (args,
@@ -234,7 +242,13 @@ fun specialize' file =
decls = #decls st
}
+ (*val () = print ("Created " ^ Int.toString f' ^ " from "
+ ^ Int.toString f ^ "\n")
+ val () = Print.prefaces "body'"
+ [("body'", CorePrint.p_exp CoreEnv.empty body')]*)
val (body', st) = specExp st body'
+ (*val () = Print.prefaces "body''"
+ [("body'", CorePrint.p_exp CoreEnv.empty body')]*)
val e' = foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan))
(ENamed f', ErrorMsg.dummySpan) xs'
in
@@ -316,6 +330,7 @@ fun specialize' file =
fun specialize file =
let
+ (*val () = Print.prefaces "Intermediate" [("file", CorePrint.p_file CoreEnv.empty file)];*)
val (changed, file) = specialize' file
in
if changed then
diff --git a/src/unnest.sml b/src/unnest.sml
index 6a37d484..fe63f9fe 100644
--- a/src/unnest.sml
+++ b/src/unnest.sml
@@ -36,6 +36,35 @@ structure U = ElabUtil
structure IS = IntBinarySet
+fun liftExpInExp by =
+ U.Exp.mapB {kind = fn k => k,
+ con = fn _ => fn c => c,
+ exp = fn bound => fn e =>
+ case e of
+ ERel xn =>
+ if xn < bound then
+ e
+ else
+ ERel (xn + by)
+ | _ => e,
+ bind = fn (bound, U.Exp.RelE _) => bound + 1
+ | (bound, _) => bound}
+
+val subExpInExp =
+ U.Exp.mapB {kind = fn k => k,
+ con = fn _ => fn c => c,
+ exp = fn (xn, rep) => fn e =>
+ case e of
+ ERel xn' =>
+ if xn' = xn then
+ #1 rep
+ else
+ e
+ | _ => e,
+ bind = fn ((xn, rep), U.Exp.RelE _) => (xn+1, E.liftExpInExp 0 rep)
+ | ((xn, rep), U.Exp.RelC _) => (xn, E.liftConInExp 0 rep)
+ | (ctx, _) => ctx}
+
val fvsCon = U.Con.foldB {kind = fn (_, st) => st,
con = fn (cb, c, cvs) =>
case c of
@@ -87,7 +116,7 @@ fun positionOf (x : int) ls =
po (n + 1) ls'
in
po 0 ls
- handle Fail _ => raise Fail ("Unnset.positionOf("
+ handle Fail _ => raise Fail ("Unnest.positionOf("
^ Int.toString x
^ ", "
^ String.concatWith ";" (map Int.toString ls)
@@ -124,7 +153,7 @@ fun squishExp (nr, cfv, efv) =
case e of
ERel n =>
if n >= eb then
- ERel (positionOf (n - eb) efv + eb)
+ ERel (positionOf (n - eb) efv + eb - nr)
else
e
| _ => e,
@@ -146,17 +175,32 @@ fun exp ((ks, ts), e as old, st : state) =
case e of
ELet (eds, e) =>
let
- (*val () = Print.prefaces "let" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*)
+ (*val () = Print.prefaces "Letto" [("e", ElabPrint.p_exp E.empty (old, ErrorMsg.dummySpan))]*)
- val doSubst = foldl (fn (p, e) => E.subExpInExp p e)
+ fun doSubst' (e, subs) = foldl (fn (p, e) => subExpInExp p e) e subs
- val (eds, (ts, maxName, ds, subs)) =
+ fun doSubst (e, subs, by) =
+ let
+ val e = doSubst' (e, subs)
+ in
+ liftExpInExp (~by) (length subs) e
+ end
+
+ val (eds, (ts, maxName, ds, subs, by)) =
ListUtil.foldlMapConcat
- (fn (ed, (ts, maxName, ds, subs)) =>
+ (fn (ed, (ts, maxName, ds, subs, by)) =>
case #1 ed of
- EDVal (x, t, _) => ([ed],
- ((x, t) :: ts,
- maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs))
+ EDVal (x, t, e) =>
+ let
+ val e = doSubst (e, subs, by)
+ in
+ ([(EDVal (x, t, e), #2 ed)],
+ ((x, t) :: ts,
+ maxName, ds,
+ ((0, (ERel 0, #2 ed))
+ :: map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs),
+ by))
+ end
| EDValRec vis =>
let
val loc = #2 ed
@@ -182,6 +226,7 @@ fun exp ((ks, ts), e as old, st : state) =
val () = app (fn (x, t) =>
Print.prefaces "Var" [("x", Print.PD.string x),
("t", ElabPrint.p_con E.empty t)]) ts*)
+
val cfv = IS.foldl (fn (x, cfv) =>
let
(*val () = print (Int.toString x ^ "\n")*)
@@ -198,56 +243,54 @@ fun exp ((ks, ts), e as old, st : state) =
maxName + 1))
maxName vis
- fun apply e =
- let
- val e = IS.foldr (fn (x, e) =>
- (ECApp (e, (CRel x, loc)), loc))
- e cfv
- in
- IS.foldr (fn (x, e) =>
- (EApp (e, (ERel x, loc)), loc))
- e efv
- end
- val subs = map (fn (n, e) => (n + nr, E.liftExpInExp nr e)) subs
+
+ val subs = map (fn (n, e) => (n + nr,
+ case e of
+ (ERel _, _) => e
+ | _ => liftExpInExp nr 0 e))
+ subs
+
val subs' = ListUtil.mapi (fn (i, (_, n, _, _)) =>
let
- val dummy = (EError, ErrorMsg.dummySpan)
-
- fun repeatLift k =
- if k = 0 then
- apply (ENamed n, loc)
- else
- E.liftExpInExp 0 (repeatLift (k - 1))
+ val e = (ENamed n, loc)
+
+ val e = IS.foldr (fn (x, e) =>
+ (ECApp (e, (CRel x, loc)), loc))
+ e cfv
+
+ val e = IS.foldr (fn (x, e) =>
+ (EApp (e, (ERel (nr + x), loc)),
+ loc))
+ e efv
in
- (0, repeatLift i)
+ (nr - i - 1, e)
end)
vis
- val subs' = rev subs'
-
val cfv = IS.listItems cfv
val efv = IS.listItems efv
- val efn = length efv
- val subs = subs @ subs'
+ val subs = subs' @ subs
val vis = map (fn (x, n, t, e) =>
let
(*val () = Print.prefaces "preSubst"
[("e", ElabPrint.p_exp E.empty e)]*)
- val e = doSubst e subs
+ val e = doSubst' (e, subs)
(*val () = Print.prefaces "squishCon"
[("t", ElabPrint.p_con E.empty t)]*)
val t = squishCon cfv t
(*val () = Print.prefaces "squishExp"
[("e", ElabPrint.p_exp E.empty e)]*)
- val e = squishExp (0(*nr*), cfv, efv) e
+ val e = squishExp (nr, cfv, efv) e
+ (*val () = print ("Avail: " ^ Int.toString (length ts) ^ "\n")*)
val (e, t) = foldl (fn (ex, (e, t)) =>
let
+ (*val () = print (Int.toString ex ^ "\n")*)
val (name, t') = List.nth (ts, ex)
in
((EAbs (name,
@@ -258,6 +301,7 @@ fun exp ((ks, ts), e as old, st : state) =
t), loc))
end)
(e, t) efv
+ (*val () = print "Done\n"*)
val (e, t) = foldl (fn (cx, (e, t)) =>
let
@@ -274,19 +318,28 @@ fun exp ((ks, ts), e as old, st : state) =
end)
(e, t) cfv
in
+ (*Print.prefaces "Have a vi"
+ [("x", Print.PD.string x),
+ ("e", ElabPrint.p_exp ElabEnv.empty e)];*)
(x, n, t, e)
end)
vis
- val ts = map (fn (x, _, t, _) => (x, t)) vis @ ts
+ val ts = List.revAppend (map (fn (x, _, t, _) => (x, t)) vis, ts)
in
- ([], (ts, maxName, vis @ ds, subs))
+ ([], (ts, maxName, vis @ ds, subs, by + nr))
end)
- (ts, #maxName st, #decls st, []) eds
+ (ts, #maxName st, #decls st, [], 0) eds
+
+ val e' = doSubst (e, subs, by)
in
- (ELet (eds, doSubst e subs),
+ (*Print.prefaces "Before" [("e", ElabPrint.p_exp ElabEnv.empty e),
+ ("se", ElabPrint.p_exp ElabEnv.empty (doSubst' (e, subs))),
+ ("e'", ElabPrint.p_exp ElabEnv.empty e')];*)
+ (ELet (eds, e'),
{maxName = maxName,
decls = ds})
+ (*(ELet (eds, doSubst (liftExpInExp (~(length subs - numRemaining)) (length subs) e) subs),*)
end
| _ => (e, st)
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-04 01:51:57 +0000