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 file = ref NONE

  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 f id = fprint `".S" I id `":\tdb " `(PP.?? id) `", 0\n" %
  in
    fprint `"\n" %;
    List.app f 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 getVarsForAlloc vregs =
  let
    fun loop idx acc =
      if idx = D.length vregs then
        rev acc
      else
        let
          val { t, ... } = D.get vregs idx
        in
          if t = I.RtReg then
            loop (idx + 1) (idx :: acc)
          else
            loop (idx + 1) acc
        end
  in
    loop 0 []
  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) ops labels =
  let
    val e = extendEnd (s, e) ops labels
  in
    (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) ops labels
      else
        (iStart, iEnd)
  in
    (var, iStart, iEnd)
  end

  fun computeInts (F as I.Fi { vregs, ... }) vars =
    List.map (computeInt F) vars

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


  fun regAlloc (F as I.Fi { vregs, labels, ... }) =
  let
    val varsForAlloc = getVarsForAlloc vregs
    val () = printfn `"for alloc: " Plist i varsForAlloc (", ", true, 0) %

    val intervals = computeInts F varsForAlloc

    val () = printInts intervals
  in
    raise Unimplemented
  end

  fun emitFunc (F as I.Fi { vregs, ... }) =
  let
    val () = regAlloc F vregs
  in
    raise Unimplemented
  end

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

  fun emit fname
    (I.Ctx { globSyms, extSyms, objsZI, objs, strlits, funcInfos, ... }) =
  let
    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