diff options
author | 2010-12-18 14:17:45 -0500 | |
---|---|---|
committer | 2010-12-18 14:17:45 -0500 | |
commit | 39cd3aba26129807a15ccc29bb9f71e2537c4551 (patch) | |
tree | a234fad234187fc2eb74166ebdcd4e810bf60d30 /src | |
parent | 496433cdd2f108b483e4762776dfe1305c466eee (diff) |
Change tasks to support parametric code; add clientLeaves
Diffstat (limited to 'src')
-rw-r--r-- | src/cjr.sml | 4 | ||||
-rw-r--r-- | src/cjr_print.sml | 72 | ||||
-rw-r--r-- | src/cjrize.sml | 7 | ||||
-rw-r--r-- | src/elaborate.sml | 5 | ||||
-rw-r--r-- | src/prepare.sml | 4 |
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) |