path: root/emit.fun

functor Emit(I: IL) = struct
  structure I = I

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

  val ip = I

  val file = ref NONE

  datatype reg =
    Rax | Rbx | Rcx | Rdx | Rsi | Rdi | Rbp | Rsp | R8 |
    R9 | R10 | R11 | R12 | R13 | R14 | R15

  datatype vConst = VConst of word | VAddrConst of int * word
  datatype vrType =
    VtConst of vConst | VtReg of reg | VtStack of int | VtUnk

  datatype affinity = AfHard of reg | AfSoft of int list | AfUnk

  val regs = [
    (R8, 0),
    (R9, 1),
    (R10, 2),
    (R11, 3),

    (Rbx, 4),
    (R12, 5),
    (R13, 6),
    (R14, 7),
    (R15, 8),

    (Rdi, 9),
    (Rsi, 10),
    (Rdx, 11),
    (Rcx, 12),

    (Rax, 13),
    (Rsp, 14),
    (Rbp, 15)
  ]

  val callerSavedRegs = 4
  val usedRegNum = 9

  val usedOverallRegNum = 13

  fun reg2idx reg =
    case List.find (fn (r, _) => r = reg) regs of
      NONE => raise Unreachable
    | SOME (_, idx) => idx

  fun idx2reg idx =
    case List.find (fn (_, i) => i = idx) regs of
      NONE => raise Unreachable
    | SOME (r, _) => r

  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

  local
    fun output s =
    let
      val outstream = valOf $ !file
    in
      TextIO.output (outstream, s)
    end

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

  fun fprintt g = fprint `"\t" g

  fun fprinttn g =
    fprintt (fn (a, _) => g (a, fn (_, out) => (Printf out `"\n" %)))

  fun handleBSS objsZI =
  let
    val () = fprint `"section .bss\n" %

    fun handleObj (id, _, t, _, _) =
    let
      val align = P.alignOfType t
      val size = P.sizeOfType t
    in
      fprinttn `"align\t" W align %;
      fprint PP.? id `":\tresb " W size `"\n" %
    end
  in
    List.app handleObj objsZI
  end

  fun dd size w =
  let
    val cmd =
      case size of
        0w1 => "db"
      | 0w2 => "dw"
      | 0w4 => "dd"
      | 0w8 => "dq"
      | _ => raise Unreachable
  in
    fprint `cmd `" " W w %
  end

  fun emitAggrLayout id =
  let
    val (_, size, layout) = D.get P.iniLayouts id

    val () = fprint `"\n" %

    fun getPadding offset t [] = size - (offset + P.sizeOfType t)
      | getPadding offset t ({ offset = offset', ... } :: _) =
        offset' - (offset + P.sizeOfType t)

    fun emitScalars ({ offset, t, value } :: tail) =
    let
      val () = fprint `"\t" %
      val () = dd (P.sizeOfType t) value
      val padding = getPadding offset t tail
    in
      if padding > 0w0 then
        fprint `"\n\tresb " W padding `"\n" %
      else
        fprint `"\n" %;
      emitScalars tail
    end
      | emitScalars [] = ()
  in
    emitScalars layout
  end

  fun handleData objs =
  let
    val () = fprint `"section .data\n" %

    fun emitLayout (id, _, t, ini, _) =
    let
      val align = P.alignOfType t
      val () = fprinttn `"align\t" W align %
      val () = fprint PP.? id `":" %
    in
      case ini of
        P.CiniLayout id => emitAggrLayout id
      | P.CiniExpr _ => raise Unreachable
    end
  in
    List.app emitLayout objs
  end

  fun handleStrlits strlits =
  let
    fun unique l =
    let
      val l = sort (op <=) l
      fun u [] acc = rev acc
        | u (x :: xs) [] = u xs [x]
        | u (x :: xs) (y :: ys) =
          if x = y then
            u xs (y :: ys)
          else
            u xs (x :: y :: ys)
    in
      u l []
    end

    fun emitStrlit id =
    let
      val symbols = PP.T.strlit2charList (PP.?? id)

      datatype strPart = SpStr of string | SpOrd of int

      open Char

      fun collectStr (c :: cs) acc =
        if isPrint c andalso (c = #" " orelse not (isSpace c)) then
          collectStr cs (c :: acc)
        else
          let
            val p = SpOrd (ord c)
            val l = collectStr cs []
          in
            if null acc then l else SpStr (implode $ rev acc) :: p :: l
          end
        | collectStr [] acc =
            if null acc then [] else [SpStr (implode $ rev acc)]

     fun printPart (SpStr s) out = Printf out `"'" `s `"'" %
       | printPart (SpOrd v) out = Printf out I v %

     fun printStr [] = ()
       | printStr (p :: ps) = (fprint A1 printPart p `", " %; printStr ps)

      val parts = collectStr symbols []
    in
      fprint `".S" I id `":\t" %;
      fprint `"db " %;
      List.app (fn p => fprint A1 printPart p `", " %) parts;
      fprint `"0\n" %
    end
  in
    fprint `"\n" %;
    List.app emitStrlit (unique strlits)
  end

  fun handleLocalIniLayouts () =
  let
    fun f (_, (true, _, _)) = ()
      | f (n, (false, _, _)) = (
        fprint `"\talign 16\n" %;
        fprint `".I" I n `":" %;
        emitAggrLayout n
      )
  in
    D.appi f P.iniLayouts
  end

  fun extendEnd (iStart, iEnd) ops labels =
  let
    fun loop idx iEnd =
      if idx = D.length ops then
        iEnd
      else
        let
          val (ins, _) = D.get ops idx
        in
          case ins of
            SOME (I.IrJmp lid) | SOME (I.IrJz (_, lid)) |
            SOME (I.IrJnz (_, lid)) =>
            let
              val ldest = valOf $ D.get labels lid

              val iEnd =
                if ldest > iStart andalso ldest < iEnd then
                  idx
                else
                  iEnd
            in
              loop (idx + 1) iEnd
            end
          | _ => loop (idx + 1) iEnd
        end
  in
    loop iEnd iEnd
  end

  fun computeIntLocal (s, e) firstDef ops labels =
  let
    val e = extendEnd (s, e) ops labels

    val (_, li) = D.get ops firstDef
  in
    case li of
      SOME (startL, endL) =>
      let
        val (startLoop, endLoop) =
          (valOf $ D.get labels startL, valOf $ D.get labels endL)

        val s = if s < startLoop then s else startLoop
        val e = if e > endLoop then e else endLoop
      in
        (s, e)
      end
    | _ => (s, e)
  end

  fun getBasicInt [] _ = raise Unreachable
    | getBasicInt defs [] = (List.last defs, hd defs + 1)
    | getBasicInt defs use =
    let
      val (firstDef, lastDef) = (List.last defs, hd defs)
      val (firstUse, lastUse) = (List.last use, hd use)

      val first = if firstDef < firstUse then firstDef else firstUse - 1
      val last = if lastDef < lastUse then lastUse else lastDef + 1
    in
      (first, last)
    end

  fun computeInt (I.Fi { vregs, ops, localBound, labels, ... }) var =
  let
    val { defs, use, ... } = D.get vregs var
    val (iStart, iEnd) = getBasicInt defs use

    val (iStart, iEnd) =
      if var < localBound then
        computeIntLocal (iStart, iEnd) (List.last defs) ops labels
      else
        (iStart, iEnd)
  in
    (var, iStart, iEnd)
  end

  fun computeInts F vars = List.map (computeInt F) vars

  fun printInts ints =
  let
    val () = dprintf `"\nsorted intervals:\n" %
    fun p (id, s, e) = dprintf `"id: %" I id `" {" I s `", " I e `"}\n" %
  in
    List.app p ints;
    dprintf `"\n" %
  end

  fun updAff arr idx aff =
  let
    val (_, vt) = Array.sub (arr, idx)
  in
    Array.update (arr, idx, (aff, vt))
  end

  datatype insAff = IaNone | IaHard of (int * reg) list
                  | IaSoft of int * int list

  fun parNum2reg pr =
    case pr of
      0 => Rdi
    | 1 => Rsi
    | 2 => Rdx
    | 3 => Rcx
    | 5 => R8
    | 6 => R9
    | _ => raise Unreachable

  fun getInsAff (SOME ins) =
  let
    fun tr (rd, rs1, rs2) = IaSoft (rd, [rs1, rs2])

    fun setAff (rd, I.SaVReg rs) = IaSoft (rd, [rs])
      | setAff _ = IaNone

    fun fcallAff args =
    let
      fun collect idx (arg :: args) acc =
        collect (idx + 1) args ((arg, parNum2reg idx) :: acc)
        | collect _ [] acc = rev acc
    in
      IaHard $ collect 0 args []
    end
  in
    case ins of
      I.IrSet p => setAff p
    | I.IrAdd t => tr t
    | I.IrSub t => tr t
    | I.IrMul t => tr t
    | I.IrIMul t => tr t
    | I.IrDiv t => tr t
    | I.IrIDiv t => tr t
    | I.IrMod t => tr t
    | I.IrIMod t => tr t
    | I.IrShl t => tr t
    | I.IrShr t => tr t
    | I.IrSar t => tr t
    | I.IrAnd t => tr t
    | I.IrOr t => tr t
    | I.IrXor t => tr t

    | I.IrCmp (_, _, _, _) => IaNone

    | I.IrExtZero _ | I.IrExtSign _
    | I.IrLoad _ | I.IrStore _ | I.IrJmp _
    | I.IrJz _ | I.IrJnz _ | I.IrNopLabel _
    | I.IrNop _ | I.IrRet _ | I.IrAlloc _
    | I.IrCopy _ => IaNone
    | I.IrFcall (_, _, args) => fcallAff args
  end
   | getInsAff NONE = IaNone

  fun updateSoftAff rinfo rd rss =
  let
    fun sort [r] = [r]
      | sort [rs1, rs2] = if rs1 < rs2 then [rs1, rs2] else [rs2, rs1]
      | sort _ = raise Unreachable

    fun isNotConst rv =
    let
      val (_, vt) = Array.sub (rinfo, rv)
    in
      case vt of
        VtConst _ => false
      | _ => true
    end

    val (aff, vt) = Array.sub (rinfo, rd)
    val rss = List.filter isNotConst $ sort rss

    fun insertSorted ins [] = ins
      | insertSorted [] acc = acc
      | insertSorted (x :: xs) (y :: ys) =
        if x < y then
          x :: insertSorted xs (y :: ys)
        else
          y :: insertSorted (x :: xs) ys

    val aff =
      case aff of
        AfUnk => AfSoft rss
      | AfSoft affs => AfSoft $ insertSorted rss affs
      | AfHard _ => aff
  in
    Array.update (rinfo, rd, (aff, vt))
  end

  fun updateHardAff rinfo hards =
  let
    fun f (rd, reg) =
    let
      val (aff, vt) = Array.sub (rinfo, rd)

      val aff =
        case aff of
          AfUnk | AfSoft _ => AfHard reg
        | AfHard _ => raise Unreachable
    in
      Array.update (rinfo, rd, (aff, vt))
    end
  in
    List.app f hards
  end

  fun compAffinity rinfo ops paramNum =
  let
    fun compParams idx =
      if idx = paramNum then
        ()
      else
        let
          val reg = parNum2reg idx
        in
          updAff rinfo idx (AfHard reg);
          compParams (idx + 1)
        end
    val () = compParams 0

    fun loop idx =
      if idx = D.length ops then
        ()
      else
        let
          val (ins, _) = D.get ops idx
        in
          case getInsAff ins of
            IaNone => ()
          | IaSoft (rd, rss) => updateSoftAff rinfo rd rss
          | IaHard hards => updateHardAff rinfo hards;
          loop (idx + 1)
        end
  in
    loop 0
  end

  fun prepareRegInfo paramNum ops vregs =
  let
    val rinfo = Array.array (D.length vregs, (AfUnk, VtUnk))

    val () = compAffinity rinfo ops paramNum;

    fun transfer idx acc =
      if idx = D.length vregs then
        rev acc
      else
      let
        val (aff, _) = Array.sub (rinfo, idx)

        val (vt, cand) =
          case #t $ D.get vregs idx of
            I.RtRem => (VtUnk, NONE)
          | I.RtConst w => (VtConst (VConst w), NONE)
          | I.RtAddrConst (id, w) =>
              (VtConst (VAddrConst (id, w)), NONE)
          | I.RtReg => (
            case aff of
              AfHard reg => (VtReg reg, NONE)
            | _ => (VtUnk, SOME idx)
          )
      in
        Array.update (rinfo, idx, (aff, vt));
        transfer (idx + 1) (if isSome cand then valOf cand :: acc else acc)
      end

    val toAlloc = transfer 0 []
  in
    (toAlloc, rinfo)
  end

  fun preg reg out =
  let
    val s =
      case reg of
        Rax => "rax"
      | Rbx => "rbx"
      | Rcx => "rcx"
      | Rdx => "rdx"
      | Rsi => "rsi"
      | Rdi => "rdi"
      | Rbp => "rbp"
      | Rsp => "rsp"
      | R8 => "r8"
      | R9 => "r9"
      | R10 => "r10"
      | R11 => "r11"
      | R12 => "r12"
      | R13 => "r13"
      | R14 => "r14"
      | R15 => "r15"
  in
    Printf out `s %
  end

  val Preg = fn z => bind A1 preg z

  fun affPrint rinfo =
  let
    fun pv idx out = Printf out `"%" I idx %

    fun p (idx, (aff, _)) =
    let
      val () = dprintf `"%" I idx %
    in
      case aff of
       AfUnk => dprintf `" = unk\n" %
     | AfHard reg => dprintf `" <- " Preg reg `"\n" %
     | AfSoft rss => dprintf `" <- " Plist pv rss (", ", true, 1) `"\n" %
    end
  in
    Array.appi p rinfo
  end

  fun updateI i = fn z =>
  let
    fun from rinfo active pool intervals stackOff  =
      { rinfo, active, pool, intervals, stackOff }
    fun to f { rinfo, active, pool, intervals, stackOff } =
      f rinfo active pool intervals stackOff
  in
    FRU.makeUpdate5 (from, from, to) i
  end z

  fun returnToPool pool reg =
  let
    val idx = reg2idx reg
  in
    Array.update (pool, idx, NONE)
  end

  fun expireOne { rinfo, active, pool, ... } (_, start, _) =
    case !active of
      [] => false
    | (j, startp, endp) :: acts =>
      if endp > start then
        false
      else
        let
          val (_, vt) = Array.sub (rinfo, j)
          val reg = case vt of VtReg reg => reg | _ => raise Unreachable

          val () = dprintf `"III!!! interval %"
              ip j `"(" ip startp `", " ip endp `") "
              `"with " Preg reg `" has expired\n" %
        in
          returnToPool pool reg;
          active := acts;
          true
        end

  fun expireOld (I as { active, ... }) int =
    let
      fun loop I =
        case expireOne I int of
          false => dprintf `"\n" %
        | true => loop I
    in
      case !active of
        [] => ()
      | _ => (dprintf `"\n" %; loop I)
    end

  fun addToActive int [] = [int]
    | addToActive (I as (_, _, e1)) (act :: acts) =
    if e1 < #3 act then
      (I :: act :: acts)
    else
      act :: addToActive I acts

  fun updReg arr idx reg =
  let
    val (aff, _) = Array.sub (arr, idx)
  in
    Array.update (arr, idx, (aff, reg))
  end

  fun getUser pool r = Array.sub (pool, reg2idx r)
  fun setUser pool u r = Array.update(pool, reg2idx r, SOME u)

  fun assignFirstReg poff { rinfo, pool, ... } vr =
  let
    fun loop idx =
      if idx = Array.length pool then
        raise Unreachable
      else
        let
          val user = Array.sub (pool, idx)
        in
          case user of
            SOME _ => loop (idx + 1)
          | NONE =>
            let
              val reg = idx2reg idx
              val () = setUser pool vr reg

              val () = dprintf R poff
                `"assigned (first) reg " Preg reg `" to %" ip vr `"\n" %
            in
              updReg rinfo vr (VtReg reg)
            end
        end
  in
    loop 0
  end

  fun freeRegList pool =
  let
    fun loop idx acc =
      if idx = Array.length pool then
        rev acc
      else
        case Array.sub (pool, idx) of
          NONE => loop (idx + 1) (idx2reg idx :: acc)
        | SOME _ => loop (idx + 1) acc
  in
    loop 0 []
  end

  fun getAffRegList rinfo affs =
  let
    fun loop [] acc = rev acc
      | loop (vr :: vrs) acc =
      let
        val (_, vt) = Array.sub (rinfo, vr)
      in
        case vt of
          VtReg r => loop vrs (r :: acc)
        | _ => loop vrs acc
      end
  in
    loop affs []
  end

  fun findCommonRegs l1 l2 =
  let
    val l1 = sort (fn (r1, r2) => reg2idx r1 <= reg2idx r2) l1
    val l2 = sort (fn (r1, r2) => reg2idx r1 <= reg2idx r2) l2

    fun intersection [] _ = []
      | intersection _ [] = []
      | intersection (x :: xs) (y :: ys) =
        case Int.compare (reg2idx x, reg2idx y) of
          LESS => intersection xs (y :: ys)
        | EQUAL => x :: intersection xs ys
        | GREATER => intersection (x :: xs) ys
  in
    intersection l1 l2
  end

  fun assignSoftReg poff affs (I as { rinfo, pool, ... }) vr =
  let
    val () = dprintf R poff
      `"trying to assign register (by affinity) to %" ip vr `"\n" %

    val regs = freeRegList pool
    val affRegs = getAffRegList rinfo affs
    val common = findCommonRegs regs affRegs

    val () = dprintf R (poff + 1)
      `"free registers: " Plist preg regs (", ", true, 0) `"\n" %
    val () = dprintf R (poff + 1)
      `"affinity registers: " Plist preg affRegs (", ", true, 0) `"\n" %
  in
    case common of
      [] =>
      let
        val () = dprintf R (poff + 1) `"affinity was not satisfied\n" %
      in
        assignFirstReg (poff + 2) I vr
      end
    | (reg :: _) =>
      let
      in
        updReg rinfo vr (VtReg reg);
        setUser pool vr reg;

        dprintf R (poff + 1)
          `"assigned (by affinity) reg " Preg reg `" to %" ip vr `"\n" %;
        dprintf R (poff + 1)
          `"free registers: " Plist preg (freeRegList pool) (", ", true, 0)
          `"\n" %
      end
  end

  fun putToStack poff { rinfo, stackOff, ... } vr =
  let
    val newStackOff = !stackOff - 8
    val () = dprintf R poff
      `"puting %" ip vr `" to stack: " ip newStackOff `"\n" %
  in
    updReg rinfo vr (VtStack newStackOff);
    stackOff := newStackOff
  end

  fun assignReg (I as { rinfo, ... }) (vr, _, _) =
  let
    val (aff, _) = Array.sub (rinfo, vr)
  in
    case aff of
      AfUnk => assignFirstReg 0 I vr
    | AfSoft affs => assignSoftReg 0 affs I vr
    | AfHard _ => raise Unreachable
  end

  fun getPool () = Array.array (usedRegNum, NONE)

  fun changeInActive active newInt oldVr =
  let
    val a = !active
    val a = List.filter (fn (v, _, _) => v <> oldVr) a
  in
    active := addToActive newInt a
  end

  fun userIdx pool vr =
  let
    fun loop idx =
      if idx = Array.length pool then
        raise Unreachable
      else
        case Array.sub (pool, idx) of
          SOME u =>
            if u = vr then
              idx
            else
              loop (idx + 1)
        | NONE => loop (idx + 1)
  in
    loop 0
  end

  fun spillAtInterval (I as { rinfo, active, pool, ... }) int =
  let
    val spill = List.last (!active)

    val vr = #1 int

    val () = dprintf `"SpillAtInt\n" %
    val () = dprintf R 0
      `"free registers: " Plist preg (freeRegList pool) (", ", true, 0) `"\n" %
  in
    if #3 spill > #3 int then
      let
        val () = dprintf `"spilling!!!\n" %
        val idx = userIdx pool (#1 spill)
        val reg = idx2reg idx
      in
        setUser pool vr reg;
        updReg rinfo vr (VtReg reg);
        putToStack 1 I (#1 spill);
        changeInActive active int (#1 spill)
      end
    else
      putToStack 0 I vr
  end

  fun linearscan rinfo ints stackOff =
  let
    fun incStart ((_, start1, _), (_, start2, _)) = start1 <= start2
    val ints = sort incStart ints

    val () = printInts ints

    fun loop { stackOff, ... } [] = stackOff
      | loop (I as { active, ... }) (int :: ints) =
      let
        val () = expireOld I int

        val () = dprintf `"inspecting interval %"
            ip (#1 int) `": (" ip (#2 int) `", " ip (#3 int) `")\n" %

        val () =
          if length (!active) < usedRegNum then
            let
              val () = assignReg I int
            in
              active := addToActive int (!active)
            end
          else
            spillAtInterval I int
      in
        loop I ints
      end
  in
    loop { active = ref [], pool = getPool (), rinfo,
      stackOff = ref stackOff } ints
  end

  fun pr is8 reg out =
  let
    fun old s =
    let
      val s = if is8 then s else "e" ^ String.extract (s, 1, NONE)
    in
      Printf out `s %
    end

    fun new s = Printf out `(if is8 then s else s ^ "d") %
  in
    case reg of
      Rcx => old "rcx"
    | Rsi => old "rsi"
    | Rdi => old "rdi"
    | R8 => new "r8"
    | R9 => new "r9"
    | R10 => new "r10"
    | R11 => new "r11"

    | Rbx => old "rbx"
    | R12 => new "r12"
    | R13 => new "r13"
    | R14 => new "r14"
    | R15 => new "r15"

    | Rax => old "rax"
    | Rdx => old "rdx"
    | Rsp => old "rsp"
    | Rbp => old "rbp"
  end

  fun printAllocVar rinfo v =
  let
    val () = dprintf `"%" I v `": " %
    val (_, vt) = Array.sub (rinfo, v)
  in
    case vt of
      VtStack off => dprintf `"stack " I off `"\n" %
    | VtReg reg => dprintf `"reg " A1 preg reg `"\n" %
    | VtConst _ | VtUnk => raise Unreachable
  end

  fun printAlloced rinfo toAlloc =
  let
    val () = dprintf `"\nallocated:\n\n" %
  in
    List.app (printAllocVar rinfo) toAlloc
  end

  fun getUsedRegs rinfo =
  let
    val regs = Array.array (usedOverallRegNum, false)

    fun loop idx =
      if idx = Array.length rinfo then
        ()
      else
        let
          val (_, vt) = Array.sub (rinfo, idx)
        in
          case vt of
            VtReg reg => Array.update (regs, reg2idx reg, true)
          | _ => ();
          loop (idx + 1)
        end
    val () = loop 0

    fun collect idx acc =
      if idx = usedRegNum then
        acc
      else
        if Array.sub (regs, idx) then
          collect (idx + 1) (idx2reg idx :: acc)
        else
          collect (idx + 1) acc
  in
    collect 0 []
  end

  fun getRegsToSave rinfo =
  let
    val regs = getUsedRegs rinfo
  in
    List.filter (fn r => reg2idx r >= callerSavedRegs) regs
  end

  fun initMap len =
  let
    open Array
    val map = array (len, array (callerSavedRegs, NONE))
    val i = ref 1
  in
    while !i < len do (
        update (map, !i, array (callerSavedRegs, NONE));
        i := !i + 1
    );
    map
  end

  fun computeMap len intervals rinfo =
  let
    val map = initMap len

    fun addInt (vr, startp, endp) =
      case #2 $ Array.sub (rinfo, vr) of
        VtReg reg =>
          let
            fun f idx =
              if reg2idx reg >= callerSavedRegs orelse idx = endp then
                ()
              else
                let
                  val row = Array.sub (map, idx)
                in
                  Array.update (row, reg2idx reg, SOME vr);
                  f (idx + 1)
                end
          in
            f (startp + 1)
          end
      | _ => ()
  in
    List.app addInt intervals;
    map
  end

  fun printMap map =
  let
    val () = dprintf `"Register map\n\n" %

    fun printHeader idx =
      if idx = callerSavedRegs then
        dprintf `"\n" %
      else
        let
          val reg = sprintf Preg (idx2reg idx) %
          val reg = if size reg = 3 then reg else " " ^ reg
        in
          dprintf `" " `reg `" " %;
          printHeader (idx + 1)
        end
    val () = dprintf `"      " %
    val () = printHeader 0

    fun printRow (idx, row) =
    let
      val () = dprintf Ip 4 idx `": " %

      fun loop idx =
        if idx = callerSavedRegs then
          dprintf `"\n" %
        else (
          case Array.sub (row, idx) of
            NONE => dprintf `"     " %
          | SOME vr =>
            let
              val n: string = sprintf I vr %
              val n =
                if size n < 3 then
                  implode (List.tabulate (3 - size n, fn _ => #" ")) ^ n
                else
                  n
            in
              dprintf `" " `n `" " %
            end;
          loop (idx + 1)
        )
    in
      loop 0
    end
  in
    Array.appi printRow map
  end

  fun resolveAlloc ops =
  let
    fun loop idx stackOffset =
      if idx = D.length ops then
        stackOffset
      else
        case D.get ops idx of
          (SOME (I.IrAlloc (v, size, _)), li) =>
          let
            val () =
              if Word.mod (size, 0w8) <> 0w0 then
                raise Unreachable
              else
                ()

            val stackOffset = stackOffset - Word.toInt size
            val negOffset = ~stackOffset
            val ins = (SOME $ I.IrAlloc (v, size, SOME negOffset), li)
          in
            D.set ops idx ins;
            loop (idx + 1) stackOffset
          end
        | (NONE, _) | (SOME _, _) => loop (idx + 1) stackOffset
  in
    loop 0 0
  end

  fun regAlloc (F as I.Fi { vregs, ops, paramNum, ... }) =
  let
    val stackOffset = resolveAlloc ops
    val (toAlloc, regInfo) = prepareRegInfo paramNum ops vregs
    val () = dprintf `"for alloc: " Plist i toAlloc (", ", true, 0) `"\n" %

    val () = affPrint regInfo

    val intervals = computeInts F toAlloc

    val stackOffset = linearscan regInfo intervals stackOffset
    val () = printAlloced regInfo toAlloc

    val regsToSave = getRegsToSave regInfo
    val () = dprintf
      `"registers to save: " Plist preg regsToSave (", ", true, 0) `"\n" %

    val regMap = computeMap (D.length ops) intervals regInfo
    val () = printMap regMap
  in
    { regsToSave, stackOffset = !stackOffset, regMap, ops,
      rinfo = regInfo, vregs }
  end

  fun emitPushPopReg op' reg = fprinttn `op' `" " Preg reg %

  fun emitPrologue ({ stackOffset, regsToSave, ... }) name =
  let
    val () = fprint PP.? name `":\n" %
  in
    List.app (emitPushPopReg "push") regsToSave;
    if stackOffset <> 0 then (
      fprinttn `"push rbp" %;
      fprinttn `"mov rbp, rsp" %;
      fprinttn `"sub rsp, " I (~ stackOffset) %
    ) else
      ()
  end

  fun emitEpilogue { regsToSave, stackOffset, ... } = (
    if stackOffset <> 0 then (
      fprinttn `"mov rsp, rbp" %;
      fprinttn `"pop rbp" %
    ) else
      ();
    List.app (emitPushPopReg "pop") (rev regsToSave);
    fprinttn `"ret" %
  )


  fun pm is8 off out =
    Printf out `(if is8 then "qword" else "dword") `" [rbp-" I off `"]"%

  fun getType { rinfo, vregs, ... } vr =
  let
    val (_, vt) = Array.sub (rinfo, vr)
    val { class, ... } = D.get vregs vr
  in
    (if class = I.VR8 then true else false, vt)
  end

  datatype template =
    RRR of reg * reg * reg |
    RRM of reg * reg * int |
    RRV of reg * reg * vConst |
    RMR of reg * int * reg |
    RMM of reg * int * int |
    RMV of reg * int * vConst |
    RVR of reg * vConst * reg |
    RVM of reg * vConst * int |

    MRR of int * reg * reg |
    MRM of int * reg * int |
    MRV of int * reg * vConst |
    MMR of int * int * reg |
    MMM of int * int * int |
    MMV of int * int * vConst |
    MVR of int * vConst * reg |
    MVM of int * vConst * int |

    RR of reg * reg |
    RM of reg * int |
    RV of reg * vConst |
    MR of int * reg |
    MM of int * int |
    MV of int * vConst

  fun pc is8 c out =
    case c of
      VConst w =>
        if is8 then
          Printf out W w %
        else
          Printf out W (P.extz w 0w4) %
    | VAddrConst (id, w) =>
      let
        val repr = PP.?? id
        val repr =
          if String.sub (repr, 0) = #"\"" then
            ".S" ^ Int.toString id
          else
            repr
      in
        if w = 0w0 then
          Printf out `repr %
        else
          Printf out `repr I.Pwc I.VR8 w %
      end

  fun wordFitsInNsx N w =
  let
    open Word
    val nm1 = fromInt N - 0w1
  in
    if w < << (0w1, nm1) then (* sign bit is zero *)
      true
    else
      let
        val mask = << (~ 0w1, nm1)
      in
        andb (mask, w) = mask (* sign bit and all bits after == 1 *)
      end
  end

  fun fitsInNsx N c =
    case c of
      VConst w => wordFitsInNsx N w
    | VAddrConst _ => false

  fun opRR is8 op' r1 r2 = sprintf `op' `" " A2 pr is8 r1 `", " A2 pr is8 r2 %
  fun opRM is8 op' r off = sprintf `op' `" " A2 pr is8 r `", " A2 pm is8 off %
  fun opMR is8 op' off r = sprintf `op' `" " A2 pm is8 off `", " A2 pr is8 r %

  fun opRV is8 op' r c =
    sprintf `op' `" " A2 pr is8 r `", " A2 pc is8 c %

  fun opMV is8 op' off c =
    sprintf `op' `" " A2 pm is8 off `", " A2 pc is8 c %

  fun movRR is8 r1 r2 = sprintf `"mov " A2 pr is8 r1 `", " A2 pr is8 r2 %
  fun movRM is8 r off = sprintf `"mov " A2 pr is8 r `", " A2 pm is8 off %
  fun movMR is8 off r = sprintf `"mov " A2 pm is8 off `", " A2 pr is8 r %

  fun isZeroConst (VConst 0w0) = true
    | isZeroConst _ = false

  fun xorIdiom r = sprintf `"xor " A2 pr false r `", " A2 pr false r %

  fun movRV is8 r c =
    if isZeroConst c then
      xorIdiom r
    else
      sprintf `"mov " A2 pr is8 r `", " A2 pc is8 c %
  fun movMV is8 off c =
  let
    val () = if not $ fitsInNsx 32 c then raise Unreachable else ()
  in
    opMV is8 "mov" off c
  end

  fun getTripleTemplate I (rd, rs1, rs2) comm fold =
  let
    val (is81, t1) = getType I rd
    val (is82, t2) = getType I rs1
    val (is83, t3) = getType I rs2

    val () =
      if is81 <> is82 orelse is82 <> is83 then raise Unreachable else ()

    val tmp =
      case (t1, t2, t3) of
        (VtReg r1, VtReg r2, VtReg r3) =>
            if r1 = r2 andalso fold then
              RR (r1, r3)
            else if r1 = r3 andalso comm andalso fold then
              RR (r1, r2)
            else
              RRR (r1, r2, r3)

      | (VtReg r1, VtReg r2, VtStack off) =>
          if r1 = r2 andalso fold then
            RM (r1, off)
          else
            RRM (r1, r2, off)
      | (VtReg r1, VtStack off, VtReg r2) =>
          if r1 = r2 andalso comm andalso fold then
            RM (r1, off)
          else
            RMR (r1, off, r2)

      | (VtReg r1, VtReg r2, VtConst c) =>
          if r1 = r2 andalso fold then
            RV (r1, c)
          else
            RRV (r1, r2, c)
      | (VtReg r1, VtConst c, VtReg r2) =>
          if r1 = r2 andalso comm andalso fold then
            RV (r1, c)
          else
            RVR (r1, c, r2)

      | (VtReg r, VtStack off1, VtStack off2) => RMM (r, off1, off2)

      | (VtReg r, VtStack off, VtConst c) => RMV (r, off, c)
      | (VtReg r, VtConst c, VtStack off) => RVM (r, c, off)

      | (VtStack off, VtReg r1, VtReg r2) => MRR (off, r1, r2)

      | (VtStack off1, VtReg r, VtStack off2) =>
          if off1 = off2 andalso comm andalso fold then
            MR (off1, r)
          else
            MRM (off1, r, off2)
      | (VtStack off1, VtStack off2, VtReg r) =>
          if off1 = off2 andalso fold then
            MR (off1, r)
          else
            MMR (off1, off2, r)

      | (VtStack off, VtReg r, VtConst c) => MRV (off, r, c)
      | (VtStack off, VtConst c, VtReg r) => MVR (off, c, r)

      | (VtStack off1, VtStack off2, VtStack off3) =>
          if off1 = off2 andalso fold then
            MM (off1, off3)
          else if off1 = off3 andalso comm andalso fold then
            MM (off1, off2)
          else
            MMM (off1, off2, off3)

      | (VtStack off1, VtStack off2, VtConst c) =>
          if off1 = off2 andalso fold then
            MV (off1, c)
          else
            MMV (off1, off2, c)
      | (VtStack off1, VtConst c, VtStack off2) =>
          if off1 = off2 andalso comm andalso fold then
            MV (off1, c)
          else
            MVM (off1, c, off2)
      | (VtConst _, _, _) | (VtUnk, _, _) | (_, VtUnk, _) |
        (_, _, VtUnk) | (_, VtConst _, VtConst _) => raise Unreachable
  in
    (is81, tmp)
  end

  fun getUtilMovs is8 =
  let
    val movRR = movRR is8
    val movRM = movRM is8
    val movMR = movMR is8
    val movRV = movRV is8
  in
    { movRR, movRM, movRV, movMR }
  end

  fun getUtilOps is8 op' =
  let
    val opRR = opRR is8 op'
    val opRM = opRM is8 op'
    val opRV = opRV is8 op'
    val opMR = opMR is8 op'
    val opMV = opMV is8 op'
  in
    { opRR, opRM, opRV, opMR, opMV }
  end

  fun emitGenComm I op' triple =
  let
    val (is8, tmp) = getTripleTemplate I triple true true
    val Pr = fn z => bind A1 (pr is8) z
    val { movRR, movRM, movMR, movRV } = getUtilMovs is8
    val { opRR, opRM, opMR, opRV, opMV } = getUtilOps is8 op'
  in
    case tmp of
      RRR (r1, r2, r3) =>
        if op' = "add" then
          [sprintf `"lea " Pr r1 `", [" Pr r2 `"+" Pr r3 `"]" % ]
        else
          [movRR r1 r2, opRR r1 r3]
    | RRM (r1, r2, off) | RMR (r1, off, r2) => [ movRR r1 r2, opRM r1 off ]
    | MMM (off1, off2, off3) =>
        [ movRM Rax off2, opRM Rax off3, movMR off1 Rax ]
    | MRM (off1, r, off2) | MMR (off1, off2, r) =>
        [ movMR off1 r, movRM Rax off2, opMR off1 Rax ]
    | MRR (off, r1, r2) => [ movMR off r1, opMR off r2 ]
    | RMM (r, off1, off2) => [ movRM r off1, opRM r off2 ]
    | RRV (r1, r2, c) | RVR (r1, c, r2) =>
      if fitsInNsx 32 c then
        [ movRR r1 r2, opRV r1 c ]
      else
        [ movRV r1 c, opRR r1 r2 ]
    | MMV (off1, off2, c) | MVM (off1, c, off2) =>
        [ movRV Rax c, opRM Rax off2, movMR off1 Rax ]
    | MRV (off, r, c) | MVR (off, c, r) =>
        [ movRV Rax c, opRR Rax r, movMR off Rax ]
    | RMV (r, off, c) | RVM (r, c, off) => [ movRV r c, opRM r off ]
    | MM (off1, off2) => [ movRM Rax off2, opMR off1 Rax ]
    | MR (off, r) => [ opMR off r ]
    | MV (off, c) =>
        if fitsInNsx 32 c then
          [ opMV off c ]
        else
          [ movRV Rax c, opMR off Rax ]
    | RR (r1, r2) => [ opRR r1 r2 ]
    | RM (r, off) => [ opRM r off ]
    | RV (r, c) =>
      if fitsInNsx 32 c then
        [ opRV r c ]
      else
        [ movRV Rax c, opRR r Rax ]
  end

  fun truncConst (VConst w) N = VConst $ P.extz w N
    | truncConst (C as (VAddrConst _)) _ = C

  fun emitShift I op' triple =
  let
    val (is8, tmp) = getTripleTemplate I triple false true
    val Pr = fn z => bind A1 (pr is8) z
    val { movRR, movRM, movMR, movRV } = getUtilMovs is8
    val opRV = opRV is8 op'
    val opRR = opRR is8 op'
    val opMV = opMV is8 op'

    fun shift3 r1 r2 r3 =
      sprintf `op' `"x " Pr r1 `", " Pr r2 `", " Pr r3 %

    fun shift3m r1 off r2 =
      sprintf `op' `"x " Pr r1 `", " A2 pm is8 off `", " Pr r2 %

    fun t v = truncConst v 0w1
  in
    case tmp of
      RRR (r1, r2, r3) => [shift3 r1 r2 r3]
    | RRM (r1, r2, off) => [movRM Rax off, shift3 r1 r2 Rax]
    | RRV (r1, r2, v) => [movRR r1 r2, opRV r1 (t v)]
    | RMR (r1, off, r2) => [shift3m r1 off r2]
    | RMM (r1, off1, off2) =>
        [movRM Rax off1, movRM Rdx off2, shift3 r1 Rax Rdx]
    | RMV (r, off, v) => [movRM r off, opRV r (t v)]
    | RVR (r1, v, r2) => [movRV Rax v, shift3 r1 Rax r2]
    | RVM (r, v, off) => [movRV Rax v, movRM Rdx off, shift3 r Rax Rdx]
    | MRR (off, r1, r2) => [shift3 Rax r1 r2, movMR off Rax]
    | MRM (off1, r1, off2) =>
        [movRM Rax off2, shift3 Rax r1 Rax, movMR off1 Rax]
    | MRV (off, r, v) => [movRV Rax (t v), shift3 Rax r Rax, movMR off Rax]
    | MMR (off1, off2, v) => [shift3m Rax off2 v, movMR off1 Rax]
    | MMM (off1, off2, off3) =>
        [movRM Rdx off3, shift3m Rax off2 Rdx, movMR off1 Rax]
    | MMV (off1, off2, v) =>
        [movRM Rax off2, opRV Rax (t v), movMR off1 Rax]
    | MVR (off1, v, r) => [movRV Rax v, opRR Rax r, movMR off1 Rax]
    | MVM (off1, v, off2) =>
        [movRV Rax v, movRM Rdx off2, opRR Rax Rdx, movMR off1 Rax]

    | RR (r1, r2) => [opRR r1 r2]
    | RM (r1, off) => [movRM Rax off, shift3 r1 r1 Rax]
    | RV (r1, v) => [opRV r1 (t v)]
    | MR (off, r) => [movRM Rax off, opRR Rax r, movMR off Rax]
    | MM (off1, off2) =>
        [movRM Rax off1, movRM Rdx off2, opRR Rax Rdx, movMR off1 Rax]
    | MV (off, v) => [opMV off (t v)]
  end

  fun wordIsZero w =
    case Word.compare (w, 0w0) of
       EQUAL => true
     | _ => false

  datatype cbv = CbvTrue | CbvFalse | CbvUnsure of int * word

  fun constBoolVal (VConst w) = if wordIsZero w then CbvFalse else CbvTrue
   | constBoolVal (VAddrConst (id, off)) =
    if wordIsZero off then
     CbvTrue
    else
     CbvUnsure (id, off)

  fun emitSub I triple =
  let
    val (is8, tmp) = getTripleTemplate I triple false true
    val { movRR, movRM, movRV, movMR } = getUtilMovs is8
    val { opRR, opRM, opRV, opMR, opMV } = getUtilOps is8 "sub"
  in
    case tmp of
      RRR (r1, r2, r3) => [movRR r1 r2, opRR r1 r3]
    | RRM (r1, r2, off) => [movRR r1 r2, opRM r1 off]
    | RRV (r1, r2, c) =>
      if fitsInNsx 32 c then
        [movRR r1 r2, opRV r1 c]
      else
        [movRR r1 r2, movRV Rax c, opRR r1 Rax]
    | RMR (r1, off, r2) => [movRM r1 off, opRR r1 r2]
    | RMM (r1, off1, off2) =>
        [movRM r1 off1, movRM Rax off2, opRR r1 Rax]
    | RMV (r1, off, v) =>
      if fitsInNsx 32 v then
        [movRM r1 off, opRV r1 v]
      else
        [movRM r1 off, movRV Rax v, opRR r1 Rax]
    | RVR (r1, v, r2) =>
      if r1 = r2 andalso isZeroConst v then
        [sprintf `"neg " A2 pr is8 r1 %]
      else
        [movRV r1 v, opRR r1 r2]
    | RVM (r, v, off) => [movRV r v, opRM r off]
    | MRR (off, r1, r2) => [movRR Rax r1, opRR Rax r2, movMR off Rax]
    | MRM (off1, r, off2) => [opRM r off2, movMR off1 r]
    | MRV (off, r, v) =>
        if fitsInNsx 32 v then
          [movRR Rax r, opRV Rax v, movMR off Rax]
        else
          [movRR Rax r, movRV Rdx v, opRR Rax Rdx, movMR off Rax]
    | MMR (off1, off2, r) => [movRM Rax off2, opRR Rax r, movMR off1 Rax]
    | MMM (off1, off2, off3) =>
        [movRM Rax off2, opRM Rax off3, movMR off1 Rax]
    | MMV (off1, off2, v) =>
        if fitsInNsx 32 v then
          [movRM Rax off2, opRV Rax v, movMR off1 Rax]
        else
          [movRM Rax off2, movRV Rdx v, opRR Rax Rdx, movMR off1 Rax]
    | MVM (off1, v, off2) =>
      if off1 = off2 andalso isZeroConst v then
        [sprintf `"neg " A2 pm is8 off1 %]
      else
        [movRV Rax v, opRM Rax off2, movMR off1 Rax]
    | MVR (off1, v, r) => [movRV Rax v, opRR Rax r, movMR off1 Rax]
    | RR (r1, r2) => [opRR r1 r2]
    | RM (r, off) => [opRM r off]
    | RV (r, v) =>
        if fitsInNsx 32 v then
          [opRV r v]
        else
          [movRV Rax v, opRR r Rax]
    | MR (off, r) => [opMR off r]
    | MM (off1, off2) => [movRM Rax off2, opMR off1 Rax]
    | MV (off, v) =>
        if fitsInNsx 32 v then
          [opMV off v]
        else
          [movRV Rax v, opMR off Rax]
  end

  fun mov is8 r1 r2 =
    case (r1, r2) of
      (VtReg r1, VtReg r2) => movRR is8 r1 r2
    | (VtReg r, VtStack off) => movRM is8 r off
    | (VtReg r, VtConst c) => movRV is8 r c
    | (VtStack off, VtReg r) => movMR is8 off r
    | _ => raise Unreachable

  fun prm is8 vr out =
    case vr of
      VtReg r => Printf out A2 pr is8 r %
    | VtStack off => Printf out A2 pm is8 off %
    | _ => raise Unreachable

  fun assertSize is81 is82 is83 =
    if is81 <> is82 orelse is82 <> is83 then
      raise Unreachable
    else
      ()

  fun emitDivMod I (rd, rs1, rs2) op' resInReg signExtend =
  let
    val (is81, t1) = getType I rd
    val (is82, t2) = getType I rs1
    val (is83, t3) = getType I rs2

    val () = assertSize is81 is82 is83

    val (first, second) =
      case (t2, t3) of
        (VtReg _ | VtStack _, _) => (t3, t2)
      | (_, VtReg _ | VtStack _) => (t2, t3)
      | (_, _) => raise Unreachable
  in
    [
      if signExtend then
        if is81 then "cqo" else "cdq"
      else
        "xor edx, edx",
      mov is81 (VtReg Rax) first,
      sprintf `op' `" " A2 prm is81 second %,
      mov is81 t1 (VtReg resInReg)
    ]
  end

  fun moveBackIfNeeded is8 dest vt =
    if dest = Rax then
      [mov is8 vt (VtReg Rax)]
    else
      []

  fun emitIMul I (vd, vs1, vs2) =
  let
    val (is81, t1) = getType I vd
    val (is82, t2) = getType I vs1
    val (is83, t3) = getType I vs2

    val () = assertSize is81 is82 is83

    datatype form = Reduced of vrType | Normal of vrType * vrType

    fun getReg vt =
      case vt of
        VtReg r => r
      | _ => Rax

    fun op2 () =
    let
      val form =
        if t3 = t1 then
          Reduced t2
        else if t2 = t1 then
          Reduced t3
       else
         Normal (t2, t3)

      val dest = getReg t1
      val main =
        case form of
          Reduced rs =>
            [ sprintf `"imul " A2 pr is81 dest `", " A2 prm is81 rs % ]
        | Normal (rs1, rs2) => [
            mov is81 (VtReg dest) rs1,
            sprintf `"imul " A2 pr is81 dest `", " A2 prm is81 rs2 %
          ]
    in
      main @ moveBackIfNeeded is81 dest t1
    end

    fun op3 rs1 c =
      if fitsInNsx 32 c then
        let
          val dest = getReg t1

          val main =
            [sprintf `"imul " A2 pr is81 dest `", "
              A2 prm is81 rs1 `", " A2 pc is81 c %]
        in
          main @ moveBackIfNeeded is81 dest t1
        end
      else
        op2 ()
  in
    case (t2, t3) of
      (VtConst c, _) => op3 t3 c
    | (_, VtConst c) => op3 t2 c
    | _ => op2 ()
  end

  fun regByAc ac r =
  let
    fun get16bitName r =
    let
      val repr = sprintf A2 pr false r %
    in
      if String.sub (repr, 0) = #"r" then
        repr ^ "w"
      else
        String.extract (repr, 1, NONE)
    end

    fun get8bitName r =
    let
      val repr = sprintf A2 pr false r %
    in
      if String.sub (repr, 0) = #"r" then
        let
          val len = size repr
        in
          String.substring (repr, 0, len - 1) ^ "b"
        end
      else
        case r of
          Rbx => "bl"
        | Rcx => "cl"
        | Rsi => "sil"
        | Rdi => "dil"
        | R8 | R9 | R10 | R11 | R12 | R13 | R14 | R15
        | Rbp | Rsp | Rax | Rdx => raise Unreachable
    end
  in
    case ac of
      I.AC8 => sprintf A2 pr true r %
    | I.AC4 => sprintf A2 pr false r %
    | I.AC2 => get16bitName r
    | I.AC1 => get8bitName r
  end

  fun pByAc ac vt out =
    case vt of
      VtReg r => Printf out `(regByAc ac r) %
    | VtStack off => Printf out I.Pac ac `" [rbp-" I off `"]" %
    | _ => raise Unreachable

  fun emitLoad I (vd, vs, ac) =
  let
    val (_, tl) = getType I vd
    val (_, tr) = getType I vs

    val (pre, src) =
      case tr of
        VtReg r => ([], r)
      | _ => ([mov true (VtReg Rdx) tr], Rdx)

    val dest =
      case tl of
        VtReg r => r
      | _ => Rax

    val main =
      [
        sprintf `"mov " `(regByAc ac dest) `", "
          I.Pac ac `" [" A2 pr true src `"]" %
      ]
  in
    pre @ main @ moveBackIfNeeded true dest tl
  end

  fun emitStore I (vd, vs, ac) =
  let
    val (_, tl) = getType I vd
    val (_, tr) = getType I vs
    val (pre, src) =
      case tr of
        VtReg r => ([], VtReg r)
      | VtConst c =>
          if fitsInNsx 32 c then
            ([], VtConst c)
          else
            ([mov true (VtReg Rdx) tr], VtReg Rdx)
      | _ => ([mov true (VtReg Rdx) tr], VtReg Rdx)


    val (mid, dest) =
      case tl of
        VtReg r => ([], r)
      | _ => ([mov true (VtReg Rax) tl], Rax)

    fun p vt out =
      case vt of
        VtReg reg => Printf out `(regByAc ac reg) %
      | VtConst c => Printf out A2 pc true c %
      | _ => raise Unreachable

    val main =
      [ sprintf `"mov " I.Pac ac `" [" A2 pr true dest `"], " A1 p src % ]
  in
    pre @ mid @ main
  end

  fun emitCmp E (cmpop, rd, rs1, rs2) =
  let
    val (_, td) = getType E rd
    val (is82, ts1) = getType E rs1
    val (is83, ts2) = getType E rs2

    val () = if is82 <> is83 then raise Unreachable else ()

    fun RMwithImm vt c =
      sprintf `"cmp " A2 prm is82 vt `", " A2 pc is82 c %

    fun RMwithR vt r =
      sprintf `"cmp " A2 prm is82 vt `", " A2 pr is82 r %

    fun RwithRM r vt = sprintf `"cmp " A2 pr is82 r `", " A2 prm is82 vt %

    val zeroing = sprintf `"xor " A2 pr false Rax `", " A2 pr false Rax %

    val (pre, main) =
      case (ts1, ts2) of
        (VtReg _ | VtStack _, VtConst c) =>
          if fitsInNsx 32 c then
            ([], RMwithImm ts1 c)
          else
            ([movRV is82 Rax c], RMwithR ts1 Rax)
      | (VtReg _ | VtStack _, VtReg r) => ([], RMwithR ts1 r)
      | (VtReg r, VtStack _) => ([], RwithRM r ts2)

      | (VtConst c, _) => ([movRV is82 Rax c], RwithRM Rax ts2)
      | (VtStack off, VtStack _) => ([movRM is82 Rax off], RwithRM Rax ts2)
      | (VtUnk, _) | (_, VtUnk) => raise Unreachable

    val flags =
      case cmpop of
        I.Cmpeq => "e"
      | I.Cmpneq => "ne"
      | I.Cmpul => "b"
      | I.Cmpug => "a"
      | I.Cmpule => "be"
      | I.Cmpuge => "ae"
      | I.Cmpsl => "l"
      | I.Cmpsg => "g"
      | I.Cmpsle => "le"
      | I.Cmpsge => "ge"

    val setPart = sprintf `"set" `flags `" al" %
  in
    [zeroing] @ pre @ [main] @ [setPart] @ [mov true td (VtReg Rax)]
  end

  fun emitExt E (vd, vs, from) op' =
  let
    val (is81, td) = getType E vd
    val (_, ts) = getType E vs

    val to = if is81 then I.AC8 else I.AC4
    val dest =
      case td of
        VtReg r => r
      | _ => Rax

    fun ext () =
      sprintf `op' `" " A2 pr is81 dest `", " A2 pByAc from ts %
    val main =
      case (to, from) of
        (I.AC4, I.AC1) | (I.AC4, I.AC2) => ext ()
      | (I.AC8, I.AC1) | (I.AC8, I.AC2) | (I.AC8, I.AC4) => ext ()

      | (I.AC4, I.AC4) | (I.AC4, I.AC8) => raise Unreachable
      | (I.AC8, I.AC8) => raise Unreachable

      | (I.AC1, _) | (I.AC2, _) => raise Unreachable
  in
    [main] @ moveBackIfNeeded is81 dest td
  end

  fun emitSet I (vrd, I.SaVReg vrs) =
  let
    val (is81, t1) = getType I vrd
    val (is82, t2) = getType I vrs
  in
    case (is81, t1, is82, t2) of
      (false, VtReg r1, false, VtReg r2)
    | (false, VtReg r1, true, VtReg r2)
    | (true, VtReg r1, true, VtReg r2) =>
        if r1 = r2 then
          []
        else
          [movRR true r1 r2]
    | (true, VtReg r1, false, VtReg r2) => [movRR false r1 r2]

    | (_, VtReg r, _, VtConst c) => [movRV true r c]
    | (_, VtReg r, _, VtStack off) => [movRM true r off]
    | (_, VtStack off, _, VtReg r) => [movMR true off r]
    | (_, VtStack off1, _, VtStack off2) =>
        [movRM true Rax off2, movMR true off1 Rax]

    | (_, VtStack off, _, VtConst c) =>
        if fitsInNsx 32 c then
          [movMV true off c]
        else
          [movRV true Rax c, movMR true off Rax]

    | (_, VtConst _, _, _) | (_, VtUnk, _, _) | (_, _, _, VtUnk) =>
        raise Unreachable
  end
   | emitSet I (vrd, I.SaConst w) =
   let
      val (_, t1) = getType I vrd
     val c = VConst w
   in
     case t1 of
       VtReg r => [movRV true r c]
     | VtStack off =>
         if fitsInNsx 32 c then
           [movMV true off c]
         else
           [movRV true Rax c, movMR true off Rax]
     | VtConst _ | VtUnk => raise Unreachable
   end
   | emitSet I (vrd, I.SaAddr p) =
   let
     val (_, t1) = getType I vrd
     val c = VAddrConst p
   in
     case t1 of
       VtReg r => [movRV true r c]
     | VtStack off => [movRV true Rax c, movMR true off Rax]
     | VtUnk | VtConst _ => raise Unreachable
   end

  fun emitAlloc E (vrd, _, SOME stackOffset) =
  let
    val (is8, t1) = getType E vrd
    val () = if not is8 then raise Unreachable else ()
  in
    case t1 of
      VtReg r =>
      [ sprintf `"lea " A2 pr true r `", [rsp-" I stackOffset `"]" % ]
    | _ => raise Unreachable
  end
    | emitAlloc _ (_, _, NONE) = raise Unreachable

  fun jmp lid = sprintf `"jmp .L" I lid %

  fun emitRet (E as { ops, ... }) vr idx =
  let
    val begin =
      case vr of
        NONE => []
      | SOME vr =>
        let
          val (is8, t) = getType E vr
        in
          case t of
            VtReg r => [movRR is8 Rax r]
          | VtStack off => [movRM is8 Rax off]
          | VtConst c => [movRV is8 Rax c]
          | VtUnk => raise Unreachable
        end
  in
    if idx < D.length ops - 2 then
      begin @ [ jmp 0 ]
    else
      begin
  end

  fun emitCopy E (vr, lid, size) =
  let
    val (is8, t) = getType E vr
    val () = if not is8 then raise Unreachable else ()
    val (prolog, destReg) =
      case t of
        VtReg r => ([], r)
      | VtStack off => ([movRM true Rdx off], Rdx)
      | VtConst _ | VtUnk => raise Unreachable

    fun loop off acc =
      if off = size then
        rev acc
      else
        let
          val from = sprintf `"mov rax, qword [.I" I lid `"+" W off `"]" %
          val to =
            sprintf `"mov [" A2 pr true destReg `"+" W off `"], rax" %
        in
          loop (off + 0w8) (to :: from :: acc)
        end
  in
    loop 0w0 prolog
  end

  fun emitJz E (vr, lid) isJz =
  let
    val (is8, vt) = getType E vr
    val jmp' = sprintf `"j" `(if isJz then "z" else "nz") `" .L" I lid %
  in
    case vt of
      VtReg reg =>
        [sprintf `"test " A2 pr is8 reg `", " A2 pr is8 reg %, jmp']
    | VtStack off => [sprintf `"cmp " A2 pm is8 off `", 0" %, jmp']
    | VtConst c => (
      case constBoolVal c of
        CbvTrue => [ jmp lid ]
      | CbvFalse => []
      | CbvUnsure (id, off) => [
          sprintf `"lea rax, [" PP.? id I.Pwc I.VR8 off `"]" %,
          sprintf `"test rax, 0" %,
          jmp'
      ]
    )
    | VtUnk => raise Unreachable
  end

  fun getRegsWeSave map idx =
  let
    val row = Array.sub (map, idx)

    fun loop j acc =
      if j = callerSavedRegs then
        rev acc
      else
        case Array.sub (row, j) of
          NONE => loop (j + 1) acc
        | SOME _ => loop (j + 1) (idx2reg j :: acc)
  in
    loop 0 []
  end

  fun prepFuncPrologue ({ stackOffset, regsToSave, regMap, ... }) idx =
  let
    val offFromCall = 8 + 8 * length regsToSave
    val offFromCall =
      if (stackOffset <> 0) then
        offFromCall + 8 (* push rbp *)
      else
        offFromCall
    val offFromCall = offFromCall + ~ stackOffset

    fun pushRegs regs = map (fn r => sprintf `"push " A2 pr true r %) regs
    val regsWeSave = getRegsWeSave regMap idx

    val registerPush: string list = pushRegs regsWeSave
    val offFromCall = offFromCall + 8 * length regsWeSave

    val tail =
      if offFromCall mod 16 <> 0 then
        [sprintf `"sub rsp, 8" %]
      else
        []
  in
    (not $ null tail, regsWeSave, registerPush @ tail)
  end

  fun emitFcall E (rd, rf, _) idx =
  let
    val (shouldAdd, regsToRestore, prologueSeq) = prepFuncPrologue E idx
    val (_, tf) = getType E rf

    val fcall =
      case tf of
        VtConst (C as VAddrConst _) => [sprintf `"call " A2 pc true C %]
      | VtConst (VConst _) => [mov true (VtReg Rax) tf, sprintf `"call rax" %]
      | VtReg _ | VtStack _ => [sprintf `"call " A2 prm true tf %]
      | VtUnk => raise Unreachable

    val regRestoration =
      let
        val pre =
          if shouldAdd then
            [sprintf `"add rsp, 8" %]
          else
            []
        val restoration =
          map (fn r => sprintf `"pop " A2 pr true r %) (rev regsToRestore)

      in
        pre @ restoration
      end
    val assignRes =
      if rd = ~1 then
        []
      else
        let
          val (is8, t) = getType E rd
        in
          [mov is8 t (VtReg Rax)]
        end
  in
    prologueSeq @ fcall @ regRestoration @ assignRes
  end

  fun emitOpStrList ins E idx =
    case ins of
      I.IrSet p => emitSet E p
    | I.IrAdd t => emitGenComm E "add" t
    | I.IrAnd t => emitGenComm E "and" t
    | I.IrOr t => emitGenComm E "or" t
    | I.IrXor t => emitGenComm E "xor" t

    | I.IrSub t => emitSub E t

    | I.IrShl t => emitShift E "shl" t
    | I.IrShr t => emitShift E "shr" t
    | I.IrSar t => emitShift E "sar" t

    | I.IrMul t => emitIMul E t
    | I.IrIMul t => emitIMul E t
    | I.IrDiv t => emitDivMod E t "div" Rax false
    | I.IrIDiv t => emitDivMod E t "idiv" Rax true
    | I.IrMod t => emitDivMod E t "div" Rdx false
    | I.IrIMod t => emitDivMod E t "idiv" Rdx true

    | I.IrCmp q => emitCmp E q

    | I.IrLoad t => emitLoad E t
    | I.IrStore t => emitStore E t

    | I.IrExtZero t => emitExt E t "movzx"
    | I.IrExtSign t => emitExt E t "movsx"

    | I.IrFcall t => emitFcall E t idx

    | I.IrAlloc t => emitAlloc E t
    | I.IrRet vr => emitRet E vr idx
    | I.IrCopy t => emitCopy E t
    | I.IrNopLabel lid => [ sprintf `".L" I lid `":" % ]
    | I.IrJmp lid => [ jmp lid ]
    | I.IrJz p => emitJz E p true
    | I.IrJnz p => emitJz E p false
    | I.IrNop comment => [sprintf  `"; " `comment %]

  fun emitIns (I as { ops, ... }) =
  let
    val outputBuf = Array.array (D.length ops, [])

    fun printFromBuf () =
    let
      fun printLine line = (
        if String.sub (line, 0) <> #"." then
          fprint `"\t" %
        else
          ();
        fprint `line `"\n" %
      )

    in
      Array.app
        (fn lines => List.app printLine lines)
        outputBuf
    end

    fun loop idx =
      if idx < 0 then
        printFromBuf ()
      else
        let
          val (ins, _) = D.get ops idx
        in
          case ins of
            SOME ins =>
            let
              val slist = emitOpStrList ins I idx
            in
              Array.update (outputBuf, idx, slist);
              loop (idx - 1)
            end
          | NONE => loop (idx - 1)
        end
  in
    loop (D.length ops - 1)
  end

  fun emitFunction info name = (
    fprint `"\nsection .text\n" %;
    emitPrologue info name;
    emitIns info;
    emitEpilogue info
  )

  fun emitFunc (F as I.Fi { name, ... }) =
  let
    val info = regAlloc F
  in
    emitFunction info name
  end

  fun openFile fname = file := SOME (TextIO.openOut fname)

  fun emit fname
    (I.Ctx { globSyms, extSyms, objsZI, objs, strlits, funcInfos, ... })
    debugFileName
  =
  let

    val () =
      case debugFileName of
        NONE => ()
      | SOME fname => debugFile := SOME (TextIO.openOut fname)
    val () = openFile fname

    val () = List.app (fn gs => fprint `"global " PP.? gs `"\n" %) globSyms
    val () = List.app (fn es => fprint `"extern " PP.? es `"\n" %) extSyms

    val () = handleBSS objsZI
    val () = handleData objs
    val () = handleStrlits strlits
    val () = handleLocalIniLayouts ()

    val () = List.app emitFunc funcInfos
  in
    ()
  end
end