Mercurial > urweb
changeset 484:685b41e85634
Defunctionalization gets CommentBlog working
| author | Adam Chlipala <adamc@hcoop.net> |
|---|---|
| date | Sun, 09 Nov 2008 16:54:42 -0500 |
| parents | a0f47540d8ad |
| children | 3ce20b0b6914 |
| files | src/compiler.sig src/compiler.sml src/core_util.sig src/core_util.sml src/defunc.sig src/defunc.sml src/sources |
| diffstat | 7 files changed, 330 insertions(+), 1 deletions(-) [+] |
line wrap: on
line diff
--- a/src/compiler.sig Sun Nov 09 12:41:34 2008 -0500 +++ b/src/compiler.sig Sun Nov 09 16:54:42 2008 -0500 @@ -65,6 +65,7 @@ val especialize : (Core.file, Core.file) phase val core_untangle : (Core.file, Core.file) phase val shake : (Core.file, Core.file) phase + val defunc : (Core.file, Core.file) phase val tag : (Core.file, Core.file) phase val reduce : (Core.file, Core.file) phase val unpoly : (Core.file, Core.file) phase @@ -89,6 +90,7 @@ val toEspecialize : (string, Core.file) transform val toCore_untangle : (string, Core.file) transform val toShake1 : (string, Core.file) transform + val toDefunc : (string, Core.file) transform val toTag : (string, Core.file) transform val toReduce : (string, Core.file) transform val toUnpoly : (string, Core.file) transform
--- a/src/compiler.sml Sun Nov 09 12:41:34 2008 -0500 +++ b/src/compiler.sml Sun Nov 09 16:54:42 2008 -0500 @@ -439,12 +439,19 @@ val toShake1 = transform shake "shake1" o toCore_untangle +val defunc = { + func = Defunc.defunc, + print = CorePrint.p_file CoreEnv.empty +} + +val toDefunc = transform defunc "defunc" o toShake1 + val tag = { func = Tag.tag, print = CorePrint.p_file CoreEnv.empty } -val toTag = transform tag "tag" o toShake1 +val toTag = transform tag "tag" o toDefunc val reduce = { func = Reduce.reduce,
--- a/src/core_util.sig Sun Nov 09 12:41:34 2008 -0500 +++ b/src/core_util.sig Sun Nov 09 16:54:42 2008 -0500 @@ -105,6 +105,12 @@ con : Core.con' * 'state -> 'state, exp : Core.exp' * 'state -> 'state} -> 'state -> Core.exp -> 'state + + val foldB : {kind : Core.kind' * 'state -> 'state, + con : 'context * Core.con' * 'state -> 'state, + exp : 'context * Core.exp' * 'state -> 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.exp -> 'state val exists : {kind : Core.kind' -> bool, con : Core.con' -> bool, @@ -148,6 +154,12 @@ exp : Core.exp' * 'state -> Core.exp' * 'state, decl : Core.decl' * 'state -> Core.decl' * 'state} -> 'state -> Core.decl -> Core.decl * 'state + val foldMapB : {kind : Core.kind' * 'state -> Core.kind' * 'state, + con : 'context * Core.con' * 'state -> Core.con' * 'state, + exp : 'context * Core.exp' * 'state -> Core.exp' * 'state, + decl : 'context * Core.decl' * 'state -> Core.decl' * 'state, + bind : 'context * binder -> 'context} + -> 'context -> 'state -> Core.decl -> Core.decl * 'state end structure File : sig
--- a/src/core_util.sml Sun Nov 09 12:41:34 2008 -0500 +++ b/src/core_util.sml Sun Nov 09 16:54:42 2008 -0500 @@ -709,6 +709,14 @@ S.Continue (_, s) => s | S.Return _ => raise Fail "CoreUtil.Exp.fold: Impossible" +fun foldB {kind, con, exp, bind} ctx s e = + case mapfoldB {kind = fn k => fn s => S.Continue (k, kind (k, s)), + con = fn ctx => fn c => fn s => S.Continue (c, con (ctx, c, s)), + exp = fn ctx => fn e => fn s => S.Continue (e, exp (ctx, e, s)), + bind = bind} ctx e s of + S.Continue (_, s) => s + | S.Return _ => raise Fail "CoreUtil.Exp.foldB: Impossible" + fun exists {kind, con, exp} k = case mapfold {kind = fn k => fn () => if kind k then @@ -861,6 +869,15 @@ S.Continue v => v | S.Return _ => raise Fail "CoreUtil.Decl.foldMap: Impossible" +fun foldMapB {kind, con, exp, decl, bind} ctx s d = + case mapfoldB {kind = fn k => fn s => S.Continue (kind (k, s)), + con = fn ctx => fn c => fn s => S.Continue (con (ctx, c, s)), + exp = fn ctx => fn e => fn s => S.Continue (exp (ctx, e, s)), + decl = fn ctx => fn d => fn s => S.Continue (decl (ctx, d, s)), + bind = bind} ctx d s of + S.Continue v => v + | S.Return _ => raise Fail "CoreUtil.Decl.foldMapB: Impossible" + end structure File = struct
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/defunc.sig Sun Nov 09 16:54:42 2008 -0500 @@ -0,0 +1,32 @@ +(* Copyright (c) 2008, 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 DEFUNC = sig + + val defunc : Core.file -> Core.file + +end
--- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/src/defunc.sml Sun Nov 09 16:54:42 2008 -0500 @@ -0,0 +1,256 @@ +(* Copyright (c) 2008, 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 Defunc :> DEFUNC = struct + +open Core + +structure E = CoreEnv +structure U = CoreUtil + +structure IS = IntBinarySet + +val functionInside = U.Con.exists {kind = fn _ => false, + con = fn TFun _ => true + | CFfi ("Basis", "transaction") => true + | _ => false} + +val freeVars = U.Exp.foldB {kind = fn (_, xs) => xs, + con = fn (_, _, xs) => xs, + exp = fn (bound, e, xs) => + case e of + ERel x => + if x >= bound then + IS.add (xs, x - bound) + else + xs + | _ => xs, + bind = fn (bound, b) => + case b of + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 IS.empty + +fun positionOf (v : int, ls) = + let + fun pof (pos, ls) = + case ls of + [] => raise Fail "Defunc.positionOf" + | v' :: ls' => + if v = v' then + pos + else + pof (pos + 1, ls') + in + pof (0, ls) + end + +fun squish fvs = + U.Exp.mapB {kind = fn k => k, + con = fn _ => fn c => c, + exp = fn bound => fn e => + case e of + ERel x => + if x >= bound then + ERel (positionOf (x - bound, fvs) + bound) + else + e + | _ => e, + bind = fn (bound, b) => + case b of + U.Exp.RelE _ => bound + 1 + | _ => bound} + 0 + +fun default (_, x, st) = (x, st) + +datatype 'a search = + Yes + | No + | Maybe of 'a + +structure EK = struct +type ord_key = exp +val compare = U.Exp.compare +end + +structure EM = BinaryMapFn(EK) + +type state = { + maxName : int, + funcs : int EM.map, + vis : (string * int * con * exp * string) list +} + +fun exp (env, e, st) = + case e of + ERecord xes => + let + val (xes, st) = + ListUtil.foldlMap + (fn (tup as (fnam as (CName x, loc), e, xt), st) => + if x <> "Link" andalso x <> "Action" then + (tup, st) + else + let + fun needsAttention (e, _) = + case e of + ENamed f => Maybe (#2 (E.lookupENamed env f)) + | EApp (f, _) => + (case needsAttention f of + No => No + | Yes => Yes + | Maybe t => + case t of + (TFun (dom, _), _) => + if functionInside dom then + Yes + else + No + | _ => No) + | _ => No + + fun headSymbol (e, _) = + case e of + ENamed f => f + | EApp (e, _) => headSymbol e + | _ => raise Fail "Defunc: headSymbol" + + fun rtype (e, _) = + case e of + ENamed f => #2 (E.lookupENamed env f) + | EApp (f, _) => + (case rtype f of + (TFun (_, ran), _) => ran + | _ => raise Fail "Defunc: rtype [1]") + | _ => raise Fail "Defunc: rtype [2]" + in + (*Print.prefaces "Found one!" + [("e", CorePrint.p_exp env e)];*) + case needsAttention e of + Yes => + let + (*val () = print "Yes\n"*) + val f = headSymbol e + + val fvs = IS.listItems (freeVars e) + + val e = squish fvs e + val (e, t) = foldl (fn (n, (e, t)) => + let + val (x, xt) = E.lookupERel env n + in + ((EAbs (x, xt, t, e), loc), + (TFun (xt, t), loc)) + end) + (e, rtype e) fvs + + val (f', st) = + case EM.find (#funcs st, e) of + SOME f' => (f', st) + | NONE => + let + val (fx, _, _, tag) = E.lookupENamed env f + val f' = #maxName st + + val vi = (fx, f', t, e, tag) + in + (f', {maxName = f' + 1, + funcs = EM.insert (#funcs st, e, f'), + vis = vi :: #vis st}) + end + + val e = foldr (fn (n, e) => + (EApp (e, (ERel n, loc)), loc)) + (ENamed f', loc) fvs + in + (*app (fn n => Print.prefaces + "Free" + [("n", CorePrint.p_exp env (ERel n, ErrorMsg.dummySpan))]) + fvs; + Print.prefaces "Squished" + [("e", CorePrint.p_exp CoreEnv.empty e)];*) + + ((fnam, e, xt), st) + end + | _ => (tup, st) + end + | (tup, st) => (tup, st)) + st xes + in + (ERecord xes, st) + end + | _ => (e, st) + +fun bind (env, b) = + case b of + U.Decl.RelC (x, k) => E.pushCRel env x k + | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co + | U.Decl.RelE (x, t) => E.pushERel env x t + | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s + +fun doDecl env = U.Decl.foldMapB {kind = fn x => x, + con = default, + exp = exp, + decl = default, + bind = bind} + env + +fun defunc file = + let + fun doDecl' (d, (env, st)) = + let + val env = E.declBinds env d + + val (d, st) = doDecl env st d + + val ds = + case #vis st of + [] => [d] + | vis => + case d of + (DValRec vis', loc) => [(DValRec (vis' @ vis), loc)] + | _ => [(DValRec vis, #2 d), d] + in + (ds, + (env, + {maxName = #maxName st, + funcs = #funcs st, + vis = []})) + end + + val (file, _) = ListUtil.foldlMapConcat doDecl' + (E.empty, + {maxName = U.File.maxName file + 1, + funcs = EM.empty, + vis = []}) + file + in + file + end + +end