From e5e468f67bf1442ad295681039ce31e17931ba5d Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Thu, 17 Sep 2009 19:01:04 -0400 Subject: Grid changed to use Dlist.replace; filters stopped working --- src/rpcify.sml | 126 ++------------------------------------------------------- 1 file changed, 4 insertions(+), 122 deletions(-) (limited to 'src/rpcify.sml') diff --git a/src/rpcify.sml b/src/rpcify.sml index 4ed90228..0e5a1076 100644 --- a/src/rpcify.sml +++ b/src/rpcify.sml @@ -32,26 +32,12 @@ open Core structure U = CoreUtil structure E = CoreEnv -fun multiLiftExpInExp n e = - if n = 0 then - e - else - multiLiftExpInExp (n - 1) (E.liftExpInExp 0 e) - structure IS = IntBinarySet structure IM = IntBinaryMap -structure SS = BinarySetFn(struct - type ord_key = string - val compare = String.compare - end) - type state = { exported : IS.set, - export_decls : decl list, - - cpsed : exp' IM.map, - rpc : IS.set + export_decls : decl list } fun frob file = @@ -124,9 +110,7 @@ fun frob file = (DExport (Rpc ReadWrite, n), loc) :: #export_decls st) val st = {exported = exported, - export_decls = export_decls, - cpsed = #cpsed st, - rpc = #rpc st} + export_decls = export_decls} val k = (ECApp ((EFfi ("Basis", "return"), loc), (CFfi ("Basis", "transaction"), loc)), loc) @@ -145,11 +129,6 @@ fun frob file = else (e, st) - | ENamed n => - (case IM.find (#cpsed st, n) of - NONE => (e, st) - | SOME re => (re, st)) - | _ => (e, st) end @@ -159,99 +138,6 @@ fun frob file = fun decl (d, st : state) = let - val makesServerCall = U.Exp.exists {kind = fn _ => false, - con = fn _ => false, - exp = fn EFfi ("Basis", "rpc") => true - | ENamed n => IS.member (#rpc st, n) - | _ => false} - - val (d, st) = - case #1 d of - DValRec vis => - if List.exists (fn (_, _, _, e, _) => makesServerCall e) vis then - let - val rpc = foldl (fn ((_, n, _, _, _), rpc) => - IS.add (rpc, n)) (#rpc st) vis - - val (cpsed, vis') = - foldl (fn (vi as (x, n, t, e, s), (cpsed, vis')) => - let - fun getArgs (t, acc) = - case #1 t of - TFun (dom, ran) => - getArgs (ran, dom :: acc) - | _ => (rev acc, t) - val (ts, ran) = getArgs (t, []) - val ran = case #1 ran of - CApp (_, ran) => ran - | _ => raise Fail "Rpcify: Tail function not transactional" - val len = length ts - - val loc = #2 e - val args = ListUtil.mapi - (fn (i, _) => - (ERel (len - i - 1), loc)) - ts - val k = (EFfi ("Basis", "return"), loc) - val trans = (CFfi ("Basis", "transaction"), loc) - val k = (ECApp (k, trans), loc) - val k = (ECApp (k, ran), loc) - val k = (EApp (k, (EFfi ("Basis", "transaction_monad"), - loc)), loc) - val re = (ETailCall (n, args, k, ran, ran), loc) - val (re, _) = foldr (fn (dom, (re, ran)) => - ((EAbs ("x", dom, ran, re), - loc), - (TFun (dom, ran), loc))) - (re, ran) ts - - val be = multiLiftExpInExp (len + 1) e - val be = ListUtil.foldli - (fn (i, _, be) => - (EApp (be, (ERel (len - i), loc)), loc)) - be ts - val ne = (EFfi ("Basis", "bind"), loc) - val ne = (ECApp (ne, trans), loc) - val ne = (ECApp (ne, ran), loc) - val unit = (TRecord (CRecord ((KType, loc), []), - loc), loc) - val ne = (ECApp (ne, unit), loc) - val ne = (EApp (ne, (EFfi ("Basis", "transaction_monad"), - loc)), loc) - val ne = (EApp (ne, be), loc) - val ne = (EApp (ne, (ERel 0, loc)), loc) - val tunit = (CApp (trans, unit), loc) - val kt = (TFun (ran, tunit), loc) - val ne = (EAbs ("k", kt, tunit, ne), loc) - val (ne, res) = foldr (fn (dom, (ne, ran)) => - ((EAbs ("x", dom, ran, ne), loc), - (TFun (dom, ran), loc))) - (ne, (TFun (kt, tunit), loc)) ts - in - (IM.insert (cpsed, n, #1 re), - (x, n, res, ne, s) :: vis') - end) - (#cpsed st, []) vis - in - ((DValRec (rev vis'), ErrorMsg.dummySpan), - {exported = #exported st, - export_decls = #export_decls st, - cpsed = cpsed, - rpc = rpc}) - end - else - (d, st) - | DVal (x, n, t, e, s) => - (d, - {exported = #exported st, - export_decls = #export_decls st, - cpsed = #cpsed st, - rpc = if makesServerCall e then - IS.add (#rpc st, n) - else - #rpc st}) - | _ => (d, st) - val (d, st) = U.Decl.foldMap {kind = fn x => x, con = fn x => x, exp = exp, @@ -260,16 +146,12 @@ fun frob file = in (#export_decls st @ [d], {exported = #exported st, - export_decls = [], - cpsed = #cpsed st, - rpc = #rpc st}) + export_decls = []}) end val (file, _) = ListUtil.foldlMapConcat decl {exported = IS.empty, - export_decls = [], - cpsed = IM.empty, - rpc = rpcBaseIds} + export_decls = []} file in file -- cgit v1.2.3