Most of conversion to il

1 files changed, 1028 insertions, 7 deletions

diff --git a/il.fun b/il.fun
index bcf4f29..5b38660 100644
--- a/il.fun
+++ b/il.fun
@@ -2,6 +2,7 @@ functor IL(P: PARSER) = struct
 
   structure P = P
   structure PP = P.P
+  structure D = P.D
 
   datatype ctx = Ctx of {
     objs: P.objDef list,
@@ -12,9 +13,70 @@ functor IL(P: PARSER) = struct
     strlits: int list
   }
 
-  fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) =
-    Ctx { objs, objsZI, extSyms = ext, globSyms = glob, funcs, strlits }
+  datatype vregClass = VR4 | VR8
+
+  type vreg = int
+  type label = int
+
+  datatype setArg = SaVReg of vreg | SaConst of word | SaGL of P.nid
+
+  datatype accessClass = AC1 | AC2 | AC4 | AC8
+
+  datatype irIsn =
+      IrSet of vreg * setArg
+    | IrAdd of vreg * vreg * vreg
+    | IrSub of vreg * vreg * vreg
+    | IrMul of vreg * vreg * vreg
+    | IrIMul of vreg * vreg * vreg
+    | IrDiv of vreg * vreg * vreg
+    | IrIDiv of vreg * vreg * vreg
+    | IrMod of vreg * vreg * vreg
+    | IrIMod of vreg * vreg * vreg
+    | IrShr of vreg * vreg * vreg
+    | IrShl of vreg * vreg * vreg
+    | IrSar of vreg * vreg * vreg
+    | IrAnd of vreg * vreg * vreg
+    | IrOr of vreg * vreg * vreg
+    | IrXor of vreg * vreg * vreg
+    | IrEq of vreg * vreg * vreg
+    | IrNeq of vreg * vreg * vreg
+
+    | IrCmpul of vreg * vreg * vreg
+    | IrCmpug of vreg * vreg * vreg
+    | IrCmpule of vreg * vreg * vreg
+    | IrCmpuge of vreg * vreg * vreg
+
+    | IrCmpsl of vreg * vreg * vreg
+    | IrCmpsg of vreg * vreg * vreg
+    | IrCmpsle of vreg * vreg * vreg
+    | IrCmpsge of vreg * vreg * vreg
+
+    | IrExtZero of vreg * vreg * accessClass
+    | IrExtSign of vreg * vreg * accessClass
+    | IrLoad of vreg * vreg * accessClass (* %1 <- [%2] *)
+    | IrStore of vreg * vreg * accessClass (* [%1] <- %2 *)
 
+    | IrJz of vreg * label
+    | IrJnz of vreg * label
+    | IrJmp of label
+
+    | IrRet of vreg option
+    | IrAlloc of vreg * word
+    | IrCopy of vreg * label * word
+
+    | IrNopLabel of label
+
+  datatype ev = Reg of vreg | Addr of vreg
+
+  datatype localCtx = Lctx of {
+    localVars: { onStack: bool, t: P.ctype } vector,
+    vregs: { class: vregClass } D.t,
+    newLabelNum: int,
+    ops: irIsn list,
+    loopLabels: { break: label, continue: label } list
+  }
+
+  (*
   fun updateCtx (Ctx ctx) = fn z =>
   let
     fun from objs objsZI extSyms globSyms funcs strlits =
@@ -24,13 +86,972 @@ functor IL(P: PARSER) = struct
   in
     FRU.makeUpdate6 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f))
   end
+  *)
+
+  fun updateLctx (Lctx ctx) = fn z =>
+  let
+    fun from localVars vregs ops newLabelNum loopLabels =
+      { localVars, vregs, ops, newLabelNum, loopLabels }
+    fun to f { localVars, vregs, ops, newLabelNum, loopLabels } =
+      f localVars vregs ops newLabelNum loopLabels
+  in
+    FRU.makeUpdate5 (from, from, to) ctx (fn (a, f) => z (a, Lctx o f))
+  end
+
+  fun typeAccessClass t =
+    case P.sizeOfType t of
+      0w1 => AC1
+    | 0w2 => AC2
+    | 0w4 => AC4
+    | 0w8 => AC8
+    | _ => raise Unreachable
+
+
+  fun setupLocalVars localVars =
+  let
+    val len = Vector.length localVars
+
+    fun setup idx acc =
+      if idx = len then
+        Vector.fromList (rev acc)
+      else
+        let
+          val { onStack: bool, t, ... } = Vector.sub (localVars, idx)
+        in
+          setup (idx + 1) ({ onStack, t } :: acc)
+        end
+  in
+    setup 0 []
+  end
+
+  fun getClassForType t =
+    case Word.compare (P.sizeOfType t, 0w8) of
+      GREATER => raise Unreachable
+    | EQUAL => VR8
+    | LESS => VR4
+
+  fun setupVregs localVars =
+  let
+    val len = Vector.length localVars
+    val vregs = D.create len
+
+    fun loop idx =
+      if idx = len then
+        ()
+      else
+        let
+          val { t, onStack, ... } = Vector.sub (localVars, idx)
+          val class = if onStack then VR8 else getClassForType t
+        in
+          D.push vregs ({ class });
+          loop (idx + 1)
+        end
+    val () = loop 0
+  in
+    vregs
+  end
 
-  fun register ctx (P.Objects revObjs) =
-    updateCtx ctx u#objs (fn objs => List.revAppend (revObjs, objs)) %
-    | register ctx (P.Definition _) = ctx
+  fun createLocalCtx localVars =
+  let
+    val localVars = setupLocalVars localVars
+    val vregs = setupVregs localVars
+  in
+    Lctx { localVars, vregs, ops = [], newLabelNum = 0, loopLabels = [] }
+  end
 
     (*
-  type objDef = int * P.tkPos * ctype * cini * linkage
-  type decl = P.tkPos * declClass * ctype * linkage 
+  type funcInfo = {
+    name: int,
+    pos: P.tkPos,
+    t: ctype,
+    paramNum: int,
+    localVars: { name: nid, pos: P.tkPos, onStack: bool, t: ctype } vector,
+    stmt: stmt
+  }
+  *)
+
+  fun getNewVReg class (Lctx { vregs, ... }) =
+  let
+    val id = D.pushAndGetId vregs ({ class })
+  in
+    id
+  end
+
+  val getNew4 = getNewVReg VR4
+  val getNew8 = getNewVReg VR8
+
+  fun ctxPutOp ctx op' = updateLctx ctx u#ops (fn l => op' ::  l) %
+
+  fun newConst ctx class w =
+  let
+    val v = getNewVReg class ctx
+  in
+    (v, ctxPutOp ctx (IrSet (v, SaConst w)))
+  end
+
+  fun getClass (Lctx { vregs, ... }) id = #class $ D.get vregs id
+
+  fun convConst ctx (w, t) =
+  let
+    val class =
+      case Word.compare (P.sizeOfType t, 0w8) of
+        GREATER => raise Unreachable
+      | EQUAL => VR8
+      | LESS => VR4
+
+    val v = getNewVReg class ctx
+  in
+    (Reg v, ctxPutOp ctx (IrSet (v, SaConst w)))
+  end
+
+  fun convGLconst ctx (id, isFunc) =
+  let
+    val v = getNew8 ctx
+    val ctx = ctxPutOp ctx (IrSet (v, SaGL id))
+  in
+    if isFunc then
+      (Reg v, ctx)
+    else
+      (Addr v, ctx)
+  end
+
+  fun convId ctx (P.Gid p) = convGLconst ctx p
+    | convId (C as Lctx { localVars, ... }) (P.Lid id) =
+    let
+      val onStack = #onStack $ Vector.sub (localVars, id)
+    in
+      ((if onStack then Addr else Reg) id, C)
+    end
+
+  fun getOffset ea field = #1 $ valOf $ P.getFieldInfo (P.getT ea) field
+
+  fun computeFieldFromVReg ctx v offset =
+  let
+    val (vOff, ctx) = newConst ctx VR8 offset
+    val vRes = getNew8 ctx
+    val ctx = ctxPutOp ctx (IrAdd (vRes, v, vOff))
+  in
+    (Addr vRes, ctx)
+  end
+
+  fun convFieldAccessByV ctx ea field =
+  let
+    val (v, ctx) = convExpr ctx ea
+    val offset = getOffset ea field
+  in
+    case v of
+      Addr v => computeFieldFromVReg ctx v offset
+    | Reg _ => raise Unreachable
+  end
+
+  and convFieldAccesByP ctx ea field =
+  let
+    val (v, ctx) = convExpr ctx ea
+
+    val offset = getOffset ea field
+  in
+    case v of
+      Reg v => computeFieldFromVReg ctx v offset
+    | Addr v =>
+        let
+          val vl = getNew8 ctx
+          val ctx = ctxPutOp ctx (IrLoad (vl, v, AC8))
+        in
+          computeFieldFromVReg ctx vl offset
+        end
+  end
+
+  and convSizeOfType ctx t: ev * localCtx =
+  let
+    val w = P.sizeOfType t
+    val (v, ctx) = newConst ctx VR8 w
+  in
+    (Reg v, ctx)
+  end
+
+  and convPre op' ctx (v, t) =
+    case v of
+      Reg v =>
+      let
+        val class = getClass ctx v
+        val (v1, ctx) = newConst ctx class 0w1
+
+        val ctx = ctxPutOp ctx (op' (v, v, v1))
+      in
+        (Reg v, ctx)
+      end
+    | Addr v =>
+      let
+        val class = getClassForType t
+        val aClass = typeAccessClass t
+        val vl = getNewVReg class ctx
+        val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass))
+        val (v1, ctx) = newConst ctx class 0w1
+        val ctx = ctxPutOp ctx (op' (vl, vl, v1))
+        val ctx = ctxPutOp ctx (IrStore (v, vl, aClass))
+      in
+        (Reg vl, ctx)
+      end
+
+  and convPost op' ctx (v, t) =
+    case v of
+      Reg v =>
+        let
+          val class = getClass ctx v
+          val vOld = getNewVReg class ctx
+          val ctx = ctxPutOp ctx (IrSet (vOld, SaVReg v))
+          val (v1, ctx) = newConst ctx class 0w1
+          val ctx = ctxPutOp ctx (op' (v, v, v1))
+        in
+          (Reg vOld, ctx)
+        end
+    | Addr v =>
+      let
+        val class = getClassForType t
+        val aClass = typeAccessClass t
+        val vl = getNewVReg class ctx
+        val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass))
+        val vOld = getNewVReg class ctx
+        val ctx = ctxPutOp ctx (IrSet (vOld, SaVReg vl))
+        val (v1, ctx) = newConst ctx class 0w1
+        val ctx = ctxPutOp ctx (op' (vl, vl, v1))
+        val ctx = ctxPutOp ctx (IrStore (v, vl, aClass))
+      in
+        (Reg vOld, ctx)
+      end
+
+  and convAddr ctx v =
+    case v of
+      Reg _ => raise Unreachable
+    | Addr v => (Reg v, ctx)
+
+  and convDeref ctx v =
+    case v of
+      Reg v => (Addr v, ctx)
+    | Addr v =>
+      let
+        val vD = getNew8 ctx
+        val ctx = ctxPutOp ctx (IrLoad (vD, v, AC8))
+      in
+        (Addr vD, ctx)
+      end
+
+  and convPos ctx v = (v, ctx)
+
+  and prepIsZero ctx vDest vSrc =
+  let
+    val (vc, ctx) = newConst ctx (getClass ctx vSrc) 0w0
+  in
+    ctxPutOp ctx (IrEq (vDest, vSrc, vc))
+  end
+
+  and prepNeg ctx vDest vSrc =
+  let
+    val (vc, ctx) = newConst ctx (getClass ctx vSrc) 0w0
+  in
+    ctxPutOp ctx (IrSub (vDest, vc, vSrc))
+  end
+
+  and prepComp ctx vDest vSrc =
+  let
+    val (vc, ctx) = newConst ctx (getClass ctx vSrc) (Word.~ 0w1)
+  in
+    ctxPutOp ctx (IrXor (vDest, vSrc, vc))
+  end
+
+  and convSimpleUnop fop ctx (v, t) =
+    case v of
+      Reg v =>
+      let
+        val vNew = getNewVReg (getClass ctx v) ctx
+        val ctx = fop ctx vNew v
+      in
+        (Reg vNew, ctx)
+      end
+    | Addr v =>
+      let
+        val aClass = typeAccessClass t
+        val class = getClassForType t
+        val vl = getNewVReg class ctx
+        val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass))
+        val ctx = fop ctx vl vl
+        val ctx = ctxPutOp ctx (IrStore (v, vl, aClass))
+      in
+        (Reg vl, ctx)
+      end
+
+  and convCast ctx (v, fromT, toT) =
+    case Word.compare (P.sizeOfType toT, P.sizeOfType fromT) of
+      EQUAL => (v, ctx)
+    | LESS => (
+        case v of
+          Reg v =>
+            let
+              val vNew = getNew4 ctx
+              val ctx = ctxPutOp ctx (IrSet (vNew, SaVReg v))
+            in
+              (Reg vNew, ctx)
+            end
+        | Addr v => (Addr v, ctx)
+    )
+    | GREATER =>
+      let
+        val op' = if P.isSigned fromT then IrExtSign else IrExtZero
+        val aClass = typeAccessClass fromT
+        val toTClass = getClassForType toT
+
+        val (v, ctx) =
+            case v of
+              Addr v =>
+              let
+                val vl = getNew4 ctx
+                val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass))
+              in
+                (vl, ctx)
+              end
+            | Reg v => (v, ctx)
+       val vNew = getNewVReg toTClass ctx
+       val ctx = ctxPutOp ctx (op' (vNew, v, aClass))
+      in
+        (Reg vNew, ctx)
+      end
+
+  and convUnop ctx unop ea t =
+  let
+    val (v, ctx) = convExpr ctx ea
+    val subT = P.getT ea
+  in
+    case unop of
+      P.UnopPreInc => convPre IrAdd ctx (v, subT)
+    | P.UnopPreDec => convPre IrSub ctx (v, subT)
+    | P.UnopPostInc => convPost IrAdd ctx (v, subT)
+    | P.UnopPostDec => convPost IrSub ctx (v, subT)
+    | P.UnopSizeof => convSizeOfType ctx subT
+    | P.UnopAddr => convAddr ctx v
+    | P.UnopDeref => convDeref ctx v
+    | P.UnopPos => convPos ctx v
+    | P.UnopNeg => convSimpleUnop prepNeg ctx (v, subT)
+    | P.UnopComp => convSimpleUnop prepComp ctx (v, subT)
+    | P.UnopLogNeg => convSimpleUnop prepIsZero ctx (v, subT)
+    | P.UnopCast => convCast ctx (v, subT, t)
+  end
+
+  and loadIfNeeded ctx t vLeft =
+    case vLeft of
+      Reg v => (v, ctx)
+    | Addr v =>
+      let
+        val aClass = typeAccessClass t
+        val class = getClassForType t
+        val vl = getNewVReg class ctx
+        val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass))
+      in
+        (vl, ctx)
+      end
+
+  and binopPrepOpers ctx t vLeft vRight =
+  let
+    val (vLeft, ctx) = loadIfNeeded ctx t vLeft
+    val (vRight, ctx) = loadIfNeeded ctx t vRight
+    val vNew = getNewVReg (getClass ctx vLeft) ctx
+  in
+    (vNew, vLeft, vRight, ctx)
+  end
+
+  and convSimple ctx t vLeft vRight op' =
+  let
+    val (vNew, vLeft, vRight, ctx) = binopPrepOpers ctx t vLeft vRight
+    val ctx = ctxPutOp ctx (op' (vNew, vLeft, vRight))
+  in
+    (Reg vNew, ctx)
+  end
+
+  and shiftPointer ctx op' (leftT, vLeft) (rightT, vRight) =
+    let
+      val (v, ctx) =
+        case convCast ctx (Reg vRight, rightT, P.ulong_t) of
+          (Reg v, ctx) => (v, ctx)
+        | (Addr _, _) => raise Unreachable
+      val (multiplier, ctx) =
+        newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT))
+      val vm = getNew8 ctx
+      val ctx = ctxPutOp ctx (IrMul (vm, v, multiplier))
+      val vRes = getNew8 ctx
+      val ctx = ctxPutOp ctx (op' (vRes, vLeft, vm))
+    in
+      (Reg vRes, ctx)
+    end
+
+  and convSum ctx (leftT, vLeft) (rightT, vRight) =
+  let
+    val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft
+    val (vRight, ctx) = loadIfNeeded ctx rightT vRight
+  in
+    if P.isPointer leftT then
+      shiftPointer ctx IrAdd (leftT, vLeft) (rightT, vRight)
+    else
+      let
+        val vNew = getNewVReg (getClass ctx vLeft) ctx
+        val ctx = ctxPutOp ctx (IrAdd (vNew, vLeft, vRight))
+      in
+        (Reg vNew, ctx)
+      end
+  end
+
+  and convSub ctx (leftT, vLeft) (rightT, vRight) =
+  let
+    val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft
+    val (vRight, ctx) = loadIfNeeded ctx rightT vRight
+  in
+    if P.isPointer leftT then
+      if P.isPointer rightT then
+        let
+          val vDiff = getNew8 ctx
+          val ctx = ctxPutOp ctx (IrSub (vDiff, vLeft, vRight))
+          val (divider, ctx) =
+            newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT))
+          val vRes = getNew8 ctx
+          val ctx = ctxPutOp ctx (IrDiv (vRes, vDiff, divider))
+        in
+          (Reg vRes, ctx)
+        end
+      else
+        shiftPointer ctx IrSub (leftT, vLeft) (rightT, vRight)
+    else
+      let
+        val vNew = getNewVReg (getClass ctx vLeft) ctx
+        val ctx = ctxPutOp ctx (IrSub (vNew, vLeft, vRight))
+      in
+        (Reg vNew, ctx)
+      end
+  end
+
+  and convSimpleAssignment ctx leftT vLeft vRight =
+  let
+    val (vRight, ctx) = loadIfNeeded ctx leftT vRight
+  in
+    case vLeft of
+      Reg v =>
+        let
+          val ctx = ctxPutOp ctx (IrSet (v, SaVReg vRight))
+        in
+          (Reg v, ctx)
+        end
+    | Addr v =>
+        let
+          val ctx =
+            ctxPutOp ctx (IrStore (v, vRight, typeAccessClass leftT))
+        in
+          (Reg vRight, ctx)
+        end
+  end
+
+  and convSubscript ctx (leftT, vLeft) (rightT, vRight) =
+  let
+    val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft
+    val (vRight, ctx) = loadIfNeeded ctx rightT vRight
+
+    val (res, ctx) =
+      case shiftPointer ctx IrAdd (leftT, vLeft) (rightT, vRight) of
+        (Reg v, ctx) => (v, ctx)
+      | (Addr _, _) => raise Unreachable
+  in
+    (Addr res, ctx)
+  end
+
+  and convCompAssign ctx (leftT, vLeft) (rightT, vRight) (op', op2) =
+  let
+    val (vRight, ctx) = loadIfNeeded ctx rightT vRight
+    val leftT = P.resolveType leftT
+    val rightT = P.resolveType rightT
+
+    val commonType = P.commonType leftT rightT
+
+    fun convIfNeeded ctx t v =
+      if t <> commonType then
+        case convCast ctx (Reg v, t, commonType) of
+          (Reg v, ctx) => (v, ctx)
+        | (Addr _, _) => raise Unreachable
+      else
+        (v, ctx)
+
+    fun apply ctx leftV =
+    let
+      val (vLeft, ctx) = convIfNeeded ctx leftT leftV
+      val (vRight, ctx) = convIfNeeded ctx rightT vRight
+
+      val op' = if P.isSigned commonType then op2 else op'
+      val ctx = ctxPutOp ctx (op' (vLeft, vLeft, vRight))
+    in
+      (vLeft, ctx)
+    end
+  in
+    case vLeft of
+      Reg v =>
+      let
+        val (vLeft, ctx) = apply ctx v
+
+        val ctx =
+          if leftT <> commonType then
+            ctxPutOp ctx (IrSet (v, SaVReg vLeft))
+          else
+            ctx
+      in
+        (Reg v, ctx)
+      end
+    | Addr v =>
+      let
+        val class = getClassForType leftT
+        val aClass = typeAccessClass leftT
+        val vl = getNewVReg class ctx
+        val ctx = ctxPutOp ctx (IrLoad (vl, v, aClass))
+
+        val (vLeft, ctx) = apply ctx vl
+        val ctx = ctxPutOp ctx (IrStore (v, vLeft, aClass))
+      in
+        (Reg vLeft, ctx)
+      end
+  end
+
+  and convComma ctx _ (_, vRight) = (vRight, ctx)
+
+  and getLabel (C as Lctx { newLabelNum, ... }) =
+    (newLabelNum, updateLctx C u#newLabelNum (fn l => l + 1) %)
+
+  and getLabelPair ctx =
+  let
+    val (l1, ctx) = getLabel ctx
+    val (l2, ctx) = getLabel ctx
+  in
+    (l1, l2, ctx)
+  end
+
+  and genLogPart ctx ea =
+  let
+    val t = P.getT ea
+    val (v, ctx) = convExpr ctx ea
+    val (v, ctx) = loadIfNeeded ctx t v
+    val (v, ctx) =
+      if P.typeRank t < P.typeRank P.int_t then
+        case convCast ctx (Reg v, t, P.int_t) of
+          (Reg v, ctx) => (v, ctx)
+        | (Addr _, _) => raise Unreachable
+      else
+        (v, ctx)
+  in
+    (v, ctx)
+  end
+
+  and convLogOr ctx left right =
+  let
+    val (vLeft, ctx) = genLogPart ctx left
+
+    val (elseLabel, endLabel, ctx) = getLabelPair ctx
+    val ctx = ctxPutOp ctx (IrJz (vLeft, elseLabel))
+    val vRes = getNew4 ctx
+    val ctx = ctxPutOp ctx (IrSet (vRes, SaConst 0w1))
+    val ctx = ctxPutOp ctx (IrJmp endLabel)
+    val ctx = ctxPutOp ctx (IrNopLabel elseLabel)
+
+    val (vRight, ctx) = genLogPart ctx right
+    val (vC, ctx) = newConst ctx (getClass ctx vRight) 0w0
+    val ctx = ctxPutOp ctx (IrNeq (vRes, vRight, vC))
+  in
+    (Reg vRes, ctx)
+  end
+
+  and convLogAnd ctx left right =
+  let
+    val (vLeft, ctx) = genLogPart ctx left
+    val (falseLabel, endLabel, ctx) = getLabelPair ctx
+    val ctx = ctxPutOp ctx (IrJz (vLeft, falseLabel))
+    val (vRight, ctx) = genLogPart ctx right
+    val vRes = getNew4 ctx
+    val (vC, ctx) = newConst ctx (getClass ctx vRight) 0w0
+    val ctx = ctxPutOp ctx (IrNeq (vRes, vRight, vC))
+    val ctx = ctxPutOp ctx (IrJmp endLabel)
+    val ctx = ctxPutOp ctx (IrNopLabel (falseLabel))
+    val ctx = ctxPutOp ctx (IrSet (vRes, SaConst 0w0))
+    val ctx = ctxPutOp ctx (IrNopLabel endLabel)
+  in
+    (Reg vRes, ctx)
+  end
+
+  and convBinop ctx binop left right =
+  let
+    val leftT = P.getT left
+    val rightT = P.getT right
+
+    fun chs opS opU = if P.isSigned leftT then opS else opU
+
+    fun apply f =
+    let
+      val (vLeft, ctx) = convExpr ctx left
+      val (vRight, ctx) = convExpr ctx right
+    in
+      f ctx (leftT, vLeft) (rightT, vRight)
+    end
+
+    fun commonWrapper f ctx (leftT, vLeft) (_, vRight) =
+      f ctx leftT vLeft vRight
+
+    val convSimple = apply $ commonWrapper convSimple
+    val convCompAssign = apply convCompAssign
+  in
+    case binop of
+      P.BR P.BrMul => convSimple (chs IrIMul IrMul)
+    | P.BR P.BrDiv => convSimple (chs IrIDiv IrDiv)
+    | P.BR P.BrMod => convSimple (chs IrIMod IrMod)
+    | P.BR P.BrShiftLeft => convSimple IrShl
+    | P.BR P.BrShiftRight => convSimple (chs IrSar IrShr)
+    | P.BR P.BrBitAnd => convSimple IrAnd
+    | P.BR P.BrBitOr => convSimple IrOr
+    | P.BR P.BrBitXor => convSimple IrXor
+    | P.BR P.BrEqual => convSimple IrEq
+    | P.BR P.BrNotEqual => convSimple IrNeq
+    | P.BR P.BrGreater => convSimple (chs IrCmpsg IrCmpug)
+    | P.BR P.BrLess => convSimple (chs IrCmpsl IrCmpul)
+    | P.BR P.BrGreaterEqual => convSimple (chs IrCmpsge IrCmpuge)
+    | P.BR P.BrLessEqual => convSimple (chs IrCmpsle IrCmpule)
+
+    | P.BR P.BrAssign => apply $ commonWrapper convSimpleAssignment
+    | P.BR P.BrBitAndAssign => convCompAssign (IrAnd, IrAnd)
+    | P.BR P.BrBitOrAssign => convCompAssign (IrOr, IrOr)
+    | P.BR P.BrBitXorAssign => convCompAssign (IrXor, IrXor)
+
+    | P.BR P.BrLeftShiftAssign => convCompAssign (IrShl, IrShl)
+    | P.BR P.BrRightShiftAssign => convCompAssign (IrShr, IrSar)
+    | P.BR P.BrDivAssign => convCompAssign (IrDiv, IrIDiv)
+    | P.BR P.BrMulAssign => convCompAssign (IrMul, IrIMul)
+    | P.BR P.BrModAssign => convCompAssign (IrMod, IrIMod)
+
+    | P.BR P.BrSubscript => apply convSubscript
+    | P.BR P.BrComma => apply convComma
+
+    | P.BR P.BrSum => apply convSum
+    | P.BR P.BrSub => apply convSub
+    | P.BR P.BrSumAssign => convCompAssign (IrAdd, IrAdd)
+    | P.BR P.BrSubAssign => convCompAssign (IrSub, IrSub)
+
+    | P.BR P.BrLogOr => convLogOr ctx left right
+    | P.BR P.BrLogAnd => convLogAnd ctx left right
+    | P.BinopTernaryIncomplete _ => raise Unreachable
+  end
+
+  and convTernary ctx cond left right =
+  let
+    val leftT = P.getT left
+
+    val (cond, ctx) = genLogPart ctx cond
+    val (elseLabel, endLabel, ctx) = getLabelPair ctx
+    val ctx = ctxPutOp ctx (IrJz (cond, elseLabel))
+    val vRes = getNewVReg (getClassForType leftT) ctx
+    val (vLeft, ctx) = convExpr ctx left
+    val (vLeft, ctx) = loadIfNeeded ctx leftT vLeft
+    val ctx = ctxPutOp ctx (IrSet (vRes, SaVReg vLeft))
+    val ctx = ctxPutOp ctx (IrJmp endLabel)
+    val ctx = ctxPutOp ctx (IrNopLabel elseLabel)
+    val (vRight, ctx) = convExpr ctx right
+    val (vRight, ctx) = loadIfNeeded ctx leftT vRight
+    val ctx = ctxPutOp ctx (IrSet (vRes, SaVReg vRight))
+    val ctx = ctxPutOp ctx (IrNopLabel endLabel)
+  in
+    (Reg vRes, ctx)
+  end
+
+  (*
+    EfuncCall of exprAug * exprAug list |
   *)
+
+  and convExpr ctx ea: ev * localCtx =
+  let
+    val P.EA (e, _, _, t) = ea
+  in
+    case e of
+      P.Eid (_, loc) => convId ctx (valOf loc)
+    | P.Econst (_, P.Ninteger w) => convConst ctx (w, t)
+    | P.Econst (_, _) => raise Unreachable
+    | P.Estrlit id => convGLconst ctx (id, false)
+    | P.EmemberByV (ea, field) => convFieldAccessByV ctx ea field
+    | P.EmemberByP (ea, field) => convFieldAccesByP ctx ea field
+    | P.EsizeofType t => convSizeOfType ctx t
+    | P.Eunop (unop, ea) => convUnop ctx unop ea t
+    | P.Ebinop (binop, left, right) => convBinop ctx binop left right
+    | P.Eternary (cond, left, right) => convTernary ctx cond left right
+    | P.EfuncCall (_, _) => raise Unimplemented
+  end
+
+  fun convIni (C as Lctx { localVars, ... }) (id, NONE) =
+  let
+    val size = P.sizeOfType $ #t $ Vector.sub (localVars, id)
+  in
+    ctxPutOp C (IrAlloc (id, size))
+  end
+    | convIni (C as Lctx { localVars, ... }) (id, SOME (P.CiniExpr ea)) =
+    let
+      val t = P.getT ea
+      val (v, ctx) = convExpr C ea
+      val (v, ctx) = loadIfNeeded ctx t v
+    in
+      if #onStack $ Vector.sub (localVars, id) then
+        ctxPutOp ctx (IrLoad (id, v, typeAccessClass t))
+      else
+        ctxPutOp ctx (IrSet (id, SaVReg v))
+    end
+    | convIni ctx (id, SOME (P.CiniLayout lid)) =
+    let
+      val size = P.getLayoutSize lid
+    in
+      ctxPutOp ctx (IrCopy (id, lid, size))
+    end
+
+  fun convReturn ctx ea =
+    case ea of
+      SOME ea =>
+      let
+        val (v, ctx) = convExpr ctx ea
+        val (v, ctx) = loadIfNeeded ctx (P.getT ea) v
+      in
+        ctxPutOp ctx (IrRet $ SOME v)
+      end
+   | NONE => ctxPutOp ctx (IrRet NONE)
+
+  fun convIf ctx (cond, thenPart, elsePart) =
+  let
+    val (v, ctx) = genLogPart ctx cond
+    val (elseL, endL, ctx) = getLabelPair ctx
+    val ctx = ctxPutOp ctx (IrJz (v, elseL))
+    val ctx = convStmt ctx thenPart
+
+    val ctx = if isSome elsePart then ctxPutOp ctx (IrJmp endL) else ctx
+    val ctx = ctxPutOp ctx (IrNopLabel elseL)
+
+    val ctx =
+      case elsePart of
+        SOME elsePart =>
+        let
+          val ctx = convStmt ctx elsePart
+          val ctx = ctxPutOp ctx (IrNopLabel endL)
+        in
+          ctx
+        end
+      | NONE => ctx
+  in
+    ctx
+  end
+
+  and ctxGetLoopLabels ctx =
+  let
+    val (l1, l2, ctx) = getLabelPair ctx
+    val ctx = updateLctx ctx u#loopLabels
+        (fn l => { break = l1, continue = l2 } :: l) %
+  in
+    (l1, l2, ctx)
+  end
+
+  and ctxLoopExit ctx = updateLctx ctx u#loopLabels tl %
+
+  and convWhile ctx (cond, body) =
+  let
+    val (breakL, contL, ctx) = ctxGetLoopLabels ctx
+    val ctx = ctxPutOp ctx (IrNopLabel contL)
+    val (cond, ctx) = genLogPart ctx cond
+    val ctx = ctxPutOp ctx (IrJz (cond, breakL))
+    val ctx = convStmt ctx body
+    val ctx = ctxPutOp ctx (IrJmp contL)
+    val ctx = ctxPutOp ctx (IrNopLabel breakL)
+
+    val ctx = ctxLoopExit ctx
+  in
+    ctx
+  end
+
+  and convDoWhile ctx (body, cond) =
+  let
+    val (breakL, contL, ctx) = ctxGetLoopLabels ctx
+    val (startL, ctx) = getLabel ctx
+    val ctx = ctxPutOp ctx (IrNopLabel startL)
+    val ctx = convStmt ctx body
+    val ctx = ctxPutOp ctx (IrNopLabel contL)
+    val (cond, ctx) = genLogPart ctx cond
+    val ctx = ctxPutOp ctx (IrJnz (cond, startL))
+    val ctx = ctxPutOp ctx (IrNopLabel breakL)
+
+    val ctx = ctxLoopExit ctx
+  in
+    ctx
+  end
+
+  and convBreakOrCont isBreak (C as Lctx { loopLabels, ... }) =
+  let
+    val { break, continue } = hd loopLabels
+    val label = if isBreak then break else continue
+  in
+    ctxPutOp C (IrJmp label)
+  end
+
+  and convStmt ctx stmt =
+    case stmt of
+      P.StmtExpr ea => #2 $ convExpr ctx ea
+    | P.StmtCompound (inis, stmts) =>
+        let
+          open List
+          val ctx = foldl (fn (ini, ctx) => convIni ctx ini) ctx inis
+          val ctx = foldl (fn (stmt, ctx) => convStmt ctx stmt) ctx stmts
+        in
+          ctx
+        end
+    | P.StmtIf t => convIf ctx t
+    | P.StmtReturn ea => convReturn ctx ea
+    | P.StmtWhile pair => convWhile ctx pair
+    | P.StmtDoWhile pair => convDoWhile ctx pair
+    | P.StmtBreak => convBreakOrCont true ctx
+    | P.StmtContinue => convBreakOrCont false ctx
+    | _ => raise Unimplemented
+
+  val Preg = fn z =>
+  let
+    fun f id out = Printf out `"%" I id %
+  in
+    bind A1 f
+  end z
+
+  val Pl = fn z =>
+  let
+    fun f l out = Printf out `".L" I l %
+  in
+    bind A1 f
+  end z
+
+  val Pac = fn z =>
+  let
+    fun f ac out =
+      Printf out `(
+        case ac of
+          AC1 => "byte"
+        | AC2 => "word"
+        | AC4 => "dword"
+        | AC8 => "qword") %
+  in
+    bind A1 f
+  end z
+
+  val Pt = fn z =>
+  let
+    fun f ctx id out =
+    let
+      val c = getClass ctx id
+    in
+      Printf out `(case c of VR4 => "w4" | VR8 => "w8") %
+    end
+  in
+    bind A2 f
+  end z
+
+  fun printOpSet ctx reg arg =
+  let
+    val () = printf `"\t" Preg reg `" " Pt ctx reg `" = " %
+  in
+    case arg of
+      SaVReg reg => printf Preg reg %
+    | SaConst w => printf W w %
+    | SaGL id => printf PP.? id %
+  end
+
+  fun printOp ctx op' =
+  let
+    fun pt (reg1, reg2, reg3) op' =
+      printf `"\t" Preg reg1 `" " Pt ctx reg1 `" = "
+          `op' `" " Preg reg2 `", " Preg reg3 %
+
+    fun pe (reg1, reg2, aClass) op' =
+      printf `"\t" Preg reg1 `" " Pt ctx reg1 `" = "
+          `op' `" " Pac aClass `" " Preg reg2 %
+
+    fun pj (r, l) op' = printf `"\t" `op' `" " Preg r `", " Pl l %
+
+
+    fun printRet NONE = printf `"\tret" %
+      | printRet (SOME reg) =
+        printf `"\tret " Pt ctx reg `" " Preg reg %
+
+    fun printAlloc (r, size) = printf `"\t" Preg r `" = alloc " W size %
+    fun printCopy (to, from, size) =
+      printf `"\tcopy " Preg to `", .I" I from `", " W size %
+  in
+    case op' of
+      IrSet (reg, arg) => printOpSet ctx reg arg
+    | IrAdd t => pt t "add"
+    | IrSub t => pt t "sub"
+    | IrMul t => pt t "mul"
+    | IrIMul t => pt t "imul"
+    | IrDiv t => pt t "div"
+    | IrIDiv t => pt t "idiv"
+    | IrMod t => pt t "mod"
+    | IrIMod t => pt t "imod"
+    | IrShl t => pt t "shl"
+    | IrShr t => pt t "shr"
+    | IrSar t => pt t "sar"
+    | IrAnd t => pt t "and"
+    | IrOr t => pt t "or"
+    | IrXor t => pt t "xor"
+    | IrEq t => pt t "eq"
+    | IrNeq t => pt t "neq"
+    | IrCmpul t => pt t "cmpul"
+    | IrCmpug t => pt t "cmpug"
+    | IrCmpule t => pt t "cmpule"
+    | IrCmpuge t => pt t "cmpuge"
+    | IrCmpsl t => pt t "cmpsl"
+    | IrCmpsg t => pt t "cmpsg"
+    | IrCmpsle t => pt t "cmpsle"
+    | IrCmpsge t => pt t "cmpsge"
+
+    | IrExtZero t => pe t "extz"
+    | IrExtSign t => pe t "exts"
+
+    | IrLoad (r1, r2, ac) =>
+      printf `"\t" Preg r1 `" = " Pac ac `" [" Preg r2 `"]" %
+    | IrStore (r1, r2, ac) =>
+      printf `"\t" Pac ac `" [" Preg r1 `"] <- " Preg r2 %
+    | IrJmp l => printf `"\tjmp " Pl l %
+    | IrJz p => pj p "jz"
+    | IrJnz p => pj p "jnz"
+    | IrNopLabel l => printf Pl l `":" %
+    | IrRet v => printRet v
+    | IrAlloc p => printAlloc p
+    | IrCopy t => printCopy t
+    ;
+    printf `"\n" %
+  end
+
+  fun printIns (C as Lctx { ops, ... }) =
+    List.app (printOp C) ops
+
+  fun translateFn (F as { localVars, stmt, ... }) =
+  let
+    val () = P.printDef (P.Definition F)
+    val ctx = createLocalCtx localVars
+    val ctx = convStmt ctx stmt
+
+    val ctx = updateLctx ctx u#ops (fn ops => rev ops) %
+  in
+    printIns ctx
+  end
+
+  fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) =
+  let
+    val _ = List.map (fn func => translateFn func) funcs
+  in
+    Ctx { objs, objsZI, extSyms = ext, globSyms = glob, funcs, strlits }
+  end
+
+  fun updateCtx (Ctx ctx) = fn z =>
+  let
+    fun from objs objsZI extSyms globSyms funcs strlits =
+      { objs, objsZI, extSyms, globSyms, funcs, strlits }
+    fun to f { objs, objsZI, extSyms, globSyms, funcs, strlits } =
+      f objs objsZI extSyms globSyms funcs strlits
+  in
+    FRU.makeUpdate6 (from, from, to) ctx (fn (a, f) => z (a, Ctx o f))
+  end
 end