Initial import of l3c

[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

  (* see flag explanations below *)
  val flag_verbose = Flag.flag "verbose"
  val flag_liveness = Flag.flag "liveness"
  val flag_ast = Flag.flag "ast"
  val flag_ir = Flag.flag "ir"
  val flag_assem = Flag.flag "assem"
  val flag_color = Flag.flag "color"

  fun reset_flags () =
      List.app Flag.unset [flag_verbose, flag_ast,
                           flag_ir, flag_assem, flag_liveness];

  val options = [{short = "v", long=["verbose"], 
                  desc=G.NoArg (fn () => Flag.set flag_verbose),
                  help="verbose messages"},
                 {short = "a", long=["dump-ast"],
                  desc=G.NoArg (fn () => Flag.set flag_ast),
                  help="pretty print the AST"},
                 {short = "i", long=["dump-ir"],
                  desc=G.NoArg (fn () => Flag.set flag_ir),
                  help="pretty print the IR"},
                 {short = "l", long=["dump-liveness"],
                  desc=G.NoArg (fn () => Flag.set flag_liveness),
                  help="pretty print the liveness results"},
                 {short = "s", long=["dump-assem"],
                  desc=G.NoArg (fn () => Flag.set flag_assem),
                  help="pretty print the assembly before register allocaction"},
                 {short = "c", long=["dump-color"],
                  desc=G.NoArg (fn () => Flag.set flag_color),
                  help="pretty print the allocated regs"}
                ]


  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 = "_l3_" ^ (Symbol.name id)
        
        fun realname s = if (List.exists (fn n => s = n) externs)
                         then s
                         else "_l3_" ^ s
      
        val _ = Flag.guard flag_verbose say ("Processing function: " ^ name)

        val _ = Flag.guard flag_verbose say "  Generating proto-x86_64 code..."
        val assem = Codegen.codegen ir
        val _ = Flag.guard flag_assem
                  (fn () => List.app (TextIO.print o (x86.prettyprint x86.Long)) assem) ()

        val _ = Flag.guard flag_verbose say "  Analyzing liveness..."
        val (preds, liveness) = Liveness.liveness assem;
        val _ = Flag.guard flag_liveness
                  (fn () => List.app
                    (fn (asm, liv) =>
                      TextIO.print (
                        let
                          val xpp = x86.prettyprint x86.Long 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 flag_verbose say "  Graphing..."
        val (igraph,temps) = Igraph.gengraph (preds, liveness)

        val _ = Flag.guard flag_verbose say "  Ordering..."
        val order = ColorOrder.colororder (igraph,temps)
        
        val _ = Flag.guard flag_verbose say "  Coloring..."
        val colors = Colorizer.colorize order igraph;
        val _ = Flag.guard flag_color
                  (fn () => List.app (TextIO.print o
                    (fn (t, i) =>
                      (Temp.name t) ^ " => " ^ (
                        if (i <= x86.regtonum x86.R14D)
                          then (x86.prettyprint_oper x86.Long (x86.REG (x86.numtoreg i)))
                        else
                          "spill[" ^ Int.toString (i - x86.regtonum x86.R14D) ^ "]")
                        ^ "--"^ Int.toString i ^ "\n"))
                    colors) ()

        val _ = Flag.guard flag_verbose say "  Solidifying x86_64 code..."
        val x86 = Solidify.solidify colors assem;

        val _ = Flag.guard flag_verbose say "  Peepholing..."
        val x86p = Peephole.peephole x86;

        val _ = Flag.guard flag_verbose say "  Stringifying..."
        val x86d = [x86.DIRECTIVE(".globl " ^ name),
                    x86.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 _ = reset_flags (); (* 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 flag_verbose say ("Parsing... " ^ source)
        val ast = Parse.parse source
        val _ = Flag.guard flag_ast
                  (fn () => say (Ast.Print.pp_program ast)) ()
        
        val externs = List.mapPartial 
                        (fn (Ast.Function _) => NONE
                          | (Ast.Extern (_, s, _)) => SOME (Symbol.name s)) ast
        
        val _ = Flag.guard flag_verbose say "Checking..."
        val ast = TypeChecker.typecheck ast
        
        val _ = Flag.guard flag_verbose say "Translating..."
        val ir = Trans.translate ast
        val _ = Flag.guard flag_ir (fn () => say (Tree.Print.pp_program ir)) ()
        
        val output = foldr (fn (func, code) => (processir externs func) ^ code) 
          (".file\t\"" ^ source ^ "\"\n.ident\t\"15-411 L3 compiler by czl@ and jwise@\"\n") ir

        val afname = stem source ^ ".s"
        val _ = Flag.guard flag_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