Mercurial > urweb

comparison src/shake.sml @ 23:bfa2e9ae4df8

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Tree-shaking
author Adam Chlipala <adamc@hcoop.net>
date Sun, 08 Jun 2008 17:15:09 -0400
parents
children 02f42e9a1825
comparison
equal deleted inserted replaced
22:d8850cc06d24 23:bfa2e9ae4df8
1 (* Copyright (c) 2008, Adam Chlipala
2 * All rights reserved.
3 *
4 * Redistribution and use in source and binary forms, with or without
5 * modification, are permitted provided that the following conditions are met:
6 *
7 * - Redistributions of source code must retain the above copyright notice,
8 * this list of conditions and the following disclaimer.
9 * - Redistributions in binary form must reproduce the above copyright notice,
10 * this list of conditions and the following disclaimer in the documentation
11 * and/or other materials provided with the distribution.
12 * - The names of contributors may not be used to endorse or promote products
13 * derived from this software without specific prior written permission.
14 *
15 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
16 * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
17 * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
18 * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
19 * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
20 * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
21 * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
22 * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
23 * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
24 * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
25 * POSSIBILITY OF SUCH DAMAGE.
26 *)
27
28 (* Remove unused definitions from a file *)
29
30 structure Shake :> SHAKE = struct
31
32 open Core
33
34 structure U = CoreUtil
35
36 structure IS = IntBinarySet
37 structure IM = IntBinaryMap
38
39 type free = {
40 con : IS.set,
41 exp : IS.set
42 }
43
44 fun shake file =
45 case List.foldl (fn ((DVal ("main", n, _, e), _), _) => SOME (n, e)
46 | (_, s) => s) NONE file of
47 NONE => []
48 | SOME (main, body) =>
49 let
50 val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, c), edef)
51 | ((DVal (_, n, t, e), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))))
52 (IM.empty, IM.empty) file
53
54 fun kind (_, s) = s
55
56 fun con (c, s) =
57 case c of
58 CNamed n =>
59 if IS.member (#con s, n) then
60 s
61 else
62 let
63 val s' = {con = IS.add (#con s, n),
64 exp = #exp s}
65 in
66 case IM.find (cdef, n) of
67 NONE => s'
68 | SOME c => shakeCon s' c
69 end
70 | _ => s
71
72 and shakeCon s = U.Con.fold {kind = kind, con = con} s
73
74 fun exp (e, s) =
75 case e of
76 ENamed n =>
77 if IS.member (#exp s, n) then
78 s
79 else
80 let
81 val s' = {exp = IS.add (#exp s, n),
82 con = #con s}
83 in
84 case IM.find (edef, n) of
85 NONE => s'
86 | SOME (t, e) => shakeExp (shakeCon s' t) e
87 end
88 | _ => s
89
90 and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s
91
92 val s = {con = IS.empty,
93 exp = IS.singleton main}
94
95 val s = U.Exp.fold {kind = kind, con = con, exp = exp} s body
96 in
97 List.filter (fn (DCon (_, n, _, _), _) => IS.member (#con s, n)
98 | (DVal (_, n, _, _), _) => IS.member (#exp s, n)) file
99 end
100
101 end