From f4dbd4d3e80432cf1bd41d7f423580da153f11b8 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Tue, 16 Apr 2013 10:55:48 -0400 Subject: Basis.tryRpc --- src/core.sml | 6 ++++-- src/core_print.sml | 14 +++++++------- src/core_untangle.sml | 4 ++-- src/core_util.sml | 19 ++++++++++++++----- src/css.sml | 4 ++-- src/effectize.sml | 8 ++++---- src/especialize.sml | 8 ++++---- src/jscomp.sml | 21 ++++++++++++++++----- src/mono.sml | 4 ++-- src/mono_print.sml | 4 ++-- src/mono_reduce.sml | 4 ++-- src/mono_util.sml | 6 +++--- src/monoize.sml | 6 +++--- src/reduce.sml | 4 ++-- src/reduce_local.sml | 4 ++-- src/rpcify.sml | 38 ++++++++++++++++++++++++-------------- src/settings.sig | 2 +- src/shake.sml | 4 ++-- 18 files changed, 96 insertions(+), 64 deletions(-) (limited to 'src') diff --git a/src/core.sml b/src/core.sml index 4641d1ab..193825bf 100644 --- a/src/core.sml +++ b/src/core.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -86,6 +86,8 @@ datatype pat' = withtype pat = pat' located +datatype failure_mode = datatype Settings.failure_mode + datatype exp' = EPrim of Prim.t | ERel of int @@ -115,7 +117,7 @@ datatype exp' = | ELet of string * con * exp * exp - | EServerCall of int * exp list * con + | EServerCall of int * exp list * con * failure_mode withtype exp = exp' located diff --git a/src/core_print.sml b/src/core_print.sml index 910ec10a..f360f346 100644 --- a/src/core_print.sml +++ b/src/core_print.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2011, Adam Chlipala +(* Copyright (c) 2008-2011, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -446,12 +446,12 @@ fun p_exp' par env (e, _) = newline, p_exp (E.pushERel env x t) e2] - | EServerCall (n, es, _) => box [string "Server(", - p_enamed env n, - string ",", - space, - p_list (p_exp env) es, - string ")"] + | EServerCall (n, es, _, _) => box [string "Server(", + p_enamed env n, + string ",", + space, + p_list (p_exp env) es, + string ")"] | EKAbs (x, e) => box [string x, space, diff --git a/src/core_untangle.sml b/src/core_untangle.sml index d734cc6f..a3bb5595 100644 --- a/src/core_untangle.sml +++ b/src/core_untangle.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -48,7 +48,7 @@ fun exp thisGroup (e, s) = case e of ENamed n => try n | EClosure (n, _) => try n - | EServerCall (n, _, _) => try n + | EServerCall (n, _, _, _) => try n | _ => s end diff --git a/src/core_util.sml b/src/core_util.sml index d41dfe33..152ba7ac 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -439,6 +439,14 @@ fun pCompare ((p1, _), (p2, _)) = join (String.compare (x1, x2), fn () => pCompare (p1, p2))) (xps1, xps2) +fun fmCompare (fm1, fm2) = + case (fm1, fm2) of + (None, None) => EQUAL + | (None, _) => LESS + | (_, None) => GREATER + + | (Error, Error) => EQUAL + fun compare ((e1, _), (e2, _)) = case (e1, e2) of (EPrim p1, EPrim p2) => Prim.compare (p1, p2) @@ -547,9 +555,10 @@ fun compare ((e1, _), (e2, _)) = | (ELet _, _) => LESS | (_, ELet _) => GREATER - | (EServerCall (n1, es1, _), EServerCall (n2, es2, _)) => + | (EServerCall (n1, es1, _, fm1), EServerCall (n2, es2, _, fm2)) => join (Int.compare (n1, n2), - fn () => joinL compare (es1, es2)) + fn () => join (fmCompare (fm1, fm2), + fn () => joinL compare (es1, es2))) | (EServerCall _, _) => LESS | (_, EServerCall _) => GREATER @@ -738,12 +747,12 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, bind} = fn e2' => (ELet (x, t', e1', e2'), loc)))) - | EServerCall (n, es, t) => + | EServerCall (n, es, t, fm) => S.bind2 (ListUtil.mapfold (mfe ctx) es, fn es' => S.map2 (mfc ctx t, fn t' => - (EServerCall (n, es', t'), loc))) + (EServerCall (n, es', t', fm), loc))) | EKAbs (x, e) => S.map2 (mfe (bind (ctx, RelK x)) e, diff --git a/src/css.sml b/src/css.sml index 8ed6a05a..ece8cf6c 100644 --- a/src/css.sml +++ b/src/css.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2010, Adam Chlipala +(* Copyright (c) 2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -260,7 +260,7 @@ fun summarize file = in (merge' (sm1, sm2), classes) end - | EServerCall (_, es, _) => expList (es, classes) + | EServerCall (_, es, _, _) => expList (es, classes) and expList (es, classes) = foldl (fn (e, (sm, classes)) => let diff --git a/src/effectize.sml b/src/effectize.sml index 5096a945..332e1372 100644 --- a/src/effectize.sml +++ b/src/effectize.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2009-2010, Adam Chlipala +(* Copyright (c) 2009-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -46,7 +46,7 @@ fun effectize file = EFfi f => effectful f | EFfiApp (m, x, _) => effectful (m, x) | ENamed n => IM.inDomain (evs, n) - | EServerCall (n, _, _) => IM.inDomain (evs, n) + | EServerCall (n, _, _, _) => IM.inDomain (evs, n) | _ => false fun couldWriteOnload evs = U.Exp.exists {kind = fn _ => false, @@ -69,7 +69,7 @@ fun effectize file = fun exp writers readers pushers e = case e of ENamed n => IM.inDomain (pushers, n) - | EServerCall (n, _, _) => IM.inDomain (writers, n) andalso IM.inDomain (readers, n) + | EServerCall (n, _, _, _) => IM.inDomain (writers, n) andalso IM.inDomain (readers, n) | _ => false fun couldWriteWithRpc writers readers pushers = U.Exp.exists {kind = fn _ => false, @@ -80,7 +80,7 @@ fun effectize file = case e of EFfi ("Basis", "getCookie") => true | ENamed n => IM.inDomain (evs, n) - | EServerCall (n, _, _) => IM.inDomain (evs, n) + | EServerCall (n, _, _, _) => IM.inDomain (evs, n) | _ => false fun couldReadCookie evs = U.Exp.exists {kind = fn _ => false, diff --git a/src/especialize.sml b/src/especialize.sml index a3d59ef9..51e15a2d 100644 --- a/src/especialize.sml +++ b/src/especialize.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -205,7 +205,7 @@ fun calcConstArgs enclosingFunctions e = | EWrite e1 => ca depth e1 | EClosure (_, es) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es | ELet (_, _, e1, e2) => Int.min (ca depth e1, ca (depth + 1) e2) - | EServerCall (_, es, _) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es + | EServerCall (_, es, _, _) => foldl (fn (e, d) => Int.min (ca depth e, d)) maxInt es fun enterAbs depth e = case #1 e of @@ -348,11 +348,11 @@ fun specialize' (funcs, specialized) file = in ((ELet (x, t, e1, e2), loc), st) end - | EServerCall (n, es, t) => + | EServerCall (n, es, t, fm) => let val (es, st) = ListUtil.foldlMap (fn (e, st) => exp (env, e, st)) st es in - ((EServerCall (n, es, t), loc), st) + ((EServerCall (n, es, t, fm), loc), st) end in case getApp e of diff --git a/src/jscomp.sml b/src/jscomp.sml index 887fbc87..e0d87a8e 100644 --- a/src/jscomp.sml +++ b/src/jscomp.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -930,10 +930,21 @@ fun process (file : file) = st) end - | EServerCall (e, t, eff) => + | EServerCall (e, t, eff, fm) => let val (e, st) = jsE inner (e, st) val (unurl, st) = unurlifyExp loc (t, st) + val lastArg = case fm of + None => "null" + | Error => + let + val isN = if isNullable t then + "true" + else + "false" + in + "cons({c:\"c\",v:" ^ isN ^ "},null)" + end in (strcat [str ("{c:\"f\",f:rc,a:cons({c:\"c\",v:\"" ^ Settings.getUrlPrefix () @@ -944,7 +955,7 @@ fun process (file : file) = ^ (case eff of ReadCookieWrite => "true" | _ => "false") - ^ "},null)))))}")], + ^ "}," ^ lastArg ^ ")))))}")], st) end @@ -1231,11 +1242,11 @@ fun process (file : file) = ((ESignalSource e, loc), st) end - | EServerCall (e1, t, ef) => + | EServerCall (e1, t, ef, fm) => let val (e1, st) = exp outer (e1, st) in - ((EServerCall (e1, t, ef), loc), st) + ((EServerCall (e1, t, ef, fm), loc), st) end | ERecv (e1, t) => let diff --git a/src/mono.sml b/src/mono.sml index f269c52d..f5260419 100644 --- a/src/mono.sml +++ b/src/mono.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -120,7 +120,7 @@ datatype exp' = | ESignalBind of exp * exp | ESignalSource of exp - | EServerCall of exp * typ * effect + | EServerCall of exp * typ * effect * failure_mode | ERecv of exp * typ | ESleep of exp | ESpawn of exp diff --git a/src/mono_print.sml b/src/mono_print.sml index 12b36f2a..a5156aca 100644 --- a/src/mono_print.sml +++ b/src/mono_print.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -357,7 +357,7 @@ fun p_exp' par env (e, _) = p_exp env e, string ")"] - | EServerCall (n, _, _) => box [string "Server(", + | EServerCall (n, _, _, _) => box [string "Server(", p_exp env n, string ")"] | ERecv (n, _) => box [string "Recv(", diff --git a/src/mono_reduce.sml b/src/mono_reduce.sml index e7fac5ed..73adafa3 100644 --- a/src/mono_reduce.sml +++ b/src/mono_reduce.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008, Adam Chlipala +(* Copyright (c) 2008, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -515,7 +515,7 @@ fun reduce (file : file) = | ESignalBind (e1, e2) => summarize d e1 @ summarize d e2 | ESignalSource e => summarize d e - | EServerCall (e, _, _) => summarize d e @ [Unsure] + | EServerCall (e, _, _, _) => summarize d e @ [Unsure] | ERecv (e, _) => summarize d e @ [Unsure] | ESleep e => summarize d e @ [Unsure] | ESpawn e => summarize d e @ [Unsure] diff --git a/src/mono_util.sml b/src/mono_util.sml index 116dfa64..cb871891 100644 --- a/src/mono_util.sml +++ b/src/mono_util.sml @@ -380,12 +380,12 @@ fun mapfoldB {typ = fc, exp = fe, bind} = fn e' => (ESignalSource e', loc)) - | EServerCall (s, t, eff) => + | EServerCall (s, t, eff, fm) => S.bind2 (mfe ctx s, fn s' => S.map2 (mft t, fn t' => - (EServerCall (s', t', eff), loc))) + (EServerCall (s', t', eff, fm), loc))) | ERecv (s, t) => S.bind2 (mfe ctx s, fn s' => @@ -510,7 +510,7 @@ fun appLoc f = | ESignalReturn e1 => appl e1 | ESignalBind (e1, e2) => (appl e1; appl e2) | ESignalSource e1 => appl e1 - | EServerCall (e1, _, _) => appl e1 + | EServerCall (e1, _, _, _) => appl e1 | ERecv (e1, _) => appl e1 | ESleep e1 => appl e1 | ESpawn e1 => appl e1) diff --git a/src/monoize.sml b/src/monoize.sml index ce7bfbe9..e2f3d5ca 100644 --- a/src/monoize.sml +++ b/src/monoize.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2012, Adam Chlipala +(* Copyright (c) 2008-2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -4188,7 +4188,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = ((L'.ELet (x, t', e1, e2), loc), fm) end - | L.EServerCall (n, es, t) => + | L.EServerCall (n, es, t, fmode) => let val t = monoType env t val (_, ft, _, name) = Env.lookupENamed env n @@ -4218,7 +4218,7 @@ fun monoExp (env, st, fm) (all as (e, loc)) = else L'.ReadOnly - val e = (L'.EServerCall (call, t, eff), loc) + val e = (L'.EServerCall (call, t, eff, fmode), loc) val e = liftExpInExp 0 e val e = (L'.EAbs ("_", unit, unit, e), loc) in diff --git a/src/reduce.sml b/src/reduce.sml index f065fe2b..aa5408b0 100644 --- a/src/reduce.sml +++ b/src/reduce.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2011, Adam Chlipala +(* Copyright (c) 2008-2011, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -804,7 +804,7 @@ fun kindConAndExp (namedC, namedE) = (ELet (x, t, e1', exp (UnknownE :: env) e2), loc) end - | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) + | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc) in (*if dangling (edepth' (deKnown env)) r then (Print.prefaces "exp" [("e", CorePrint.p_exp CoreEnv.empty all), diff --git a/src/reduce_local.sml b/src/reduce_local.sml index a6e4f7fc..6fbc6a96 100644 --- a/src/reduce_local.sml +++ b/src/reduce_local.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -353,7 +353,7 @@ fun exp env (all as (e, loc)) = | ELet (x, t, e1, e2) => (ELet (x, con env t, exp env e1, exp (Unknown :: env) e2), loc) - | EServerCall (n, es, t) => (EServerCall (n, map (exp env) es, con env t), loc) + | EServerCall (n, es, t, fm) => (EServerCall (n, map (exp env) es, con env t, fm), loc) fun reduce file = let diff --git a/src/rpcify.sml b/src/rpcify.sml index f8aee6c7..551a1510 100644 --- a/src/rpcify.sml +++ b/src/rpcify.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2009, 2012, Adam Chlipala +(* Copyright (c) 2009, 2012-2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -42,15 +42,22 @@ type state = { fun frob file = let - val rpcBaseIds = foldl (fn ((d, _), rpcIds) => - case d of - DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => IS.add (rpcIds, n) - | DVal (_, n, _, (ENamed n', _), _) => if IS.member (rpcIds, n') then - IS.add (rpcIds, n) - else - rpcIds - | _ => rpcIds) - IS.empty file + val (rpcBaseIds, trpcBaseIds) = + foldl (fn ((d, _), (rpcIds, trpcIds)) => + case d of + DVal (_, n, _, (EFfi ("Basis", "rpc"), _), _) => + (IS.add (rpcIds, n), trpcIds) + | DVal (_, n, _, (EFfi ("Basis", "tryRpc"), _), _) => + (rpcIds, IS.add (trpcIds, n)) + | DVal (_, n, _, (ENamed n', _), _) => + if IS.member (rpcIds, n') then + (IS.add (rpcIds, n), trpcIds) + else if IS.member (trpcIds, n') then + (rpcIds, IS.add (trpcIds, n)) + else + (rpcIds, trpcIds) + | _ => (rpcIds, trpcIds)) + (IS.empty, IS.empty) file val tfuncs = foldl (fn ((d, _), tfuncs) => @@ -89,7 +96,7 @@ fun frob file = | EApp (e1, e2) => getApp (#1 e1, e2 :: args) | _ => NONE - fun newRpc (trans : exp, st : state) = + fun newRpc (trans : exp, st : state, fm) = case getApp (#1 trans, []) of NONE => (ErrorMsg.errorAt (#2 trans) "RPC code doesn't use a named function or transaction"; @@ -114,16 +121,19 @@ fun frob file = val st = {exported = exported, export_decls = export_decls} - val e' = EServerCall (n, args, ran) + val e' = EServerCall (n, args, ran, fm) in (e', st) end in case e of - EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st) + EApp ((ECApp ((EFfi ("Basis", "rpc"), _), ran), _), trans) => newRpc (trans, st, None) + | EApp ((ECApp ((EFfi ("Basis", "tryRpc"), _), ran), _), trans) => newRpc (trans, st, Error) | EApp ((ECApp ((ENamed n, _), ran), _), trans) => if IS.member (rpcBaseIds, n) then - newRpc (trans, st) + newRpc (trans, st, None) + else if IS.member (trpcBaseIds, n) then + newRpc (trans, st, Error) else (e, st) diff --git a/src/settings.sig b/src/settings.sig index 3e3f0985..453ba486 100644 --- a/src/settings.sig +++ b/src/settings.sig @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2011, Adam Chlipala +(* Copyright (c) 2008-2011, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without diff --git a/src/shake.sml b/src/shake.sml index 096c31fd..57ebec8e 100644 --- a/src/shake.sml +++ b/src/shake.sml @@ -1,4 +1,4 @@ -(* Copyright (c) 2008-2010, Adam Chlipala +(* Copyright (c) 2008-2010, 2013, Adam Chlipala * All rights reserved. * * Redistribution and use in source and binary forms, with or without @@ -186,7 +186,7 @@ fun shake file = in case e of ENamed n => check n - | EServerCall (n, _, _) => check n + | EServerCall (n, _, _, _) => check n | _ => s end -- cgit v1.2.3