diff options
-rw-r--r-- | src/compiler.sig | 2 | ||||
-rw-r--r-- | src/compiler.sml | 14 | ||||
-rw-r--r-- | src/core_util.sig | 34 | ||||
-rw-r--r-- | src/core_util.sml | 43 | ||||
-rw-r--r-- | src/list_util.sig | 2 | ||||
-rw-r--r-- | src/list_util.sml | 13 | ||||
-rw-r--r-- | src/main.mlton.sml | 2 | ||||
-rw-r--r-- | src/shake.sig | 34 | ||||
-rw-r--r-- | src/shake.sml | 101 | ||||
-rw-r--r-- | src/sources | 3 | ||||
-rw-r--r-- | tests/reduce.lac | 2 |
11 files changed, 249 insertions, 1 deletions
diff --git a/src/compiler.sig b/src/compiler.sig index cafb3d20..c06ac765 100644 --- a/src/compiler.sig +++ b/src/compiler.sig @@ -33,10 +33,12 @@ signature COMPILER = sig 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 --git a/src/compiler.sml b/src/compiler.sml index 28b92ac8..ce6f376e 100644 --- a/src/compiler.sml +++ b/src/compiler.sml @@ -77,6 +77,11 @@ fun reduce eenv cenv filename = 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 @@ fun testReduce filename = 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 --git a/src/core_util.sig b/src/core_util.sig index 45ee7dfd..64cd671b 100644 --- a/src/core_util.sig +++ b/src/core_util.sig @@ -55,6 +55,11 @@ structure Con : sig 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 @@ structure Exp : sig 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 @@ structure Decl : sig 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 @@ structure File : sig 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 --git a/src/core_util.sml b/src/core_util.sml index 4f0de447..549f7d1f 100644 --- a/src/core_util.sml +++ b/src/core_util.sml @@ -164,6 +164,12 @@ fun mapB {kind, con, bind} ctx c = 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 @@ fun map {kind, con, exp} e = 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 @@ fun mapfoldB {kind = fk, con = fc, exp = fe, decl = fd, bind} = 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 @@ fun mapfoldB (all as {bind, ...}) = 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 @@ fun mapB {kind, con, exp, decl, bind} ctx ds = 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 --git a/src/list_util.sig b/src/list_util.sig index 6ec109da..18d348ef 100644 --- a/src/list_util.sig +++ b/src/list_util.sig @@ -33,4 +33,6 @@ signature LIST_UTIL = sig val mapfold : ('data, 'state, 'abort) Search.mapfolder -> ('data list, 'state, 'abort) Search.mapfolder + val search : ('a -> 'b option) -> 'a list -> 'b option + end diff --git a/src/list_util.sml b/src/list_util.sml index eee8249b..626d0ec0 100644 --- a/src/list_util.sml +++ b/src/list_util.sml @@ -60,4 +60,17 @@ fun mapfold f = 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 --git a/src/main.mlton.sml b/src/main.mlton.sml index 46824ab9..470a619e 100644 --- a/src/main.mlton.sml +++ b/src/main.mlton.sml @@ -26,5 +26,5 @@ *) val () = case CommandLine.arguments () of - [filename] => Compiler.testReduce filename + [filename] => Compiler.testShake filename | _ => print "Bad arguments" diff --git a/src/shake.sig b/src/shake.sig new file mode 100644 index 00000000..6c617435 --- /dev/null +++ b/src/shake.sig @@ -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 --git a/src/shake.sml b/src/shake.sml new file mode 100644 index 00000000..ec2e43e5 --- /dev/null +++ b/src/shake.sml @@ -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 --git a/src/sources b/src/sources index 71ad71de..f10e0e90 100644 --- a/src/sources +++ b/src/sources @@ -52,5 +52,8 @@ corify.sml reduce.sig reduce.sml +shake.sig +shake.sml + compiler.sig compiler.sml diff --git a/tests/reduce.lac b/tests/reduce.lac index 9cdc2a1a..f292a294 100644 --- a/tests/reduce.lac +++ b/tests/reduce.lac @@ -23,3 +23,5 @@ val grab = fn n :: Name => fn t ::: Type => fn fs ::: {Type} => 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} |