path: root/il.fun

functor IL(P: PARSER) = struct

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

  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 cmpOp =
    Cmpeq | Cmpneq |
    Cmpul | Cmpug | Cmpule | Cmpuge |
    Cmpsl | Cmpsg | Cmpsle | Cmpsge

  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

    | IrCmp of cmpOp * 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 *)

    | IrJmpc of cmpOp * vreg * vreg * label
    | IrJz of vreg * label
    | IrJnz of vreg * label
    | IrJmp of label

    | IrRet of vreg option
    | IrAlloc of vreg * word * int option
    | 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 =
    RtReg |
    RtRem |
    RtConst of word |
    RtAddrConst of int * word

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

  datatype funcType = FtLeaf | FtNonLeaf

  datatype scopeInfo =
    SiLoop of { breakL: label, contL: label, startL: label, endL: label } |
    SiIf

  datatype localCtx = Lctx of {
    fname: int,
    localVars: { onStack: bool, t: P.ctype, name: int } vector,
    paramNum: int,
    ft: funcType ref,

    vregs: regInfo D.t,
    ops: (irIns option * (label * label) option) D.t,

    scopes: scopeInfo list ref,
    labels: (int option * int) D.t
  }

  datatype funcInfo = Fi of {
    name: int,
    paramNum: int,
    localBound: int,
    t: funcType,
    vregs: regInfo D.t,
    ops: (irIns option * (label * label) option) D.t,
    labels: int option D.t
  }

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

  val debugFile = ref NONE

  local
    fun output s =
    let
      val outstream = !debugFile
    in
      case outstream of
        NONE => ()
      | SOME outstream => TextIO.output (outstream, s)
    end

    val ctx = ((false, makePrintfBase output),
      fn (_: bool * ((string -> unit) * (unit -> unit))) => ())
  in
    fun dprintf g = Fold.fold ctx g
  end

  fun updateLctx (Lctx ctx) = fn z =>
  let
    fun from fname localVars paramNum ft vregs ops scopes labels =
      { fname, localVars, paramNum, ft, vregs, ops, scopes, labels }
    fun to f { fname, localVars, paramNum, ft, vregs, ops, scopes, labels } =
      f fname localVars paramNum ft vregs ops scopes labels
  in
    FRU.makeUpdate7 (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, t, name, ... } = Vector.sub (localVars, idx)
        in
          setup (idx + 1) ({ onStack, t, name } :: 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 () = dprintf `"local + copies: " I len `"\n" %

    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 = RtReg, canFold = true };
            loop (idx + 1)
          end
        else
          let
            val { class, ... } = D.get vregs (idx - lvlen)
          in
            D.push vregs
              { class, defs = [], use = [], t = RtReg, canFold = true };
            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
    | IrCmp (_, vr1, vr2, vr3) => tr (vr1, vr2, vr3)

    | 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 = [] }
    | IrJmpc (_, r1, r2, _) => { defs = [], use = [r1, r2] }
    | 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, canFold } = D.get vregs vr
    in
      D.set vregs vr { class, defs = pos :: defs, use, t, canFold }
    end
    fun updateUse vr =
    let
      val { class, defs, use, t, canFold } = D.get vregs vr
    in
      D.set vregs vr { class, defs, use = pos :: use, t, canFold }
    end
  in
    List.app updateDef defs;
    List.app updateUse use
  end

  fun getOutermostLoopIfNeeded scopes =
  let
    fun skipToIf [] = NONE
      | skipToIf (SiLoop _ :: tail) = skipToIf tail
      | skipToIf (SiIf :: tail) = SOME tail

    fun tryGetFirstLoop (SiIf :: tail) = tryGetFirstLoop tail
      | tryGetFirstLoop (SiLoop { startL, endL, ... } :: _) =
        SOME (startL, endL)
      | tryGetFirstLoop [] = NONE
  in
    case skipToIf scopes of
      NONE => NONE
    | SOME tail => tryGetFirstLoop (rev tail)
  end

  fun ctxPutOp (C as Lctx { ops, labels, scopes, ... }) op' =
  let
    val { defs, use } = getInsInfo op'
    val insPos = D.length ops
    val () = updateDefsUse C defs use insPos

    val li = getOutermostLoopIfNeeded (!scopes)
    val () = D.push ops (SOME op', li)

    fun setPos (NONE, use) = (SOME insPos, use)
      | setPos (SOME _, _) = raise Unreachable

    fun inc (v, use) = (v, use + 1)
  in
    case op' of
      IrNopLabel lid => D.update labels setPos lid
    | IrJmp lid | IrJnz (_, lid) | IrJz (_, lid) => D.update labels inc lid
    | _ => ()
  end

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

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

  fun getLabel (Lctx { labels, ... }) = D.pushAndGetId labels (NONE, 0)

  fun createLocalCtx fname localVars paramNum =
  let
    val localVars = setupLocalVars localVars
    val vregs = setupVregs localVars paramNum
    val labels = D.create0 ()

    val ctx = Lctx {
      fname,
      localVars, paramNum, ft = ref FtLeaf,
      vregs, ops = D.create0 (),
      scopes = ref [], labels
    }
    val () = ctxPutOp ctx (IrNop "")
    val _ = getLabel ctx (* label before ret *)
    val () = copyArgs ctx
  in
    ctx
  end

  fun getNewVR class (Lctx { vregs, ... }) canFold =
  let
    val id = D.pushAndGetId vregs
      { class, defs = [], use = [], t = RtReg, canFold }
  in
    id
  end

  fun getNewVReg class C = getNewVR class C true
  fun getNewVRegFuncArg class C = getNewVR class C false

  val getNew4 = getNewVReg VR4
  val getNew8 = getNewVReg VR8

  fun newConst (Lctx { vregs, ... }) class w =
  let
    val w = P.extz w (if class = VR4 then 0w4 else 0w8)

    val id = D.pushAndGetId vregs { class, defs = [], use = [],
      t = RtConst w, canFold = true }
  in
    id
  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
    val () = ctxPutOp ctx (IrSet (v, SaConst w))
  in
    Reg v
  end

  fun convGLconst ctx id =
  let
    val v = getNew8 ctx
  in
    ctxPutOp ctx (IrSet (v, SaAddr (id, 0w0)));
    Addr v
  end

  fun convStrlit ctx id t =
  let
    val v = getNew8 ctx
  in
    ctxPutOp ctx (IrSet (v, SaAddr (id, 0w0)));
    (if P.isArray t then Addr else Reg) v
  end

  fun convId ctx (P.Gid id) = convGLconst ctx id
    | convId (Lctx { localVars, paramNum, ... }) (P.Lid id) =
      if id < paramNum then (* function parameter *)
        (Reg (id + Vector.length localVars))
      else
        let
          val onStack = #onStack $ Vector.sub (localVars, id)
        in
          (if onStack then Addr else Reg) id
        end

  fun getOffset t field = #1 $ valOf $ P.getFieldInfo t field

  fun computeFieldFromVReg ctx v offset =
  let
    val vOff = newConst ctx VR8 offset
    val vRes = getNew8 ctx
    val () = ctxPutOp ctx (IrAdd (vRes, v, vOff))
  in
    Addr vRes
  end

  fun convFieldAccessByV ctx ea field: ev =
  let
    val v: ev = convExpr ctx ea
    val offset = getOffset (P.getT ea) field
  in
    case v of
      Addr v => computeFieldFromVReg ctx v offset
    | Reg _ => raise Unreachable
  end

  and convFieldAccesByP ctx ea field =
  let
    val v = convExpr ctx ea

    val offset = getOffset (P.pointsTo $ P.getT ea)field
  in
    case v of
      Reg v => computeFieldFromVReg ctx v offset
    | Addr v =>
      let
        val vl = getNew8 ctx
        val () = ctxPutOp ctx (IrLoad (vl, v, AC8))
      in
        computeFieldFromVReg ctx vl offset
      end
  end

  and convSizeOfType ctx t: ev =
  let
    val w = P.sizeOfType t
    val v = newConst ctx VR8 w
  in
    Reg v
  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 = newConst ctx class (getSingleOffset t)
      in
        ctxPutOp ctx (op' (v, v, v1));
        Reg v
      end
    | Addr v =>
      let
        val class = getClassForType t
        val aClass = typeAccessClass t
        val vl = getNewVReg class ctx
        val v1 = newConst ctx class (getSingleOffset t)
      in
        ctxPutOp ctx (IrLoad (vl, v, aClass));
        ctxPutOp ctx (op' (vl, vl, v1));
        ctxPutOp ctx (IrStore (v, vl, aClass));
        Reg vl
      end

  and convPost op' ctx (v, t) =
    case v of
      Reg v =>
        let
          val class = getClass ctx v
          val vOld = getNewVReg class ctx
          val v1 = newConst ctx class (getSingleOffset t)
        in
          ctxPutOp ctx (IrSet (vOld, SaVReg v));
          ctxPutOp ctx (op' (v, v, v1));
          Reg vOld
        end
    | Addr v =>
      let
        val class = getClassForType t
        val aClass = typeAccessClass t
        val vl = getNewVReg class ctx
        val vOld = getNewVReg class ctx
        val v1 = newConst ctx class (getSingleOffset t)
      in
        ctxPutOp ctx (IrLoad (vl, v, aClass));
        ctxPutOp ctx (IrSet (vOld, SaVReg vl));
        ctxPutOp ctx (op' (vl, vl, v1));
        ctxPutOp ctx (IrStore (v, vl, aClass));
        Reg vOld
      end

  and convAddr v =
    case v of
      Reg _ => raise Unreachable
    | Addr v => Reg v

  and convDeref ctx v =
    case v of
      Reg v => Addr v
    | Addr v =>
      let
        val vD = getNew8 ctx
        val () = ctxPutOp ctx (IrLoad (vD, v, AC8))
      in
        Addr vD
      end

  and convPos v = v

  and prepIsZero ctx vDest vSrc =
  let
    val vc = newConst ctx (getClass ctx vSrc) 0w0
  in
    ctxPutOp ctx (IrCmp (Cmpeq, vDest, vSrc, vc))
  end

  and prepNeg ctx vDest vSrc =
  let
    val vc = newConst ctx (getClass ctx vSrc) 0w0
  in
    ctxPutOp ctx (IrSub (vDest, vc, vSrc))
  end

  and prepComp ctx vDest vSrc =
  let
    val vc = 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
      in
        fop ctx vNew v;
        Reg vNew
      end
    | Addr v =>
      let
        val aClass = typeAccessClass t
        val class = getClassForType t
        val vl = getNewVReg class ctx
      in
        ctxPutOp ctx (IrLoad (vl, v, aClass));
        fop ctx vl vl;
        ctxPutOp ctx (IrStore (v, vl, aClass));
        Reg vl
      end

  and convCastScalar ctx v fromT toT =
    case Word.compare (P.sizeOfType toT, P.sizeOfType fromT) of
      EQUAL => v
    | LESS => (
        case v of
          Reg v =>
            let
              val vNew = getNew4 ctx
            in
              ctxPutOp ctx (IrSet (vNew, SaVReg v));
              Reg vNew
            end
        | Addr v => Addr v
    )
    | GREATER =>
      let
        val op' = if P.isSigned fromT then IrExtSign else IrExtZero
        val aClass = typeAccessClass fromT
        val toTClass = getClassForType toT

        val v =
            case v of
              Addr v =>
              let
                val vl = getNew4 ctx
              in
                ctxPutOp ctx (IrLoad (vl, v, aClass));
                vl
              end
            | Reg v => v
        val vNew = getNewVReg toTClass ctx
      in
        ctxPutOp ctx (op' (vNew, v, aClass));
        Reg vNew
      end

  and convCast _ (v, _, P.void_t) = v
    | convCast ctx (v, fromT, toT) =
      if P.isArray fromT then
        let
          val elT = P.elementType fromT
          val () =
            if toT <> P.pointer_t (1, elT) then raise Unreachable else ()
        in
          case v of
             Addr v => Reg v
           | _ => raise Unreachable
        end
      else if P.isFunc fromT then
        let
          val () =
            if toT <> P.pointer_t (1, fromT) then raise Unreachable else ()
        in
          case v of
            Addr v => Reg v
          | _ => raise Unreachable
        end
      else
        convCastScalar ctx v fromT toT

  and convUnop ctx unop ea t: ev =
  let
    val v: ev = 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 v
    | P.UnopDeref => convDeref ctx v
    | P.UnopPos => convPos 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
    | Addr v =>
      let
        val aClass = typeAccessClass t
        val class = getClassForType t
        val vl = getNewVReg class ctx
      in
        ctxPutOp ctx (IrLoad (vl, v, aClass));
        vl
      end

  and binopPrepOpers ctx t vLeft vRight =
  let
    val vLeft = loadIfNeeded ctx t vLeft
    val vRight = loadIfNeeded ctx t vRight
    val vNew = getNewVReg (getClass ctx vLeft) ctx
  in
    (vNew, vLeft, vRight)
  end

  and convSimple op' ctx t vLeft vRight =
  let
    val (vNew, vLeft, vRight) = binopPrepOpers ctx t vLeft vRight
  in
    ctxPutOp ctx (op' (vNew, vLeft, vRight));
    Reg vNew
  end

  and shiftPointer ctx op' (leftT, vLeft) (rightT, vRight) =
    let
      val v =
        case convCast ctx (Reg vRight, rightT, P.ulong_t) of
          Reg v => v
        | Addr _ => raise Unreachable

      val mulVal = P.sizeOfType $ P.pointsTo leftT
      val multiplier = newConst ctx VR8 mulVal

      val vm = getNew8 ctx
      val vRes = getNew8 ctx
    in
      ctxPutOp ctx (IrMul (vm, v, multiplier));
      ctxPutOp ctx (op' (vRes, vLeft, vm));
      Reg vRes
    end

  and convSum ctx (leftT, vLeft) (rightT, vRight) =
  let
    val vLeft = loadIfNeeded ctx leftT vLeft
    val vRight = 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
      in
        ctxPutOp ctx (IrAdd (vNew, vLeft, vRight));
        Reg vNew
      end
  end

  and convSub ctx (leftT, vLeft) (rightT, vRight) =
  let
    val vLeft = loadIfNeeded ctx leftT vLeft
    val vRight = loadIfNeeded ctx rightT vRight
  in
    if P.isPointer leftT then
      if P.isPointer rightT then
        let
          val vDiff = getNew8 ctx
          val vRes = getNew8 ctx
          val divider = newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT))
        in
          ctxPutOp ctx (IrSub (vDiff, vLeft, vRight));
          ctxPutOp ctx (IrDiv (vRes, vDiff, divider));
          Reg vRes
        end
      else
        shiftPointer ctx IrSub (leftT, vLeft) (rightT, vRight)
    else
      let
        val vNew = getNewVReg (getClass ctx vLeft) ctx
      in
        ctxPutOp ctx (IrSub (vNew, vLeft, vRight));
        Reg vNew
      end
  end

  and convSimpleAssignment ctx leftT vLeft vRight =
  let
    val vRight = loadIfNeeded ctx leftT vRight
  in
    case vLeft of
      Reg v => (
          ctxPutOp ctx (IrSet (v, SaVReg vRight));
          Reg v
      )
    | Addr v => (
      ctxPutOp ctx (IrStore (v, vRight, typeAccessClass leftT));
      Reg vRight
    )
  end

  and convSubscript ctx (leftT, vLeft) (rightT, vRight) =
  let
    val vLeft = loadIfNeeded ctx leftT vLeft
    val vRight = loadIfNeeded ctx rightT vRight

    val res =
      case shiftPointer ctx IrAdd (leftT, vLeft) (rightT, vRight) of
        Reg v => v
      | Addr _ => raise Unreachable
  in
    Addr res
  end

  and convCompAssign (op', op2) ctx (leftT, vLeft) (rightT, vRight) =
  let
    val vRight = 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 => v
        | Addr _ => raise Unreachable
      else
        v

    fun apply ctx leftV =
    let
      val vLeft = convIfNeeded ctx leftT leftV
      val vRight = convIfNeeded ctx rightT vRight

      val op' = if P.isSigned commonType then op2 else op'
      val vRight =
        if P.isPointer leftT then
          let
            val mul = newConst ctx VR8 (P.sizeOfType (P.pointsTo leftT))
            val vm = getNew8 ctx
          in
            ctxPutOp ctx (IrMul (vm, vRight, mul));
            vm
          end
        else
          vRight
    in
      ctxPutOp ctx (op' (vLeft, vLeft, vRight));
      vLeft
    end
  in
    case vLeft of
      Reg v =>
      let
        val vLeft = apply ctx v
      in
        if leftT <> commonType then
          ctxPutOp ctx (IrSet (v, SaVReg vLeft))
        else
          ();
        Reg v
      end
    | Addr v =>
      let
        val class = getClassForType leftT
        val aClass = typeAccessClass leftT
        val vl = getNewVReg class ctx
        val () = ctxPutOp ctx (IrLoad (vl, v, aClass))

        val vLeft = apply ctx vl
      in
        ctxPutOp ctx (IrStore (v, vLeft, aClass));
        Reg vLeft
      end
  end

  and convComma _ _ (_, vRight) = vRight

  and getLabelPair ctx =
  let
    val l1 = getLabel ctx
    val l2 = getLabel ctx
  in
    (l1, l2)
  end

  and genLogPart ctx ea =
  let
    val t = P.getT ea
    val v = convExpr ctx ea
    val v = loadIfNeeded ctx t v
    val v =
      if P.typeRank t < P.typeRank P.int_t then
        case convCast ctx (Reg v, t, P.int_t) of
          Reg v => v
        | Addr _ => raise Unreachable
      else
        v
  in
    v
  end

  and convLogOr ctx left right =
  let
    val vLeft = genLogPart ctx left

    val (elseLabel, endLabel) = getLabelPair ctx

    val vRes = getNew4 ctx
    val () = ctxPutOp ctx (IrJz (vLeft, elseLabel))
    val () = ctxPutOp ctx (IrSet (vRes, SaConst 0w1))
    val () = ctxPutOp ctx (IrJmp endLabel)
    val () = ctxPutOp ctx (IrNopLabel elseLabel)

    val vRight = genLogPart ctx right
    val vC = newConst ctx (getClass ctx vRight) 0w0
    val () = ctxPutOp ctx (IrCmp (Cmpneq, vRes, vRight, vC))
    val () = ctxPutOp ctx (IrNopLabel endLabel);
  in
    Reg vRes
  end

  and convLogAnd ctx left right =
  let
    val vLeft = genLogPart ctx left
    val (falseLabel, endLabel) = getLabelPair ctx
    val () = ctxPutOp ctx (IrJz (vLeft, falseLabel))
    val vRight = genLogPart ctx right
    val vRes = getNew4 ctx
    val vC = newConst ctx (getClass ctx vRight) 0w0
  in
    ctxPutOp ctx (IrCmp (Cmpneq, vRes, vRight, vC));
    ctxPutOp ctx (IrJmp endLabel);
    ctxPutOp ctx (IrNopLabel (falseLabel));
    ctxPutOp ctx (IrSet (vRes, SaConst 0w0));
    ctxPutOp ctx (IrNopLabel endLabel);
    Reg vRes
  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 = convExpr ctx left
      val vRight = 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

    fun cmpw cmop (r1, r2, r3) = IrCmp (cmop, r1, r2, r3)
  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 (cmpw Cmpeq)
    | P.BR P.BrNotEqual => convSimple (cmpw Cmpneq)
    | P.BR P.BrGreater => convSimple (chs (cmpw Cmpsg) (cmpw Cmpug))
    | P.BR P.BrLess => convSimple (chs (cmpw Cmpsl) (cmpw Cmpul))
    | P.BR P.BrGreaterEqual => convSimple (chs (cmpw Cmpsge) (cmpw Cmpuge))
    | P.BR P.BrLessEqual => convSimple (chs (cmpw Cmpsle) (cmpw Cmpule))

    | 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 = genLogPart ctx cond
    val (elseLabel, endLabel) = getLabelPair ctx
    val () = ctxPutOp ctx (IrJz (cond, elseLabel))
    val vRes = getNewVReg (getClassForType leftT) ctx
    val vLeft = convExpr ctx left
    val vLeft = loadIfNeeded ctx leftT vLeft
    val () = ctxPutOp ctx (IrSet (vRes, SaVReg vLeft))
    val () = ctxPutOp ctx (IrJmp endLabel)
    val () = ctxPutOp ctx (IrNopLabel elseLabel)
    val vRight = convExpr ctx right
    val vRight = loadIfNeeded ctx leftT vRight
    val () = ctxPutOp ctx (IrSet (vRes, SaVReg vRight))
    val () = ctxPutOp ctx (IrNopLabel endLabel)
  in
    Reg vRes
  end

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

    fun genArgs [] acc =
      let
        fun loop _ [] acc2 = rev acc2
          | loop idx (vArg :: acc) acc2 =
          let
            val arg = getNewVRegFuncArg (getClass ctx vArg) ctx
          in
            ctxPutOp ctx (IrSet (arg, SaVReg vArg));
            loop (idx + 1) acc (arg :: acc2)
          end

        val () = ctxPutOp ctx (IrNop "here")
      in
        loop 0 (rev acc) []
      end
      | genArgs (arg :: args) acc =
      let
        val vArg = convExpr ctx arg
        val vArg = loadIfNeeded ctx (P.getT arg) vArg
      in
        genArgs args (vArg :: acc)
      end

    val args = genArgs 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
    val Lctx { ft, ... } = ctx
  in
    ft := FtNonLeaf;
    ctxPutOp ctx (IrFcall (vRes, vFunc, args));
    Reg vRes
  end

  and convExpr ctx ea =
  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 => convStrlit ctx id t
    | 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 wrapTo8 v =
  let
    open Word
  in
    (v + 0w7) div 0w8 * 0w8
  end

  fun convIni (C as Lctx { localVars, ... }) (id, NONE) =
  let
    val size = P.sizeOfType $ #t $ Vector.sub (localVars, id)
  in
    ctxPutOp C (IrAlloc (id, wrapTo8 size, NONE))
  end
    | convIni (C as Lctx { localVars, ... }) (id, SOME (P.CiniExpr ea)) =
    let
      val t = P.getT ea
      val v = convExpr C ea
      val v = loadIfNeeded C t v

    in
      if #onStack $ Vector.sub (localVars, id) then (
        ctxPutOp C (IrAlloc (id, 0w8, NONE));
        ctxPutOp C (IrStore (id, v, typeAccessClass t))
      ) else
        ctxPutOp C (IrSet (id, SaVReg v))
    end
    | convIni ctx (id, SOME (P.CiniLayout lid)) =
    let
      val size = wrapTo8 $ P.getLayoutSize lid
    in
      ctxPutOp ctx (IrAlloc (id, size, NONE));
      ctxPutOp ctx (IrCopy (id, lid, size))
    end

  fun convReturn ctx ea =
    case ea of
      SOME ea =>
      let
        val v = convExpr ctx ea
        val v = loadIfNeeded ctx (P.getT ea) v
      in
        ctxPutOp ctx (IrRet $ SOME v)
      end
   | NONE => ctxPutOp ctx (IrRet NONE)

  fun beginIfScope (Lctx { scopes, ... }) = scopes := SiIf :: !scopes
  fun endIfScope (Lctx { scopes, ... }) =
    case hd (!scopes) of
      SiLoop _ => raise Unreachable
    | SiIf => scopes := tl (!scopes)

  fun convIf ctx (cond, thenPart, elsePart) =
  let
    val () = beginIfScope ctx
    val v = genLogPart ctx cond
    val (elseL, endL) = getLabelPair ctx
  in
    ctxPutOp ctx (IrJz (v, elseL));
    convStmt ctx thenPart;

    if isSome elsePart then ctxPutOp ctx (IrJmp endL) else ();
    ctxPutOp ctx (IrNopLabel elseL);
    case elsePart of
      SOME elsePart => (
        convStmt ctx elsePart;
        ctxPutOp ctx (IrNopLabel endL)
      )
    | NONE => ();
    endIfScope ctx
  end

  and getLabelsWhile (C as Lctx { scopes, ... }) =
  let
    val (startL, endL) = getLabelPair C
    val scope = SiLoop { startL, endL, contL = startL, breakL = endL }
  in
    scopes := scope :: !scopes;
    { startL, endL }
  end

  and ctxLoopExit (Lctx { scopes, ... }) =
  let
    val top = hd $ !scopes
  in
    case top of
      SiLoop _ => scopes := tl (!scopes)
    | _ => raise Unreachable
  end

  and convWhile ctx (cond, body) =
  let
    val { startL, endL } = getLabelsWhile ctx
    val () = ctxPutOp ctx (IrNopLabel startL)
    val cond = genLogPart ctx cond
  in
    ctxPutOp ctx (IrJz (cond, endL));
    convStmt ctx body;
    ctxPutOp ctx (IrJmp startL);
    ctxPutOp ctx (IrNopLabel endL);
    ctxLoopExit ctx
  end

  and getLabelsDoWhile (C as Lctx { scopes, ... }) =
  let
    val startL = getLabel C
    val (contL, endL) = getLabelPair C
    val scope = SiLoop { startL, endL, contL, breakL = endL }
  in
    scopes := scope :: !scopes;
    { startL, contL, endL }
  end

  and convDoWhile ctx (body, cond) =
  let
    val { startL, contL, endL } = getLabelsDoWhile ctx
    val () = ctxPutOp ctx (IrNopLabel startL)
    val () = convStmt ctx body
    val () = ctxPutOp ctx (IrNopLabel contL)
    val cond = genLogPart ctx cond
  in
    ctxPutOp ctx (IrJnz (cond, startL));
    ctxPutOp ctx (IrNopLabel endL);
    ctxLoopExit ctx
  end

  and convBreakOrCont isBreak (C as Lctx { scopes, ... }) =
  let
    fun getFirstLoopInfo [] = raise Unreachable
      | getFirstLoopInfo (SiLoop { breakL, contL, ... } :: _) =
       (breakL, contL)
      | getFirstLoopInfo (SiIf :: tail) = getFirstLoopInfo tail

    val (break, continue) = getFirstLoopInfo $ !scopes
    val label = if isBreak then break else continue
  in
    ctxPutOp C (IrJmp label)
  end

  and getLabelsFor (C as Lctx { scopes, ... }) =
  let
    val startL = getLabel C
    val (endL, contL) = getLabelPair C
    val scope = SiLoop { startL, endL, contL, breakL = endL }
  in
    scopes := scope :: !scopes;
    { startL, contL, endL }
  end

  and convFor ctx (pre, cond, post, stmt) =
  let
    val () =
      case pre of
        NONE => ()
      | SOME ea => ignore $ convExpr ctx ea
    val { startL, contL, endL } = getLabelsFor ctx

    val () = ctxPutOp ctx (IrNopLabel startL)
    val () =
      case cond of
        NONE => ()
      | SOME cond =>
        let
          val cond = genLogPart ctx cond
        in
          ctxPutOp ctx (IrJz (cond, endL))
        end
    val () = convStmt ctx stmt
    val () = ctxPutOp ctx (IrNopLabel contL)
    val () =
      case post of
        NONE => ()
      | SOME post => ignore $ convExpr ctx post
    val () = ctxPutOp ctx (IrJmp startL)
    val () = ctxPutOp ctx (IrNopLabel endL)
  in
    ctxLoopExit ctx
  end

  and convStmt ctx stmt: unit =
    case stmt of
      P.StmtExpr ea => ignore $ convExpr ctx ea
    | P.StmtCompound (inis, stmts) => (
      List.app (fn ini => convIni ctx ini) inis;
      List.app (fn stmt => convStmt ctx stmt) stmts
    )
    | 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
    | P.StmtNone => ()

  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 pwc class w out =
  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 out `sign W w %
    end

  val Pwc = fn z => bind A2 pwc z

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

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

  fun printOp ctx (idx, (SOME op', li)) =
  let
    fun printTail NONE = dprintf `"\n" %
      | printTail (SOME (startL, endL)) =
        case op' of
          IrNopLabel _ => dprintf `"\n" %
        | _ => dprintf `" ; (l" I startL `", l" I endL `")\n" %

    val () = dprintf Ip 4 idx `":" %
    val () =
      case op' of
        IrNopLabel _ => ()
      | _ => dprintf `"\t" %
    fun pt (reg1, reg2, reg3) op' =
      dprintf `"\t" Preg ctx reg1 `" " Pt ctx reg1 `" = "
          `op' `" " Preg ctx reg2 `", " Preg ctx reg3 %

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

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

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

    fun printAlloc (r, size, off) =
    let
      val () = dprintf `"\t" Preg ctx r `" = alloc " W size  %
    in
      case off of
        SOME off => dprintf `" [rbp-" I off `"]" %
      | NONE => ()
    end

    fun printCopy (to, from, size) =
      dprintf `"\tcopy " Preg ctx to `", I." I from `", " W size %

    fun printFcall (ret, f, args) =
    let
      val () = dprintf `"\t" %
      val () =
        if ret <> ~1 then
          dprintf Preg ctx ret `" " Pt ctx ret `" = " %
        else
          ()
    in
      dprintf `"fcall " Preg ctx f `"" Plist (preg ctx) args (", ", true, 0) %
    end

    fun printLabel (Lctx { labels, ... }) lid =
    let
      val (labelPos, use) = D.get labels lid
      val () = if valOf labelPos <> idx then raise Unreachable else ()
    in
        dprintf `"@" Pl lid `"(" I use `"):" %
    end

    fun cmpOpStr cmpop =
      case cmpop of
        Cmpeq => "cmpeq"
      | Cmpneq => "cmpneq"
      | Cmpul => "cmpul"
      | Cmpug => "cmpug"
      | Cmpule => "cmpule"
      | Cmpuge => "cmpuge"
      | Cmpsl => "cmpsl"
      | Cmpsg => "cmpsg"
      | Cmpsle => "cmpsle"
      | Cmpsge => "cmpsge"

    fun pjc (op', r1, r2, lid) =
    let
      val opRepr = cmpOpStr op'
      val opRepr = "jmp" ^ String.extract (opRepr, 3, NONE)
    in
      dprintf `"\t" `opRepr `" "
        Preg ctx r1 `", " Preg ctx r2 `", " Pl lid %
    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"

    | IrCmp (cmpOp, vr1, vr2, vr3) => pt (vr1, vr2, vr3) (cmpOpStr cmpOp)

    | IrExtZero t => pe t "extz"
    | IrExtSign t => pe t "exts"

    | IrLoad (r1, r2, ac) =>
      dprintf `"\t" Preg ctx r1 `" = " Pac ac `" [" Preg ctx r2 `"]" %
    | IrStore (r1, r2, ac) =>
      dprintf `"\t" Pac ac `" [" Preg ctx r1 `"] <- " Preg ctx r2 %
    | IrJmp l => dprintf `"\tjmp " Pl l %
    | IrJmpc q => pjc q
    | IrJz p => pj p "jz"
    | IrJnz p => pj p "jnz"
    | IrNopLabel l => printLabel ctx l
    | IrNop s => dprintf `"\t; " `s %
    | IrRet v => printRet v
    | IrAlloc p => printAlloc p
    | IrCopy t => printCopy t
    | IrFcall t => printFcall t
    ;
    printTail li
  end
   | printOp _ (_, (NONE, _)) = ()

  fun printIns (C as Lctx { ops, ... }) =
    D.appi (printOp C) ops

  fun printVar idx { class, defs, use, t, canFold = _ } =
  let
    val c = if class = VR4 then "w4" else "w8"

    val () = dprintf `"%" I idx `" " `c `"\t"
          `": defs = " Plist i defs (", ", true, 0)
          `", uses = " Plist i use (", ", true, 0) %
  in
    case t of
     RtReg => dprintf `" regular" %
   | RtRem => dprintf `" removed" %
   | RtConst w => dprintf `" const " Pwc class w %
   | RtAddrConst (id, w) =>
       dprintf `" addr const " PP.? id Pwc class w %
   ;
   dprintf `"\n" %
  end

  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 constAdd vregs ops vid v insId =
  let
    val { class, defs, use, ... } = D.get vregs vid
    val v =
      case v of
        RtConst w =>
        let
          val w = P.extz w (getClassSize class)
        in
          RtConst w
        end
      | RtAddrConst p => RtAddrConst p
      | RtReg | RtRem => raise Unreachable
    val () = D.set vregs vid { class, defs, use, t = v, canFold = true }

    fun f (SOME _, li) = (NONE, li)
      | f (NONE, _) = raise Unreachable
  in
    dprintf `"%" I vid `", " %;
    D.update ops f insId
  end

  fun getFirstConstants
    (Lctx { vregs, ops, localVars, paramNum, ... }) =
  let
    fun loop vid acc =
      if vid = D.length vregs then
        rev acc
      else
        let
          val { defs, t, ... } = D.get vregs vid

          fun addConstFromSet arg def =
          let
            val v =
              case arg of
                SaConst w => RtConst w
              | SaAddr p => RtAddrConst p
              | _ => raise Unreachable
          in
            constAdd vregs ops vid v def
          end
        in
          case (t, defs) of
            (RtReg, [def]) =>
            let
              val ins = valOf o #1 $ D.get ops def
            in
              case ins of
                IrSet(_, arg as SaConst _ | arg as SaAddr _) =>
                let
                  val () = addConstFromSet arg def
                in
                  loop (vid + 1) (vid :: acc)
                end
              | _ => loop (vid + 1) acc
            end
          | (RtReg, _) => loop (vid + 1) acc
          | (RtConst _, _) => loop (vid + 1) (vid :: acc)
          | _ => raise Unreachable
        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 => RtReg

  fun evalSet vregs (rd, SaVReg rs) =
  let
    val rt = getRegType vregs rs
    val { canFold, ... } = D.get vregs rd

    val fromSize = getCS vregs rs
    val toSize = getCS vregs rd
  in
    if canFold = false then
      RtReg
    else
      case rt of
        RtConst w => RtConst $ P.extz w fromSize
      | RtAddrConst p =>
          if toSize = 0w8 then
            RtAddrConst p
          else
            RtReg
      | _ => 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
          RtReg
    | _ => 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))
    | (RtRem, _) | (_, RtRem) => raise Unreachable
    | _ => RtReg
  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

    fun ecmp (cmpOp, vr1, vr2, vr3) =
    let
      val t = (vr1, vr2, vr3)
    in
      case cmpOp of
        Cmpeq => evalSimple true vregs ExtZero t eq
      | Cmpneq => evalSimple true vregs ExtZero t neq
      | Cmpul => esu t (bop Word.<)
      | Cmpug => esu t (bop Word.>)
      | Cmpule => esu t (bop Word.<=)
      | Cmpuge => esu t (bop Word.>=)
      | Cmpsl => ess t (sbop Int64.<)
      | Cmpsg => ess t (sbop Int64.>)
      | Cmpsle => ess t (sbop Int64.<=)
      | Cmpsge => ess t (sbop Int64.>=)
    end
  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.~>>

    | IrCmp q => ecmp q

    | 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 _  => RtReg
    | IrJmpc _ | 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
    | RtRem => raise Unreachable
    | _ => res
  end
   | eval NONE _ = RtReg

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

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

      (*
      val () = printfn `"Took from worklist: " I v  %
      val () = printfn `"usage: " Plist i use (", ", true, 0) %
      *)

      fun loop (insId :: tail) acc =
      let
        val (ins, li) = D.get ops insId

        (*
        val () = printfn `"v: " I v `", Ins: " I insId %
        *)
      in
        case eval ins vregs of
          RtReg => loop tail acc
        | RtRem => raise Unreachable
        | v =>
        let
          val vd = defines ins
          val { defs, ... } = D.get vregs vd
          val newConst =
            case defs of
              [_] => (constAdd vregs ops 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
                D.set ops insId (SOME ins, li);
                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 ops
    end

  fun constPropagate (C as Lctx { vregs, ops, ... }) =
  let
    val () = dprintf `"constants: " %
    val worklist = getFirstConstants C
  in
    propagate worklist vregs ops;
    dprintf `"\n" %
  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)

    | IrCmp (cmpOp, _, vr2, vr3) => IrCmp (cmpOp, rd, vr2, vr3)

    | IrAnd t => IrAnd (tr t)
    | IrOr t => IrOr (tr t)
    | IrXor t => IrXor (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 _
    | IrJmpc _ | IrJnz _ | IrStore _ => raise Unreachable
  end

  fun removeVR vregs vr =
  let
    val { class, ... } = D.get vregs vr
  in
    D.set vregs vr
      { defs = [], use = [], class, t = RtRem, canFold = false }
  end

  fun changeIns ops idx ins =
  let
    fun f (SOME _, v) = (ins, v)
      | f (NONE, _) = raise Unreachable
  in
    D.update ops f idx
  end

  fun changeEl from to (x :: xs) acc =
    changeEl from to xs $ (if x = from then to else x) :: acc
    | changeEl _ _ [] acc = rev acc

  fun changeDef vregs vr from to =
  let
    val { defs, use, class, t, canFold } = D.get vregs vr
  in
    D.set vregs vr { defs = changeEl from to defs [], use, class, t,
    canFold }
  end

  fun changeUse vregs vr from to =
  let
    val { defs, use, class, t, canFold } = D.get vregs vr
  in
    D.set vregs vr { defs, use = changeEl from to use [], class, t,
      canFold }
  end

  fun singleDefUse vregs vr =
  let
    val { defs, use, ... } = D.get vregs vr
  in
    case (defs, use) of
      ([d], [_]) => SOME d
    | _ => NONE
  end

  fun fuseSet (Lctx { vregs, localVars, paramNum, ops, ... })
    (idx, (SOME (IrSet (rd, SaVReg rs)), _))
  =
    if getCS vregs rd <> getCS vregs rs then
      ()
    else (
      case singleDefUse vregs rs of
        NONE => ()
      | SOME d => (
        if d = idx - 1 andalso rs >= Vector.length localVars + paramNum
        then
          let
            val () = dprintf `"fusing instruction " I d `" with " I idx `"\n" %
            val () = removeVR vregs rs

            val ins = valOf o #1 $ D.get ops (idx - 1)
            val ir = changeDest rd ins

            val () = changeIns ops (idx - 1) (SOME ir)
            val () = changeIns ops idx NONE
          in
            changeDef vregs rd idx (idx - 1)
          end
        else
          ()
       )
     )
    | fuseSet _ _ = ()

  fun convCmpOp op' false = op'
    | convCmpOp op' true =
      case op' of
        Cmpeq => Cmpneq
      | Cmpneq => Cmpeq
      | Cmpul => Cmpuge
      | Cmpug => Cmpule
      | Cmpule => Cmpug
      | Cmpuge => Cmpul
      | Cmpsl => Cmpsge
      | Cmpsg => Cmpsle
      | Cmpsle => Cmpsg
      | Cmpsge => Cmpsl

  fun fuseJmpCommon (Lctx { ops, vregs, ... }) idx rs lid isRev =
    case singleDefUse vregs rs of
      NONE => ()
    | SOME d => (
      case #1 $ D.get ops d of
        SOME (IrCmp (op', _, r1, r2)) =>
          let
            val () = dprintf `"fusing instruction " I d `" with " I idx %
            val () = removeVR vregs rs
            val () = changeUse vregs r1 d idx
            val () = changeUse vregs r2 d idx
            val ins = IrJmpc (convCmpOp op' isRev, r1, r2, lid)
          in
            changeIns ops d NONE;
            changeIns ops idx (SOME ins)
          end
      | _ => ()
    )

  fun fuseJmpc C (idx, (ins, _)) =
    case ins of
      SOME (IrJnz (rs, lid)) => fuseJmpCommon C idx rs lid false
    | SOME (IrJz (rs, lid)) => fuseJmpCommon C idx rs lid true
    | _ => ()

  fun log2 0w0 = NONE
    | log2 w =
    let
      open Word

      fun log 0w0 = raise Unreachable
        | log 0w1 = 0w0
        | log w = 0w1 + log (>> (w, 0w1))

    in
      if andb (w, w - 0w1) = 0w0 then
        SOME $ log w
      else
        NONE
    end

  fun lowerMul' (C as Lctx { vregs, ops, ... }) idx (rd, rs1, rs2) =
  let
    val { class, ... } = D.get vregs rd
    val { t = t1, ... } = D.get vregs rs1
    val { t = t2, ... } = D.get vregs rs2

    fun tryLower rs v =
      case log2 v of
        SOME 0w0 => changeIns ops idx (SOME $ IrSet (rd, SaVReg rs))
      | SOME log =>
          let
            val log = newConst C class log
          in
            changeIns ops idx (SOME (IrShl (rd, rs, log)))
          end
      | NONE => ()
  in
    case (t1, t2) of
      (RtConst v, _) => tryLower rs2 v
    | (_, RtConst v) => tryLower rs1 v
    | _ => ()
  end

  fun lowerMul C (idx, (ins, _)) =
    case ins of
      SOME (IrMul t) => lowerMul' C idx t
    | SOME (IrIMul t) => lowerMul' C idx t
    | _ => ()

  fun lowerDiv (C as Lctx { vregs, ops, ... })
    (idx, (SOME (IrDiv (rd, rs1, rs2)), _))
  =
  let
    val { class, ... } = D.get vregs rd
    val { t = t1, ... } = D.get vregs rs1
    val { t = t2, ... } = D.get vregs rs2
  in
    case (t1, t2) of
      (_, RtConst c) => (
        case log2 c of
          NONE => ()
        | SOME 0w0 => changeIns ops idx (SOME $ IrSet (rd, SaVReg rs1))
        | SOME log =>
          let
            val log = newConst C class log
          in
            changeIns ops idx (SOME $ IrShr (rd, rs1, log))
          end
      )
    | _ => ()
  end
    | lowerDiv _ _ = ()

  fun peephole (C as Lctx { ops, ... }) = (
    D.appi (fuseSet C) ops;
    D.appi (fuseJmpc C) ops;
    D.appi (lowerMul C) ops;
    D.appi (lowerDiv C) ops
  )

  fun removeUnusedLabels (Lctx { ops, labels, ... }) =
  let
    val () = dprintf `"removing labels: " %
    fun rem (insId, (op', _)) =
      case op' of
        SOME (IrNopLabel lid) =>
        let
          val (_, usage) = D.get labels lid
        in
          if usage = 0 andalso lid <> 0 then (
            dprintf `"L" I lid `", " %;
            D.set ops insId (NONE, NONE)
          ) else
            ()
        end
      | _ => ()

    fun loop idx =
      if idx = D.length ops then
        ()
      else (
        rem (idx, D.get ops idx);
        loop (idx + 1)
      )
  in
    loop 0;
    dprintf `"\n" %
  end

  fun removeUnusedVars (Lctx { fname, vregs, localVars, ... }) =
  let
    fun die' idx =
    let
      val varName = #name $ Vector.sub (localVars, idx)
    in
      die 1 PP.? fname `": " PP.? varName
        `": variable is used uninitialized" %
    end
    fun loop idx =
      if idx = D.length vregs then
        ()
      else
        let
          val { defs, use, t, class, canFold } = D.get vregs idx
          val t =
            if t = RtReg andalso defs = [] then
              case use of
                [] => RtRem
              | _ =>
                if idx < Vector.length localVars then
                  die' idx
                else
                  raise Unreachable
            else
              t
        in
          D.set vregs idx { defs, use, t, class, canFold };
          loop (idx + 1)
        end
  in
    loop 0
  end

  fun translateFn ({ localVars, stmt, paramNum, name, ... }: P.funcInfo) =
  let
    val () = dprintf `"\n\nfunction " PP.? name `"\n\n" %

    val ctx = createLocalCtx name localVars paramNum
    val () = convStmt ctx stmt

    val () = ctxPutOp ctx (IrNopLabel 0)

    val () = printIns ctx
    (*
    val () = printVars ctx
    *)

    val () = dprintf `"\nconstant propagation\n\n" %
    val () = constPropagate ctx
    (*
    val () = printVars ctx
    val () = printIns ctx
    *)

    val () = dprintf `"\nmisc il optimizations\n\n" %

    val () = removeUnusedLabels ctx
    val () = removeUnusedVars ctx
    val () = peephole ctx

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

    (*
    val () = dprintf `"\nvariables\n\n" %
    val () = printVars ctx
    *)

    val Lctx { vregs, ops, labels, ft, ... } = ctx
  in
    Fi {
      name, localBound = Vector.length localVars + paramNum,
      t = !ft,
      paramNum, vregs, ops,
      labels = D.copy labels (fn (v, _) => v)
    }
  end

  fun createCtx ({ ext, glob, objsZI, objs, funcs, strlits }) debugFileName =
  let
    val () =
      case debugFileName of
        NONE => ()
      | SOME fname => debugFile := SOME (TextIO.openOut fname)

    val fis = List.map (fn func => translateFn func) funcs
  in
    Ctx { objs, objsZI, extSyms = ext, globSyms = glob,
      funcInfos = fis, strlits }
  end
end