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