Driver

6 files changed, 274 insertions, 79 deletions

diff --git a/common.sml b/common.sml
index 1c7ec29..c234fb8 100644
--- a/common.sml
+++ b/common.sml
@@ -53,6 +53,7 @@ structure FRU = struct
   fun f8 z = next f7 z
   fun f9 z = next f8 z
   fun f10 z = next f9 z
+  fun f11 z = next f10 z
 
   fun c0 from = from
   fun c1 from = c0 from f1
@@ -65,6 +66,7 @@ structure FRU = struct
   fun c8 from = c7 from f8
   fun c9 from = c8 from f9
   fun c10 from = c9 from f10
+  fun c11 from = c10 from f11
 
   fun makeUpdate cX (from, from', to) record =
     let
@@ -84,6 +86,7 @@ structure FRU = struct
   fun makeUpdate8 z = makeUpdate c8 z
   fun makeUpdate9 z = makeUpdate c9 z
   fun makeUpdate10 z = makeUpdate c10 z
+  fun makeUpdate11 z = makeUpdate c11 z
 
   fun upd z = Fold.step2
     (fn (s, f, (vars, ops)) =>
diff --git a/driver.fun b/driver.fun
index 19adcaa..ebb3dfd 100644
--- a/driver.fun
+++ b/driver.fun
@@ -2,33 +2,95 @@ functor Driver(E: EMIT): DRIVER = struct
   structure I = E.I
   structure P = E.I.P
 
-  datatype execMode = Normal | DebugE | DebugT
+  datatype execMode = EmAsm | EmObj | EmExe
 
   type config = {
     file: string option,
+    outFile: string option,
     includeDirs: string list,
-    mode: execMode
+    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 includeDirs mode = { file, includeDirs, mode }
-    fun to f { file, includeDirs, mode } = f file includeDirs mode
+    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.makeUpdate3 (from, from, to)
+    FRU.makeUpdate9 (from, from, to)
   end z
 
-  val initConfig: config = { file = NONE, includeDirs = [], mode = Normal }
+  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 = updateC conf u#includeDirs rev %
+    | 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 "-dE" tail =
-    parseCmdArgs (updateC conf s#mode DebugE %) tail
-    | parseFlag conf "-dT" tail =
-        parseCmdArgs (updateC conf s#mode DebugT %) tail
+  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
@@ -57,34 +119,146 @@ functor Driver(E: EMIT): DRIVER = struct
             end
         | SOME _ => die `arg `": file already specified" %
 
-  fun exec () =
+  fun callProgram verbose name args clean =
   let
-    val config = parseCmdArgs initConfig (CommandLine.arguments ())
-    val file = valOf $ #file config
+    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 (#mode config) of
-      Normal =>
+    case fork () of
+      NONE => exec ()
+    | SOME _ =>
         let
-          val parseCtx = P.createCtx file (#includeDirs config) true
-
-          fun collect ctx =
-          let
-            val (continue, ctx) = P.parseDef ctx
-          in
-            if continue then
-              collect ctx
-            else
-              P.finalize ctx
-          end
-
-          val parseCtx = collect parseCtx
-          val progInfo = P.explode parseCtx
-          val ilCtx = I.createCtx progInfo (SOME $ file ^ ".i")
+          val (_, status) = wait ()
         in
-          E.emit (file ^ ".s") ilCtx (SOME $ file ^ ".e")
+          case status of
+            W_EXITED => clean ()
+          | W_EXITSTATUS st =>
+              die `name `": failed with " W (Word8.toLargeWord st) `"code" %
+          | _ => raise Unimplemented
         end
-    | DebugT => P.P.T.debugPrint file
-    | DebugE => P.P.debugPrint file (#includeDirs config)
   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
diff --git a/emit.fun b/emit.fun
index 709aaa9..9bfdc81 100644
--- a/emit.fun
+++ b/emit.fun
@@ -44,7 +44,7 @@ functor Emit(I: IL) = struct
   val callerSavedRegs = 4
   val usedRegNum = 10
 
-  val usedOverallRegNum = 13
+  val usedOverallRegNum = 14
 
   fun reg2idx reg =
     case List.find (fn (r, _) => r = reg) regs of
@@ -338,8 +338,6 @@ functor Emit(I: IL) = struct
     | 1 => Rsi
     | 2 => Rdx
     | 3 => Rcx
-    | 5 => R8
-    | 6 => R9
     | _ => raise Unreachable
 
   fun getInsAff (SOME ins) =
@@ -873,7 +871,12 @@ functor Emit(I: IL) = struct
           val (_, vt) = Array.sub (rinfo, idx)
         in
           case vt of
-            VtReg reg => Array.update (regs, reg2idx reg, true)
+            VtReg reg =>
+            let
+              val () = Array.update (regs, reg2idx reg, true)
+            in
+              ()
+            end
           | _ => ();
           loop (idx + 1)
         end
@@ -1436,7 +1439,7 @@ functor Emit(I: IL) = struct
     | MVM (off1, v, off2) =>
         [movRV Rax v, movRM Rdx off2, opRR Rax Rdx, movMR off1 Rax]
 
-    | RR (r1, r2) => [opRR r1 r2]
+    | RR (r1, r2) => [shift3 r1 r1 r2]
     | RM (r1, off) => [movRM Rax off, shift3 r1 r1 Rax]
     | RV (r1, v) => [opRV r1 (t v)]
     | MR (off, r) => [movRM Rax off, opRR Rax r, movMR off Rax]
@@ -1466,7 +1469,12 @@ functor Emit(I: IL) = struct
     val { opRR, opRM, opRV, opMR, opMV } = getUtilOps is8 "sub"
   in
     case tmp of
-      RRR (r1, r2, r3) => [movRR r1 r2, opRR r1 r3]
+      RRR (r1, r2, r3) =>
+      if r1 = r3 then
+        [sprintf `"neg " A2 pr is8 r1 %,
+          sprintf `"add " A2 pr is8 r1 `", " A2 pr is8 r2 %]
+      else
+        [movRR r1 r2, opRR r1 r3]
     | RRM (r1, r2, off) => [movRR r1 r2, opRM r1 off]
     | RRV (r1, r2, c) =>
       if isZeroConst c then
@@ -1542,6 +1550,7 @@ functor Emit(I: IL) = struct
     case vr of
       VtReg r => Printf out A2 pr is8 r %
     | VtStack off => Printf out A2 pm is8 off %
+    | VtConst _ => (printfn `"prm const" %; raise Unreachable)
     | _ => raise Unreachable
 
   fun assertSize is81 is82 is83 =
@@ -1596,6 +1605,8 @@ functor Emit(I: IL) = struct
         VtReg r => r
       | _ => Rax
 
+    val dest = getReg t1
+
     fun op2 () =
     let
       val form =
@@ -1606,11 +1617,10 @@ functor Emit(I: IL) = struct
        else
          Normal (t2, t3)
 
-      val dest = getReg t1
       val main =
         case form of
           Reduced rs =>
-            [ sprintf `"imul " A2 pr is81 dest `", " A2 prm is81 rs % ]
+          [ sprintf `"imul " A2 pr is81 dest `", " A2 prm is81 rs % ]
         | Normal (rs1, rs2) => [
             mov is81 (VtReg dest) rs1,
             sprintf `"imul " A2 pr is81 dest `", " A2 prm is81 rs2 %
@@ -1622,8 +1632,6 @@ functor Emit(I: IL) = struct
     fun op3 rs1 c =
       if fitsInNsx 32 c then
         let
-          val dest = getReg t1
-
           val main =
             [sprintf `"imul " A2 pr is81 dest `", "
               A2 prm is81 rs1 `", " A2 pc is81 c %]
@@ -1631,7 +1639,15 @@ functor Emit(I: IL) = struct
           main @ moveBackIfNeeded is81 dest t1
         end
       else
-        op2 ()
+        let
+          val main = [
+            movRV is81 Rax c,
+            sprintf `"imul " A2 pr is81 Rax `", " A2 prm is81 rs1 %,
+            movRR is81 dest Rax
+          ]
+        in
+          main @ moveBackIfNeeded is81 dest t1
+        end
   in
     case (t2, t3) of
       (VtConst c, _) => op3 t3 c
@@ -1667,8 +1683,9 @@ functor Emit(I: IL) = struct
         | Rcx => "cl"
         | Rsi => "sil"
         | Rdi => "dil"
+        | Rbp => "bpl"
         | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15
-        | Rbp | Rsp | Rax | Rdx => raise Unreachable
+        | Rsp | Rax | Rdx => raise Unreachable
     end
   in
     case ac of
@@ -2167,6 +2184,7 @@ functor Emit(I: IL) = struct
     val () = handleLocalIniLayouts ()
 
     val () = List.app emitFunc funcInfos
+    val () = TextIO.closeOut (valOf $ !file)
   in
     ()
   end
diff --git a/il.fun b/il.fun
index 2db885b..1ca3172 100644
--- a/il.fun
+++ b/il.fun
@@ -900,8 +900,6 @@ functor IL(P: PARSER) = struct
     val vRight = genLogPart ctx right
     val vRes = getNew4 ctx
     val vC = newConst ctx (getClass ctx vRight) 0w0
-
-    val () = printf `"&& labels: " I falseLabel `", " I endLabel %
   in
     ctxPutOp ctx (IrCmp (Cmpneq, vRes, vRight, vC));
     ctxPutOp ctx (IrJmp endLabel);
diff --git a/parser.fun b/parser.fun
index 85ff551..f95739f 100644
--- a/parser.fun
+++ b/parser.fun
@@ -330,7 +330,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     (BrLogOr, T.DoubleVerticalBar, 4, true),
 
     (BrAssign, T.EqualSign, 2, false),
-    (BrMulAssign, T.AmpersandEqualSign, 2, false),
+    (BrMulAssign, T.AsteriskEqualSign, 2, false),
     (BrDivAssign, T.SlashEqualSign, 2, false),
     (BrModAssign, T.PercentEqualSign, 2, false),
     (BrSumAssign, T.PlusEqualSign, 2, false),
@@ -746,13 +746,12 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     fun dprintf g = Fold.fold ctx g
   end
 
-  fun createCtx fname incDirs debug =
+  fun createCtx fname incDirs dFile =
   let
     val () =
-      if debug then
-        debugFile := SOME (TextIO.openOut (fname ^ ".p"))
-      else
-        ()
+      case dFile of
+        NONE => ()
+      | SOME fname => debugFile := SOME (TextIO.openOut fname)
   in
     Ctx {
       aggrTypeNames = Tree.empty,
@@ -1401,7 +1400,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
     D.set localVars id ({ name, pos, onStack = true, t })
   end
 
-  and findId (Ctx ctx) pos under id =
+  and findId (Ctx ctx) pos id =
   let
     fun findLocal [] = NONE
       | findLocal (scope :: scopes) =
@@ -1412,17 +1411,8 @@ functor Parser(structure Tree: TREE; structure P: PPC;
           SOME lid =>
           let
             val t = #t $ D.get localVars lid
-
-            val () =
-              if under = UAddr then
-                if lid < valOf (#paramNum ctx) then
-                  P.error pos `"cannot take address of function argument" %
-                else
-                  reduceVarToStack lid
-              else
-                ()
           in
-            SOME $ convAggr under (EA (Eid (id, SOME $ Lid lid), pos, true, t))
+            SOME (EA (Eid (id, SOME $ Lid lid), pos, true, t))
           end
         | NONE => findLocal scopes
       end
@@ -1434,8 +1424,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
         val res = lookup (#globalSyms ctx) id
       in
         case res of
-          SOME (GsDecl (_, _, t, _)) =>
-            convAggr under (EA (Eid (id, SOME (Gid id)), pos, true, t))
+          SOME (GsDecl (_, _, t, _)) => EA (Eid (id, SOME (Gid id)), pos, true, t)
         | SOME (GsEnumConst v) =>
             EA (Econst (id, Ninteger (Word.fromInt v)), pos, false, int_t)
         | SOME (GsTypedef _) =>
@@ -1518,7 +1507,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
   and getPos (EA (_, pos, _, _)) = pos
   and setT (EA (binop, pos, lvalue, _)) t = EA (binop, pos, lvalue, t)
 
-  and checkUnop check under (EA (Eunop (unop, oper), pos, _, t)) =
+  and checkUnop check (EA (Eunop (unop, oper), pos, _, t)) =
   let
     val under' =
       case unop of
@@ -1571,9 +1560,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
           P.error pos `"expected function designator or lvalue operand" %
     | UnopDeref => (
         case ot of
-          pointer_t (1, T as function_t _) =>
-            finish false (case under of UNone => ot | _ => T)
-        | pointer_t (1, t) => finish true t
+          pointer_t (1, t) => finish true t
         | pointer_t (n, t) => finish true (pointer_t (n-1, t))
         | _ => P.error pos `"operand of not pointer type" %
     )
@@ -1585,7 +1572,7 @@ functor Parser(structure Tree: TREE; structure P: PPC;
         else
           finish false t
   end
-   | checkUnop _ _ _ = raise Unreachable
+   | checkUnop _ _ = raise Unreachable
 
   and checkSizeofType (EA (E as EsizeofType t, pos, _, _)) =
     if isFunc t then
@@ -1924,23 +1911,38 @@ functor Parser(structure Tree: TREE; structure P: PPC;
   end
    | checkMemberAccessByP _ _ = raise Unreachable
 
-  and checkExpr ctx under (E as EA (e, pos, _, _)) =
+  and checkExpr' ctx (E as EA (e, pos, _, _)) =
   let
     val check = checkExpr ctx
 
     (* val () = printf `"Checking " A1 pea E `"\n" % *)
   in
     case e of
-      Eid (id', _) => findId ctx pos under id'
+      Eid (id', _) => findId ctx pos id'
     | EsizeofType _ => checkSizeofType E
     | EfuncCall _ => checkFuncCall (check UNone) E
     | Ebinop (_, _, _) => checkBinop (check UNone) E
     | Eternary _ => checkTernary (check UNone) E
-    | Eunop (_, _) => checkUnop check under E
+    | Eunop (_, _) => checkUnop check E
     | EmemberByV _ => checkMemberAccessByV (check UNone) E
     | EmemberByP _ => checkMemberAccessByP (check UNone) E
-    | Econst _ => E
-    | Estrlit _ => convAggr under E
+    | Econst _ | Estrlit _ => E
+  end
+
+  and checkExpr (C as Ctx ctx) under ea =
+  let
+    val ea = checkExpr' C ea
+
+    val () =
+      case (under, ea) of
+        (UAddr, EA (Eid (_, SOME (Lid lid)), pos, _, _)) =>
+            if lid < valOf (#paramNum ctx) then
+              P.error pos `"cannot take address of function argument" %
+            else
+              reduceVarToStack lid
+      | _ => ()
+  in
+    convAggr under ea
   end
 
   and tryGetTypedefName (Ctx ctx) id =
diff --git a/parser.sig b/parser.sig
index 0406052..47dc5b8 100644
--- a/parser.sig
+++ b/parser.sig
@@ -145,7 +145,7 @@ signature PARSER = sig
   (* Objects are in reverse order *)
   datatype def = Objects of objDef list | Definition of funcInfo
 
-  val createCtx: string -> string list -> bool -> ctx
+  val createCtx: string -> string list -> string option -> ctx
   val parseDef: ctx -> bool * ctx
   val printDef: def -> unit