Mercurial > urweb

annotate src/mono_shake.sml @ 1327:1cc67fdac4d3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
New argument to transactional free functions, to specify whether we are about to retry
author Adam Chlipala <adam@chlipala.net>
date Sat, 04 Dec 2010 11:15:20 -0500
parents b4480a56cab7
children 27190faa36a3
rev   line source
adamc@134 1 (* Copyright (c) 2008, Adam Chlipala
adamc@134 2 * All rights reserved.
adamc@134 3 *
adamc@134 4 * Redistribution and use in source and binary forms, with or without
adamc@134 5 * modification, are permitted provided that the following conditions are met:
adamc@134 6 *
adamc@134 7 * - Redistributions of source code must retain the above copyright notice,
adamc@134 8 * this list of conditions and the following disclaimer.
adamc@134 9 * - Redistributions in binary form must reproduce the above copyright notice,
adamc@134 10 * this list of conditions and the following disclaimer in the documentation
adamc@134 11 * and/or other materials provided with the distribution.
adamc@134 12 * - The names of contributors may not be used to endorse or promote products
adamc@134 13 * derived from this software without specific prior written permission.
adamc@134 14 *
adamc@134 15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@134 16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@134 17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@134 18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@134 19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
adamc@134 20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@134 21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@134 22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@134 23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@134 24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@134 25 * POSSIBILITY OF SUCH DAMAGE.
adamc@134 26 *)
adamc@134 27
adamc@134 28 (* Remove unused definitions from a file *)
adamc@134 29
adamc@134 30 structure MonoShake :> MONO_SHAKE = struct
adamc@134 31
adamc@134 32 open Mono
adamc@134 33
adamc@134 34 structure U = MonoUtil
adamc@134 35
adamc@134 36 structure IS = IntBinarySet
adamc@134 37 structure IM = IntBinaryMap
adamc@134 38
adamc@134 39 type free = {
adamc@134 40 con : IS.set,
adamc@134 41 exp : IS.set
adamc@134 42 }
adamc@134 43
adamc@134 44 fun shake file =
adamc@134 45 let
adamc@1073 46 val usedVars = U.Exp.fold {typ = fn (c, st as (cs, es)) =>
adamc@1073 47 case c of
adamc@1073 48 TDatatype (n, _) => (IS.add (cs, n), es)
adamc@1073 49 | _ => st,
adamc@1073 50 exp = fn (e, st as (cs, es)) =>
adamc@1073 51 case e of
adamc@1073 52 ENamed n => (cs, IS.add (es, n))
adamc@1073 53 | _ => st}
adamc@1073 54
adamc@1073 55 val (page_cs, page_es) =
adamc@1073 56 List.foldl
adamc@1104 57 (fn ((DExport (_, _, n, _, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
adamc@1073 58 | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) =>
adamc@1073 59 (page_cs, IS.addList (page_es, [n1, n2]))
adamc@1075 60 | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1
adamc@1265 61 | ((DView (_, _, e), _), st) => usedVars st e
adamc@1199 62 | ((DPolicy pol, _), st) =>
adamc@1199 63 let
adamc@1199 64 val e1 = case pol of
adamc@1214 65 PolClient e1 => e1
adamc@1220 66 | PolInsert e1 => e1
adamc@1221 67 | PolDelete e1 => e1
adamc@1223 68 | PolUpdate e1 => e1
adamc@1229 69 | PolSequence e1 => e1
adamc@1199 70 in
adamc@1199 71 usedVars st e1
adamc@1199 72 end
adam@1294 73 | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
adamc@1073 74 | (_, st) => st) (IS.empty, IS.empty) file
adamc@134 75
adamc@808 76 val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) =>
adamc@808 77 (foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef)
adamc@178 78 | ((DVal (_, n, t, e, _), _), (cdef, edef)) =>
adamc@178 79 (cdef, IM.insert (edef, n, (t, e)))
adamc@134 80 | ((DValRec vis, _), (cdef, edef)) =>
adamc@134 81 (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis)
adamc@271 82 | ((DExport _, _), acc) => acc
adamc@273 83 | ((DTable _, _), acc) => acc
adamc@338 84 | ((DSequence _, _), acc) => acc
adamc@754 85 | ((DView _, _), acc) => acc
adamc@569 86 | ((DDatabase _, _), acc) => acc
adamc@718 87 | ((DJavaScript _, _), acc) => acc
adamc@725 88 | ((DCookie _, _), acc) => acc
adamc@1073 89 | ((DStyle _, _), acc) => acc
adamc@1199 90 | ((DTask _, _), acc) => acc
adam@1294 91 | ((DPolicy _, _), acc) => acc
adam@1294 92 | ((DOnError _, _), acc) => acc)
adamc@134 93 (IM.empty, IM.empty) file
adamc@134 94
adamc@164 95 fun typ (c, s) =
adamc@164 96 case c of
adamc@196 97 TDatatype (n, _) =>
adamc@164 98 if IS.member (#con s, n) then
adamc@164 99 s
adamc@164 100 else
adamc@178 101 let
adamc@178 102 val s' = {exp = #exp s,
adamc@178 103 con = IS.add (#con s, n)}
adamc@178 104 in
adamc@178 105 case IM.find (cdef, n) of
adamc@178 106 NONE => s'
adamc@178 107 | SOME xncs => foldl (fn ((_, _, to), s) =>
adamc@178 108 case to of
adamc@178 109 NONE => s
adamc@178 110 | SOME t => shakeTyp s t)
adamc@178 111 s' xncs
adamc@178 112 end
adamc@164 113 | _ => s
adamc@134 114
adamc@178 115 and shakeTyp s = U.Typ.fold typ s
adamc@178 116
adamc@134 117 fun exp (e, s) =
adamc@134 118 case e of
adamc@134 119 ENamed n =>
adamc@134 120 if IS.member (#exp s, n) then
adamc@134 121 s
adamc@134 122 else
adamc@134 123 let
adamc@134 124 val s' = {exp = IS.add (#exp s, n),
adamc@134 125 con = #con s}
adamc@134 126 in
adamc@134 127 case IM.find (edef, n) of
adamc@134 128 NONE => s'
adamc@134 129 | SOME (t, e) => shakeExp s' e
adamc@134 130 end
adamc@134 131 | _ => s
adamc@134 132
adamc@134 133 and shakeExp s = U.Exp.fold {typ = typ, exp = exp} s
adamc@134 134
adamc@1073 135 val s = {con = page_cs, exp = page_es}
adamc@134 136
adamc@1073 137 val s = IS.foldl (fn (n, s) =>
adamc@1073 138 case IM.find (cdef, n) of
adamc@1073 139 NONE => raise Fail "MonoShake: Couldn't find 'datatype'"
adamc@1073 140 | SOME xncs => foldl (fn ((_, _, SOME c), s) => shakeTyp s c
adamc@1073 141 | _ => s) s xncs) s page_cs
adamc@1073 142
adamc@1073 143 val s = IS.foldl (fn (n, s) =>
adamc@1073 144 case IM.find (edef, n) of
adamc@1073 145 NONE => raise Fail "MonoShake: Couldn't find 'val'"
adamc@1073 146 | SOME (t, e) => shakeExp s e) s page_es
adamc@134 147 in
adamc@808 148 List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts
adamc@164 149 | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
adamc@134 150 | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
adamc@271 151 | (DExport _, _) => true
adamc@273 152 | (DTable _, _) => true
adamc@338 153 | (DSequence _, _) => true
adamc@754 154 | (DView _, _) => true
adamc@569 155 | (DDatabase _, _) => true
adamc@718 156 | (DJavaScript _, _) => true
adamc@725 157 | (DCookie _, _) => true
adamc@1073 158 | (DStyle _, _) => true
adamc@1199 159 | (DTask _, _) => true
adam@1294 160 | (DPolicy _, _) => true
adam@1294 161 | (DOnError _, _) => true) file
adamc@134 162 end
adamc@134 163
adamc@134 164 end