Mercurial > urweb
changeset 957:2831be2daf2e
Grid changed to use Dlist.replace; filters stopped working
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Thu, 17 Sep 2009 19:01:04 -0400 |
| parents | d80734855790 |
| children | 3aaac251a5af |
| files | demo/more/dlist.ur src/compiler.sig src/compiler.sml src/rpcify.sml src/sources src/tailify.sig src/tailify.sml |
| diffstat | 7 files changed, 256 insertions(+), 124 deletions(-) [+] |
line wrap: on
line diff
--- a/demo/more/dlist.ur Thu Sep 17 17:17:49 2009 -0400 +++ b/demo/more/dlist.ur Thu Sep 17 19:01:04 2009 -0400 @@ -58,7 +58,7 @@ case ls of [] => return acc | x :: ls => - this <- source (Cons (x, tl)); + this <- source (Cons (x, acc)); build ls this in hd <- build (List.rev ls) tl;
--- a/src/compiler.sig Thu Sep 17 17:17:49 2009 -0400 +++ b/src/compiler.sig Thu Sep 17 19:01:04 2009 -0400 @@ -86,6 +86,7 @@ val reduce : (Core.file, Core.file) phase val unpoly : (Core.file, Core.file) phase val specialize : (Core.file, Core.file) phase + val tailify : (Core.file, Core.file) phase val marshalcheck : (Core.file, Core.file) phase val effectize : (Core.file, Core.file) phase val monoize : (Core.file, Mono.file) phase @@ -120,6 +121,7 @@ val toSpecialize : (string, Core.file) transform val toShake3 : (string, Core.file) transform val toEspecialize : (string, Core.file) transform + val toTailify : (string, Core.file) transform val toReduce2 : (string, Core.file) transform val toShake4 : (string, Core.file) transform val toMarshalcheck : (string, Core.file) transform
--- a/src/compiler.sml Thu Sep 17 17:17:49 2009 -0400 +++ b/src/compiler.sml Thu Sep 17 19:01:04 2009 -0400 @@ -779,7 +779,14 @@ val toEspecialize = transform especialize "especialize" o toShake3 -val toReduce2 = transform reduce "reduce2" o toEspecialize +val tailify = { + func = Tailify.frob, + print = CorePrint.p_file CoreEnv.empty +} + +val toTailify = transform tailify "tailify" o toEspecialize + +val toReduce2 = transform reduce "reduce2" o toTailify val toShake4 = transform shake "shake4" o toReduce2
--- a/src/rpcify.sml Thu Sep 17 17:17:49 2009 -0400 +++ b/src/rpcify.sml Thu Sep 17 19:01:04 2009 -0400 @@ -32,26 +32,12 @@ 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 @@ (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 @@ 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 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 @@ 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
--- a/src/sources Thu Sep 17 17:17:49 2009 -0400 +++ b/src/sources Thu Sep 17 19:01:04 2009 -0400 @@ -131,6 +131,9 @@ rpcify.sig rpcify.sml +tailify.sig +tailify.sml + tag.sig tag.sml
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/tailify.sig Thu Sep 17 19:01:04 2009 -0400 @@ -0,0 +1,32 @@ +(* 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. + *) + +signature TAILIFY = sig + + val frob : Core.file -> Core.file + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/tailify.sml Thu Sep 17 19:01:04 2009 -0400 @@ -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