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 |
    SaAddr of P.nid * word

  datatype accessClass = AC1 | AC2 | AC4 | AC8

  datatype irIns =
      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
    | IrFcall of vreg * vreg * vreg list

    | IrNopLabel of label
    | IrNop of string

  datatype ev = Reg of vreg | Addr of vreg

  datatype regType =
    RtUnk |
    RtConst of word |
    RtAddrConst of int * word

  type regInfo = {
    class: vregClass,
    use: int list,
    defs: int list,
    t: regType
  }

  datatype localCtx = Lctx of {
    localVars: { onStack: bool, t: P.ctype } vector,
    vregs: regInfo D.t,
    newLabelNum: int,
    ops: irIns list,
    opTable: (irIns option) array option,
    curPos: int, (* length ops + 1 *)
    loopLabels: { break: label, continue: label } list,
    paramNum: int
  }

  (*
  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 opTable curPos newLabelNum loopLabels
      paramNum =
      { localVars, vregs, ops, opTable, curPos, newLabelNum, loopLabels,
      paramNum }
    fun to f { localVars, vregs, ops, opTable, curPos, newLabelNum,
      loopLabels, paramNum } =
      f localVars vregs ops opTable curPos newLabelNum loopLabels paramNum
  in
    FRU.makeUpdate8 (from, from, to) ctx (fn (a, f) => z (a, Lctx o f))
  end

  fun isLocal (Lctx { localVars, ... }) id = id < Vector.length localVars

  fun typeAccessClass t =
    case P.sizeOfType t of
      0w1 => AC1
    | 0w2 => AC2
    | 0w4 => AC4
    | 0w8 => AC8
    | _ => raise Unreachable

  fun ac2word AC1 = 0w1
    | ac2word AC2 = 0w2
    | ac2word AC4 = 0w4
    | ac2word AC8 = 0w8

  fun getRegType vregs r = #t $ D.get vregs r

  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: P.ctype, ... } = 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 getClassSize VR4 = 0w4
    | getClassSize VR8 = 0w8

  fun setupVregs localVars paramNum =
  let
    val lvlen = Vector.length localVars
    val len = lvlen + paramNum
    val vregs = D.create len

    val () = printfn `"local + copies: " I len %

    fun loop idx =
      if idx = len then
        ()
      else
        if idx < lvlen then
          let
            val { t, onStack, ... } = Vector.sub (localVars, idx)
            val class = if onStack then VR8 else getClassForType t
            val defs = if idx < paramNum then [0] else []
          in
            D.push vregs ({ class, defs, use = [], t = RtUnk });
            loop (idx + 1)
          end
        else
          let
            val { class, ... } = D.get vregs (idx - lvlen)
          in
            D.push vregs ({ class, defs = [], use = [], t = RtUnk });
            loop (idx + 1)
          end
    val () = loop 0
  in
    vregs
  end

  fun getInsInfo op' =
  let
    fun tr (rd, rs1, rs2) = { defs = [rd], use = [rs1, rs2] }
    fun de (rd, rs1) = { defs = [rd], use = [rs1] }
    fun set reg arg =
      { defs = [reg], use = case arg of SaVReg rs => [rs] | _ => [] }
  in
    case op' of
      IrAdd t => tr t
    | IrSub t => tr t
    | IrMul t => tr t
    | IrIMul t => tr t
    | IrDiv t => tr t
    | IrIDiv t => tr t
    | IrMod t => tr t
    | IrIMod t => tr t
    | IrShl t => tr t
    | IrShr t => tr t
    | IrSar t => tr t
    | IrAnd t => tr t
    | IrOr t => tr t
    | IrXor t => tr t
    | IrEq t => tr t
    | IrNeq t => tr t
    | IrCmpul t => tr t
    | IrCmpug t => tr t
    | IrCmpule t => tr t
    | IrCmpuge t => tr t
    | IrCmpsl t => tr t
    | IrCmpsg t => tr t
    | IrCmpsle t => tr t
    | IrCmpsge t => tr t

    | IrExtZero (rd, rs, _) => de (rd, rs)
    | IrExtSign (rd, rs, _) => de (rd ,rs)

    | IrSet (reg, arg) => set reg arg

    | IrLoad (r1, r2, _) => de (r1, r2)
    | IrStore (r1, r2, _) => { defs = [], use = [r1, r2] }
    | IrJmp _ => { defs = [], use = [] }
    | IrJz (r, _) => { defs = [], use = [r] }
    | IrJnz (r, _) => { defs = [], use = [r] }
    | IrNopLabel _  | IrNop _  => { defs = [], use = [] }
    | IrRet v => { defs = [], use = case v of SOME r => [r] | _ => [] }
    | IrAlloc (r, _) => { defs = [r], use = [] }
    | IrCopy (r, _, _) => { defs = [], use = [r] }
    | IrFcall (rd, f, args) =>
        { defs = if rd = ~1 then [] else [rd], use = f :: args }
  end

  fun updateDefsUse (Lctx { vregs, ... }) defs use pos =
  let
    fun updateDef vr =
    let
      val { class, defs, use, t } = D.get vregs vr
    in
      D.set vregs vr { class, defs = pos :: defs, use, t }
    end
    fun updateUse vr =
    let
      val { class, defs, use, t } = D.get vregs vr
    in
      D.set vregs vr { class, defs, use = pos :: use, t }
    end

  in
    List.app updateDef defs;
    List.app updateUse use
  end

  fun ctxPutOp (C as Lctx { curPos, ... }) op' =
  let
    val { defs, use } = getInsInfo op'
    val insPos = curPos + 1
    val () = updateDefsUse C defs use insPos
  in
    updateLctx C u#ops (fn l => op' ::  l) u#curPos (fn pos => pos + 1) %
  end

  fun copyArgs (C as Lctx { localVars, paramNum, ... }) =
  let
    val lvlen = Vector.length localVars

    fun loop ctx idx =
      if idx = paramNum then
        ctx
      else
        loop (ctxPutOp ctx (IrSet (idx + lvlen, SaVReg idx))) (idx + 1)
    val ctx = loop C 0
  in
    ctx
  end

  fun createLocalCtx localVars paramNum =
  let
    val localVars = setupLocalVars localVars
    val vregs = setupVregs localVars paramNum
    val ctx = Lctx { localVars, vregs, ops = [], opTable = NONE, curPos = 0,
        newLabelNum = 0, loopLabels = [], paramNum }
  in
    copyArgs ctx
  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, defs = [], use = [], t = RtUnk })
  in
    id
  end

  val getNew4 = getNewVReg VR4
  val getNew8 = getNewVReg VR8

  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 pv (Reg v) out = Printf out `"Reg %" I v %
    | pv (Addr v) out = Printf out `"Addr %" I v %

  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, SaAddr (id, 0w0)))
  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, paramNum, ... }) (P.Lid id) =
      if id < paramNum then (* function parameter *)
        (Reg $ id + Vector.length (localVars), C)
      else
        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 getSingleOffset t =
    if P.isPointer t then
      P.sizeOfType (P.pointsTo t)
    else
      0w1

  and convPre op' ctx (v, t) =
    case v of
      Reg v =>
      let
        val class = getClass ctx v
        val (v1, ctx) = newConst ctx class (getSingleOffset t)

        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 (getSingleOffset t)
        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 (getSingleOffset t)
          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 (getSingleOffset t)
        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, _, P.void_t) = (v, ctx)
    | 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 op' ctx t vLeft vRight =
  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 (op', op2) ctx (leftT, vLeft) (rightT, vRight) =
  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 (vRight, ctx) =
        if P.isPointer leftT then
          let
            val (mul, ctx) =
              newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT))
            val vm = getNew8 ctx
            val ctx = ctxPutOp ctx (IrMul (vm, vRight, mul))
          in
            (vm, ctx)
          end
        else
          (vRight, ctx)
      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 = fn op' => apply $ commonWrapper (convSimple op')
    val convCompAssign = fn opp => apply $ convCompAssign opp
  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

  and convFuncCall ctx func args =
  let
    val t = P.getT func
    val (vFunc, ctx) = convExpr ctx func
    val (vFunc, ctx) = loadIfNeeded ctx t vFunc
    val (vFunc, ctx) =
      case (getClass ctx vFunc) of
        VR4 =>
        let
          val v = getNew8 ctx
        in
          (v, ctxPutOp ctx (IrSet (v, SaVReg vFunc)))
        end
      | VR8 => (vFunc, ctx)

    fun genArgs ctx [] acc =
      let
        fun loop ctx _ [] acc2 = (rev acc2, ctx)
          | loop ctx idx (vArg :: acc) acc2 =
          let
            val arg = getNewVReg (getClass ctx vArg) ctx
            val ctx = ctxPutOp ctx (IrSet (arg, SaVReg vArg))
          in
            loop ctx (idx + 1) acc (arg :: acc2)
          end
      in
        loop ctx 0 acc []
      end
      | genArgs ctx (arg :: args) acc =
      let
        val (vArg, ctx) = convExpr ctx arg
        val (vArg, ctx) = loadIfNeeded ctx (P.getT arg) vArg
        val (vArg, ctx) =
          if isLocal ctx vArg then
            let
              val vA = getNewVReg (getClassForType t) ctx
              val ctx = ctxPutOp ctx (IrSet (vA, SaVReg vArg))
            in
              (vA, ctx)
            end
          else
            (vArg, ctx)

      in
        genArgs ctx args (vArg :: acc)
      end

    val (args, ctx) = genArgs ctx args []

    val rt = #1 $ P.funcParts (P.pointsTo t)
    val vRes =
      case P.resolveType rt of
          P.void_t => ~1
        | t =>
          let
            val class = getClassForType t
            val vRes = getNewVReg class ctx
          in
            vRes
          end
  in
    (Reg vRes, ctxPutOp ctx (IrFcall (vRes, vFunc, args)))
  end

  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 (func, args) => convFuncCall ctx func args
  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 convFor ctx (pre, cond, post, stmt) =
  let
    val ctx =
      case pre of
        NONE => ctx
      | SOME ea => #2 $ convExpr ctx ea
    val (startL, ctx) = getLabel ctx
    val (breakL, contL, ctx) = ctxGetLoopLabels ctx

    val ctx = ctxPutOp ctx (IrNopLabel startL)
    val ctx =
      case cond of
        NONE => ctx
      | SOME cond =>
        let
          val (cond, ctx) = genLogPart ctx cond
        in
          ctxPutOp ctx (IrJz (cond, breakL))
        end
    val ctx = convStmt ctx stmt
    val ctx = ctxPutOp ctx (IrNopLabel contL)
    val ctx =
      case post of
        NONE => ctx
      | SOME post => #2 $ convExpr ctx post
    val ctx = ctxPutOp ctx (IrJmp startL)
    val ctx = ctxPutOp ctx (IrNopLabel breakL)
  in
    ctx
  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.StmtFor quad => convFor ctx quad
    | P.StmtWhile pair => convWhile ctx pair
    | P.StmtDoWhile pair => convDoWhile ctx pair
    | P.StmtBreak => convBreakOrCont true ctx
    | P.StmtContinue => convBreakOrCont false ctx

  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 printConst class w =
  let
    val (sign, w) =
      case class of
        VR4 =>
          if w < Word.<< (0w1, 0w31) then
            ("+", w)
          else
            ("-", Word.~ (P.exts w 0w4))
      | VR8 =>
          if w < Word.<< (0w1, 0w63) then
            ("+", w)
          else
            ("-", Word.~ w)
    in
      printf `sign W w %
    end

  fun preg (C as Lctx { vregs, ... }) id out =
  let
    val rt = getRegType vregs id
  in
    case rt of
      RtUnk => Printf out `"%" I id %
    | RtConst w => printConst (getClass C id) w
    | RtAddrConst (id, w) => (printf `"$" PP.? id %; printConst VR8 w)
  end
  val Preg = fn z => bind A2 preg z

  fun printOpSet ctx reg arg =
  let
    val () = printf `"\t" Preg ctx reg `" " Pt ctx reg `" = " %
  in
    case arg of
      SaVReg reg => printf Preg ctx reg %
    | SaConst w => printConst (getClass ctx reg) w
    | SaAddr (id, w) => (printf PP.? id %; printConst VR8 w)
  end

  fun printOp ctx (idx, SOME op') =
  let

    val () = printf I idx `":" %
    fun pt (reg1, reg2, reg3) op' =
      printf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = "
          `op' `" " Preg ctx reg2 `", " Preg ctx reg3 %

    fun pe (reg1, reg2, aClass) op' =
      printf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = "
          `op' `" " Pac aClass `" " Preg ctx reg2 %

    fun pj (r, l) op' = printf `"\t" `op' `" " Preg ctx r `", " Pl l %


    fun printRet NONE = printf `"\tret" %
      | printRet (SOME reg) =
        printf `"\tret " Pt ctx reg `" " Preg ctx reg %

    fun printAlloc (r, size) = printf `"\t" Preg ctx r `" = alloc " W size %
    fun printCopy (to, from, size) =
      printf `"\tcopy " Preg ctx to `", .I" I from `", " W size %

    fun printFcall (ret, f, args) =
    let
      val () = printf `"\t" %
      val () =
        if ret <> ~1 then
          printf Preg ctx ret `" " Pt ctx ret `" = " %
        else
          ()
    in
      printf `"fcall " Preg ctx f `"" Plist (preg ctx) args (", ", true, 0) %
    end
  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 ctx r1 `" = " Pac ac `" [" Preg ctx r2 `"]" %
    | IrStore (r1, r2, ac) =>
      printf `"\t" Pac ac `" [" Preg ctx r1 `"] <- " Preg ctx r2 %
    | IrJmp l => printf `"\tjmp " Pl l %
    | IrJz p => pj p "jz"
    | IrJnz p => pj p "jnz"
    | IrNopLabel l => printf `"@" Pl l `":" %
    | IrNop s => printf `"\t; " `s %
    | IrRet v => printRet v
    | IrAlloc p => printAlloc p
    | IrCopy t => printCopy t
    | IrFcall t => printFcall t
    ;
    printf `"\n" %
  end
   | printOp _ (_, NONE) = ()

  fun printIns (C as Lctx { opTable, ... }) =
    Array.appi (printOp C) (valOf opTable)

  fun printVar idx { class, defs, use, t = _ } =
    if length defs = 0 andalso length use = 0 then
      ()
    else
      printfn `"%" I idx `" " `(if class = VR4 then "w4" else "w8")
          `": defs = " Plist i defs (", ", true, 0)
          `", uses = " Plist i use (", ", true, 0) %

  fun printVars (Lctx { vregs, ... }) =
  let
    fun loop idx =
      if idx = D.length vregs then
        ()
      else (
        printVar idx (D.get vregs idx);
        loop (idx + 1)
      )
  in
    loop 0
  end

  fun createInsTable (C as Lctx { ops, ... }) =
  let
    val l = NONE :: map (fn v => SOME v) (rev ops)
    val arr = Array.fromList l
  in
    updateLctx C s#opTable (SOME arr) %
  end

  fun constAdd vregs opTable vid v insId =
  let
    val () = printfn `"new constant: %" I vid %

    val { class, ... } = D.get vregs vid

    val v =
      case v of
        RtConst w =>
        let
          val w = P.extz w (getClassSize class)
        in
          RtConst w
        end
      | RtAddrConst (id, w) => RtAddrConst (id, w)
      | RtUnk => raise Unreachable
    val () = D.set vregs vid { class, defs = [], use = [], t = v }
  in
    Array.update (opTable, insId, NONE)
  end

  fun getFirstConstants
    (Lctx { vregs, opTable, localVars, paramNum, ... }) =
  let
    val opTable = valOf opTable

    fun loop vid acc =
      if vid = D.length vregs then
        rev acc
      else
        let
          val { defs, ... } = D.get vregs vid

          fun addConst arg def =
          let
            val v =
              case arg of
                SaConst w => RtConst w
              | SaAddr p => RtAddrConst p
              | _ => raise Unreachable
          in
            constAdd vregs opTable vid v def
          end
        in
          case defs of
            [def] =>
            let
              val ins = valOf $ Array.sub (opTable, def)
            in
              case ins of
                IrSet(_, arg as SaConst _ | arg as SaAddr _) =>
                let
                  val () = addConst arg def
                in
                  loop (vid + 1) (vid :: acc)
                end
              | _ => loop (vid + 1) acc
            end
            | _ => loop (vid + 1) acc
        end
  in
    loop (Vector.length localVars + paramNum) []
  end

  datatype ext = ExtSign | ExtZero

  fun getCS vregs r =
  let
    val { class, ... } = D.get vregs r
  in
    getClassSize class
  end

  fun evalPrep supThird vregs (rd, rs1, rs2) ext =
  let
    val getC = getCS vregs

    val () =
      if getC rs1 <> getC rs2 then
        raise Unreachable
      else
        if not supThird andalso getC rd <> getC rs1 then
          raise Unreachable
        else
          ()

    val rt1 = getRegType vregs rs1
    val rt2 = getRegType vregs rs2
    val size = getC rd

  in
    case (rt1, rt2) of
      (RtConst w1, RtConst w2) => (
        case ext of
          ExtZero => SOME (P.extz w1 size, P.extz w2 size)
        | ExtSign => SOME (P.exts w1 size, P.exts w2 size)
      )
    | _ => NONE
  end

  fun evalSimple supThird vregs ext triple op' =
    case evalPrep supThird vregs triple ext of
      SOME wp => RtConst (op' wp)
    | NONE => RtUnk

  fun evalSet vregs (rd, SaVReg rs) =
  let
    val rt = getRegType vregs rs
    val fromSize = getCS vregs rs
    val toSize = getCS vregs rd
  in
    case rt of
      RtConst w => RtConst $ P.extz w fromSize
    | RtAddrConst p =>
        if toSize = 0w8 then
          RtAddrConst p
        else
          RtUnk
    | _ => raise Unreachable
  end
    | evalSet _ _ = raise Unreachable

  fun evalExt vregs ext (_, rs, aClass) =
  let
    val rt = getRegType vregs rs
    val ext = if ext = ExtZero then P.extz else P.exts
  in
    case rt of
      RtConst w => RtConst $ ext w (ac2word aClass)
    | RtAddrConst p =>
        if aClass = AC8 then
          RtAddrConst p
        else
          RtUnk
    | _ => raise Unreachable
  end

  fun evalAddSub op' vregs (rd, rs1, rs2) =
  let
    val getC = getCS vregs
    val () =
      if getC rs1 <> getC rs2 orelse getC rd <> getC rs1 then
        raise Unreachable
      else
        ()
    val size = getC rd

    val rt1 = getRegType vregs rs1
    val rt2 = getRegType vregs rs2
  in
    case (rt1, rt2) of
      (RtConst w1, RtConst w2) => RtConst $ P.extz (op' (w1, w2)) size
    | (RtAddrConst (id, w1), RtConst w2) => RtAddrConst (id, op' (w1, w2))
    | _ => RtUnk
  end

  fun eval' ins vregs =
  let
    open Word

    val es = evalSimple false vregs
    val esu = es ExtZero
    val ess = es ExtSign

    fun opCommon conv op' (w1, w2) =
    let
      val i1 = word64Toint64 w1
      val i2 = word64Toint64 w2
    in
      conv (op' (i1, i2))
    end

    val sop = opCommon int64Toword64

    fun bop op' wp =
    let
      val res = op' wp
    in
      if res then 0w1 else 0w0
    end

    val sbop = opCommon (fn true => 0w1 | false => 0w0)

    fun eq wp = case compare wp of EQUAL => 0w1 | _ => 0w0
    fun neq wp = case compare wp of EQUAL => 0w0 | _ => 0w1
  in
    case ins of
      IrAdd t => evalAddSub Word.+ vregs t
    | IrSub t => evalAddSub Word.- vregs t

    | IrAnd t => esu t Word.andb
    | IrOr t => esu t Word.orb
    | IrXor t => esu t Word.xorb
    | IrMul t => esu t Word.*
    | IrIMul t => ess t (sop Int64.*)
    | IrDiv t => esu t Word.div
    | IrIDiv t => ess t (sop Int64.div)
    | IrMod t => esu t Word.mod
    | IrIMod t => esu t (sop Int64.mod)
    | IrShl t => esu t Word.<<
    | IrShr t => esu t Word.>>
    | IrSar t => ess t Word.~>>

    | IrCmpul t => esu t (bop Word.<)
    | IrCmpug t => esu t (bop Word.<)
    | IrCmpule t => esu t (bop Word.<=)
    | IrCmpuge t => esu t (bop Word.>=)
    | IrCmpsl t => ess t (sbop Int64.<)
    | IrCmpsg t => ess t (sbop Int64.>)
    | IrCmpsle t => ess t (sbop Int64.<=)
    | IrCmpsge t => ess t (sbop Int64.>=)
    | IrEq t => evalSimple true vregs ExtZero t eq
    | IrNeq t => evalSimple true vregs ExtZero t neq
    | IrSet t => evalSet vregs t
    | IrExtZero p => evalExt vregs ExtZero p
    | IrExtSign p => evalExt vregs ExtSign p

    | IrAlloc _ | IrLoad _ | IrStore _ | IrRet _ | IrFcall _
    | IrCopy _ | IrJz _ | IrJnz _  => RtUnk
    | IrJmp _ | IrNop _ | IrNopLabel _ => raise Unreachable
  end

  fun eval (SOME ins) vregs =
  let
    val res = eval' ins vregs
  in
    case res of
      RtConst w =>
      let
        val { defs, ...  } = getInsInfo ins
        val { class, ... } = D.get vregs (hd defs)
        val w = P.extz w (getClassSize class)
      in
        RtConst w
      end
    | _ => res
  end
   | eval NONE _ = RtUnk

  fun defines (SOME ins) =
  let
    val { defs, ... } = getInsInfo ins
  in
    hd defs
  end
    | defines NONE = raise Unreachable

  fun propagate [] _ _ = ()
    | propagate (v :: vs) vregs opTable =
    let
      open Array
      val { use, ... } = D.get vregs v

      fun loop (insId :: tail) acc =
      let
        val ins = sub (opTable, insId)
      in
        case eval ins vregs of
          RtUnk => loop tail acc
        | v =>
        let
          val vd = defines ins
          val { defs, ... } = D.get vregs vd
          val newConst =
            case defs of
              [_] => (constAdd vregs opTable vd v insId; SOME vd)
            | _ =>
              let
                val vl =
                  case v of
                    RtConst w => SaConst w
                  | RtAddrConst p => SaAddr p
                  | _ => raise Unreachable
                val ins = IrSet (vd, vl)
              in
                update (opTable, insId, SOME ins);
                NONE
              end
        in
          loop tail (case newConst of SOME vc => vc :: acc | NONE => acc)
        end
      end
        | loop [] acc = acc

      val newConst = loop use []
    in
      propagate (List.revAppend (newConst, vs)) vregs opTable
    end

  fun constPropagate (C as Lctx { vregs, opTable, ... }) =
  let
    val opTable = valOf opTable
    val worklist = getFirstConstants C
  in
    propagate worklist vregs opTable
  end

  fun changeDest rd ins =
  let
    fun tr (_, rs1, rs2) = (rd, rs1, rs2)
  in
    case ins of
      IrAdd t => IrAdd (tr t)
    | IrSub t => IrSub (tr t)
    | IrMul t => IrMul (tr t)
    | IrIMul t => IrIMul (tr t)
    | IrDiv t => IrDiv (tr t)
    | IrIDiv t => IrIDiv (tr t)
    | IrMod t => IrMod (tr t)
    | IrIMod t => IrIMod (tr t)
    | IrCmpul t => IrCmpul (tr t)
    | IrCmpug t => IrCmpug (tr t)
    | IrCmpule t => IrCmpule (tr t)
    | IrCmpuge t => IrCmpuge (tr t)
    | IrCmpsl t => IrCmpsl (tr t)
    | IrCmpsg t => IrCmpsg (tr t)
    | IrCmpsle t => IrCmpsle (tr t)
    | IrCmpsge t => IrCmpsge (tr t)
    | IrAnd t => IrAnd (tr t)
    | IrOr t => IrOr (tr t)
    | IrXor t => IrXor (tr t)
    | IrEq t => IrEq (tr t)
    | IrNeq t => IrNeq (tr t)
    | IrExtSign t => IrExtSign (tr t)
    | IrExtZero t => IrExtZero (tr t)
    | IrLoad (_, rs, am) => IrLoad (rd, rs, am)
    | IrShl t => IrShl (tr t)
    | IrShr t => IrShr (tr t)
    | IrSar t => IrSar (tr t)
    | IrFcall (_, f, args) => IrFcall (rd, f, args)
    | IrRet (SOME _) => IrRet (SOME rd)
    | IrRet NONE => raise Unreachable
    | IrSet (_, arg) => IrSet (rd, arg)
    | IrNop _ | IrNopLabel _ | IrAlloc _ | IrCopy _ | IrJmp _ | IrJz _
    | IrJnz _ | IrStore _ => raise Unreachable
  end

  fun mergeIns (Lctx { vregs, opTable, ... }) idx rd rs =
  let
    val opTable = valOf opTable

    val { class, t, ... } = D.get vregs rs
    val () = D.set vregs rs { defs = [], use = [], class, t }
    val ins = valOf $ Array.sub (opTable, idx - 1)
    val ir = changeDest rd ins
    val () = Array.update (opTable, idx - 1, SOME ir)
    val () = Array.update (opTable, idx, NONE)

    val { defs, use, class, t } = D.get vregs rd

    fun loop (d :: ds) acc =
      loop ds $ (if d = idx then idx - 1 else d) :: acc
      | loop [] acc = rev acc
    val () = D.set vregs rd { defs = loop defs [], use, class, t }
  in
    ()
  end

  fun optSet (C as Lctx { vregs, opTable, localVars, ... })
    (idx, SOME (IrSet (rd, SaVReg rs)))
  =
    if getCS vregs rd <> getCS vregs rs then
      ()
    else
      let
        val { defs, use, ... } = D.get vregs rs
      in
        case (defs, use) of
          ([d], [_]) =>
            if d = idx - 1 andalso rs >= Vector.length localVars then
              mergeIns C idx rd rs
            else
              ()
        | _ => ()
      end
    | optSet _ _ = ()

  fun peephole (C as Lctx { opTable, ... }) =
  let
    val () = Array.appi (optSet C) (valOf opTable)
  in
    ()
  end

  fun translateFn (F as { localVars, stmt, paramNum, ... }) =
  let
    val () = P.printDef (P.Definition F)
    val ctx = createLocalCtx localVars paramNum
    val ctx = convStmt ctx stmt

    val ctx = createInsTable ctx
    val () = printVars ctx
    val () = printIns ctx

    val () = printf `"\nconstant propagation\n\n" %
    val () = constPropagate ctx
    val () = printIns ctx

    val () = printf `"\npeephole il optimizations\n\n" %
    val () = peephole ctx
    val () = printIns ctx

    val () = printf `"\nvariables\n\n" %
    val () = printVars ctx
  in
    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