summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/compiler.sig2
-rw-r--r--src/compiler.sml14
-rw-r--r--src/core_util.sig34
-rw-r--r--src/core_util.sml43
-rw-r--r--src/list_util.sig2
-rw-r--r--src/list_util.sml13
-rw-r--r--src/main.mlton.sml2
-rw-r--r--src/shake.sig34
-rw-r--r--src/shake.sml101
-rw-r--r--src/sources3
-rw-r--r--tests/reduce.lac2
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}
generated by cgit v1.2.3 (git 2.39.1) at 2024-10-30 07:23:28 +0000