# HG changeset patch
# User Adam Chlipala <adamc@hcoop.net>
# Date 1212959709 14400
# Node ID bfa2e9ae4df8838039a5f8bc9edcffa8a7ba15bb
# Parent  d8850cc06d24759c4089cb8baf3995f1ab3008f1
Tree-shaking

diff -r d8850cc06d24 -r bfa2e9ae4df8 src/compiler.sig
--- a/src/compiler.sig	Sun Jun 08 16:08:31 2008 -0400
+++ b/src/compiler.sig	Sun Jun 08 17:15:09 2008 -0400
@@ -33,10 +33,12 @@
     val elaborate : ElabEnv.env -> string -> (ElabEnv.env * Elab.file) option
     val corify : ElabEnv.env -> CoreEnv.env -> string -> Core.file option
     val reduce : ElabEnv.env -> CoreEnv.env -> string -> Core.file option
+    val shake : ElabEnv.env -> CoreEnv.env -> string -> Core.file option
 
     val testParse : string -> unit
     val testElaborate : string -> unit
     val testCorify : string -> unit
     val testReduce : string -> unit
+    val testShake : string -> unit
 
 end
diff -r d8850cc06d24 -r bfa2e9ae4df8 src/compiler.sml
--- a/src/compiler.sml	Sun Jun 08 16:08:31 2008 -0400
+++ b/src/compiler.sml	Sun Jun 08 17:15:09 2008 -0400
@@ -77,6 +77,11 @@
         NONE => NONE
       | SOME file => SOME (Reduce.reduce file)
 
+fun shake eenv cenv filename =
+    case reduce eenv cenv filename of
+        NONE => NONE
+      | SOME file => SOME (Shake.shake file)
+
 fun testParse filename =
     case parse filename of
         NONE => print "Failed\n"
@@ -111,4 +116,13 @@
     handle CoreEnv.UnboundNamed n =>
            print ("Unbound named " ^ Int.toString n ^ "\n")
 
+fun testShake filename =
+    (case shake ElabEnv.basis CoreEnv.basis filename of
+         NONE => print "Failed\n"
+       | SOME file =>
+         (Print.print (CorePrint.p_file CoreEnv.basis file);
+          print "\n"))
+    handle CoreEnv.UnboundNamed n =>
+           print ("Unbound named " ^ Int.toString n ^ "\n")
+
 end
diff -r d8850cc06d24 -r bfa2e9ae4df8 src/core_util.sig
--- a/src/core_util.sig	Sun Jun 08 16:08:31 2008 -0400
+++ b/src/core_util.sig	Sun Jun 08 17:15:09 2008 -0400
@@ -55,6 +55,11 @@
                 con : 'context -> Core.con' -> Core.con',
                 bind : 'context * binder -> 'context}
                -> 'context -> (Core.con -> Core.con)
+
+    val fold : {kind : Core.kind' * 'state -> 'state,
+               con : Core.con' * 'state -> 'state}
+              -> 'state -> Core.con -> 'state
+
     val exists : {kind : Core.kind' -> bool,
                   con : Core.con' -> bool} -> Core.con -> bool
 end
@@ -85,6 +90,12 @@
                 exp : 'context -> Core.exp' -> Core.exp',
                 bind : 'context * binder -> 'context}
                -> 'context -> (Core.exp -> Core.exp)
+
+    val fold : {kind : Core.kind' * 'state -> 'state,
+                con : Core.con' * 'state -> 'state,
+                exp : Core.exp' * 'state -> 'state}
+               -> 'state -> Core.exp -> 'state
+                                        
     val exists : {kind : Core.kind' -> bool,
                   con : Core.con' -> bool,
                   exp : Core.exp' -> bool} -> Core.exp -> bool
@@ -99,6 +110,17 @@
                     decl : ('context, Core.decl', 'state, 'abort) Search.mapfolderB,
                     bind : 'context * binder -> 'context}
                    -> ('context, Core.decl, 'state, 'abort) Search.mapfolderB
+    val mapfold : {kind : (Core.kind', 'state, 'abort) Search.mapfolder,
+                   con : (Core.con', 'state, 'abort) Search.mapfolder,
+                   exp : (Core.exp', 'state, 'abort) Search.mapfolder,
+                   decl : (Core.decl', 'state, 'abort) Search.mapfolder}
+                  -> (Core.decl, 'state, 'abort) Search.mapfolder
+
+    val fold : {kind : Core.kind' * 'state -> 'state,
+                con : Core.con' * 'state -> 'state,
+                exp : Core.exp' * 'state -> 'state,
+                decl : Core.decl' * 'state -> 'state}
+               -> 'state -> Core.decl -> 'state
 end
 
 structure File : sig
@@ -111,12 +133,24 @@
                     bind : 'context * binder -> 'context}
                    -> ('context, Core.file, 'state, 'abort) Search.mapfolderB
 
+    val mapfold : {kind : (Core.kind', 'state, 'abort) Search.mapfolder,
+                   con : (Core.con', 'state, 'abort) Search.mapfolder,
+                   exp : (Core.exp', 'state, 'abort) Search.mapfolder,
+                   decl : (Core.decl', 'state, 'abort) Search.mapfolder}
+                  -> (Core.file, 'state, 'abort) Search.mapfolder
+
     val mapB : {kind : Core.kind' -> Core.kind',
                 con : 'context -> Core.con' -> Core.con',
                 exp : 'context -> Core.exp' -> Core.exp',
                 decl : 'context -> Core.decl' -> Core.decl',
                 bind : 'context * binder -> 'context}
                -> 'context -> Core.file -> Core.file
+
+    val fold : {kind : Core.kind' * 'state -> 'state,
+                con : Core.con' * 'state -> 'state,
+                exp : Core.exp' * 'state -> 'state,
+                decl : Core.decl' * 'state -> 'state}
+               -> 'state -> Core.file -> 'state
 end
 
 end
diff -r d8850cc06d24 -r bfa2e9ae4df8 src/core_util.sml
--- a/src/core_util.sml	Sun Jun 08 16:08:31 2008 -0400
+++ b/src/core_util.sml	Sun Jun 08 17:15:09 2008 -0400
@@ -164,6 +164,12 @@
         S.Continue (c, ()) => c
       | S.Return _ => raise Fail "CoreUtil.Con.mapB: Impossible"
 
+fun fold {kind, con} s c =
+    case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)),
+                  con = fn c => fn s => S.Continue (c, con (c, s))} c s of
+        S.Continue (_, s) => s
+      | S.Return _ => raise Fail "CoreUtil.Con.fold: Impossible"
+
 fun exists {kind, con} k =
     case mapfold {kind = fn k => fn () =>
                                     if kind k then
@@ -281,6 +287,13 @@
         S.Return () => raise Fail "Core_util.Exp.map"
       | S.Continue (e, ()) => e
 
+fun fold {kind, con, exp} s e =
+    case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)),
+                  con = fn c => fn s => S.Continue (c, con (c, s)),
+                  exp = fn e => fn s => S.Continue (e, exp (e, s))} e s of
+        S.Continue (_, s) => s
+      | S.Return _ => raise Fail "CoreUtil.Exp.fold: Impossible"
+
 fun exists {kind, con, exp} k =
     case mapfold {kind = fn k => fn () =>
                                     if kind k then
@@ -343,6 +356,21 @@
         mfd
     end    
 
+fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} =
+    mapfoldB {kind = fk,
+              con = fn () => fc,
+              exp = fn () => fe,
+              decl = fn () => fd,
+              bind = fn ((), _) => ()} ()
+
+fun fold {kind, con, exp, decl} s d =
+    case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)),
+                  con = fn c => fn s => S.Continue (c, con (c, s)),
+                  exp = fn e => fn s => S.Continue (e, exp (e, s)),
+                  decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
+        S.Continue (_, s) => s
+      | S.Return _ => raise Fail "CoreUtil.Decl.fold: Impossible"
+
 end
 
 structure File = struct
@@ -374,6 +402,13 @@
         mff
     end
 
+fun mapfold {kind = fk, con = fc, exp = fe, decl = fd} =
+    mapfoldB {kind = fk,
+              con = fn () => fc,
+              exp = fn () => fe,
+              decl = fn () => fd,
+              bind = fn ((), _) => ()} ()
+
 fun mapB {kind, con, exp, decl, bind} ctx ds =
     case mapfoldB {kind = fn k => fn () => S.Continue (kind k, ()),
                    con = fn ctx => fn c => fn () => S.Continue (con ctx c, ()),
@@ -383,6 +418,14 @@
         S.Continue (ds, ()) => ds
       | S.Return _ => raise Fail "CoreUtil.File.mapB: Impossible"
 
+fun fold {kind, con, exp, decl} s d =
+    case mapfold {kind = fn k => fn s => S.Continue (k, kind (k, s)),
+                  con = fn c => fn s => S.Continue (c, con (c, s)),
+                  exp = fn e => fn s => S.Continue (e, exp (e, s)),
+                  decl = fn d => fn s => S.Continue (d, decl (d, s))} d s of
+        S.Continue (_, s) => s
+      | S.Return _ => raise Fail "CoreUtil.File.fold: Impossible"
+
 end
 
 end
diff -r d8850cc06d24 -r bfa2e9ae4df8 src/list_util.sig
--- a/src/list_util.sig	Sun Jun 08 16:08:31 2008 -0400
+++ b/src/list_util.sig	Sun Jun 08 17:15:09 2008 -0400
@@ -33,4 +33,6 @@
     val mapfold : ('data, 'state, 'abort) Search.mapfolder
                   -> ('data list, 'state, 'abort) Search.mapfolder
 
+    val search : ('a -> 'b option) -> 'a list -> 'b option
+
 end
diff -r d8850cc06d24 -r bfa2e9ae4df8 src/list_util.sml
--- a/src/list_util.sml	Sun Jun 08 16:08:31 2008 -0400
+++ b/src/list_util.sml	Sun Jun 08 17:15:09 2008 -0400
@@ -60,4 +60,17 @@
         mf
     end
 
+fun search f =
+    let
+        fun s ls =
+            case ls of
+                [] => NONE
+              | h :: t =>
+                case f h of
+                    NONE => s t
+                  | v => v
+    in
+        s
+    end
+
 end
diff -r d8850cc06d24 -r bfa2e9ae4df8 src/main.mlton.sml
--- a/src/main.mlton.sml	Sun Jun 08 16:08:31 2008 -0400
+++ b/src/main.mlton.sml	Sun Jun 08 17:15:09 2008 -0400
@@ -26,5 +26,5 @@
  *)
 
 val () = case CommandLine.arguments () of
-             [filename] => Compiler.testReduce filename
+             [filename] => Compiler.testShake filename
            | _ => print "Bad arguments"
diff -r d8850cc06d24 -r bfa2e9ae4df8 src/shake.sig
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/shake.sig	Sun Jun 08 17:15:09 2008 -0400
@@ -0,0 +1,34 @@
+(* Copyright (c) 2008, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+(* Remove unused definitions from a file *)
+
+signature SHAKE = sig
+
+    val shake : Core.file -> Core.file
+
+end
diff -r d8850cc06d24 -r bfa2e9ae4df8 src/shake.sml
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/src/shake.sml	Sun Jun 08 17:15:09 2008 -0400
@@ -0,0 +1,101 @@
+(* Copyright (c) 2008, Adam Chlipala
+ * All rights reserved.
+ *
+ * Redistribution and use in source and binary forms, with or without
+ * modification, are permitted provided that the following conditions are met:
+ *
+ * - Redistributions of source code must retain the above copyright notice,
+ *   this list of conditions and the following disclaimer.
+ * - Redistributions in binary form must reproduce the above copyright notice,
+ *   this list of conditions and the following disclaimer in the documentation
+ *   and/or other materials provided with the distribution.
+ * - The names of contributors may not be used to endorse or promote products
+ *   derived from this software without specific prior written permission.
+ *
+ * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
+ * AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+ * IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ * ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
+ * LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR 
+ * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
+ * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
+ * INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
+ * CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
+ * ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
+ * POSSIBILITY OF SUCH DAMAGE.
+ *)
+
+(* Remove unused definitions from a file *)
+
+structure Shake :> SHAKE = struct
+
+open Core
+
+structure U = CoreUtil
+
+structure IS = IntBinarySet
+structure IM = IntBinaryMap
+
+type free = {
+     con : IS.set,
+     exp : IS.set
+}
+
+fun shake file =
+    case List.foldl (fn ((DVal ("main", n, _, e), _), _) => SOME (n, e)
+                      | (_, s) => s) NONE file of
+        NONE => []
+      | SOME (main, body) =>
+        let
+            val (cdef, edef) = foldl (fn ((DCon (_, n, _, c), _), (cdef, edef)) => (IM.insert (cdef, n, c), edef)
+                                       | ((DVal (_, n, t, e), _), (cdef, edef)) => (cdef, IM.insert (edef, n, (t, e))))
+                               (IM.empty, IM.empty) file
+
+            fun kind (_, s) = s
+
+            fun con (c, s) =
+                case c of
+                    CNamed n =>
+                    if IS.member (#con s, n) then
+                        s
+                    else
+                        let
+                            val s' = {con = IS.add (#con s, n),
+                                      exp = #exp s}
+                        in
+                            case IM.find (cdef, n) of
+                                NONE => s'
+                              | SOME c => shakeCon s' c
+                        end
+                  | _ => s
+
+            and shakeCon s = U.Con.fold {kind = kind, con = con} s
+
+            fun exp (e, s) =
+                case e of
+                    ENamed n =>
+                    if IS.member (#exp s, n) then
+                        s
+                    else
+                        let
+                            val s' = {exp = IS.add (#exp s, n),
+                                      con = #con s}
+                        in
+                            case IM.find (edef, n) of
+                                NONE => s'
+                              | SOME (t, e) => shakeExp (shakeCon s' t) e
+                        end
+                  | _ => s
+
+            and shakeExp s = U.Exp.fold {kind = kind, con = con, exp = exp} s
+
+            val s = {con = IS.empty,
+                     exp = IS.singleton main}
+                    
+            val s = U.Exp.fold {kind = kind, con = con, exp = exp} s body
+        in
+            List.filter (fn (DCon (_, n, _, _), _) => IS.member (#con s, n)
+                          | (DVal (_, n, _, _), _) => IS.member (#exp s, n)) file
+        end
+
+end
diff -r d8850cc06d24 -r bfa2e9ae4df8 src/sources
--- a/src/sources	Sun Jun 08 16:08:31 2008 -0400
+++ b/src/sources	Sun Jun 08 17:15:09 2008 -0400
@@ -52,5 +52,8 @@
 reduce.sig
 reduce.sml
 
+shake.sig
+shake.sml
+
 compiler.sig
 compiler.sml
diff -r d8850cc06d24 -r bfa2e9ae4df8 tests/reduce.lac
--- a/tests/reduce.lac	Sun Jun 08 16:08:31 2008 -0400
+++ b/tests/reduce.lac	Sun Jun 08 17:15:09 2008 -0400
@@ -23,3 +23,5 @@
         fn x : $([n = t] ++ fs) => x.n
 val test_grab1 = grab[#A] {A = 6, B = "13"}
 val test_grab2 = grab[#B] {A = 6, B = "13"}
+
+val main = {A = test_grab1, B = test_grab2}