path: root/il.fun

functor IL(P: PARSER) = struct

  structure P = P
  structure PP = P.P
  structure D = P.D

  datatype ctx = Ctx of {
    objs: P.objDef list,
    objsZI: P.objDef list,
    extSyms: P.nid list,
    globSyms: P.nid list,
    funcs: P.funcInfo list,
    strlits: int list
  }

  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 =
      { 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
  *)

  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 createLocalCtx localVars =
  let
    val localVars = setupLocalVars localVars
    val vregs = setupVregs localVars
  in
    Lctx { localVars, vregs, ops = [], newLabelNum = 0, loopLabels = [] }
  end

    (*
  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