From b3379c2a4d9b23c49c286b31ab24850129b5bb1e Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 13 Jul 2008 12:06:47 -0400 Subject: Closure code generation almost there --- src/cjrize.sml | 3 +++ src/corify.sml | 7 ++++++- src/mono.sml | 2 ++ src/mono_print.sml | 6 ++++++ src/mono_util.sml | 5 +++++ src/monoize.sml | 41 +++++++++++++++++++++++++++++++---------- src/tag.sml | 2 +- 7 files changed, 54 insertions(+), 12 deletions(-) (limited to 'src') diff --git a/src/cjrize.sml b/src/cjrize.sml index 52b1b4ac..558fac0b 100644 --- a/src/cjrize.sml +++ b/src/cjrize.sml @@ -155,6 +155,9 @@ fun cifyExp ((e, loc), sm) = ((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, _) => diff --git a/src/corify.sml b/src/corify.sml index 9c44140d..55d9a95a 100644 --- a/src/corify.sml +++ b/src/corify.sml @@ -376,8 +376,13 @@ fun corifyDecl ((d, loc : EM.span), st) = | 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) diff --git a/src/mono.sml b/src/mono.sml index 913650fa..4092891e 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -54,6 +54,8 @@ datatype exp' = | EWrite of exp | ESeq of exp * exp + | EClosure of int * exp list + withtype exp = exp' located diff --git a/src/mono_print.sml b/src/mono_print.sml index a936c146..07065b3a 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -130,6 +130,12 @@ fun p_exp' par env (e, _) = 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) = diff --git a/src/mono_util.sml b/src/mono_util.sml index 1a7c8f5b..0d5211cf 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -194,6 +194,11 @@ fun mapfoldB {typ = fc, exp = fe, bind} = 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 diff --git a/src/monoize.sml b/src/monoize.sml index 2e21a2bf..266a031a 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -79,14 +79,35 @@ fun monoType env (all as (c, loc)) = 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 @@ fun monoExp env (all as (e, loc)) = 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 @@ fun monoExp env (all as (e, loc)) = | 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)) = diff --git a/src/tag.sml b/src/tag.sml index a244c294..038572b6 100644 --- a/src/tag.sml +++ b/src/tag.sml @@ -166,7 +166,7 @@ fun tag file = (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 -- cgit v1.2.3