Change tasks to support parametric code; add clientLeaves

5 files changed, 63 insertions, 29 deletions

diff --git a/src/cjr.sml b/src/cjr.sml
index 5013033f..c57128cf 100644
--- a/src/cjr.sml
+++ b/src/cjr.sml
@@ -103,7 +103,7 @@ datatype exp' =
 
 withtype exp = exp' located
 
-datatype task = Initialize
+datatype task = Initialize | ClientLeaves
 
 datatype decl' =
          DStruct of int * (string * typ) list
@@ -123,7 +123,7 @@ datatype decl' =
        | DCookie of string
        | DStyle of string
 
-       | DTask of task * exp
+       | DTask of task * string (* first arg name *) * string * exp
        | DOnError of int
 
 withtype decl = decl' located
diff --git a/src/cjr_print.sml b/src/cjr_print.sml
index fbbbc548..2bb5775e 100644
--- a/src/cjr_print.sml
+++ b/src/cjr_print.sml
@@ -2794,7 +2794,8 @@ fun p_file env (ds, ps) =
                  string "}",
                  newline]
 
-        val initializers = List.mapPartial (fn (DTask (Initialize, e), _) => SOME e | _ => NONE) ds
+        val initializers = List.mapPartial (fn (DTask (Initialize, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds
+        val expungers = List.mapPartial (fn (DTask (ClientLeaves, x1, x2, e), _) => SOME (x1, x2, e) | _ => NONE) ds
 
         val onError = ListUtil.search (fn (DOnError n, _) => SOME n | _ => NONE) ds
 
@@ -2968,31 +2969,58 @@ fun p_file env (ds, ps) =
              newline,
              newline,
 
-             if hasDb then
-                 box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
-                      newline,
+             box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) {",
+                  newline,
+
+                  p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
+                                                              newline,
+                                                              string "uw_Basis_client __uwr_",
+                                                              string x1,
+                                                              string "_0 = cli;",
+                                                              newline,
+                                                              string "uw_unit __uwr_",
+                                                              string x2,
+                                                              string "_1 = uw_unit_v;",
+                                                              newline,
+                                                              p_exp (E.pushERel (E.pushERel env x1 (TFfi ("Basis", "client"), ErrorMsg.dummySpan))
+                                                                                x2 dummyt) e,
+                                                              string ";",
+                                                              newline,
+                                                              string "});",
+                                                              newline]) expungers,
+
+                  if hasDb then
                       box [p_enamed env (!expunge),
                            string "(ctx, cli);",
-                           newline],
-                      string "}",
-                      newline,
-                      newline,
+                           newline]
+                  else
+                      box [],
+                  string "}"],
 
-                      string "static void uw_initializer(uw_context ctx) {",
-                      newline,
-                      box [p_list_sep (box []) (fn e => box [p_exp env e,
-                                                             string ";",
-                                                             newline]) initializers,
-                           p_enamed env (!initialize),
+             newline,
+             string "static void uw_initializer(uw_context ctx) {",
+             newline,
+             box [p_list_sep (box []) (fn (x1, x2, e) => box [string "({",
+                                                              newline,
+                                                              string "uw_unit __uwr_",
+                                                              string x1,
+                                                              string "_0 = uw_unit_v, __uwr_",
+                                                              string x2,
+                                                              string "_1 = uw_unit_v;",
+                                                              newline,
+                                                              p_exp (E.pushERel (E.pushERel env x1 dummyt) x2 dummyt) e,
+                                                              string ";",
+                                                              newline,
+                                                              string "});",
+                                                              newline]) initializers,
+                  if hasDb then
+                      box [p_enamed env (!initialize),
                            string "(ctx, uw_unit_v);",
-                           newline],
-                      string "}",
-                      newline]
-             else
-                 box [string "static void uw_expunger(uw_context ctx, uw_Basis_client cli) { };",
-                      newline,
-                      string "static void uw_initializer(uw_context ctx) { };",
-                      newline],
+                           newline]
+                  else
+                      box []],
+             string "}",
+             newline,
 
              case onError of
                  NONE => box []
diff --git a/src/cjrize.sml b/src/cjrize.sml
index 2915b0ca..0505af62 100644
--- a/src/cjrize.sml
+++ b/src/cjrize.sml
@@ -1,4 +1,4 @@
-(* Copyright (c) 2008, Adam Chlipala
+(* Copyright (c) 2008-2010, Adam Chlipala
  * All rights reserved.
  *
  * Redistribution and use in source and binary forms, with or without
@@ -662,15 +662,16 @@ fun cifyDecl ((d, loc), sm) =
       | L.DStyle args => (SOME (L'.DStyle args, loc), NONE, sm)
       | L.DTask (e1, e2) =>
         (case #1 e2 of
-             L.EAbs (_, _, _, e) =>
+             L.EAbs (x1, _, _, (L.EAbs (x2, _, _, e), _)) =>
              let
                  val tk = case #1 e1 of
                               L.EFfi ("Basis", "initialize") => L'.Initialize
+                            | L.EFfi ("Basis", "clientLeaves") => L'.ClientLeaves
                             | _ => (ErrorMsg.errorAt loc "Task kind not fully determined";
                                     L'.Initialize)
                  val (e, sm) = cifyExp (e, sm)
              in
-                 (SOME (L'.DTask (tk, e), loc), NONE, sm)
+                 (SOME (L'.DTask (tk, x1, x2, e), loc), NONE, sm)
              end
            | _ => (ErrorMsg.errorAt loc "Initializer has not been fully determined";
                    (NONE, NONE, sm)))
diff --git a/src/elaborate.sml b/src/elaborate.sml
index b1515b6e..76e22139 100644
--- a/src/elaborate.sml
+++ b/src/elaborate.sml
@@ -3962,9 +3962,14 @@ and elabDecl (dAll as (d, loc), (env, denv, gs)) =
                     val (e1', t1, gs1) = elabExp (env, denv) e1
                     val (e2', t2, gs2) = elabExp (env, denv) e2
 
+                    val targ = cunif (loc, (L'.KType, loc))
+
                     val t1' = (L'.CModProj (!basis_r, [], "task_kind"), loc)
+                    val t1' = (L'.CApp (t1', targ), loc)
+
                     val t2' = (L'.CApp ((L'.CModProj (!basis_r, [], "transaction"), loc),
                                         (L'.TRecord (L'.CRecord ((L'.KType, loc), []), loc), loc)), loc)
+                    val t2' = (L'.TFun (targ, t2'), loc)
                 in
                     checkCon env e1' t1 t1';
                     checkCon env e2' t2 t2';
diff --git a/src/prepare.sml b/src/prepare.sml
index 4d81940f..1b7454dc 100644
--- a/src/prepare.sml
+++ b/src/prepare.sml
@@ -325,11 +325,11 @@ fun prepDecl (d as (_, loc), st) =
       | DJavaScript _ => (d, st)
       | DCookie _ => (d, st)
       | DStyle _ => (d, st)
-      | DTask (tk, e) =>
+      | DTask (tk, x1, x2, e) =>
         let
             val (e, st) = prepExp (e, st)
         in
-            ((DTask (tk, e), loc), st)
+            ((DTask (tk, x1, x2, e), loc), st)
         end
       | DOnError _ => (d, st)