adamc@134: (* Copyright (c) 2008, Adam Chlipala adamc@134: * All rights reserved. adamc@134: * adamc@134: * Redistribution and use in source and binary forms, with or without adamc@134: * modification, are permitted provided that the following conditions are met: adamc@134: * adamc@134: * - Redistributions of source code must retain the above copyright notice, adamc@134: * this list of conditions and the following disclaimer. adamc@134: * - Redistributions in binary form must reproduce the above copyright notice, adamc@134: * this list of conditions and the following disclaimer in the documentation adamc@134: * and/or other materials provided with the distribution. adamc@134: * - The names of contributors may not be used to endorse or promote products adamc@134: * derived from this software without specific prior written permission. adamc@134: * adamc@134: * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" adamc@134: * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE adamc@134: * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE adamc@134: * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE adamc@134: * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR adamc@134: * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF adamc@134: * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS adamc@134: * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN adamc@134: * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) adamc@134: * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE adamc@134: * POSSIBILITY OF SUCH DAMAGE. adamc@134: *) adamc@134: adamc@134: (* Remove unused definitions from a file *) adamc@134: adamc@134: structure MonoShake :> MONO_SHAKE = struct adamc@134: adamc@134: open Mono adamc@134: adamc@134: structure U = MonoUtil adamc@134: adamc@134: structure IS = IntBinarySet adamc@134: structure IM = IntBinaryMap adamc@134: adamc@134: type free = { adamc@134: con : IS.set, adamc@134: exp : IS.set adamc@134: } adamc@134: adamc@134: fun shake file = adamc@134: let adamc@1073: val usedVars = U.Exp.fold {typ = fn (c, st as (cs, es)) => adamc@1073: case c of adamc@1073: TDatatype (n, _) => (IS.add (cs, n), es) adamc@1073: | _ => st, adamc@1073: exp = fn (e, st as (cs, es)) => adamc@1073: case e of adamc@1073: ENamed n => (cs, IS.add (es, n)) adamc@1073: | _ => st} adamc@1073: adamc@1073: val (page_cs, page_es) = adamc@1073: List.foldl adamc@1104: (fn ((DExport (_, _, n, _, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n)) adamc@1073: | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) => adamc@1073: (page_cs, IS.addList (page_es, [n1, n2])) adamc@1075: | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1 adamc@1265: | ((DView (_, _, e), _), st) => usedVars st e adamc@1199: | ((DPolicy pol, _), st) => adamc@1199: let adamc@1199: val e1 = case pol of adamc@1214: PolClient e1 => e1 adamc@1220: | PolInsert e1 => e1 adamc@1221: | PolDelete e1 => e1 adamc@1223: | PolUpdate e1 => e1 adamc@1229: | PolSequence e1 => e1 adam@1281: | PolEqual {table = e1, ...} => e1 adamc@1199: in adamc@1199: usedVars st e1 adamc@1199: end adamc@1073: | (_, st) => st) (IS.empty, IS.empty) file adamc@134: adamc@808: val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) => adamc@808: (foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef) adamc@178: | ((DVal (_, n, t, e, _), _), (cdef, edef)) => adamc@178: (cdef, IM.insert (edef, n, (t, e))) adamc@134: | ((DValRec vis, _), (cdef, edef)) => adamc@134: (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis) adamc@271: | ((DExport _, _), acc) => acc adamc@273: | ((DTable _, _), acc) => acc adamc@338: | ((DSequence _, _), acc) => acc adamc@754: | ((DView _, _), acc) => acc adamc@569: | ((DDatabase _, _), acc) => acc adamc@718: | ((DJavaScript _, _), acc) => acc adamc@725: | ((DCookie _, _), acc) => acc adamc@1073: | ((DStyle _, _), acc) => acc adamc@1199: | ((DTask _, _), acc) => acc adamc@1199: | ((DPolicy _, _), acc) => acc) adamc@134: (IM.empty, IM.empty) file adamc@134: adamc@164: fun typ (c, s) = adamc@164: case c of adamc@196: TDatatype (n, _) => adamc@164: if IS.member (#con s, n) then adamc@164: s adamc@164: else adamc@178: let adamc@178: val s' = {exp = #exp s, adamc@178: con = IS.add (#con s, n)} adamc@178: in adamc@178: case IM.find (cdef, n) of adamc@178: NONE => s' adamc@178: | SOME xncs => foldl (fn ((_, _, to), s) => adamc@178: case to of adamc@178: NONE => s adamc@178: | SOME t => shakeTyp s t) adamc@178: s' xncs adamc@178: end adamc@164: | _ => s adamc@134: adamc@178: and shakeTyp s = U.Typ.fold typ s adamc@178: adamc@134: fun exp (e, s) = adamc@134: case e of adamc@134: ENamed n => adamc@134: if IS.member (#exp s, n) then adamc@134: s adamc@134: else adamc@134: let adamc@134: val s' = {exp = IS.add (#exp s, n), adamc@134: con = #con s} adamc@134: in adamc@134: case IM.find (edef, n) of adamc@134: NONE => s' adamc@134: | SOME (t, e) => shakeExp s' e adamc@134: end adamc@134: | _ => s adamc@134: adamc@134: and shakeExp s = U.Exp.fold {typ = typ, exp = exp} s adamc@134: adamc@1073: val s = {con = page_cs, exp = page_es} adamc@134: adamc@1073: val s = IS.foldl (fn (n, s) => adamc@1073: case IM.find (cdef, n) of adamc@1073: NONE => raise Fail "MonoShake: Couldn't find 'datatype'" adamc@1073: | SOME xncs => foldl (fn ((_, _, SOME c), s) => shakeTyp s c adamc@1073: | _ => s) s xncs) s page_cs adamc@1073: adamc@1073: val s = IS.foldl (fn (n, s) => adamc@1073: case IM.find (edef, n) of adamc@1073: NONE => raise Fail "MonoShake: Couldn't find 'val'" adamc@1073: | SOME (t, e) => shakeExp s e) s page_es adamc@134: in adamc@808: List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts adamc@164: | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n) adamc@134: | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis adamc@271: | (DExport _, _) => true adamc@273: | (DTable _, _) => true adamc@338: | (DSequence _, _) => true adamc@754: | (DView _, _) => true adamc@569: | (DDatabase _, _) => true adamc@718: | (DJavaScript _, _) => true adamc@725: | (DCookie _, _) => true adamc@1073: | (DStyle _, _) => true adamc@1199: | (DTask _, _) => true adamc@1199: | (DPolicy _, _) => true) file adamc@134: end adamc@134: adamc@134: end