adamc@23: (* Copyright (c) 2008, Adam Chlipala
adamc@23:  * All rights reserved.
adamc@23:  *
adamc@23:  * Redistribution and use in source and binary forms, with or without
adamc@23:  * modification, are permitted provided that the following conditions are met:
adamc@23:  *
adamc@23:  * - Redistributions of source code must retain the above copyright notice,
adamc@23:  *   this list of conditions and the following disclaimer.
adamc@23:  * - Redistributions in binary form must reproduce the above copyright notice,
adamc@23:  *   this list of conditions and the following disclaimer in the documentation
adamc@23:  *   and/or other materials provided with the distribution.
adamc@23:  * - The names of contributors may not be used to endorse or promote products
adamc@23:  *   derived from this software without specific prior written permission.
adamc@23:  *
adamc@23:  * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
adamc@23:  * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
adamc@23:  * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
adamc@23:  * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
adamc@23:  * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
adamc@23:  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
adamc@23:  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
adamc@23:  * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
adamc@23:  * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
adamc@23:  * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
adamc@23:  * POSSIBILITY OF SUCH DAMAGE.
adamc@23:  *)
adamc@23: 
adamc@23: (* Remove unused definitions from a file *)
adamc@23: 
adamc@23: structure Shake :> SHAKE = struct
adamc@23: 
adamc@23: open Core
adamc@23: 
adamc@23: structure U = CoreUtil
adamc@23: 
adamc@23: structure IS = IntBinarySet
adamc@23: structure IM = IntBinaryMap
adamc@23: 
adamc@23: type free = {
adamc@23:      con : IS.set,
adamc@23:      exp : IS.set
adamc@23: }
adamc@23: 
adamc@23: fun shake file =
adamc@23:     case List.foldl (fn ((DVal ("main", n, _, e), _), _) => SOME (n, e)
adamc@23:                       | (_, s) => s) NONE file of
adamc@23:         NONE => []
adamc@23:       | SOME (main, body) =>
adamc@23:         let
adamc@23:             val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, c), edef)
adamc@23:                                        | ((DVal (_, n, t, e), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))))
adamc@23:                                (IM.empty, IM.empty) file
adamc@23: 
adamc@23:             fun kind (_, s) = s
adamc@23: 
adamc@23:             fun con (c, s) =
adamc@23:                 case c of
adamc@23:                     CNamed n =>
adamc@23:                     if IS.member (#con s, n) then
adamc@23:                         s
adamc@23:                     else
adamc@23:                         let
adamc@23:                             val s' = {con = IS.add (#con s, n),
adamc@23:                                       exp = #exp s}
adamc@23:                         in
adamc@23:                             case IM.find (cdef, n) of
adamc@23:                                 NONE => s'
adamc@23:                               | SOME c => shakeCon s' c
adamc@23:                         end
adamc@23:                   | _ => s
adamc@23: 
adamc@23:             and shakeCon s = U.Con.fold {kind = kind, con = con} s
adamc@23: 
adamc@23:             fun exp (e, s) =
adamc@23:                 case e of
adamc@23:                     ENamed n =>
adamc@23:                     if IS.member (#exp s, n) then
adamc@23:                         s
adamc@23:                     else
adamc@23:                         let
adamc@23:                             val s' = {exp = IS.add (#exp s, n),
adamc@23:                                       con = #con s}
adamc@23:                         in
adamc@23:                             case IM.find (edef, n) of
adamc@23:                                 NONE => s'
adamc@23:                               | SOME (t, e) => shakeExp (shakeCon s' t) e
adamc@23:                         end
adamc@23:                   | _ => s
adamc@23: 
adamc@23:             and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s
adamc@23: 
adamc@23:             val s = {con = IS.empty,
adamc@23:                      exp = IS.singleton main}
adamc@23:                     
adamc@23:             val s = U.Exp.fold {kind = kind, con = con, exp = exp} s body
adamc@23:         in
adamc@23:             List.filter (fn (DCon (_, n, _, _), _) => IS.member (#con s, n)
adamc@23:                           | (DVal (_, n, _, _), _) => IS.member (#exp s, n)) file
adamc@23:         end
adamc@23: 
adamc@23: end