Mercurial > urweb
changeset 111:2d6116de9cca
Closure code generation almost there
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 13 Jul 2008 12:06:47 -0400 |
| parents | 3739af9e727a |
| children | 690d72c92a15 |
| files | src/cjrize.sml src/corify.sml src/mono.sml src/mono_print.sml src/mono_util.sml src/monoize.sml src/tag.sml tests/link.lac |
| diffstat | 8 files changed, 54 insertions(+), 14 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjrize.sml Sun Jul 13 11:43:57 2008 -0400 +++ b/src/cjrize.sml Sun Jul 13 12:06:47 2008 -0400 @@ -155,6 +155,9 @@ ((L'.ESeq (e1, e2), loc), sm) end + | L.EClosure _ => (ErrorMsg.errorAt loc "Nested closure remains in code generation"; + (dummye, sm)) + fun cifyDecl ((d, loc), sm) = case d of L.DVal (x, n, t, e, _) =>
--- a/src/corify.sml Sun Jul 13 11:43:57 2008 -0400 +++ b/src/corify.sml Sun Jul 13 12:06:47 2008 -0400 @@ -376,8 +376,13 @@ | L.DVal (x, n, t, e) => let val (st, n) = St.bindVal st x n + val s = + if String.isPrefix "wrap_" x then + String.extract (x, 5, NONE) + else + x in - ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, x), loc)], st) + ([(L'.DVal (x, n, corifyCon st t, corifyExp st e, s), loc)], st) end | L.DSgn _ => ([], st)
--- a/src/mono.sml Sun Jul 13 11:43:57 2008 -0400 +++ b/src/mono.sml Sun Jul 13 12:06:47 2008 -0400 @@ -54,6 +54,8 @@ | EWrite of exp | ESeq of exp * exp + | EClosure of int * exp list + withtype exp = exp' located
--- a/src/mono_print.sml Sun Jul 13 11:43:57 2008 -0400 +++ b/src/mono_print.sml Sun Jul 13 12:06:47 2008 -0400 @@ -130,6 +130,12 @@ space, p_exp env e2] + | EClosure (n, es) => box [string "CLOSURE(", + p_enamed env n, + p_list_sep (string "") (fn e => box [string ", ", + p_exp env e]) es, + string ")"] + and p_exp env = p_exp' false env fun p_decl env ((d, _) : decl) =
--- a/src/mono_util.sml Sun Jul 13 11:43:57 2008 -0400 +++ b/src/mono_util.sml Sun Jul 13 12:06:47 2008 -0400 @@ -194,6 +194,11 @@ S.map2 (mfe ctx e2, fn e2' => (ESeq (e1', e2'), loc))) + + | EClosure (n, es) => + S.map2 (ListUtil.mapfold (mfe ctx) es, + fn es' => + (EClosure (n, es'), loc)) in mfe end
--- a/src/monoize.sml Sun Jul 13 11:43:57 2008 -0400 +++ b/src/monoize.sml Sun Jul 13 12:06:47 2008 -0400 @@ -79,14 +79,35 @@ val dummyExp = (L'.EPrim (Prim.Int 0), E.dummySpan) -fun attrifyExp (e, tAll as (t, loc)) = - case t of - L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", "attrifyString", [e]), loc) - | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", "attrifyInt", [e]), loc) - | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", "attrifyFloat", [e]), loc) - | _ => (E.errorAt loc "Don't know how to encode attribute type"; - Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; - dummyExp) +fun attrifyExp env (e, tAll as (t, loc)) = + case #1 e of + L'.EClosure (fnam, args) => + let + val (_, ft, _, s) = Env.lookupENamed env fnam + val ft = monoType env ft + + fun attrify (args, ft, e) = + case (args, ft) of + ([], _) => e + | (arg :: args, (L'.TFun (t, ft), _)) => + (L'.EStrcat (e, + (L'.EStrcat ((L'.EPrim (Prim.String "/"), loc), + attrifyExp env (arg, t)), loc)), loc) + | _ => (E.errorAt loc "Type mismatch encoding attribute"; + e) + in + attrify (args, ft, (L'.EPrim (Prim.String s), loc)) + end + | _ => + case t of + L'.TFfi ("Basis", "string") => (L'.EFfiApp ("Basis", "attrifyString", [e]), loc) + | L'.TFfi ("Basis", "int") => (L'.EFfiApp ("Basis", "attrifyInt", [e]), loc) + | L'.TFfi ("Basis", "float") => (L'.EFfiApp ("Basis", "attrifyFloat", [e]), loc) + | L'.TRecord [] => (L'.EPrim (Prim.String ""), loc) + + | _ => (E.errorAt loc "Don't know how to encode attribute type"; + Print.eprefaces' [("Type", MonoPrint.p_typ MonoEnv.empty tAll)]; + dummyExp) fun monoExp env (all as (e, loc)) = let @@ -155,7 +176,7 @@ in (L'.EStrcat (s, (L'.EStrcat ((L'.EPrim (Prim.String xp), loc), - (L'.EStrcat (attrifyExp (e, t), + (L'.EStrcat (attrifyExp env (e, t), (L'.EPrim (Prim.String "\""), loc)), loc)), loc)), loc) @@ -193,7 +214,7 @@ | L.EFold _ => poly () | L.EWrite e => (L'.EWrite (monoExp env e), loc) - | L.EClosure _ => raise Fail "Monoize EClosure" + | L.EClosure (n, es) => (L'.EClosure (n, map (monoExp env) es), loc) end fun monoDecl env (all as (d, loc)) =
--- a/src/tag.sml Sun Jul 13 11:43:57 2008 -0400 +++ b/src/tag.sml Sun Jul 13 12:06:47 2008 -0400 @@ -166,7 +166,7 @@ (newDs @ [d], (env, count, tags)) end - val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count, IM.empty) file + val (file, _) = ListUtil.foldlMapConcat doDecl (CoreEnv.empty, count+1, IM.empty) file in file end