adamc@484: (* Copyright (c) 2008, Adam Chlipala adamc@484: * All rights reserved. adamc@484: * adamc@484: * Redistribution and use in source and binary forms, with or without adamc@484: * modification, are permitted provided that the following conditions are met: adamc@484: * adamc@484: * - Redistributions of source code must retain the above copyright notice, adamc@484: * this list of conditions and the following disclaimer. adamc@484: * - Redistributions in binary form must reproduce the above copyright notice, adamc@484: * this list of conditions and the following disclaimer in the documentation adamc@484: * and/or other materials provided with the distribution. adamc@484: * - The names of contributors may not be used to endorse or promote products adamc@484: * derived from this software without specific prior written permission. adamc@484: * adamc@484: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@484: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@484: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@484: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@484: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@484: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@484: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@484: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@484: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@484: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@484: * POSSIBILITY OF SUCH DAMAGE. adamc@484: *) adamc@484: adamc@484: structure Defunc :> DEFUNC = struct adamc@484: adamc@484: open Core adamc@484: adamc@484: structure E = CoreEnv adamc@484: structure U = CoreUtil adamc@484: adamc@484: structure IS = IntBinarySet adamc@484: adamc@484: val functionInside = U.Con.exists {kind = fn _ => false, adamc@484: con = fn TFun _ => true adamc@484: | CFfi ("Basis", "transaction") => true adamc@484: | _ => false} adamc@484: adamc@626: val freeVars = U.Exp.foldB {kind = fn (_, _, xs) => xs, adamc@484: con = fn (_, _, xs) => xs, adamc@484: exp = fn (bound, e, xs) => adamc@484: case e of adamc@484: ERel x => adamc@484: if x >= bound then adamc@484: IS.add (xs, x - bound) adamc@484: else adamc@484: xs adamc@484: | _ => xs, adamc@484: bind = fn (bound, b) => adamc@484: case b of adamc@484: U.Exp.RelE _ => bound + 1 adamc@484: | _ => bound} adamc@484: 0 IS.empty adamc@484: adamc@484: fun positionOf (v : int, ls) = adamc@484: let adamc@484: fun pof (pos, ls) = adamc@484: case ls of adamc@484: [] => raise Fail "Defunc.positionOf" adamc@484: | v' :: ls' => adamc@484: if v = v' then adamc@484: pos adamc@484: else adamc@484: pof (pos + 1, ls') adamc@484: in adamc@484: pof (0, ls) adamc@484: end adamc@484: adamc@484: fun squish fvs = adamc@626: U.Exp.mapB {kind = fn _ => fn k => k, adamc@484: con = fn _ => fn c => c, adamc@484: exp = fn bound => fn e => adamc@484: case e of adamc@484: ERel x => adamc@484: if x >= bound then adamc@484: ERel (positionOf (x - bound, fvs) + bound) adamc@484: else adamc@484: e adamc@484: | _ => e, adamc@484: bind = fn (bound, b) => adamc@484: case b of adamc@484: U.Exp.RelE _ => bound + 1 adamc@484: | _ => bound} adamc@484: 0 adamc@484: adamc@484: fun default (_, x, st) = (x, st) adamc@484: adamc@484: datatype 'a search = adamc@484: Yes adamc@484: | No adamc@484: | Maybe of 'a adamc@484: adamc@484: structure EK = struct adamc@484: type ord_key = exp adamc@484: val compare = U.Exp.compare adamc@484: end adamc@484: adamc@484: structure EM = BinaryMapFn(EK) adamc@484: adamc@484: type state = { adamc@484: maxName : int, adamc@484: funcs : int EM.map, adamc@484: vis : (string * int * con * exp * string) list adamc@484: } adamc@484: adamc@484: fun exp (env, e, st) = adamc@484: case e of adamc@484: ERecord xes => adamc@484: let adamc@484: val (xes, st) = adamc@484: ListUtil.foldlMap adamc@484: (fn (tup as (fnam as (CName x, loc), e, xt), st) => adamc@485: if (x <> "Link" andalso x <> "Action") adamc@485: orelse case #1 e of adamc@485: ENamed _ => true adamc@485: | _ => false then adamc@484: (tup, st) adamc@484: else adamc@484: let adamc@484: fun needsAttention (e, _) = adamc@484: case e of adamc@484: ENamed f => Maybe (#2 (E.lookupENamed env f)) adamc@484: | EApp (f, _) => adamc@484: (case needsAttention f of adamc@484: No => No adamc@484: | Yes => Yes adamc@484: | Maybe t => adamc@484: case t of adamc@484: (TFun (dom, _), _) => adamc@484: if functionInside dom then adamc@484: Yes adamc@484: else adamc@484: No adamc@484: | _ => No) adamc@484: | _ => No adamc@484: adamc@484: fun headSymbol (e, _) = adamc@484: case e of adamc@484: ENamed f => f adamc@484: | EApp (e, _) => headSymbol e adamc@484: | _ => raise Fail "Defunc: headSymbol" adamc@484: adamc@484: fun rtype (e, _) = adamc@484: case e of adamc@484: ENamed f => #2 (E.lookupENamed env f) adamc@484: | EApp (f, _) => adamc@484: (case rtype f of adamc@484: (TFun (_, ran), _) => ran adamc@484: | _ => raise Fail "Defunc: rtype [1]") adamc@484: | _ => raise Fail "Defunc: rtype [2]" adamc@484: in adamc@484: (*Print.prefaces "Found one!" adamc@484: [("e", CorePrint.p_exp env e)];*) adamc@484: case needsAttention e of adamc@484: Yes => adamc@484: let adamc@484: (*val () = print "Yes\n"*) adamc@484: val f = headSymbol e adamc@484: adamc@484: val fvs = IS.listItems (freeVars e) adamc@484: adamc@484: val e = squish fvs e adamc@484: val (e, t) = foldl (fn (n, (e, t)) => adamc@484: let adamc@484: val (x, xt) = E.lookupERel env n adamc@484: in adamc@484: ((EAbs (x, xt, t, e), loc), adamc@484: (TFun (xt, t), loc)) adamc@484: end) adamc@484: (e, rtype e) fvs adamc@484: adamc@484: val (f', st) = adamc@484: case EM.find (#funcs st, e) of adamc@484: SOME f' => (f', st) adamc@484: | NONE => adamc@484: let adamc@484: val (fx, _, _, tag) = E.lookupENamed env f adamc@484: val f' = #maxName st adamc@484: adamc@484: val vi = (fx, f', t, e, tag) adamc@484: in adamc@484: (f', {maxName = f' + 1, adamc@484: funcs = EM.insert (#funcs st, e, f'), adamc@484: vis = vi :: #vis st}) adamc@484: end adamc@484: adamc@484: val e = foldr (fn (n, e) => adamc@484: (EApp (e, (ERel n, loc)), loc)) adamc@484: (ENamed f', loc) fvs adamc@484: in adamc@484: (*app (fn n => Print.prefaces adamc@484: "Free" adamc@484: [("n", CorePrint.p_exp env (ERel n, ErrorMsg.dummySpan))]) adamc@484: fvs; adamc@484: Print.prefaces "Squished" adamc@484: [("e", CorePrint.p_exp CoreEnv.empty e)];*) adamc@484: adamc@484: ((fnam, e, xt), st) adamc@484: end adamc@484: | _ => (tup, st) adamc@484: end adamc@484: | (tup, st) => (tup, st)) adamc@484: st xes adamc@484: in adamc@484: (ERecord xes, st) adamc@484: end adamc@484: | _ => (e, st) adamc@484: adamc@484: fun bind (env, b) = adamc@484: case b of adamc@626: U.Decl.RelK x => E.pushKRel env x adamc@626: | U.Decl.RelC (x, k) => E.pushCRel env x k adamc@484: | U.Decl.NamedC (x, n, k, co) => E.pushCNamed env x n k co adamc@484: | U.Decl.RelE (x, t) => E.pushERel env x t adamc@484: | U.Decl.NamedE (x, n, t, eo, s) => E.pushENamed env x n t eo s adamc@484: adamc@626: fun doDecl env = U.Decl.foldMapB {kind = default, adamc@484: con = default, adamc@484: exp = exp, adamc@484: decl = default, adamc@484: bind = bind} adamc@484: env adamc@484: adamc@484: fun defunc file = adamc@484: let adamc@484: fun doDecl' (d, (env, st)) = adamc@484: let adamc@484: val env = E.declBinds env d adamc@484: adamc@484: val (d, st) = doDecl env st d adamc@484: adamc@484: val ds = adamc@484: case #vis st of adamc@484: [] => [d] adamc@484: | vis => adamc@484: case d of adamc@484: (DValRec vis', loc) => [(DValRec (vis' @ vis), loc)] adamc@484: | _ => [(DValRec vis, #2 d), d] adamc@484: in adamc@484: (ds, adamc@484: (env, adamc@484: {maxName = #maxName st, adamc@484: funcs = #funcs st, adamc@484: vis = []})) adamc@484: end adamc@484: adamc@484: val (file, _) = ListUtil.foldlMapConcat doDecl' adamc@484: (E.empty, adamc@484: {maxName = U.File.maxName file + 1, adamc@484: funcs = EM.empty, adamc@484: vis = []}) adamc@484: file adamc@484: in adamc@484: file adamc@484: end adamc@484: adamc@484: end