path: root/driver.fun

functor Driver(E: EMIT): DRIVER = struct
  structure I = E.I
  structure P = E.I.P

  datatype execMode = EmAsm | EmObj | EmExe

  type config = {
    file: string option,
    outFile: string option,
    includeDirs: string list,
    libDir: string option,
    mode: execMode,
    verbose: bool,
    debugParser: bool,
    debugIl: bool,
    debugEmit: bool
  }

  fun mod2int m =
    case m of
      EmAsm => 0
    | EmObj => 1
    | EmExe => 2

  fun modCmp (m1, m2) = compare (mod2int m1) (mod2int m2)

  val updateC = fn z =>
  let
    fun from file outFile includeDirs libDir mode verbose
      debugParser debugIl debugEmit =
      { file, outFile, includeDirs, libDir, mode, verbose,
        debugParser, debugIl, debugEmit }
    fun to f { file, outFile, includeDirs, libDir, mode, verbose,
      debugParser, debugIl, debugEmit  }
    =
      f file outFile includeDirs libDir mode verbose
        debugParser debugIl debugEmit
  in
    FRU.makeUpdate9 (from, from, to)
  end z

  val initConfig: config = { file = NONE, outFile = NONE,
  includeDirs = [], libDir = NONE, mode = EmExe,
    verbose = false,
    debugParser = false, debugIl = false, debugEmit = false }

  val die = fn z => die 1 z

  fun finish ({ file = NONE, ... }: config) = die `"No file specified" %
    | finish conf =
    let
      val conf = updateC conf u#includeDirs rev %
    in
      case #outFile conf of
        NONE =>
        let
          val sfx =
            case #mode conf of
              EmAsm => ".s"
            | EmObj => ".o"
            | EmExe => ""
        in
          updateC conf s#outFile (SOME (valOf (#file conf) ^ sfx)) %
        end
      | SOME _ => conf
    end

  fun parseFlag conf "-v" tail =
        parseCmdArgs (updateC conf s#verbose true %) tail
    | parseFlag conf "-dp" tail =
        parseCmdArgs (updateC conf s#debugParser true %) tail
    | parseFlag conf "-di" tail =
        parseCmdArgs (updateC conf s#debugIl true %) tail
    | parseFlag conf "-de" tail =
        parseCmdArgs (updateC conf s#debugEmit true %) tail
    | parseFlag conf "-c" tail =
        parseCmdArgs (updateC conf s#mode EmObj %) tail
    | parseFlag conf "-S" tail =
        parseCmdArgs (updateC conf s#mode EmAsm %) tail
    | parseFlag _ "-o" [] =
        die `"-o: expected file name after argument" %
    | parseFlag (C as { outFile, ... }) "-o" (file :: tail) = (
        case outFile of
          NONE => parseCmdArgs (updateC C s#outFile (SOME file) %) tail
       | SOME _ => die `file `": output file name is already specified" %
    )
    | parseFlag _ "-L" [] =
        die `"-L: expected directory name after argument" %
    | parseFlag (C as { libDir, ... }) "-L" ((dir: string) :: tail) = (
        case libDir of
          NONE => parseCmdArgs (updateC C s#libDir (SOME dir) %) tail
       | SOME _ => die `dir `": libdir name is already specified" %
    )
    | parseFlag _ arg _ = die `arg `": unknown flag" %

  and parseCmdArgs conf [] = finish conf
    | parseCmdArgs _ ("-I" :: []) =
        die `"-I: expected directory path after flag" %
    | parseCmdArgs conf ("-I" :: path :: tail) =
        parseCmdArgs (updateC conf u#includeDirs
            (fn dirs => path :: dirs) %) tail
    | parseCmdArgs (C as { file, ... }) (arg :: tail) =
      if String.sub (arg, 0) = #"-" then
        parseFlag C arg tail
      else
        case file of
          NONE =>
            let
              val size = size arg
            in
              if String.extract (arg, size - 2, NONE) <> ".c" then
                die `arg `": expected file with .c suffix" %
              else
                let
                  val file = String.substring (arg, 0, size - 2)
                in
                  parseCmdArgs (updateC C s#file (SOME file) %) tail
                end
            end
        | SOME _ => die `arg `": file already specified" %

  fun callProgram verbose name args clean =
  let
    open Posix.Process
    fun exec () =
    let
      val args = name :: args
      fun ps s out = Printf out `s %
      val () =
        if verbose then
          printfn Plist ps args (" ", false, 0) %
        else
          ()
    in
      execp (name, args);
      die `"canot exec " `name `": exec failed" %
    end
  in
    case fork () of
      NONE => exec ()
    | SOME _ =>
        let
          val (_, status) = wait ()
        in
          case status of
            W_EXITED => clean ()
          | W_EXITSTATUS st =>
              die `name `": failed with " W (Word8.toLargeWord st) `"code" %
          | _ => raise Unimplemented
        end
  end

  fun linkArgs _ _ NONE = die `"libdir: is not specified" %
    | linkArgs input output (SOME d) =
    let
      open OS
      val crt = Path.joinDirFile { dir = d, file = "crt1.o" }
      val libc = Path.joinDirFile { dir = d, file =  "libc.a" }
    in
      ["-o", output, input, crt, libc]
    end

  fun assemble { mode, outFile, verbose, ... } asmFile =
  let
    val outputFile =
      case mode of
        EmObj => valOf outFile
      | _ => String.substring (asmFile, 0, size asmFile - 2) ^ ".o"

    val args = ["-f", "elf64", "-o", outputFile, asmFile]
    val clean =
      fn () =>
        let
          val () = if verbose then printfn `"removing " `asmFile % else ()
        in
          Posix.FileSys.unlink asmFile
        end
  in
    callProgram verbose "nasm" args clean;
    outputFile
  end

  fun link { libDir, outFile, verbose, ... } objFile =
  let
    val args = linkArgs objFile (valOf outFile) libDir
    val clean =
      fn () =>
        let
          val () = if verbose then printfn `"removing " `objFile % else ()
        in
          Posix.FileSys.unlink objFile
        end
  in
    callProgram verbose "ld" args clean
  end

  fun parse { file, includeDirs, debugParser, ... } =
  let
    val file = valOf file
    val debugFile = if debugParser then SOME (file ^ ".p") else NONE
    val parseCtx = P.createCtx file includeDirs debugFile

    fun collect ctx =
    let
      val (continue, ctx) = P.parseDef ctx
    in
      if continue then
        collect ctx
      else
        P.finalize ctx
    end
  in
    collect parseCtx
  end

  fun ilConv parseCtx config =
  let
    val debugFile =
      if #debugIl config then
        SOME (valOf (#file config) ^ ".i")
      else
        NONE
    val progInfo = P.explode parseCtx
  in
    I.createCtx progInfo debugFile
  end

  fun emit ilCtx { debugEmit, file, outFile, mode, ... }=
  let
    val debugFile =
      if debugEmit then
        SOME (valOf file ^ ".e")
      else
        NONE
    val out =
      case mode of
        EmAsm => valOf $ outFile
      | _ => OS.FileSys.tmpName () ^ ".s"
  in
    E.emit out ilCtx debugFile;
    out
  end

  fun exec () =
  let
    val config = parseCmdArgs initConfig (CommandLine.arguments ())

    val parseCtx = parse config
    val ilCtx = ilConv parseCtx config
    val asmFile = emit ilCtx config
  in
    if modCmp (#mode config, EmAsm) = GREATER then
      let
        val objFile = assemble config asmFile
      in
        if modCmp (#mode config, EmObj) = GREATER then
          link config objFile
        else
          ()
      end
    else
      ()
  end
end