adamc@443: (* Copyright (c) 2008, Adam Chlipala adamc@443: * All rights reserved. adamc@443: * adamc@443: * Redistribution and use in source and binary forms, with or without adamc@443: * modification, are permitted provided that the following conditions are met: adamc@443: * adamc@443: * - Redistributions of source code must retain the above copyright notice, adamc@443: * this list of conditions and the following disclaimer. adamc@443: * - Redistributions in binary form must reproduce the above copyright notice, adamc@443: * this list of conditions and the following disclaimer in the documentation adamc@443: * and/or other materials provided with the distribution. adamc@443: * - The names of contributors may not be used to endorse or promote products adamc@443: * derived from this software without specific prior written permission. adamc@443: * adamc@443: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@443: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@443: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@443: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@443: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@443: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@443: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@443: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@443: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@443: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@443: * POSSIBILITY OF SUCH DAMAGE. adamc@443: *) adamc@443: adamc@443: structure ESpecialize :> ESPECIALIZE = struct adamc@443: adamc@443: open Core adamc@443: adamc@443: structure E = CoreEnv adamc@443: structure U = CoreUtil adamc@443: adamc@479: type skey = exp adamc@453: adamc@453: structure K = struct adamc@479: type ord_key = exp list adamc@479: val compare = Order.joinL U.Exp.compare adamc@443: end adamc@443: adamc@453: structure KM = BinaryMapFn(K) adamc@443: structure IM = IntBinaryMap adamc@443: adamc@479: val sizeOf = U.Exp.fold {kind = fn (_, n) => n, adamc@479: con = fn (_, n) => n, adamc@479: exp = fn (_, n) => n + 1} adamc@479: 0 adamc@479: adamc@479: val isOpen = U.Exp.existsB {kind = fn _ => false, adamc@479: con = fn ((nc, _), c) => adamc@479: case c of adamc@479: CRel n => n >= nc adamc@479: | _ => false, adamc@479: exp = fn ((_, ne), e) => adamc@479: case e of adamc@479: ERel n => n >= ne adamc@479: | _ => false, adamc@479: bind = fn ((nc, ne), b) => adamc@479: case b of adamc@479: U.Exp.RelC _ => (nc + 1, ne) adamc@479: | U.Exp.RelE _ => (nc, ne + 1) adamc@479: | _ => (nc, ne)} adamc@479: (0, 0) adamc@479: adamc@479: fun baseBad (e, _) = adamc@453: case e of adamc@479: EAbs (_, _, _, e) => sizeOf e > 20 adamc@479: | ENamed _ => false adamc@479: | _ => true adamc@453: adamc@479: fun isBad e = adamc@479: case e of adamc@479: (ERecord xes, _) => adamc@479: length xes > 10 adamc@479: orelse List.exists (fn (_, e, _) => baseBad e) xes adamc@479: | _ => baseBad e adamc@479: adamc@479: fun skeyIn e = adamc@479: if isBad e orelse isOpen e then adamc@479: NONE adamc@479: else adamc@479: SOME e adamc@479: adamc@479: fun skeyOut e = e adamc@453: adamc@443: type func = { adamc@443: name : string, adamc@453: args : int KM.map, adamc@443: body : exp, adamc@443: typ : con, adamc@443: tag : string adamc@443: } adamc@443: adamc@443: type state = { adamc@443: maxName : int, adamc@443: funcs : func IM.map, adamc@443: decls : (string * int * con * exp * string) list adamc@443: } adamc@443: adamc@443: fun kind (k, st) = (k, st) adamc@443: fun con (c, st) = (c, st) adamc@443: adamc@443: fun exp (e, st : state) = adamc@443: let adamc@443: fun getApp e = adamc@443: case e of adamc@443: ENamed f => SOME (f, [], []) adamc@480: | EField ((ERecord xes, _), (CName x, _), _) => adamc@480: (case List.find (fn ((CName x', _), _,_) => x' = x adamc@480: | _ => false) xes of adamc@480: NONE => NONE adamc@480: | SOME (_, (e, _), _) => getApp e) adamc@443: | EApp (e1, e2) => adamc@443: (case getApp (#1 e1) of adamc@443: NONE => NONE adamc@453: | SOME (f, xs, xs') => adamc@453: let adamc@453: val k = adamc@453: if List.null xs' then adamc@453: skeyIn e2 adamc@453: else adamc@453: NONE adamc@453: in adamc@453: case k of adamc@453: NONE => SOME (f, xs, xs' @ [e2]) adamc@453: | SOME k => SOME (f, xs @ [k], xs') adamc@453: end) adamc@443: | _ => NONE adamc@443: in adamc@443: case getApp e of adamc@443: NONE => (e, st) adamc@480: | SOME (f, [], xs') => (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) adamc@480: (ENamed f, ErrorMsg.dummySpan) xs'), st) adamc@443: | SOME (f, xs, xs') => adamc@443: case IM.find (#funcs st, f) of adamc@480: NONE => adamc@480: let adamc@480: val e = foldl (fn (arg, e) => (EApp (e, skeyOut arg), ErrorMsg.dummySpan)) adamc@480: (ENamed f, ErrorMsg.dummySpan) xs adamc@480: in adamc@480: (#1 (foldl (fn (arg, e) => (EApp (e, arg), ErrorMsg.dummySpan)) adamc@480: e xs'), st) adamc@480: end adamc@443: | SOME {name, args, body, typ, tag} => adamc@453: case KM.find (args, xs) of adamc@453: SOME f' => ((*Print.prefaces "Pre-existing" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))];*) adamc@453: (#1 (foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) adamc@453: (ENamed f', ErrorMsg.dummySpan) xs'), adamc@453: st)) adamc@443: | NONE => adamc@443: let adamc@453: (*val () = Print.prefaces "New" [("e", CorePrint.p_exp CoreEnv.empty (e, ErrorMsg.dummySpan))]*) adamc@453: adamc@443: fun subBody (body, typ, xs) = adamc@443: case (#1 body, #1 typ, xs) of adamc@443: (_, _, []) => SOME (body, typ) adamc@443: | (EAbs (_, _, _, body'), TFun (_, typ'), x :: xs) => adamc@453: let adamc@479: val body'' = E.subExpInExp (0, skeyOut x) body' adamc@453: in adamc@453: (*Print.prefaces "espec" [("body'", CorePrint.p_exp CoreEnv.empty body'), adamc@453: ("body''", CorePrint.p_exp CoreEnv.empty body'')];*) adamc@453: subBody (body'', adamc@453: typ', adamc@453: xs) adamc@453: end adamc@443: | _ => NONE adamc@443: in adamc@443: case subBody (body, typ, xs) of adamc@443: NONE => (e, st) adamc@443: | SOME (body', typ') => adamc@443: let adamc@443: val f' = #maxName st adamc@453: (*val () = print ("f' = " ^ Int.toString f' ^ "\n")*) adamc@443: val funcs = IM.insert (#funcs st, f, {name = name, adamc@453: args = KM.insert (args, xs, f'), adamc@443: body = body, adamc@443: typ = typ, adamc@443: tag = tag}) adamc@443: val st = { adamc@443: maxName = f' + 1, adamc@443: funcs = funcs, adamc@443: decls = #decls st adamc@443: } adamc@443: adamc@443: val (body', st) = specExp st body' adamc@443: val e' = foldl (fn (e, arg) => (EApp (e, arg), ErrorMsg.dummySpan)) adamc@443: (ENamed f', ErrorMsg.dummySpan) xs' adamc@443: in adamc@443: (#1 e', adamc@443: {maxName = #maxName st, adamc@443: funcs = #funcs st, adamc@444: decls = (name, f', typ', body', tag) :: #decls st}) adamc@443: end adamc@443: end adamc@443: end adamc@443: adamc@443: and specExp st = U.Exp.foldMap {kind = kind, con = con, exp = exp} st adamc@443: adamc@443: fun decl (d, st) = (d, st) adamc@443: adamc@443: val specDecl = U.Decl.foldMap {kind = kind, con = con, exp = exp, decl = decl} adamc@443: adamc@453: fun specialize' file = adamc@443: let adamc@453: fun doDecl (d, (st : state, changed)) = adamc@443: let adamc@453: val funcs = #funcs st adamc@453: val funcs = adamc@453: case #1 d of adamc@453: DValRec vis => adamc@453: foldl (fn ((x, n, c, e, tag), funcs) => adamc@453: IM.insert (funcs, n, {name = x, adamc@453: args = KM.empty, adamc@453: body = e, adamc@453: typ = c, adamc@453: tag = tag})) adamc@453: funcs vis adamc@453: | _ => funcs adamc@453: adamc@453: val st = {maxName = #maxName st, adamc@453: funcs = funcs, adamc@453: decls = []} adamc@453: adamc@443: val (d', st) = specDecl st d adamc@443: adamc@443: val funcs = #funcs st adamc@443: val funcs = adamc@443: case #1 d of adamc@443: DVal (x, n, c, e as (EAbs _, _), tag) => adamc@443: IM.insert (funcs, n, {name = x, adamc@453: args = KM.empty, adamc@443: body = e, adamc@443: typ = c, adamc@443: tag = tag}) adamc@469: | DVal (_, n, _, (ENamed n', _), _) => adamc@469: (case IM.find (funcs, n') of adamc@469: NONE => funcs adamc@469: | SOME v => IM.insert (funcs, n, v)) adamc@443: | _ => funcs adamc@443: adamc@453: val (changed, ds) = adamc@443: case #decls st of adamc@453: [] => (changed, [d']) adamc@453: | vis => adamc@453: (true, case d' of adamc@453: (DValRec vis', _) => [(DValRec (vis @ vis'), ErrorMsg.dummySpan)] adamc@453: | _ => [(DValRec vis, ErrorMsg.dummySpan), d']) adamc@443: in adamc@453: (ds, ({maxName = #maxName st, adamc@453: funcs = funcs, adamc@453: decls = []}, changed)) adamc@443: end adamc@443: adamc@453: val (ds, (_, changed)) = ListUtil.foldlMapConcat doDecl adamc@453: ({maxName = U.File.maxName file + 1, adamc@453: funcs = IM.empty, adamc@453: decls = []}, false) adamc@453: file adamc@443: in adamc@453: (changed, ds) adamc@443: end adamc@443: adamc@453: fun specialize file = adamc@453: let adamc@453: val (changed, file) = specialize' file adamc@453: in adamc@453: if changed then adamc@453: specialize file adamc@453: else adamc@453: file adamc@453: end adamc@453: adamc@443: adamc@443: end