Add strings to type system and parser/lexer

[snipe.git] / codegen / codegen.sml

(* L3 Compiler
 * Assembly code generator for fake x86 assembly
 * Author: Joshua Wise <jwise@andrew.cmu.edu>
 * Author: Chris Lu <czl@andrew.cmu.edu>
 *)

signature CODEGEN =
sig
  val codegen : Tree.stm list -> Blarg.insn list
end

structure Codegen :> CODEGEN = 
struct
  structure T = Tree
  structure TU = TreeUtils
  structure X = Blarg
  structure Tm = Temp

  (* hasfixed : T.exp -> bool
   * true iff the given expression has an hasfixed.
   *)
  fun hasfixed (T.CALL _) = true
    | hasfixed (T.BINOP(_, a, b)) = (hasfixed a) orelse (hasfixed b)
    | hasfixed (T.UNOP (_, a)) = hasfixed a
    | hasfixed (T.ALLOC(_)) = true
    | hasfixed (T.MEMORY (m)) = hasfixed m
    | hasfixed (T.STMVAR _) = true
    | hasfixed _ = false

  (* binophit : X.oper -> X.opc -> T.exp -> T.exp -> X.insn list *)
  (* binophit d oper e1 e2
   * generates instructions to achieve d <- e1 oper e2
   * oper should be something like X.ADD
   *)
  fun binophit d oper e1 e2 =
    let
      val t = X.TEMP (Tm.new "binop")
      val i1 = munch_exp d e1
      val i2 = munch_exp t e2
(*      val _ = print ("s1 = " ^ Tm.sfx s1 ^ ", s2 = " ^ Tm.sfx s2 ^ ", ") *)
(*      val _ = print ("rs = " ^ Tm.sfx rs ^ " from " ^ TU.Print.pp_exp e1 ^ " and " ^ TU.Print.pp_exp e2 ^ "\n") *)
    in
      [X.COMMENT "binophit" ] @ i1 @ i2 @ [X.INSN (X.AL, oper (d, t)), X.COMMENT "binophit done"]
    end
  
  (* cmphit : X.oper -> X.exp -> X.insn list
   * cmphit d ex 
   * generates instructions to set d based on the truth value of ex
   *)
  and cmphit d ex =
    let
      val (insns, pos, neg) = munch_cond ex
    in 
      insns @ [X.INSN (X.AL, X.MOVLIT (d, 0w0)), X.INSN (pos, X.MOVLIT (d, 0w1))]
    end

  (* munch_exp : prex86oper -> T.exp -> prex86insn list *)
  (* munch_exp d e
   * generates instructions to achieve d <- e
   * d must be TEMP(t) or REG(r)
   *)
  and munch_exp d (T.CONST n) = [X.INSN (X.AL, X.MOVLIT(d, Word.fromLarge n))]
    | munch_exp d (T.NULLPTR) = [X.INSN (X.AL, X.MOVLIT(d, 0w0))]
    | munch_exp d (T.TEMP(t)) = [X.INSN (X.AL, X.MOV(d, X.TEMP t))]
    | munch_exp d (T.ARG(0)) = [X.INSN (X.AL, X.MOV(d, X.REG X.R0))]
    | munch_exp d (T.ARG(1)) = [X.INSN (X.AL, X.MOV(d, X.REG X.R1))]
    | munch_exp d (T.ARG(2)) = [X.INSN (X.AL, X.MOV(d, X.REG X.R2))]
    | munch_exp d (T.ARG(3)) = [X.INSN (X.AL, X.MOV(d, X.REG X.R3))]
    | munch_exp d (T.ARG(t)) = [X.INSN (X.AL, X.MOV(d, X.STACKARG (t - 4)))]
    | munch_exp d (T.CALL(name, l)) = (* Scary demons live here. *)
        let
          val nargs = length l
          val nstack = if (nargs <= 4)
                       then 0
                       else nargs - 4
          val stackb = nstack * 1
          fun argdest 1 = X.REG X.R0
            | argdest 2 = X.REG X.R1
            | argdest 3 = X.REG X.R2
            | argdest 4 = X.REG X.R3
            | argdest n = raise ErrorMsg.InternalError "more than 4 args not supported yet" (*X.REL ((X.REG X.RSP, Tm.Quad), (X.CONST (Word32.fromInt (~(stackb - 8 * (n - 7)))), Tm.Quad), 0w1)*)

          val dests = List.tabulate (nargs, fn x => argdest (x+1))
          val hf = List.map hasfixed l
          val (d_hf, l_hf) = ListPair.unzip (ListPair.foldr
            (fn (a,b,c) => if b then a::c else c)
            nil
            (ListPair.zip (dests,l), hf)
          )
          val (d_nohf, l_nohf) = ListPair.unzip (ListPair.foldr
            (fn (a,b,c) => if b then c else a::c)
            nil
            (ListPair.zip (dests,l), hf)
          )
          val temps = List.map (fn _ => Temp.new ("arg")) l_hf
          val argevals_hf = List.map
            (fn (t,exp) => munch_exp (X.TEMP t) exp)
            (ListPair.zip (temps, l_hf))
          val argpushes = List.map
            (fn (dest, t) => [X.INSN (X.AL, X.MOV (dest, X.TEMP t))])
            (ListPair.zip (d_hf, temps))
          val argevals_nohf = List.map
            (fn (d,exp) => munch_exp d exp)
            (ListPair.zip (d_nohf, l_nohf))
          
          val t_stackb = Temp.new ("stackb")
          val t_target = Temp.new ("target")
        in
          List.concat argevals_hf @ 
          List.concat argpushes @
          List.concat argevals_nohf @
          [ X.INSN (X.AL, X.MOVLIT (X.TEMP t_stackb, Word.fromInt stackb)),
            X.INSN (X.AL, X.MOVSYM (X.TEMP t_target, name)),
            X.INSN (X.AL, X.SUB (X.REG X.SP, X.TEMP t_stackb)),
            X.INSN (X.AL, X.CALL (X.REG X.SP, X.TEMP t_target, nargs)),
            X.INSN (X.AL, X.ADD (X.REG X.SP, X.TEMP t_stackb)),
            X.INSN (X.AL, X.MOV (d, X.REG X.R0))]
        end
    (*| munch_exp d (T.BINOP(T.ADD, e1, T.CONST n)) = binophit_c d X.ADD e1 n
    | munch_exp d (T.BINOP(T.ADD, T.CONST n, e1)) = binophit_c d X.ADD e1 n
    | munch_exp d (T.BINOP(T.ADD, e1, T.TEMP t)) = binophit_t d X.ADD e1 t
    | munch_exp d (T.BINOP(T.ADD, T.TEMP t, e1)) = binophit_t d X.ADD e1 t*)
    | munch_exp d (T.BINOP(T.ADD, e1, e2)) = binophit d X.ADD e1 e2

    (*| munch_exp d (T.BINOP(T.SUB, e1, T.CONST n)) = binophit_c d X.SUB e1 n
    | munch_exp d (T.BINOP(T.SUB, e1, T.TEMP t)) = binophit_t d X.SUB e1 t*)
    | munch_exp d (T.BINOP(T.SUB, e1, e2)) = binophit d X.SUB e1 e2
    | munch_exp d (T.BINOP(T.MUL, e1, e2)) = munch_exp d (T.CALL (Symbol.symbol "__blarg_mul", [e1, e2]))
    | munch_exp d (T.BINOP(T.DIV, e1, e2)) = munch_exp d (T.CALL (Symbol.symbol "__blarg_div", [e1, e2]))
    | munch_exp d (T.BINOP(T.MOD, e1, e2)) = munch_exp d (T.CALL (Symbol.symbol "__blarg_mod", [e1, e2]))
    | munch_exp d (T.BINOP(T.LSH, e1, e2)) = binophit d X.SHL e1 e2
    | munch_exp d (T.BINOP(T.RSH, e1, e2)) = binophit d X.SHR e1 e2
    | munch_exp d (T.BINOP(T.BITAND, e1, e2)) = binophit d X.AND e1 e2
    | munch_exp d (T.BINOP(T.BITOR, e1, e2)) = munch_exp d (T.UNOP (T.BITNOT, T.BINOP (T.BITAND, T.UNOP (T.BITNOT, e1), T.UNOP (T.BITNOT, e2))))
    | munch_exp d (T.BINOP(T.BITXOR, e1, e2)) =
        munch_exp d (T.BINOP(T.BITOR, T.BINOP(T.BITAND, e1, T.UNOP(T.BITNOT, e2)),
                                      T.BINOP(T.BITAND, e2, T.UNOP(T.BITNOT, e1))))

    | munch_exp d (a as T.BINOP(T.LOGAND, e1, e2)) =
        let
          val (insn1, pos1, neg1) = munch_cond e1
          val (insn2, pos2, neg2) = munch_cond e2
          val l = Label.new ()
        in
          (insn1) @
          [X.INSN (X.AL, X.MOVLIT (d, 0w0)),
           X.INSN (neg1, X.MOVLBL (X.REG X.PC, l))] @
          (insn2) @
          [X.INSN (pos2, X.MOVLIT (d, 0w1)),
           X.LABEL l]
        end
    | munch_exp d (a as T.BINOP(T.LOGOR, e1, e2)) =
        let
          val (insn1, pos1, neg1) = munch_cond e1
          val (insn2, pos2, neg2) = munch_cond e2
          val t1 = X.TEMP (Tm.new "logand 1")
          val t2 = X.TEMP (Tm.new "logand 2")
          val l = Label.new ()
        in
          (insn1) @
          [X.INSN (X.AL, X.MOVLIT (d, 0w0)),
           X.INSN (pos1, X.MOVLIT (d, 0w1)),
           X.INSN (pos1, X.MOVLBL (X.REG X.PC, l))] @
          (insn2) @
          [X.INSN (pos2, X.MOVLIT (d, 0w1)),
           X.LABEL l]
        end
    | munch_exp d (a as T.BINOP(T.EQ, _, _)) = cmphit d a
    | munch_exp d (a as T.BINOP(T.NEQ, _, _)) = cmphit d a
    | munch_exp d (a as T.BINOP(T.LE, _, _)) = cmphit d a
    | munch_exp d (a as T.BINOP(T.LT, _, _)) = cmphit d a
    | munch_exp d (a as T.BINOP(T.GE, _, _)) = cmphit d a
    | munch_exp d (a as T.BINOP(T.GT, _, _)) = cmphit d a
    | munch_exp d (a as T.BINOP(T.BE, _, _)) = cmphit d a

    | munch_exp d (T.UNOP(T.NEG, e1)) =
        let
          val t = Temp.new "-val"
          val i = munch_exp (X.TEMP t) e1
        in
          (i) @
          [X.INSN (X.AL, X.MOVLIT (d, 0w0)),
           X.INSN (X.AL, X.SUB (d, X.TEMP t))]
        end
    | munch_exp d (T.UNOP(T.BITNOT, e1)) = let val i = munch_exp d e1 in i @ [X.INSN (X.AL, X.NOT (d, d))] end
    | munch_exp d (T.UNOP(T.BANG, e)) = 
        let
          val (insns, pos, neg) = munch_cond e
        in
          insns @
          [X.INSN (X.AL, X.MOVLIT (d, 0w0)),
           X.INSN (neg, X.MOVLIT (d, 0w1))]
        end
    | munch_exp d (T.MEMORY (e1)) =
        let
          val a = X.TEMP (Temp.new "addr")
          val i = munch_exp a e1
        in
          i @
          [X.INSN (X.AL, X.LDR (d, a))]
        end
    
    | munch_exp d (T.ALLOC(exp)) =
        let
          val t1 = Temp.new "alloc"
          val l1 = Label.new()
          val einsn = munch_exp (X.TEMP t1) exp
          val insns = munch_exp d (T.CALL (Symbol.symbol "calloc", [T.TEMP t1, T.CONST 0w1]))
        in
          einsn @ insns 
        end
(*    | munch_exp d (T.COND(c, T.CONST n1, T.CONST n2)) = let val (i,p,n) = munch_cond c in ((X.MOV (d, X.CONST n1))::i) @ [X.CMOVcc (p, d, X.CONST n2)] end *)
    | munch_exp d (T.COND(c,e1,e2)) =
        let
          val (insns, pos, neg) = munch_cond c
          val l1 = Label.new()
          val l2 = Label.new()
          val i1 = munch_exp d e1
          val i2 = munch_exp d e2
(*          val _ = print ("cond: size " ^ Tm.sfx s1 ^ " from " ^ TU.Print.pp_exp e1 ^ ", " ^ Tm.sfx s2 ^ " from " ^ TU.Print.pp_exp e2 ^ "\n") *)
        in
          insns @
          [X.INSN (neg, X.MOVLBL (X.REG X.PC, l1))] @
          i1 @
          [X.INSN (X.AL, X.MOVLBL (X.REG X.PC, l2)),
           X.LABEL l1] @
          i2 @
          [X.LABEL l2]
        end
    | munch_exp d (T.STMVAR (sl, e)) = let val i = munch_exp d e in List.concat (map munch_stm sl) @ i end

  and condhit e1 e2 (pos, neg) =
    let
      val t1 = X.TEMP (Temp.new ("var cond 1"))
      val t2 = X.TEMP (Temp.new ("var cond 2"))
      val i1 = munch_exp t1 e1
      val i2 = munch_exp t2 e2
    in
      (i1 @ i2 @ [X.INSN (X.AL, X.SUBS (t1, t2))], pos, neg)
    end

  (* munch_cond : T.exp -> X.insn list * X.cond * X.cond
   * munch_cond stm generates code to set flags, and then returns a conditional
   * to test if the expression was true and for if it was false.
   *)
  and munch_cond (T.UNOP (T.BANG, e)) =
        let
          val (insns, pos, neg) = munch_cond e
        in
          (insns, neg, pos)
        end
    | munch_cond (T.BINOP(T.NEQ, e1, e2)) = condhit e1 e2 (X.NE, X.EQ)
    | munch_cond (T.BINOP(T.EQ, e1, e2)) =  condhit e1 e2 (X.EQ, X.NE)
    | munch_cond (T.BINOP(T.LE, e1, e2)) =  condhit e1 e2 (X.LE, X.GT)
    | munch_cond (T.BINOP(T.LT, e1, e2)) =  condhit e1 e2 (X.LT, X.GE)
    | munch_cond (T.BINOP(T.GT, e1, e2)) =  condhit e1 e2 (X.GT, X.LE)
    | munch_cond (T.BINOP(T.GE, e1, e2)) =  condhit e1 e2 (X.GE, X.LT)

    | munch_cond (T.BINOP(T.BE, e1, e2)) = raise ErrorMsg.InternalError "memory safety not supported"

    | munch_cond e =
      let
        val t = X.TEMP (Temp.new ("munch c"))
        val i = munch_exp t e
      in
        (i @ [ X.INSN (X.AL, X.MOVS (t,t)) ], X.NE, X.EQ)
      end

  (* munch_lval : T.exp -> X.operand
   * Takes an expression that has been typechecked as being a valid lvalue and a location of a datum, and then returns an instruction list to store.
   *)
  and munch_lval (T.TEMP t) oper = [X.INSN (X.AL, X.MOV (X.TEMP t, oper))]
    | munch_lval (T.MEMORY m) oper = 
      let
        val t = X.TEMP (Tm.new "lv addr")
        val i = munch_exp t m
      in
        i @
        [X.INSN (X.AL, X.STO (t, oper))]
      end
    | munch_lval _ _ = raise ErrorMsg.InternalError "That wasn't really a valid lvalue..."

  (* munch_stm : T.stm -> X.insn list *)
  (* munch_stm stm generates code to execute stm *)
  and munch_stm (T.MOVE (T.TEMP t1, T.TEMP t2)) = [X.INSN (X.AL, X.MOV(X.TEMP t1, X.TEMP t2))]
    | munch_stm (T.MOVE (T.TEMP t, T.CONST n)) = [X.INSN (X.AL, X.MOVLIT(X.TEMP t, Word.fromLarge n))]
    | munch_stm (T.MOVE (T.TEMP t, a as T.ARG (an))) =
        let
          val i = munch_exp (X.TEMP t) a
        in
          i
        end
    | munch_stm (T.MOVE (T.TEMP t, a as T.CALL _)) = munch_exp (X.TEMP t) a
    | munch_stm (T.MOVE (a, e2)) =
        let
          val t = X.TEMP (Temp.new ("assign"))
          val i = munch_exp t e2
          val li = munch_lval a t
        in
          i @ li
        end
    | munch_stm (T.RETURN(e)) =
        let
          val t = X.TEMP (Temp.new ("retval"))
          val i = munch_exp t e
        in
          i @ [X.INSN (X.AL, X.MOV(X.REG X.R0, t)), X.INSN (X.AL, X.POP (X.REG X.SP, X.REG X.PC))]
        end
    | munch_stm (T.LABEL l) = [X.LABEL l]
    | munch_stm (T.JUMP l) = [X.INSN (X.AL, X.MOVLBL (X.REG X.PC, l))]
    | munch_stm (T.JUMPIFN(e, l)) =
       let
         val (insns, pos, neg) = munch_cond e 
       in
         insns @ [X.INSN (neg, X.MOVLBL (X.REG X.PC, l))]
       end
    | munch_stm (T.EFFECT exp) = let val t = X.TEMP (Temp.new "throwaway") val i = munch_exp t exp in i end

  fun codegen nil = nil
    | codegen (stm::stms) = munch_stm stm @ codegen stms
end