Mercurial > urweb
changeset 453:787d4931fb07
Almost have that nested save function compiling
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sat, 01 Nov 2008 21:19:43 -0400 |
| parents | 222cbc1da232 |
| children | 9163f8014f9b |
| files | src/cjrize.sml src/core_util.sml src/elab_util.sml src/especialize.sml src/expl_print.sml src/expl_util.sml src/mono_opt.sml src/mono_reduce.sig src/shake.sml src/sources src/termination.sml src/unnest.sml tests/blog.ur tests/blog.urp tests/blog.urs tests/nest.ur tests/nest2.ur tests/nest2.urp |
| diffstat | 18 files changed, 268 insertions(+), 85 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjrize.sml Sat Nov 01 17:19:12 2008 -0400 +++ b/src/cjrize.sml Sat Nov 01 21:19:43 2008 -0400 @@ -39,6 +39,7 @@ val find : t * (string * L.typ) list * (string * L'.typ) list -> t * int val declares : t -> (int * (string * L'.typ) list) list + val clearDeclares : t -> t end = struct structure FM = BinaryMapFn(struct @@ -61,6 +62,8 @@ fun declares (_, _, ds) = ds +fun clearDeclares (n, m, _) = (n, m, []) + end fun cifyTyp x = @@ -520,23 +523,25 @@ val (dsF, ds, ps, sm) = foldl (fn (d, (dsF, ds, ps, sm)) => let val (dop, pop, sm) = cifyDecl (d, sm) + val (dsF, ds) = case dop of NONE => (dsF, ds) - | SOME (d as (L'.DDatatype (dk, x, n, _), loc)) => - ((L'.DDatatypeForward (dk, x, n), loc) :: dsF, - d :: ds) + | SOME (d as (L'.DDatatype _, loc)) => + (d :: dsF, ds) | SOME d => (dsF, d :: ds) + + val dsF = map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm) + @ dsF + val ps = case pop of NONE => ps | SOME p => p :: ps in - (dsF, ds, ps, sm) + (dsF, ds, ps, Sm.clearDeclares sm) end) ([], [], [], Sm.empty) ds in - (List.revAppend (dsF, - List.revAppend (map (fn v => (L'.DStruct v, ErrorMsg.dummySpan)) (Sm.declares sm), - rev ds)), + (List.revAppend (dsF, rev ds), ps) end
--- a/src/core_util.sml Sat Nov 01 17:19:12 2008 -0400 +++ b/src/core_util.sml Sat Nov 01 21:19:43 2008 -0400 @@ -492,7 +492,7 @@ fn t' => S.bind2 (mfe ctx e1, fn e1' => - S.map2 (mfe ctx e2, + S.map2 (mfe (bind (ctx, RelE (x, t'))) e2, fn e2' => (ELet (x, t', e1', e2'), loc))))
--- a/src/elab_util.sml Sat Nov 01 17:19:12 2008 -0400 +++ b/src/elab_util.sml Sat Nov 01 21:19:43 2008 -0400 @@ -375,14 +375,19 @@ | ELet (des, e) => let val (des, ctx) = foldl (fn (ed, (des, ctx)) => - (S.bind2 (des, - fn des' => - S.map2 (mfed ctx ed, + let + val ctx' = + case #1 ed of + EDVal (x, t, _) => bind (ctx, RelE (x, t)) + | EDValRec vis => + foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis + in + (S.bind2 (des, + fn des' => + S.map2 (mfed ctx ed, fn ed' => des' @ [ed'])), - case #1 ed of - EDVal (x, t, _) => bind (ctx, RelE (x, t)) - | EDValRec vis => - foldl (fn ((x, t, _), env) => bind (ctx, RelE (x, t))) ctx vis)) + ctx') + end) (S.return2 [], ctx) des in S.bind2 (des, @@ -400,7 +405,7 @@ (EDVal vi', loc)) | EDValRec vis => let - val ctx = foldl (fn ((x, t, _), env) => bind (ctx, RelE (x, t))) ctx vis + val ctx = foldl (fn ((x, t, _), ctx) => bind (ctx, RelE (x, t))) ctx vis in S.map2 (ListUtil.mapfold (mfvi ctx) vis, fn vis' =>
--- a/src/especialize.sml Sat Nov 01 17:19:12 2008 -0400 +++ b/src/especialize.sml Sat Nov 01 21:19:43 2008 -0400 @@ -32,17 +32,43 @@ structure E = CoreEnv structure U = CoreUtil -structure ILK = struct -type ord_key = int list -val compare = Order.joinL Int.compare +datatype skey = + Named of int + | App of skey * skey + +structure K = struct +type ord_key = skey list +fun compare' (k1, k2) = + case (k1, k2) of + (Named n1, Named n2) => Int.compare (n1, n2) + | (Named _, _) => LESS + | (_, Named _) => GREATER + + | (App (x1, y1), App (x2, y2)) => Order.join (compare' (x1, x2), fn () => compare' (y1, y2)) + +val compare = Order.joinL compare' end -structure ILM = BinaryMapFn(ILK) +structure KM = BinaryMapFn(K) structure IM = IntBinaryMap +fun skeyIn (e, _) = + case e of + ENamed n => SOME (Named n) + | EApp (e1, e2) => + (case (skeyIn e1, skeyIn e2) of + (SOME k1, SOME k2) => SOME (App (k1, k2)) + | _ => NONE) + | _ => NONE + +fun skeyOut (k, loc) = + case k of + Named n => (ENamed n, loc) + | App (k1, k2) => (EApp (skeyOut (k1, loc), skeyOut (k2, loc)), loc) + type func = { name : string, - args : int ILM.map, + args : int KM.map, body : exp, typ : con, tag : string @@ -62,14 +88,21 @@ fun getApp e = case e of ENamed f => SOME (f, [], []) - | EApp (e1, (ENamed x, _)) => - (case getApp (#1 e1) of - NONE => NONE - | SOME (f, xs, xs') => SOME (f, xs @ [x], xs')) | EApp (e1, e2) => (case getApp (#1 e1) of NONE => NONE - | SOME (f, xs, xs') => SOME (f, xs, xs' @ [e2])) + | SOME (f, xs, xs') => + let + val k = + if List.null xs' then + skeyIn e2 + else + NONE + in + case k of + NONE => SOME (f, xs, xs' @ [e2]) + | SOME k => SOME (f, xs @ [k], xs') + end) | _ => NONE in case getApp e of @@ -77,21 +110,30 @@ | SOME (_, [], _) => (e, st) | SOME (f, xs, xs') => case IM.find (#funcs st, f) of - NONE => (e, st) + NONE => ((*print "SHOT DOWN!\n";*) (e, st)) | SOME {name, args, body, typ, tag} => - case ILM.find (args, xs) of - SOME f' => (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) - (ENamed f', ErrorMsg.dummySpan) xs'), - st) + case KM.find (args, xs) of + SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*) + (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) + (ENamed f', ErrorMsg.dummySpan) xs'), + st)) | NONE => let + (*val () = Print.prefaces "New" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*) + fun subBody (body, typ, xs) = case (#1 body, #1 typ, xs) of (_, _, []) => SOME (body, typ) | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => - subBody (E.subExpInExp (0, (ENamed x, ErrorMsg.dummySpan)) body', - typ', - xs) + let + val body'' = E.subExpInExp (0, skeyOut (x, #2 body)) body' + in + (*Print.prefaces "espec" [("body'", CorePrint.p_exp CoreEnv.empty body'), + ("body''", CorePrint.p_exp CoreEnv.empty body'')];*) + subBody (body'', + typ', + xs) + end | _ => NONE in case subBody (body, typ, xs) of @@ -99,8 +141,9 @@ | SOME (body', typ') => let val f' = #maxName st + (*val () = print ("f' = " ^ Int.toString f' ^ "\n")*) val funcs = IM.insert (#funcs st, f, {name = name, - args = ILM.insert (args, xs, f'), + args = KM.insert (args, xs, f'), body = body, typ = typ, tag = tag}) @@ -128,10 +171,27 @@ val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} -fun specialize file = +fun specialize' file = let - fun doDecl (d, st) = + fun doDecl (d, (st : state, changed)) = let + val funcs = #funcs st + val funcs = + case #1 d of + DValRec vis => + foldl (fn ((x, n, c, e, tag), funcs) => + IM.insert (funcs, n, {name = x, + args = KM.empty, + body = e, + typ = c, + tag = tag})) + funcs vis + | _ => funcs + + val st = {maxName = #maxName st, + funcs = funcs, + decls = []} + val (d', st) = specDecl st d val funcs = #funcs st @@ -139,38 +199,43 @@ case #1 d of DVal (x, n, c, e as (EAbs _, _), tag) => IM.insert (funcs, n, {name = x, - args = ILM.empty, + args = KM.empty, body = e, typ = c, tag = tag}) - | DValRec vis => - foldl (fn ((x, n, c, e, tag), funcs) => - IM.insert (funcs, n, {name = x, - args = ILM.empty, - body = e, - typ = c, - tag = tag})) - funcs vis | _ => funcs - val ds = + val (changed, ds) = case #decls st of - [] => [d'] - | vis => [(DValRec vis, ErrorMsg.dummySpan), d'] + [] => (changed, [d']) + | vis => + (true, case d' of + (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] + | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) in - (ds, {maxName = #maxName st, - funcs = funcs, - decls = []}) + (ds, ({maxName = #maxName st, + funcs = funcs, + decls = []}, changed)) end - val (ds, _) = ListUtil.foldlMapConcat doDecl - {maxName = U.File.maxName file + 1, - funcs = IM.empty, - decls = []} - file + val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl + ({maxName = U.File.maxName file + 1, + funcs = IM.empty, + decls = []}, false) + file in - ds + (changed, ds) end +fun specialize file = + let + val (changed, file) = specialize' file + in + if changed then + specialize file + else + file + end + end
--- a/src/expl_print.sml Sat Nov 01 17:19:12 2008 -0400 +++ b/src/expl_print.sml Sat Nov 01 21:19:43 2008 -0400 @@ -370,6 +370,7 @@ string x, space, string ":", + space, p_con env t, space, string "=",
--- a/src/expl_util.sml Sat Nov 01 17:19:12 2008 -0400 +++ b/src/expl_util.sml Sat Nov 01 21:19:43 2008 -0400 @@ -331,7 +331,7 @@ fn t' => S.bind2 (mfe ctx e1, fn e1' => - S.map2 (mfe ctx e2, + S.map2 (mfe (bind (ctx, RelE (x, t))) e2, fn e2' => (ELet (x, t', e1', e2'), loc)))) in
--- a/src/mono_opt.sml Sat Nov 01 17:19:12 2008 -0400 +++ b/src/mono_opt.sml Sat Nov 01 21:19:43 2008 -0400 @@ -89,7 +89,7 @@ fun sqlifyString s = "E'" ^ String.translate (fn #"'" => "\\'" | ch => str ch) (String.toString s) ^ "'::text" - + fun exp e = case e of EPrim (Prim.String s) => @@ -287,6 +287,19 @@ {disc = disc, result = (TRecord [], loc)}), loc) + | EApp ((ECase (discE, pes, {disc, ...}), loc), arg as (ERecord [], _)) => + let + fun doBody e = + case #1 e of + EAbs (_, _, _, body) => MonoReduce.subExpInExp (0, arg) body + | _ => (EApp (e, arg), loc) + in + optExp (ECase (discE, + map (fn (p, e) => (p, doBody e)) pes, + {disc = disc, + result = (TRecord [], loc)}), loc) + end + | EWrite (EQuery {exps, tables, state, query, initial = (EPrim (Prim.String ""), _), body = (EStrcat ((EPrim (Prim.String s), _),
--- a/src/mono_reduce.sig Sat Nov 01 17:19:12 2008 -0400 +++ b/src/mono_reduce.sig Sat Nov 01 21:19:43 2008 -0400 @@ -30,5 +30,7 @@ signature MONO_REDUCE = sig val reduce : Mono.file -> Mono.file - + + val subExpInExp : int * Mono.exp -> Mono.exp -> Mono.exp + end
--- a/src/shake.sml Sat Nov 01 17:19:12 2008 -0400 +++ b/src/shake.sml Sat Nov 01 21:19:43 2008 -0400 @@ -55,14 +55,19 @@ val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, [c]), edef) | ((DDatatype (_, n, _, xncs), _), (cdef, edef)) => (IM.insert (cdef, n, List.mapPartial #3 xncs), edef) - | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))) + | ((DVal (_, n, t, e, _), _), (cdef, edef)) => (cdef, IM.insert (edef, n, ([], t, e))) | ((DValRec vis, _), (cdef, edef)) => - (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis) + let + val all_ns = map (fn (_, n, _, _, _) => n) vis + in + (cdef, foldl (fn ((_, n, t, e, _), edef) => + IM.insert (edef, n, (all_ns, t, e))) edef vis) + end | ((DExport _, _), acc) => acc | ((DTable (_, n, c, _), _), (cdef, edef)) => - (cdef, IM.insert (edef, n, (c, dummye))) + (cdef, IM.insert (edef, n, ([], c, dummye))) | ((DSequence (_, n, _), _), (cdef, edef)) => - (cdef, IM.insert (edef, n, (dummyt, dummye))) + (cdef, IM.insert (edef, n, ([], dummyt, dummye))) | ((DDatabase _, _), acc) => acc) (IM.empty, IM.empty) file @@ -96,9 +101,15 @@ val s' = {exp = IS.add (#exp s, n), con = #con s} in + (*print ("Need " ^ Int.toString n ^ "\n");*) case IM.find (edef, n) of NONE => s' - | SOME (t, e) => shakeExp (shakeCon s' t) e + | SOME (ns, t, e) => + let + val s' = shakeExp (shakeCon s' t) e + in + foldl (fn (n, s') => exp (ENamed n, s')) s' ns + end end | _ => s @@ -109,7 +120,12 @@ val s = foldl (fn (n, s) => case IM.find (edef, n) of NONE => raise Fail "Shake: Couldn't find 'val'" - | SOME (t, e) => shakeExp (shakeCon s t) e) s page_es + | SOME (ns, t, e) => + let + val s = shakeExp (shakeCon s t) e + in + foldl (fn (n, s) => exp (ENamed n, s)) s ns + end) s page_es val s = foldl (fn (c, s) => shakeCon s c) s table_cs in
--- a/src/sources Sat Nov 01 17:19:12 2008 -0400 +++ b/src/sources Sat Nov 01 21:19:43 2008 -0400 @@ -116,15 +116,15 @@ monoize.sig monoize.sml +mono_reduce.sig +mono_reduce.sml + mono_opt.sig mono_opt.sml untangle.sig untangle.sml -mono_reduce.sig -mono_reduce.sml - mono_shake.sig mono_shake.sml
--- a/src/termination.sml Sat Nov 01 17:19:12 2008 -0400 +++ b/src/termination.sml Sat Nov 01 21:19:43 2008 -0400 @@ -293,7 +293,15 @@ | EUnif (ref (SOME e)) => exp parent (penv, calls) e | EUnif (ref NONE) => (Rabble, calls) - | ELet (_, e) => exp parent (penv, calls) e + | ELet (eds, e) => + let + fun extPenv ((ed, _), penv) = + case ed of + EDVal _ => Rabble :: penv + | EDValRec vis => foldl (fn (_, penv) => Rabble :: penv) penv vis + in + exp parent (foldl extPenv penv eds, calls) e + end end fun doVali (i, (_, f, _, e), calls) =
--- a/src/unnest.sml Sat Nov 01 17:19:12 2008 -0400 +++ b/src/unnest.sml Sat Nov 01 21:19:43 2008 -0400 @@ -124,7 +124,7 @@ case e of ERel n => if n >= eb then - ERel (positionOf (n - eb) efv + eb) + ERel (positionOf (n - eb) efv + eb) else e | _ => e, @@ -142,17 +142,21 @@ fun kind (k, st) = (k, st) -fun exp ((ks, ts), e, st : state) = +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 doSubst = foldl (fn (p, e) => E.subExpInExp p e) - val (eds, (maxName, ds, subs)) = + val (eds, (ts, maxName, ds, subs)) = ListUtil.foldlMapConcat - (fn (ed, (maxName, ds, subs)) => + (fn (ed, (ts, maxName, ds, subs)) => case #1 ed of - EDVal _ => ([ed], (maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs)) + EDVal (x, t, _) => ([ed], + ((x, t) :: ts, + maxName, ds, map (fn (n, e) => (n + 1, E.liftExpInExp 0 e)) subs)) | EDValRec vis => let val loc = #2 ed @@ -174,7 +178,10 @@ end) (IS.empty, IS.empty) vis - (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n")*) + (*val () = print ("A: " ^ Int.toString (length ts) ^ ", " ^ Int.toString (length ks) ^ "\n") + 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")*) @@ -193,11 +200,11 @@ fun apply e = let - val e = IS.foldl (fn (x, e) => + val e = IS.foldr (fn (x, e) => (ECApp (e, (CRel x, loc)), loc)) e cfv in - IS.foldl (fn (x, e) => + IS.foldr (fn (x, e) => (EApp (e, (ERel x, loc)), loc)) e efv end @@ -237,9 +244,9 @@ val t = squishCon cfv t (*val () = Print.prefaces "squishExp" [("e", ElabPrint.p_exp E.empty e)]*) - val e = squishExp (nr, cfv, efv) e + val e = squishExp (0(*nr*), cfv, efv) e - val (e, t) = foldr (fn (ex, (e, t)) => + val (e, t) = foldl (fn (ex, (e, t)) => let val (name, t') = List.nth (ts, ex) in @@ -252,7 +259,7 @@ end) (e, t) efv - val (e, t) = foldr (fn (cx, (e, t)) => + val (e, t) = foldl (fn (cx, (e, t)) => let val (name, k) = List.nth (ks, cx) in @@ -272,10 +279,12 @@ vis val d = (DValRec vis, #2 ed) + + val ts = map (fn (x, _, t, _) => (x, t)) vis @ ts in - ([], (maxName, d :: ds, subs)) + ([], (ts, maxName, d :: ds, subs)) end) - (#maxName st, #decls st, []) eds + (ts, #maxName st, #decls st, []) eds in (ELet (eds, doSubst e subs), {maxName = maxName,
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/blog.ur Sat Nov 01 21:19:43 2008 -0400 @@ -0,0 +1,16 @@ +fun main wrap = + let + fun edit id = + let + val r = 0 + fun save () = <xml/> + in + wrap (save ()) + end + in + edit 0 + end + +fun wrap (inside : xbody) = return <xml/> + +val main () = main wrap
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/blog.urp Sat Nov 01 21:19:43 2008 -0400 @@ -0,0 +1,4 @@ +debug +database dbname=blog + +blog \ No newline at end of file
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/blog.urs Sat Nov 01 21:19:43 2008 -0400 @@ -0,0 +1,1 @@ +val main : unit -> transaction page
--- a/tests/nest.ur Sat Nov 01 17:19:12 2008 -0400 +++ b/tests/nest.ur Sat Nov 01 21:19:43 2008 -0400 @@ -45,7 +45,26 @@ page3 end -datatype list t = Nil | Cons of t * list t +fun add2 (x : int) (y : int) = + let + fun add3 () = x + y + in + add3 + end + +fun add3 (x : int) = + let + fun add2 (y : int) = + let + fun add1 (z : int) = x + y + z + in + add1 + end + in + add2 + end + +(*datatype list t = Nil | Cons of t * list t fun length (t ::: Type) (ls : list t) = let @@ -57,3 +76,4 @@ length' ls 0 end +*)
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/tests/nest2.ur Sat Nov 01 21:19:43 2008 -0400 @@ -0,0 +1,15 @@ +fun wooho (wrap : xbody -> transaction page) = + let + fun subPage n = + let + fun subberPage () = wrap <xml>{[n]}</xml> + in + wrap <xml><a link={subberPage ()}>Go</a></xml> + end + in + subPage 0 + end + +fun wrap x = return <xml><body>{x}</body></xml> + +fun main () = wooho wrap