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@453: datatype skey = adamc@453: Named of int adamc@453: | App of skey * skey adamc@453: adamc@453: structure K = struct adamc@453: type ord_key = skey list adamc@453: fun compare' (k1, k2) = adamc@453: case (k1, k2) of adamc@453: (Named n1, Named n2) => Int.compare (n1, n2) adamc@453: | (Named _, _) => LESS adamc@453: | (_, Named _) => GREATER adamc@453: adamc@453: | (App (x1, y1), App (x2, y2)) => Order.join (compare' (x1, x2), fn () => compare' (y1, y2)) adamc@453: adamc@453: val compare = Order.joinL compare' adamc@443: end adamc@443: adamc@453: structure KM = BinaryMapFn(K) adamc@443: structure IM = IntBinaryMap adamc@443: adamc@453: fun skeyIn (e, _) = adamc@453: case e of adamc@453: ENamed n => SOME (Named n) adamc@453: | EApp (e1, e2) => adamc@453: (case (skeyIn e1, skeyIn e2) of adamc@453: (SOME k1, SOME k2) => SOME (App (k1, k2)) adamc@453: | _ => NONE) adamc@453: | _ => NONE adamc@453: adamc@453: fun skeyOut (k, loc) = adamc@453: case k of adamc@453: Named n => (ENamed n, loc) adamc@453: | App (k1, k2) => (EApp (skeyOut (k1, loc), skeyOut (k2, loc)), loc) 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@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@443: | SOME (_, [], _) => (e, st) adamc@443: | SOME (f, xs, xs') => adamc@443: case IM.find (#funcs st, f) of adamc@469: NONE => ((*print ("SHOT DOWN! " ^ Int.toString f ^ "\n");*) (e, st)) 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@453: val body'' = E.subExpInExp (0, skeyOut (x, #2 body)) 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