Mercurial > urweb

annotate src/mono_shake.sml @ 2291:50ad02829abd

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Make cache flushes happen immediately instead of at end of transaction.
author Ziv Scully <ziv@mit.edu>
date Tue, 17 Nov 2015 02:44:37 -0500
parents e843a04499d4
children
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
ziv@2252 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
adam@1845 44 fun shake (file : file) =
adamc@134 45 let
adamc@808 46 val (cdef, edef) = foldl (fn ((DDatatype dts, _), (cdef, edef)) =>
adamc@808 47 (foldl (fn ((_, n, xncs), cdef) => IM.insert (cdef, n, xncs)) cdef dts, edef)
adamc@178 48 | ((DVal (_, n, t, e, _), _), (cdef, edef)) =>
adamc@178 49 (cdef, IM.insert (edef, n, (t, e)))
adamc@134 50 | ((DValRec vis, _), (cdef, edef)) =>
adamc@134 51 (cdef, foldl (fn ((_, n, t, e, _), edef) => IM.insert (edef, n, (t, e))) edef vis)
adamc@271 52 | ((DExport _, _), acc) => acc
adamc@273 53 | ((DTable _, _), acc) => acc
adamc@338 54 | ((DSequence _, _), acc) => acc
adamc@754 55 | ((DView _, _), acc) => acc
adamc@569 56 | ((DDatabase _, _), acc) => acc
adamc@718 57 | ((DJavaScript _, _), acc) => acc
adamc@725 58 | ((DCookie _, _), acc) => acc
adamc@1073 59 | ((DStyle _, _), acc) => acc
adamc@1199 60 | ((DTask _, _), acc) => acc
adam@1294 61 | ((DPolicy _, _), acc) => acc
adam@1294 62 | ((DOnError _, _), acc) => acc)
ziv@2252 63 (IM.empty, IM.empty) (#1 file)
adamc@134 64
adamc@164 65 fun typ (c, s) =
adamc@164 66 case c of
adamc@196 67 TDatatype (n, _) =>
adamc@164 68 if IS.member (#con s, n) then
adamc@164 69 s
adamc@164 70 else
adamc@178 71 let
adamc@178 72 val s' = {exp = #exp s,
adamc@178 73 con = IS.add (#con s, n)}
adamc@178 74 in
adamc@178 75 case IM.find (cdef, n) of
adamc@178 76 NONE => s'
adamc@178 77 | SOME xncs => foldl (fn ((_, _, to), s) =>
adamc@178 78 case to of
adamc@178 79 NONE => s
adamc@178 80 | SOME t => shakeTyp s t)
adamc@178 81 s' xncs
adamc@178 82 end
adamc@164 83 | _ => s
adamc@134 84
adamc@178 85 and shakeTyp s = U.Typ.fold typ s
adamc@178 86
adamc@134 87 fun exp (e, s) =
adamc@134 88 case e of
adamc@134 89 ENamed n =>
adamc@134 90 if IS.member (#exp s, n) then
adamc@134 91 s
adamc@134 92 else
adamc@134 93 let
adamc@134 94 val s' = {exp = IS.add (#exp s, n),
adamc@134 95 con = #con s}
adamc@134 96 in
adamc@134 97 case IM.find (edef, n) of
adamc@134 98 NONE => s'
adamc@134 99 | SOME (t, e) => shakeExp s' e
adamc@134 100 end
adamc@134 101 | _ => s
adamc@134 102
adamc@134 103 and shakeExp s = U.Exp.fold {typ = typ, exp = exp} s
adamc@134 104
kkallio@1535 105 fun usedVars (cs, es) e =
kkallio@1535 106 let
kkallio@1535 107 val {con = cs', exp = es'} = shakeExp {con = cs, exp = es} e
kkallio@1535 108 in
kkallio@1535 109 (cs', es')
kkallio@1535 110 end
kkallio@1535 111
kkallio@1535 112 val (page_cs, page_es) =
kkallio@1535 113 List.foldl
kkallio@1535 114 (fn ((DExport (_, _, n, _, _, _), _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
kkallio@1535 115 | ((DDatabase {expunge = n1, initialize = n2, ...}, _), (page_cs, page_es)) =>
kkallio@1535 116 (page_cs, IS.addList (page_es, [n1, n2]))
kkallio@1535 117 | ((DTask (e1, e2), _), st) => usedVars (usedVars st e2) e1
adam@1623 118 | ((DTable (_, xts, e1, e2), _), st) => usedVars (usedVars (usedVars st e1) e2)
adam@1623 119 (ERecord (map (fn (x, t) => (x, (ERecord [], #2 e1), t)) xts), #2 e1)
kkallio@1535 120 | ((DView (_, _, e), _), st) => usedVars st e
kkallio@1535 121 | ((DPolicy pol, _), st) =>
kkallio@1535 122 let
kkallio@1535 123 val e1 = case pol of
kkallio@1535 124 PolClient e1 => e1
kkallio@1535 125 | PolInsert e1 => e1
kkallio@1535 126 | PolDelete e1 => e1
kkallio@1535 127 | PolUpdate e1 => e1
kkallio@1535 128 | PolSequence e1 => e1
kkallio@1535 129 in
kkallio@1535 130 usedVars st e1
kkallio@1535 131 end
kkallio@1535 132 | ((DOnError n, _), (page_cs, page_es)) => (page_cs, IS.add (page_es, n))
ziv@2252 133 | (_, st) => st) (IS.empty, IS.empty) (#1 file)
kkallio@1535 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
ziv@2252 148 (List.filter (fn (DDatatype dts, _) => List.exists (fn (_, n, _) => IS.member (#con s, n)) dts
adam@1845 149 | (DVal (_, n, _, _, _), _) => IS.member (#exp s, n)
adam@1845 150 | (DValRec vis, _) => List.exists (fn (_, n, _, _, _) => IS.member (#exp s, n)) vis
adam@1845 151 | (DExport _, _) => true
adam@1845 152 | (DTable _, _) => true
adam@1845 153 | (DSequence _, _) => true
adam@1845 154 | (DView _, _) => true
adam@1845 155 | (DDatabase _, _) => true
adam@1845 156 | (DJavaScript _, _) => true
adam@1845 157 | (DCookie _, _) => true
adam@1845 158 | (DStyle _, _) => true
adam@1845 159 | (DTask _, _) => true
adam@1845 160 | (DPolicy _, _) => true
ziv@2252 161 | (DOnError _, _) => true) (#1 file), #2 file)
adamc@134 162 end
adamc@134 163
adamc@134 164 end