[snipe.git] / top / top.sml

(* L3 Compiler
 * Top Level Environment
 * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
 * Modified: Alex Vaynberg <alv@andrew.cmu.edu>
 * Modified: Frank Pfenning <fp@cs.cmu.edu>
 *)

signature TOP =
sig
  (* main function for standalone executable
   * use with SMLofNJ.exportFn("heapfilename", Top.main)
   *)
  val main : string * string list -> OS.Process.status
  
  (* test "arguments"; is the same as executing a saved
   * heap with arguments on the command line
   *)
  val test : string -> OS.Process.status
end

structure Top :> TOP =
struct
  structure G = GetOpt  (* from $/smlnj-lib/Util/getopt-sig.sml *)

  fun say s = TextIO.output (TextIO.stdErr, s ^ "\n")

  fun newline () = TextIO.output (TextIO.stdErr, "\n")

  exception EXIT
  
  val alloptimizations =
    [(*ConstantFold.optimizer,
     StupidFunctionElim.optimizer,
     FeckfulnessAnalysis.optimizer,
     ConstantFold.optimizer,
     LabelCoalescing.optimizer,
     Peephole.optimizer*)] : Optimizer.optimization list
  
  val uniqopts =
    foldr
      (fn (opt : Optimizer.optimization, l) =>
        if (List.exists (fn (x : Optimizer.optimization) => (#shortname opt) = (#shortname x)) l)
        then l
        else opt :: l)
      []
      alloptimizations

  val enabledopts = ref alloptimizations

  val options = [{short = "v", long=["verbose"], 
                  desc=G.NoArg (fn () => Flag.set Flags.verbose),
                  help="verbose messages"},
                 {short = "a", long=["dump-ast"],
                  desc=G.NoArg (fn () => Flag.set Flags.ast),
                  help="pretty print the AST"},
                 {short = "i", long=["dump-ir"],
                  desc=G.NoArg (fn () => Flag.set Flags.ir),
                  help="pretty print the IR"},
                 {short = "l", long=["dump-liveness"],
                  desc=G.NoArg (fn () => Flag.set Flags.liveness),
                  help="pretty print the liveness results"},
                 {short = "s", long=["dump-assem"],
                  desc=G.NoArg (fn () => Flag.set Flags.assem),
                  help="pretty print the assembly before register allocaction"},
                 {short = "c", long=["dump-color"],
                  desc=G.NoArg (fn () => Flag.set Flags.color),
                  help="pretty print the allocated regs"},
                 {short = "", long=["safe"],
                  desc=G.NoArg (fn () => Flag.set Flags.safe),
                  help="enable memory-safety"},
                 {short = "", long=["unsafe"],
                  desc=G.NoArg (fn () => Flag.unset Flags.safe),
                  help="disable memory-safety"}, 
                 {short = "", long = ["disable-all"],
                  desc=G.NoArg (fn () => enabledopts := nil),
                  help="disable all optimizations"}
                ] @
                map
                  (fn (opt : Optimizer.optimization) =>
                    { short = "", long=["disable-" ^ (#shortname opt)],
                      desc = G.NoArg (* This is nasty. *)
                        (fn () => enabledopts := List.filter (fn x => (#shortname x) <> (#shortname opt)) (!enabledopts)),
                      help = "disable optimization: " ^ (#description opt) })
                  uniqopts


  fun stem s =
      let
          val (prefix, suffix) =
              Substring.splitr (fn c => c <> #".") (Substring.full s)
      in
          if Substring.isEmpty prefix (* no "." in string s *)
             then s (* return whole string *)
          else Substring.string (Substring.trimr 1 prefix)
      end
  
  fun processir externs (Tree.FUNCTION (id, ir)) =
      let
        val name = "_l5_" ^ (Symbol.name id)
        
        fun realname s = if (List.exists (fn n => s = n) externs)
                         then s
                         else "_l5_" ^ s
      
        val _ = Flag.guard Flags.verbose say ("Processing function: " ^ name)

        val _ = Flag.guard Flags.verbose say "  Generating proto-blargCPU code..."
        val assem = Codegen.codegen ir
        val _ = Flag.guard Flags.assem
                  (fn () => List.app (TextIO.print o (Blarg.print)) assem) ()

        val _ = Flag.guard Flags.verbose say "  Optimizing pre-liveness..."
        val assem = Optimizer.optimize_preliveness (!enabledopts) assem
        
        val _ = Flag.guard Flags.verbose say "  Analyzing liveness..."
        val (preds, liveness) = Liveness.liveness assem;
        val _ = Flag.guard Flags.liveness
                  (fn () => List.app
                    (fn (asm, liv) =>
                      TextIO.print (
                        let
                          val xpp = Blarg.print asm
                          val xpp = String.extract (xpp, 0, SOME (size xpp - 1))
                          val spaces = implode (List.tabulate (40 - size xpp, fn _ => #" ")) handle size => ""
                          val lpp = Liveness.prettyprint liv
                          val lpp = String.extract (lpp, 0, SOME (size lpp - 1))
                          val spaces2 = implode (List.tabulate (40 - size lpp, fn _ => #" ")) handle size => ""
                        in
                          xpp ^ spaces ^ lpp ^ spaces2 ^ "\n"
                        end))
                    (ListPair.zip (assem, Liveness.listify liveness))) ()

        val _ = Flag.guard Flags.verbose say "  Graphing..."
        val (igraph,temps) = Igraph.gengraph (preds, liveness)

        val _ = Flag.guard Flags.verbose say "  Ordering..."
        val order = ColorOrder.colororder (igraph,temps)
        
        val _ = Flag.guard Flags.verbose say "  Coloring..."
        val colors = Colorizer.colorize order igraph
        val _ = Flag.guard Flags.color
                  (fn () => List.app (TextIO.print o
                    (fn (t, i) =>
                      (Temp.name t) ^ " => " ^ (
                        if (i <= 10)
                          then (Blarg.pp_oper (Blarg.REG (Blarg.numtoreg i)))
                        else
                          "spill[" ^ Int.toString (i - 11) ^ "]")
                        ^ "--"^ Int.toString i ^ "\n"))
                    colors) ()

        val _ = Flag.guard Flags.verbose say "  Solidifying blargCPU code..."
        val x86 = Solidify.solidify colors assem

        val _ = Flag.guard Flags.verbose say "  Optimizing final assembly..."
        val x86p = Optimizer.optimize_final (!enabledopts) x86

        val _ = Flag.guard Flags.verbose say "  Stringifying..."
        val x86d = [Blarg.DIRECTIVE(".globl " ^ name),
                    Blarg.DIRECTIVE(name ^ ":")]
                    @ x86p
        val code = Stringify.stringify realname x86d
      in
        code
      end

  fun main (name, args) =
      let
        val header = "Usage: compile [OPTION...] SOURCEFILE\nwhere OPTION is"
        val usageinfo = G.usageInfo {header = header, options = options}
        fun errfn msg = (say (msg ^ "\n" ^ usageinfo) ; raise EXIT)

        val _ = Temp.reset (); (* reset temp variable counter *)
        val _ = Flags.reset (); (* return all flags to default value *)

        val _ = if List.length args = 0 then
                    (say usageinfo; raise EXIT)
                else ()

        val (opts, files) =
            G.getOpt {argOrder = G.Permute,
                      options = options,
                      errFn = errfn}
                     args

        val source =
            case files
              of [] => errfn "Error: no input file"
               | [filename] => filename
               | _ => errfn "Error: more than one input file"

        val _ = Flag.guard Flags.verbose say ("Enabled optimizations: " ^ String.concat (map (fn x => (#shortname x) ^ " ") (!enabledopts)))

        val _ = Flag.guard Flags.verbose say ("Parsing... " ^ source)
        val ast = Parse.parse source
        val (_, funcs) = ast
        val _ = Flag.guard Flags.ast
                  (fn () => say (Ast.Print.pp_program ast)) ()

        val externs = Symbol.mapPartiali
                        (fn (a, b) => case (AstUtils.Function.data b)
                                      of Ast.Extern _ => SOME(Symbol.name a)
                                       | _ => NONE
                        ) funcs

        val _ = Flag.guard Flags.verbose say "Checking..."
        val ast = TypeChecker.typecheck ast

        val _ = Flag.guard Flags.verbose say "Translating..."
        val ir = Trans.translate ast
        val _ = Flag.guard Flags.ir (fn () => say (TreeUtils.Print.pp_program ir)) ()

        val _ = Flag.guard Flags.verbose say "Optimizing whole-program IR..."
        val ir = Optimizer.optimize_ir (!enabledopts) ir
        val _ = Flag.guard Flags.ir (fn () => say (TreeUtils.Print.pp_program ir)) ()
        
        val code = map (fn func => processir ("calloc" (* lololololol *) :: (Symbol.elems externs)) func) ir
        val strings = map (fn (sn, s) => String.concat (
                                           [Stringref.name sn, ": .word "] @
                                           (map (fn c => (Int.toString (ord c)) ^ ", ") (String.explode s)) @ 
                                           ["0\n"]
                                         ) ) (Stringref.all ())

        val output =
          String.concat (
            ".file\t\"" :: source :: "\"\n" ::
            ".ident\t\"15-411 ASS compiler by czl@ and jwise@\"\n" ::
            ".ident \"Optimizations enabled: " :: (map (fn x => (#shortname x) ^ " ") (!enabledopts)) @ [ "\"\n" ] @
            code @
            [ ".section .rodata\n" ] @
            strings )

        val afname = stem source ^ ".s"
        val _ = Flag.guard Flags.verbose say ("Writing assembly to " ^ afname ^ " ...")
        val _ = SafeIO.withOpenOut afname (fn afstream =>
                   TextIO.output (afstream, output))
      in
          OS.Process.success
      end
      handle ErrorMsg.Error => ( say "Compilation failed" ; OS.Process.failure )
           | EXIT => OS.Process.failure
           | ErrorMsg.InternalError s => ( say ("Internal compiler error: "^s^"\n"); OS.Process.failure)
           | e => (say ("Unrecognized exception " ^ exnMessage e); OS.Process.failure)

  fun test s = main ("", String.tokens Char.isSpace s)
end
Commit	Line	Data
6ade8b0a	1	(* L3 Compiler
12aa4087 JW	2	* Top Level Environment
	3	* Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
	4	* Modified: Alex Vaynberg <alv@andrew.cmu.edu>
	5	* Modified: Frank Pfenning <fp@cs.cmu.edu>
	6	*)
	7
	8	signature TOP =
	9	sig
	10	(* main function for standalone executable
	11	* use with SMLofNJ.exportFn("heapfilename", Top.main)
	12	*)
	13	val main : string * string list -> OS.Process.status
	14
	15	(* test "arguments"; is the same as executing a saved
	16	* heap with arguments on the command line
	17	*)
	18	val test : string -> OS.Process.status
	19	end
	20
	21	structure Top :> TOP =
	22	struct
	23	structure G = GetOpt (* from $/smlnj-lib/Util/getopt-sig.sml *)
	24
	25	fun say s = TextIO.output (TextIO.stdErr, s ^ "\n")
	26
	27	fun newline () = TextIO.output (TextIO.stdErr, "\n")
	28
	29	exception EXIT
5c79bb68 JW	30
5c79bb68 JW	31	val alloptimizations =
f716a180	32	[(*ConstantFold.optimizer,
5c79bb68 JW	33	StupidFunctionElim.optimizer,
	34	FeckfulnessAnalysis.optimizer,
	35	ConstantFold.optimizer,
	36	LabelCoalescing.optimizer,
de034162	37	Peephole.optimizer*)] : Optimizer.optimization list
5c79bb68 JW	38
	39	val uniqopts =
	40	foldr
	41	(fn (opt : Optimizer.optimization, l) =>
	42	if (List.exists (fn (x : Optimizer.optimization) => (#shortname opt) = (#shortname x)) l)
	43	then l
	44	else opt :: l)
	45	[]
	46	alloptimizations
12aa4087	47
5c79bb68	48	val enabledopts = ref alloptimizations
12aa4087 JW	49
12aa4087 JW	50	val options = [{short = "v", long=["verbose"],
5c79bb68	51	desc=G.NoArg (fn () => Flag.set Flags.verbose),
0a24e44d JW	52	help="verbose messages"},
0a24e44d JW	53	{short = "a", long=["dump-ast"],
5c79bb68	54	desc=G.NoArg (fn () => Flag.set Flags.ast),
0a24e44d JW	55	help="pretty print the AST"},
0a24e44d JW	56	{short = "i", long=["dump-ir"],
5c79bb68	57	desc=G.NoArg (fn () => Flag.set Flags.ir),
0a24e44d JW	58	help="pretty print the IR"},
0a24e44d JW	59	{short = "l", long=["dump-liveness"],
5c79bb68	60	desc=G.NoArg (fn () => Flag.set Flags.liveness),
0a24e44d JW	61	help="pretty print the liveness results"},
0a24e44d JW	62	{short = "s", long=["dump-assem"],
5c79bb68	63	desc=G.NoArg (fn () => Flag.set Flags.assem),
6ade8b0a JW	64	help="pretty print the assembly before register allocaction"},
6ade8b0a JW	65	{short = "c", long=["dump-color"],
5c79bb68 JW	66	desc=G.NoArg (fn () => Flag.set Flags.color),
	67	help="pretty print the allocated regs"},
	68	{short = "", long=["safe"],
	69	desc=G.NoArg (fn () => Flag.set Flags.safe),
	70	help="enable memory-safety"},
	71	{short = "", long=["unsafe"],
	72	desc=G.NoArg (fn () => Flag.unset Flags.safe),
	73	help="disable memory-safety"},
	74	{short = "", long = ["disable-all"],
	75	desc=G.NoArg (fn () => enabledopts := nil),
	76	help="disable all optimizations"}
	77	] @
	78	map
	79	(fn (opt : Optimizer.optimization) =>
	80	{ short = "", long=["disable-" ^ (#shortname opt)],
	81	desc = G.NoArg (* This is nasty. *)
	82	(fn () => enabledopts := List.filter (fn x => (#shortname x) <> (#shortname opt)) (!enabledopts)),
	83	help = "disable optimization: " ^ (#description opt) })
	84	uniqopts
12aa4087 JW	85
	86
	87	fun stem s =
	88	let
0a24e44d JW	89	val (prefix, suffix) =
0a24e44d JW	90	Substring.splitr (fn c => c <> #".") (Substring.full s)
12aa4087	91	in
0a24e44d JW	92	if Substring.isEmpty prefix (* no "." in string s *)
	93	then s (* return whole string *)
	94	else Substring.string (Substring.trimr 1 prefix)
12aa4087	95	end
6ade8b0a JW	96
	97	fun processir externs (Tree.FUNCTION (id, ir)) =
	98	let
5c79bb68	99	val name = "_l5_" ^ (Symbol.name id)
6ade8b0a JW	100
	101	fun realname s = if (List.exists (fn n => s = n) externs)
	102	then s
5c79bb68	103	else "_l5_" ^ s
6ade8b0a	104
5c79bb68	105	val _ = Flag.guard Flags.verbose say ("Processing function: " ^ name)
6ade8b0a	106
d4e2479e	107	val _ = Flag.guard Flags.verbose say " Generating proto-blargCPU code..."
6ade8b0a	108	val assem = Codegen.codegen ir
5c79bb68	109	val _ = Flag.guard Flags.assem
de034162	110	(fn () => List.app (TextIO.print o (Blarg.print)) assem) ()
6ade8b0a	111
5c79bb68 JW	112	val _ = Flag.guard Flags.verbose say " Optimizing pre-liveness..."
	113	val assem = Optimizer.optimize_preliveness (!enabledopts) assem
	114
	115	val _ = Flag.guard Flags.verbose say " Analyzing liveness..."
6ade8b0a	116	val (preds, liveness) = Liveness.liveness assem;
5c79bb68	117	val _ = Flag.guard Flags.liveness
6ade8b0a JW	118	(fn () => List.app
	119	(fn (asm, liv) =>
	120	TextIO.print (
	121	let
de034162	122	val xpp = Blarg.print asm
6ade8b0a JW	123	val xpp = String.extract (xpp, 0, SOME (size xpp - 1))
	124	val spaces = implode (List.tabulate (40 - size xpp, fn _ => #" ")) handle size => ""
	125	val lpp = Liveness.prettyprint liv
	126	val lpp = String.extract (lpp, 0, SOME (size lpp - 1))
	127	val spaces2 = implode (List.tabulate (40 - size lpp, fn _ => #" ")) handle size => ""
	128	in
	129	xpp ^ spaces ^ lpp ^ spaces2 ^ "\n"
	130	end))
	131	(ListPair.zip (assem, Liveness.listify liveness))) ()
	132
5c79bb68	133	val _ = Flag.guard Flags.verbose say " Graphing..."
6ade8b0a JW	134	val (igraph,temps) = Igraph.gengraph (preds, liveness)
6ade8b0a JW	135
5c79bb68	136	val _ = Flag.guard Flags.verbose say " Ordering..."
6ade8b0a JW	137	val order = ColorOrder.colororder (igraph,temps)
6ade8b0a JW	138
5c79bb68 JW	139	val _ = Flag.guard Flags.verbose say " Coloring..."
	140	val colors = Colorizer.colorize order igraph
	141	val _ = Flag.guard Flags.color
6ade8b0a JW	142	(fn () => List.app (TextIO.print o
	143	(fn (t, i) =>
	144	(Temp.name t) ^ " => " ^ (
d4e2479e	145	if (i <= 10)
de034162	146	then (Blarg.pp_oper (Blarg.REG (Blarg.numtoreg i)))
6ade8b0a	147	else
d4e2479e	148	"spill[" ^ Int.toString (i - 11) ^ "]")
6ade8b0a JW	149	^ "--"^ Int.toString i ^ "\n"))
	150	colors) ()
	151
c2b45b36	152	val _ = Flag.guard Flags.verbose say " Solidifying blargCPU code..."
5c79bb68	153	val x86 = Solidify.solidify colors assem
6ade8b0a	154
5c79bb68 JW	155	val _ = Flag.guard Flags.verbose say " Optimizing final assembly..."
5c79bb68 JW	156	val x86p = Optimizer.optimize_final (!enabledopts) x86
6ade8b0a	157
5c79bb68	158	val _ = Flag.guard Flags.verbose say " Stringifying..."
c2b45b36 JW	159	val x86d = [Blarg.DIRECTIVE(".globl " ^ name),
c2b45b36 JW	160	Blarg.DIRECTIVE(name ^ ":")]
6ade8b0a	161	@ x86p
c2b45b36	162	val code = Stringify.stringify realname x86d
6ade8b0a	163	in
c2b45b36	164	code
6ade8b0a	165	end
12aa4087 JW	166
	167	fun main (name, args) =
	168	let
0a24e44d JW	169	val header = "Usage: compile [OPTION...] SOURCEFILE\nwhere OPTION is"
	170	val usageinfo = G.usageInfo {header = header, options = options}
	171	fun errfn msg = (say (msg ^ "\n" ^ usageinfo) ; raise EXIT)
	172
	173	val _ = Temp.reset (); (* reset temp variable counter *)
5c79bb68	174	val _ = Flags.reset (); (* return all flags to default value *)
0a24e44d JW	175
	176	val _ = if List.length args = 0 then
	177	(say usageinfo; raise EXIT)
	178	else ()
	179
	180	val (opts, files) =
	181	G.getOpt {argOrder = G.Permute,
	182	options = options,
	183	errFn = errfn}
	184	args
	185
	186	val source =
	187	case files
	188	of [] => errfn "Error: no input file"
	189	\| [filename] => filename
	190	\| _ => errfn "Error: more than one input file"
	191
5c79bb68 JW	192	val _ = Flag.guard Flags.verbose say ("Enabled optimizations: " ^ String.concat (map (fn x => (#shortname x) ^ " ") (!enabledopts)))
	193
	194	val _ = Flag.guard Flags.verbose say ("Parsing... " ^ source)
0a24e44d	195	val ast = Parse.parse source
1144856b	196	val (_, funcs) = ast
5c79bb68	197	val _ = Flag.guard Flags.ast
0a24e44d	198	(fn () => say (Ast.Print.pp_program ast)) ()
1144856b JW	199
	200	val externs = Symbol.mapPartiali
	201	(fn (a, b) => case (AstUtils.Function.data b)
	202	of Ast.Extern _ => SOME(Symbol.name a)
	203	\| _ => NONE
	204	) funcs
	205
5c79bb68	206	val _ = Flag.guard Flags.verbose say "Checking..."
0a24e44d	207	val ast = TypeChecker.typecheck ast
1144856b	208
5c79bb68	209	val _ = Flag.guard Flags.verbose say "Translating..."
0a24e44d	210	val ir = Trans.translate ast
5c79bb68 JW	211	val _ = Flag.guard Flags.ir (fn () => say (TreeUtils.Print.pp_program ir)) ()
	212
	213	val _ = Flag.guard Flags.verbose say "Optimizing whole-program IR..."
	214	val ir = Optimizer.optimize_ir (!enabledopts) ir
	215	val _ = Flag.guard Flags.ir (fn () => say (TreeUtils.Print.pp_program ir)) ()
469e60eb JW	216
	217	val code = map (fn func => processir ("calloc" (* lololololol *) :: (Symbol.elems externs)) func) ir
	218	val strings = map (fn (sn, s) => String.concat (
	219	[Stringref.name sn, ": .word "] @
	220	(map (fn c => (Int.toString (ord c)) ^ ", ") (String.explode s)) @
	221	["0\n"]
	222	) ) (Stringref.all ())
	223
	224	val output =
	225	String.concat (
	226	".file\t\"" :: source :: "\"\n" ::
	227	".ident\t\"15-411 ASS compiler by czl@ and jwise@\"\n" ::
	228	".ident \"Optimizations enabled: " :: (map (fn x => (#shortname x) ^ " ") (!enabledopts)) @ [ "\"\n" ] @
	229	code @
	230	[ ".section .rodata\n" ] @
	231	strings )
0a24e44d JW	232
0a24e44d JW	233	val afname = stem source ^ ".s"
5c79bb68	234	val _ = Flag.guard Flags.verbose say ("Writing assembly to " ^ afname ^ " ...")
0a24e44d	235	val _ = SafeIO.withOpenOut afname (fn afstream =>
6ade8b0a	236	TextIO.output (afstream, output))
12aa4087	237	in
0a24e44d	238	OS.Process.success
12aa4087 JW	239	end
12aa4087 JW	240	handle ErrorMsg.Error => ( say "Compilation failed" ; OS.Process.failure )
0a24e44d JW	241	\| EXIT => OS.Process.failure
0a24e44d JW	242	\| ErrorMsg.InternalError s => ( say ("Internal compiler error: "^s^"\n"); OS.Process.failure)
12aa4087 JW	243	\| e => (say ("Unrecognized exception " ^ exnMessage e); OS.Process.failure)
	244
	245	fun test s = main ("", String.tokens Char.isSpace s)
	246	end