summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--src/compiler.sig26
-rw-r--r--src/compiler.sml330
2 files changed, 99 insertions, 257 deletions
diff --git a/src/compiler.sig b/src/compiler.sig
index 6bc80748..2594a0c7 100644
--- a/src/compiler.sig
+++ b/src/compiler.sig
@@ -30,7 +30,7 @@
signature COMPILER = sig
type job = string list
- (*val compile : job -> unit*)
+ val compile : job -> unit
val compileC : {cname : string, oname : string, ename : string} -> unit
type ('src, 'dst) phase
@@ -51,10 +51,32 @@ signature COMPILER = sig
val elaborate : (Source.file, Elab.file) phase
val explify : (Elab.file, Expl.file) phase
val corify : (Expl.file, Core.file) phase
+ val shake : (Core.file, Core.file) phase
+ val tag : (Core.file, Core.file) phase
+ val reduce : (Core.file, Core.file) phase
+ val specialize : (Core.file, Core.file) phase
+ val monoize : (Core.file, Mono.file) phase
+ val mono_opt : (Mono.file, Mono.file) phase
+ val untangle : (Mono.file, Mono.file) phase
+ val mono_reduce : (Mono.file, Mono.file) phase
+ val mono_shake : (Mono.file, Mono.file) phase
+ val cjrize : (Mono.file, Cjr.file) phase
val toParse : (job, Source.file) transform
val toElaborate : (job, Elab.file) transform
val toExplify : (job, Expl.file) transform
- val toCorify : (job, Core.file) transform
+ val toCorify : (job, Core.file) transform
+ val toShake1 : (job, Core.file) transform
+ val toTag : (job, Core.file) transform
+ val toReduce : (job, Core.file) transform
+ val toSpecialize : (job, Core.file) transform
+ val toShake2 : (job, Core.file) transform
+ val toMonoize : (job, Mono.file) transform
+ val toMono_opt1 : (job, Mono.file) transform
+ val toUntangle : (job, Mono.file) transform
+ val toMono_reduce : (job, Mono.file) transform
+ val toMono_shake : (job, Mono.file) transform
+ val toMono_opt2 : (job, Mono.file) transform
+ val toCjrize : (job, Cjr.file) transform
end
diff --git a/src/compiler.sml b/src/compiler.sml
index 6249aabf..6ea393a6 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -257,256 +257,79 @@ val corify = {
val toCorify = toExplify o transform corify "corify"
-(*fun shake' job =
- case corify job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (Shake.shake file)
+val shake = {
+ func = Shake.shake,
+ print = CorePrint.p_file CoreEnv.empty
+}
-fun tag job =
- case shake' job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (Tag.tag file)
+val toShake1 = toCorify o transform shake "shake1"
-fun reduce job =
- case tag job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (Reduce.reduce file)
+val tag = {
+ func = Tag.tag,
+ print = CorePrint.p_file CoreEnv.empty
+}
-fun specialize job =
- case reduce job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (Specialize.specialize file)
+val toTag = toShake1 o transform tag "tag"
-fun shake job =
- case specialize job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (Shake.shake file)
+val reduce = {
+ func = Reduce.reduce,
+ print = CorePrint.p_file CoreEnv.empty
+}
-fun monoize job =
- case shake job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (Monoize.monoize CoreEnv.empty file)
+val toReduce = toTag o transform reduce "reduce"
-fun mono_opt' job =
- case monoize job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (MonoOpt.optimize file)
+val specialize = {
+ func = Specialize.specialize,
+ print = CorePrint.p_file CoreEnv.empty
+}
-fun untangle job =
- case mono_opt' job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (Untangle.untangle file)
+val toSpecialize = toReduce o transform specialize "specialize"
-fun mono_reduce job =
- case untangle job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (MonoReduce.reduce file)
+val toShake2 = toSpecialize o transform shake "shake2"
-fun mono_shake job =
- case mono_reduce job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (MonoShake.shake file)
+val monoize = {
+ func = Monoize.monoize CoreEnv.empty,
+ print = MonoPrint.p_file MonoEnv.empty
+}
-fun mono_opt job =
- case mono_shake job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (MonoOpt.optimize file)
+val toMonoize = toShake2 o transform monoize "monoize"
-fun cjrize job =
- case mono_opt job of
- NONE => NONE
- | SOME file =>
- if ErrorMsg.anyErrors () then
- NONE
- else
- SOME (Cjrize.cjrize file)
+val mono_opt = {
+ func = MonoOpt.optimize,
+ print = MonoPrint.p_file MonoEnv.empty
+}
-fun testParse job =
- case parse job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (SourcePrint.p_file file);
- print "\n")
+val toMono_opt1 = toMonoize o transform mono_opt "mono_opt1"
+
+val untangle = {
+ func = Untangle.untangle,
+ print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toUntangle = toMono_opt1 o transform untangle "untangle"
+
+val mono_reduce = {
+ func = MonoReduce.reduce,
+ print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toMono_reduce = toUntangle o transform mono_reduce "mono_reduce"
+
+val mono_shake = {
+ func = MonoShake.shake,
+ print = MonoPrint.p_file MonoEnv.empty
+}
+
+val toMono_shake = toMono_reduce o transform mono_shake "mono_shake"
+
+val toMono_opt2 = toMono_shake o transform mono_opt "mono_opt2"
-fun testElaborate job =
- (case elaborate job of
- NONE => print "Failed\n"
- | SOME file =>
- (print "Succeeded\n";
- Print.print (ElabPrint.p_file ElabEnv.empty file);
- print "\n"))
- handle ElabEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testExplify job =
- (case explify job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (ExplPrint.p_file ExplEnv.empty file);
- print "\n"))
- handle ExplEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testCorify job =
- (case corify job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (CorePrint.p_file CoreEnv.empty file);
- print "\n"))
- handle CoreEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testShake' job =
- (case shake' job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (CorePrint.p_file CoreEnv.empty file);
- print "\n"))
- handle CoreEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testReduce job =
- (case reduce job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (CorePrint.p_file CoreEnv.empty file);
- print "\n"))
- handle CoreEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testSpecialize job =
- (case specialize job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (CorePrint.p_file CoreEnv.empty file);
- print "\n"))
- handle CoreEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testTag job =
- (case tag job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (CorePrint.p_file CoreEnv.empty file);
- print "\n"))
- handle CoreEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testShake job =
- (case shake job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (CorePrint.p_file CoreEnv.empty file);
- print "\n"))
- handle CoreEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testMonoize job =
- (case monoize job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (MonoPrint.p_file MonoEnv.empty file);
- print "\n"))
- handle MonoEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testMono_opt' job =
- (case mono_opt' job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (MonoPrint.p_file MonoEnv.empty file);
- print "\n"))
- handle MonoEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testUntangle job =
- (case untangle job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (MonoPrint.p_file MonoEnv.empty file);
- print "\n"))
- handle MonoEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testMono_reduce job =
- (case mono_reduce job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (MonoPrint.p_file MonoEnv.empty file);
- print "\n"))
- handle MonoEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testMono_shake job =
- (case mono_shake job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (MonoPrint.p_file MonoEnv.empty file);
- print "\n"))
- handle MonoEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testMono_opt job =
- (case mono_opt job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (MonoPrint.p_file MonoEnv.empty file);
- print "\n"))
- handle MonoEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")
-
-fun testCjrize job =
- (case cjrize job of
- NONE => print "Failed\n"
- | SOME file =>
- (Print.print (CjrPrint.p_file CjrEnv.empty file);
- print "\n"))
- handle CjrEnv.UnboundNamed n =>
- print ("Unbound named " ^ Int.toString n ^ "\n")*)
+val cjrize = {
+ func = Cjrize.cjrize,
+ print = CjrPrint.p_file CjrEnv.empty
+}
+
+val toCjrize = toMono_opt2 o transform cjrize "cjrize"
fun compileC {cname, oname, ename} =
let
@@ -521,25 +344,22 @@ fun compileC {cname, oname, ename} =
print "Success\n"
end
-(*fun compile job =
- case cjrize job of
+fun compile job =
+ case run toCjrize job of
NONE => print "Laconic compilation failed\n"
| SOME file =>
- if ErrorMsg.anyErrors () then
- print "Laconic compilation failed\n"
- else
- let
- val cname = "/tmp/lacweb.c"
- val oname = "/tmp/lacweb.o"
- val ename = "/tmp/webapp"
-
- val outf = TextIO.openOut cname
- val s = TextIOPP.openOut {dst = outf, wid = 80}
- in
- Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
- TextIO.closeOut outf;
-
- compileC {cname = cname, oname = oname, ename = ename}
- end*)
+ let
+ val cname = "/tmp/lacweb.c"
+ val oname = "/tmp/lacweb.o"
+ val ename = "/tmp/webapp"
+
+ val outf = TextIO.openOut cname
+ val s = TextIOPP.openOut {dst = outf, wid = 80}
+ in
+ Print.fprint s (CjrPrint.p_file CjrEnv.empty file);
+ TextIO.closeOut outf;
+
+ compileC {cname = cname, oname = oname, ename = ename}
+ end
end
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 12:18:23 +0000