From 58d54b5e088ae016b6ec2f38bc2faa9852b3aacd 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/tailify.sml | 206 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 206 insertions(+) create mode 100644 src/tailify.sml (limited to 'src/tailify.sml') diff --git a/src/tailify.sml b/src/tailify.sml new file mode 100644 index 00000000..4b086e09 --- /dev/null +++ b/src/tailify.sml @@ -0,0 +1,206 @@ +(* Copyright (c) 2009, Adam Chlipala + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions are met: + * + * - Redistributions of source code must retain the above copyright notice, + * this list of conditions and the following disclaimer. + * - Redistributions in binary form must reproduce the above copyright notice, + * this list of conditions and the following disclaimer in the documentation + * and/or other materials provided with the distribution. + * - The names of contributors may not be used to endorse or promote products + * derived from this software without specific prior written permission. + * + * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" + * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE + * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE + * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE + * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR + * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF + * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS + * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN + * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) + * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE + * POSSIBILITY OF SUCH DAMAGE. + *) + +structure Tailify :> TAILIFY = struct + +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 + +type state = { + cpsed : exp' IM.map, + rpc : IS.set +} + +fun frob file = + let + fun exp (e, st : state) = + case e of + ENamed n => + (case IM.find (#cpsed st, n) of + NONE => (e, st) + | SOME re => (re, st)) + + | _ => (e, st) + + and doExp (e, st) = U.Exp.foldMap {kind = fn x => x, + con = fn x => x, + exp = exp} st (ReduceLocal.reduceExp e) + + fun decl (d, st : state) = + let + fun makesServerCall b (e, _) = + case e of + EServerCall _ => true + | ETailCall _ => raise Fail "Tailify: ETailCall too early" + | ENamed n => IS.member (#rpc st, n) + + | EPrim _ => false + | ERel n => List.nth (b, n) + | ECon (_, _, _, NONE) => false + | ECon (_, _, _, SOME e) => makesServerCall b e + | EFfi _ => false + | EFfiApp (_, _, es) => List.exists (makesServerCall b) es + | EApp (e1, e2) => makesServerCall b e1 orelse makesServerCall b e2 + | EAbs (_, _, _, e1) => makesServerCall (false :: b) e1 + | ECApp (e1, _) => makesServerCall b e1 + | ECAbs (_, _, e1) => makesServerCall b e1 + + | EKAbs (_, e1) => makesServerCall b e1 + | EKApp (e1, _) => makesServerCall b e1 + + | ERecord xes => List.exists (fn ((CName s, _), e, _) => + not (String.isPrefix "On" s) andalso makesServerCall b e + | (_, e, _) => makesServerCall b e) xes + | EField (e1, _, _) => makesServerCall b e1 + | EConcat (e1, _, e2, _) => makesServerCall b e1 orelse makesServerCall b e2 + | ECut (e1, _, _) => makesServerCall b e1 + | ECutMulti (e1, _, _) => makesServerCall b e1 + + | ECase (e1, pes, _) => makesServerCall b e1 + orelse List.exists (fn (p, e) => + makesServerCall (List.tabulate (E.patBindsN p, + fn _ => false) @ b) + e) pes + + | EWrite e1 => makesServerCall b e1 + + | EClosure (_, es) => List.exists (makesServerCall b) es + + | ELet (_, _, e1, e2) => makesServerCall (makesServerCall b e1 :: b) e2 + + val makesServerCall = makesServerCall [] + + 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), + {cpsed = cpsed, + rpc = rpc}) + end + else + (d, st) + | DVal (x, n, t, e, s) => + (d, + {cpsed = #cpsed st, + rpc = if makesServerCall e then + IS.add (#rpc st, n) + else + #rpc st}) + | _ => (d, st) + in + U.Decl.foldMap {kind = fn x => x, + con = fn x => x, + exp = exp, + decl = fn x => x} + st d + end + + val (file, _) = ListUtil.foldlMap decl + {cpsed = IM.empty, + rpc = IS.empty} + file + in + file + end + +end -- cgit v1.2.3