top/top.sml

   1 (* L3 Compiler
   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
  30
  31   val alloptimizations =
  32     [ConstantFold.optimizer,
  33      StupidFunctionElim.optimizer,
  34      FeckfulnessAnalysis.optimizer,
  35      ConstantFold.optimizer,
  36      LabelCoalescing.optimizer,
  37      Peephole.optimizer]
  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
  47
  48   val enabledopts = ref alloptimizations
  49
  50   val options = [{short = "v", long=["verbose"],
  51                   desc=G.NoArg (fn () => Flag.set Flags.verbose),
  52                   help="verbose messages"},
  53                  {short = "a", long=["dump-ast"],
  54                   desc=G.NoArg (fn () => Flag.set Flags.ast),
  55                   help="pretty print the AST"},
  56                  {short = "i", long=["dump-ir"],
  57                   desc=G.NoArg (fn () => Flag.set Flags.ir),
  58                   help="pretty print the IR"},
  59                  {short = "l", long=["dump-liveness"],
  60                   desc=G.NoArg (fn () => Flag.set Flags.liveness),
  61                   help="pretty print the liveness results"},
  62                  {short = "s", long=["dump-assem"],
  63                   desc=G.NoArg (fn () => Flag.set Flags.assem),
  64                   help="pretty print the assembly before register allocaction"},
  65                  {short = "c", long=["dump-color"],
  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
  85
  86
  87   fun stem s =
  88       let
  89           val (prefix, suffix) =
  90               Substring.splitr (fn c => c <> #".") (Substring.full s)
  91       in
  92           if Substring.isEmpty prefix (* no "." in string s *)
  93              then s (* return whole string *)
  94           else Substring.string (Substring.trimr 1 prefix)
  95       end
  96
  97   fun processir externs (Tree.FUNCTION (id, ir)) =
  98       let
  99         val name = "_l5_" ^ (Symbol.name id)
 100
 101         fun realname s = if (List.exists (fn n => s = n) externs)
 102                          then s
 103                          else "_l5_" ^ s
 104
 105         val _ = Flag.guard Flags.verbose say ("Processing function: " ^ name)
 106
 107         val _ = Flag.guard Flags.verbose say "  Generating proto-x86_64 code..."
 108         val assem = Codegen.codegen ir
 109         val _ = Flag.guard Flags.assem
 110                   (fn () => List.app (TextIO.print o (x86.print)) assem) ()
 111
 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..."
 116         val (preds, liveness) = Liveness.liveness assem;
 117         val _ = Flag.guard Flags.liveness
 118                   (fn () => List.app
 119                     (fn (asm, liv) =>
 120                       TextIO.print (
 121                         let
 122                           val xpp = x86.print asm
 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
 133         val _ = Flag.guard Flags.verbose say "  Graphing..."
 134         val (igraph,temps) = Igraph.gengraph (preds, liveness)
 135
 136         val _ = Flag.guard Flags.verbose say "  Ordering..."
 137         val order = ColorOrder.colororder (igraph,temps)
 138
 139         val _ = Flag.guard Flags.verbose say "  Coloring..."
 140         val colors = Colorizer.colorize order igraph
 141         val _ = Flag.guard Flags.color
 142                   (fn () => List.app (TextIO.print o
 143                     (fn (t, i) =>
 144                       (Temp.name t) ^ " => " ^ (
 145                         if (i <= x86.regtonum x86.R13D)
 146                           then (x86.pp_oper (x86.REG (x86.numtoreg i), Temp.Long))
 147                         else
 148                           "spill[" ^ Int.toString (i - x86.regtonum x86.R13D) ^ "]")
 149                         ^ "--"^ Int.toString i ^ "\n"))
 150                     colors) ()
 151
 152         val _ = Flag.guard Flags.verbose say "  Solidifying x86_64 code..."
 153         val x86 = Solidify.solidify colors assem
 154
 155         val _ = Flag.guard Flags.verbose say "  Optimizing final assembly..."
 156         val x86p = Optimizer.optimize_final (!enabledopts) x86
 157
 158         val _ = Flag.guard Flags.verbose say "  Stringifying..."
 159         val x86d = [x86.DIRECTIVE(".globl " ^ name),
 160                     x86.DIRECTIVE(name ^ ":")]
 161                     @ x86p
 162         val code = Stringify.stringify realname x86d
 163       in
 164         code
 165       end
 166
 167   fun main (name, args) =
 168       let
 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 *)
 174         val _ = Flags.reset (); (* return all flags to default value *)
 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
 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)
 195         val ast = Parse.parse source
 196         val (_, funcs) = ast
 197         val _ = Flag.guard Flags.ast
 198                   (fn () => say (Ast.Print.pp_program ast)) ()
 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
 206         val _ = Flag.guard Flags.verbose say "Checking..."
 207         val ast = TypeChecker.typecheck ast
 208
 209         val _ = Flag.guard Flags.verbose say "Translating..."
 210         val ir = Trans.translate ast
 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)) ()
 216
 217         val output = foldr (fn (func, code) => (processir ("calloc" (* lololololol *) :: (Symbol.elems externs)) func) ^ code)
 218           (".file\t\"" ^ source ^ "\"\n.ident\t\"15-411 ASS compiler by czl@ and jwise@\"\n" ^
 219            ".ident \"Optimizations enabled: " ^ String.concat (map (fn x => (#shortname x) ^ " ") (!enabledopts)) ^ "\"\n") ir
 220
 221         val afname = stem source ^ ".s"
 222         val _ = Flag.guard Flags.verbose say ("Writing assembly to " ^ afname ^ " ...")
 223         val _ = SafeIO.withOpenOut afname (fn afstream =>
 224                    TextIO.output (afstream, output))
 225       in
 226           OS.Process.success
 227       end
 228       handle ErrorMsg.Error => ( say "Compilation failed" ; OS.Process.failure )
 229            | EXIT => OS.Process.failure
 230            | ErrorMsg.InternalError s => ( say ("Internal compiler error: "^s^"\n"); OS.Process.failure)
 231            | e => (say ("Unrecognized exception " ^ exnMessage e); OS.Process.failure)
 232
 233   fun test s = main ("", String.tokens Char.isSpace s)
 234 end