Mercurial > urweb
changeset 608:330a7de47914
Export RPC functions and push RPC calls through to Mono
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 15 Feb 2009 09:27:36 -0500 |
| parents | 0dd40b6bfdf3 |
| children | 56aaa1941dad |
| files | src/cjr_print.sml src/cjrize.sml src/core.sml src/core_print.sml src/jscomp.sml src/mono.sml src/mono_print.sml src/mono_reduce.sml src/mono_util.sml src/monoize.sml src/rpcify.sml |
| diffstat | 11 files changed, 73 insertions(+), 13 deletions(-) [+] |
line wrap: on
line diff
--- a/src/cjr_print.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/cjr_print.sml Sun Feb 15 09:27:36 2009 -0500 @@ -1849,6 +1849,7 @@ val fields = foldl (fn ((ek, _, _, ts), fields) => case ek of Core.Link => fields + | Core.Rpc => fields | Core.Action => case List.nth (ts, length ts - 2) of (TRecord i, _) => @@ -1971,6 +1972,7 @@ val (ts, defInputs, inputsVar) = case ek of Core.Link => (List.take (ts, length ts - 1), string "", string "") + | Core.Rpc => (List.take (ts, length ts - 1), string "", string "") | Core.Action => case List.nth (ts, length ts - 2) of (TRecord i, _) =>
--- a/src/cjrize.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/cjrize.sml Sun Feb 15 09:27:36 2009 -0500 @@ -429,6 +429,8 @@ | L.ESignalBind _ => raise Fail "Cjrize: ESignalBind remains" | L.ESignalSource _ => raise Fail "Cjrize: ESignalSource remains" + | L.EServerCall _ => raise Fail "Cjrize EServerCall" + fun cifyDecl ((d, loc), sm) = case d of L.DDatatype (x, n, xncs) =>
--- a/src/core.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/core.sml Sun Feb 15 09:27:36 2009 -0500 @@ -113,6 +113,7 @@ datatype export_kind = Link | Action + | Rpc datatype decl' = DCon of string * int * kind * con
--- a/src/core_print.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/core_print.sml Sun Feb 15 09:27:36 2009 -0500 @@ -436,6 +436,7 @@ case ck of Link => string "link" | Action => string "action" + | Rpc => string "rpc" fun p_datatype env (x, n, xs, cons) = let
--- a/src/jscomp.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/jscomp.sml Sun Feb 15 09:27:36 2009 -0500 @@ -98,6 +98,7 @@ | ESignalReturn e => varDepth e | ESignalBind (e1, e2) => Int.max (varDepth e1, varDepth e2) | ESignalSource e => varDepth e + | EServerCall (_, es, ek) => foldl Int.max (varDepth ek) (map varDepth es) fun closedUpto d = let @@ -138,6 +139,7 @@ | ESignalReturn e => cu inner e | ESignalBind (e1, e2) => cu inner e1 andalso cu inner e2 | ESignalSource e => cu inner e + | EServerCall (_, es, ek) => List.all (cu inner) es andalso cu inner ek in cu 0 end @@ -809,6 +811,8 @@ str ")"], st) end + + | EServerCall _ => raise Fail "Jscomp EServerCall" end in jsE
--- a/src/mono.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/mono.sml Sun Feb 15 09:27:36 2009 -0500 @@ -109,6 +109,8 @@ | ESignalBind of exp * exp | ESignalSource of exp + | EServerCall of int * exp list * exp + withtype exp = exp' located datatype decl' =
--- a/src/mono_print.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/mono_print.sml Sun Feb 15 09:27:36 2009 -0500 @@ -308,6 +308,15 @@ p_exp env e, string ")"] + | EServerCall (n, es, e) => box [string "Server(", + p_enamed env n, + string ",", + space, + p_list (p_exp env) es, + string ")[", + p_exp env e, + string "]"] + and p_exp env = p_exp' false env fun p_vali env (x, n, t, e, s) =
--- a/src/mono_reduce.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/mono_reduce.sml Sun Feb 15 09:27:36 2009 -0500 @@ -81,6 +81,7 @@ | ESignalReturn e => impure e | ESignalBind (e1, e2) => impure e1 orelse impure e2 | ESignalSource e => impure e + | EServerCall _ => true val liftExpInExp = Monoize.liftExpInExp @@ -344,6 +345,8 @@ | ESignalReturn e => summarize d e | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e + + | EServerCall (_, es, ek) => List.concat (map (summarize d) es) @ summarize d ek @ [Unsure] in (*Print.prefaces "Summarize" [("e", MonoPrint.p_exp MonoEnv.empty (e, ErrorMsg.dummySpan)),
--- a/src/mono_util.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/mono_util.sml Sun Feb 15 09:27:36 2009 -0500 @@ -349,6 +349,13 @@ S.map2 (mfe ctx e, fn e' => (ESignalSource e', loc)) + + | EServerCall (n, es, ek) => + S.bind2 (ListUtil.mapfold (fn e => mfe ctx e) es, + fn es' => + S.map2 (mfe ctx ek, + fn ek' => + (EServerCall (n, es', ek'), loc))) in mfe end
--- a/src/monoize.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/monoize.sml Sun Feb 15 09:27:36 2009 -0500 @@ -2225,7 +2225,13 @@ ((L'.ELet (x, t', e1, e2), loc), fm) end - | L.EServerCall _ => raise Fail "Monoize EServerCall" + | L.EServerCall (n, es, ek) => + let + val (es, fm) = ListUtil.foldlMap (fn (e, fm) => monoExp (env, st, fm) e) fm es + val (ek, fm) = monoExp (env, st, fm) ek + in + ((L'.EServerCall (n, es, ek), loc), fm) + end end fun monoDecl (env, fm) (all as (d, loc)) =
--- a/src/rpcify.sml Sat Feb 14 14:07:56 2009 -0500 +++ b/src/rpcify.sml Sun Feb 15 09:27:36 2009 -0500 @@ -53,8 +53,11 @@ "alert"]) type state = { - exps : int IM.map, - decls : (string * int * con * exp * string) list + cpsed : int IM.map, + cps_decls : (string * int * con * exp * string) list, + + exported : IS.set, + export_decls : decl list } fun frob file = @@ -114,6 +117,19 @@ (0, [])) val (n, args) = getApp (trans1, []) + + val (exported, export_decls) = + if IS.member (#exported st, n) then + (#exported st, #export_decls st) + else + (IS.add (#exported st, n), + (DExport (Rpc, n), loc) :: #export_decls st) + + val st = {cpsed = #cpsed st, + cps_decls = #cps_decls st, + + exported = exported, + export_decls = export_decls} in (EServerCall (n, args, trans2), st) end @@ -128,19 +144,26 @@ decl = fn x => x} st d in - (case #decls st of - [] => [d] - | ds => - case d of - (DValRec vis, loc) => [(DValRec (ds @ vis), loc)] - | (_, loc) => [(DValRec ds, loc), d], - {decls = [], - exps = #exps st}) + (List.revAppend (case #cps_decls st of + [] => [d] + | ds => + case d of + (DValRec vis, loc) => [(DValRec (ds @ vis), loc)] + | (_, loc) => [d, (DValRec ds, loc)], + #export_decls st), + {cpsed = #cpsed st, + cps_decls = [], + + exported = #exported st, + export_decls = []}) end val (file, _) = ListUtil.foldlMapConcat decl - {decls = [], - exps = IM.empty} + {cpsed = IM.empty, + cps_decls = [], + + exported = IS.empty, + export_decls = []} file in file