[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
      i1 @ i2 @ [X.INSN (X.AL, oper (d, t))]
    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, _, _)) = raise ErrorMsg.InternalError "MUL does not exist on blargcpu"
    | munch_exp d (T.BINOP(T.DIV, _, _)) = raise ErrorMsg.InternalError "DIV does not exist on blargcpu"
    | munch_exp d (T.BINOP(T.MOD, _, _)) = raise ErrorMsg.InternalError "MOD does not exist on blargcpu"
    | 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 neq 1"))
      val t2 = X.TEMP (Temp.new ("var neq 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 (oper, X.TEMP t))]
    | 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
Commit	Line	Data
6ade8b0a	1	(* L3 Compiler
0a24e44d JW	2	* Assembly code generator for fake x86 assembly
	3	* Author: Joshua Wise <jwise@andrew.cmu.edu>
	4	* Author: Chris Lu <czl@andrew.cmu.edu>
12aa4087 JW	5	*)
	6
	7	signature CODEGEN =
	8	sig
075222c7	9	val codegen : Tree.stm list -> Blarg.insn list
12aa4087 JW	10	end
	11
	12	structure Codegen :> CODEGEN =
	13	struct
	14	structure T = Tree
5c79bb68	15	structure TU = TreeUtils
075222c7	16	structure X = Blarg
5c79bb68	17	structure Tm = Temp
6ade8b0a JW	18
6ade8b0a JW	19	(* hasfixed : T.exp -> bool
5c79bb68	20	* true iff the given expression has an hasfixed.
6ade8b0a	21	*)
075222c7	22	fun hasfixed (T.CALL _) = true
6ade8b0a JW	23	\| hasfixed (T.BINOP(_, a, b)) = (hasfixed a) orelse (hasfixed b)
6ade8b0a JW	24	\| hasfixed (T.UNOP (_, a)) = hasfixed a
1144856b	25	\| hasfixed (T.ALLOC(_)) = true
075222c7	26	\| hasfixed (T.MEMORY (m)) = hasfixed m
5c79bb68	27	\| hasfixed (T.STMVAR _) = true
6ade8b0a JW	28	\| hasfixed _ = false
6ade8b0a JW	29
075222c7 JW	30	(* binophit : X.oper -> X.opc -> T.exp -> T.exp -> X.insn list *)
	31	(* binophit d oper e1 e2
	32	* generates instructions to achieve d <- e1 oper e2
	33	* oper should be something like X.ADD
	34	*)
	35	fun binophit d oper e1 e2 =
5c79bb68	36	let
075222c7 JW	37	val t = X.TEMP (Tm.new "binop")
	38	val i1 = munch_exp d e1
	39	val i2 = munch_exp t e2
5c79bb68	40	(* val _ = print ("s1 = " ^ Tm.sfx s1 ^ ", s2 = " ^ Tm.sfx s2 ^ ", ") *)
5c79bb68 JW	41	(* val _ = print ("rs = " ^ Tm.sfx rs ^ " from " ^ TU.Print.pp_exp e1 ^ " and " ^ TU.Print.pp_exp e2 ^ "\n") *)
5c79bb68 JW	42	in
075222c7 JW	43	i1 @ i2 @ [X.INSN (X.AL, oper (d, t))]
	44	end
	45
	46	(* cmphit : X.oper -> X.exp -> X.insn list
	47	* cmphit d ex
	48	* generates instructions to set d based on the truth value of ex
	49	*)
	50	and cmphit d ex =
	51	let
	52	val (insns, pos, neg) = munch_cond ex
	53	in
	54	insns @ [X.INSN (X.AL, X.MOVLIT (d, 0w0)), X.INSN (pos, X.MOVLIT (d, 0w1))]
5c79bb68	55	end
5c79bb68	56
12aa4087 JW	57	(* munch_exp : prex86oper -> T.exp -> prex86insn list *)
	58	(* munch_exp d e
	59	* generates instructions to achieve d <- e
	60	* d must be TEMP(t) or REG(r)
	61	*)
075222c7 JW	62	and munch_exp d (T.CONST n) = [X.INSN (X.AL, X.MOVLIT(d, Word.fromLarge n))]
	63	\| munch_exp d (T.NULLPTR) = [X.INSN (X.AL, X.MOVLIT(d, 0w0))]
	64	\| munch_exp d (T.TEMP(t)) = [X.INSN (X.AL, X.MOV(d, X.TEMP t))]
	65	\| munch_exp d (T.ARG(0)) = [X.INSN (X.AL, X.MOV(d, X.REG X.R0))]
	66	\| munch_exp d (T.ARG(1)) = [X.INSN (X.AL, X.MOV(d, X.REG X.R1))]
	67	\| munch_exp d (T.ARG(2)) = [X.INSN (X.AL, X.MOV(d, X.REG X.R2))]
	68	\| munch_exp d (T.ARG(3)) = [X.INSN (X.AL, X.MOV(d, X.REG X.R3))]
	69	\| munch_exp d (T.ARG(t)) = [X.INSN (X.AL, X.MOV(d, X.STACKARG (t - 4)))]
	70	\| munch_exp d (T.CALL(name, l)) = (* Scary demons live here. *)
6ade8b0a JW	71	let
6ade8b0a JW	72	val nargs = length l
075222c7	73	val nstack = if (nargs <= 4)
6ade8b0a	74	then 0
075222c7 JW	75	else nargs - 4
	76	val stackb = nstack * 1
	77	fun argdest 1 = X.REG X.R0
	78	\| argdest 2 = X.REG X.R1
	79	\| argdest 3 = X.REG X.R2
	80	\| argdest 4 = X.REG X.R3
	81	\| 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)*)
6ade8b0a JW	82
6ade8b0a JW	83	val dests = List.tabulate (nargs, fn x => argdest (x+1))
075222c7	84	val hf = List.map hasfixed l
1144856b	85	val (d_hf, l_hf) = ListPair.unzip (ListPair.foldr
6ade8b0a JW	86	(fn (a,b,c) => if b then a::c else c)
	87	nil
	88	(ListPair.zip (dests,l), hf)
	89	)
1144856b	90	val (d_nohf, l_nohf) = ListPair.unzip (ListPair.foldr
6ade8b0a JW	91	(fn (a,b,c) => if b then c else a::c)
	92	nil
	93	(ListPair.zip (dests,l), hf)
	94	)
075222c7 JW	95	val temps = List.map (fn _ => Temp.new ("arg")) l_hf
	96	val argevals_hf = List.map
	97	(fn (t,exp) => munch_exp (X.TEMP t) exp)
	98	(ListPair.zip (temps, l_hf))
6ade8b0a	99	val argpushes = List.map
075222c7	100	(fn (dest, t) => [X.INSN (X.AL, X.MOV (dest, X.TEMP t))])
6ade8b0a	101	(ListPair.zip (d_hf, temps))
075222c7 JW	102	val argevals_nohf = List.map
	103	(fn (d,exp) => munch_exp d exp)
	104	(ListPair.zip (d_nohf, l_nohf))
	105
	106	val t_stackb = Temp.new ("stackb")
	107	val t_target = Temp.new ("target")
6ade8b0a	108	in
075222c7 JW	109	List.concat argevals_hf @
	110	List.concat argpushes @
	111	List.concat argevals_nohf @
	112	[ X.INSN (X.AL, X.MOVLIT (X.TEMP t_stackb, Word.fromInt stackb)),
	113	X.INSN (X.AL, X.MOVSYM (X.TEMP t_target, name)),
	114	X.INSN (X.AL, X.SUB (X.REG X.SP, X.TEMP t_stackb)),
	115	X.INSN (X.AL, X.CALL (X.REG X.SP, X.TEMP t_target, nargs)),
	116	X.INSN (X.AL, X.ADD (X.REG X.SP, X.TEMP t_stackb)),
	117	X.INSN (X.AL, X.MOV (d, X.REG X.R0))]
0a24e44d	118	end
075222c7	119	(*\| munch_exp d (T.BINOP(T.ADD, e1, T.CONST n)) = binophit_c d X.ADD e1 n
5c79bb68 JW	120	\| munch_exp d (T.BINOP(T.ADD, T.CONST n, e1)) = binophit_c d X.ADD e1 n
5c79bb68 JW	121	\| munch_exp d (T.BINOP(T.ADD, e1, T.TEMP t)) = binophit_t d X.ADD e1 t
075222c7	122	\| munch_exp d (T.BINOP(T.ADD, T.TEMP t, e1)) = binophit_t d X.ADD e1 t*)
5c79bb68 JW	123	\| munch_exp d (T.BINOP(T.ADD, e1, e2)) = binophit d X.ADD e1 e2
5c79bb68 JW	124
075222c7 JW	125	(*\| munch_exp d (T.BINOP(T.SUB, e1, T.CONST n)) = binophit_c d X.SUB e1 n
075222c7 JW	126	\| munch_exp d (T.BINOP(T.SUB, e1, T.TEMP t)) = binophit_t d X.SUB e1 t*)
5c79bb68	127	\| munch_exp d (T.BINOP(T.SUB, e1, e2)) = binophit d X.SUB e1 e2
075222c7 JW	128	\| munch_exp d (T.BINOP(T.MUL, _, _)) = raise ErrorMsg.InternalError "MUL does not exist on blargcpu"
	129	\| munch_exp d (T.BINOP(T.DIV, _, _)) = raise ErrorMsg.InternalError "DIV does not exist on blargcpu"
	130	\| munch_exp d (T.BINOP(T.MOD, _, _)) = raise ErrorMsg.InternalError "MOD does not exist on blargcpu"
	131	\| munch_exp d (T.BINOP(T.LSH, e1, e2)) = binophit d X.SHL e1 e2
	132	\| munch_exp d (T.BINOP(T.RSH, e1, e2)) = binophit d X.SHR e1 e2
5c79bb68	133	\| munch_exp d (T.BINOP(T.BITAND, e1, e2)) = binophit d X.AND e1 e2
075222c7 JW	134	\| 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))))
	135	\| munch_exp d (T.BINOP(T.BITXOR, e1, e2)) =
	136	munch_exp d (T.BINOP(T.BITOR, T.BINOP(T.BITAND, e1, T.UNOP(T.BITNOT, e2)),
	137	T.BINOP(T.BITAND, e2, T.UNOP(T.BITNOT, e1))))
5c79bb68	138
6ade8b0a	139	\| munch_exp d (a as T.BINOP(T.LOGAND, e1, e2)) =
0a24e44d	140	let
6ade8b0a JW	141	val (insn1, pos1, neg1) = munch_cond e1
6ade8b0a JW	142	val (insn2, pos2, neg2) = munch_cond e2
6ade8b0a	143	val l = Label.new ()
0a24e44d	144	in
075222c7 JW	145	(insn1) @
	146	[X.INSN (X.AL, X.MOVLIT (d, 0w0)),
	147	X.INSN (neg1, X.MOVLBL (X.REG X.PC, l))] @
	148	(insn2) @
	149	[X.INSN (pos2, X.MOVLIT (d, 0w1)),
	150	X.LABEL l]
0a24e44d	151	end
6ade8b0a	152	\| munch_exp d (a as T.BINOP(T.LOGOR, e1, e2)) =
0a24e44d	153	let
6ade8b0a JW	154	val (insn1, pos1, neg1) = munch_cond e1
6ade8b0a JW	155	val (insn2, pos2, neg2) = munch_cond e2
075222c7 JW	156	val t1 = X.TEMP (Tm.new "logand 1")
075222c7 JW	157	val t2 = X.TEMP (Tm.new "logand 2")
6ade8b0a	158	val l = Label.new ()
0a24e44d	159	in
075222c7 JW	160	(insn1) @
	161	[X.INSN (X.AL, X.MOVLIT (d, 0w0)),
	162	X.INSN (pos1, X.MOVLIT (d, 0w1)),
	163	X.INSN (pos1, X.MOVLBL (X.REG X.PC, l))] @
	164	(insn2) @
	165	[X.INSN (pos2, X.MOVLIT (d, 0w1)),
	166	X.LABEL l]
0a24e44d	167	end
5c79bb68 JW	168	\| munch_exp d (a as T.BINOP(T.EQ, _, _)) = cmphit d a
	169	\| munch_exp d (a as T.BINOP(T.NEQ, _, _)) = cmphit d a
	170	\| munch_exp d (a as T.BINOP(T.LE, _, _)) = cmphit d a
	171	\| munch_exp d (a as T.BINOP(T.LT, _, _)) = cmphit d a
	172	\| munch_exp d (a as T.BINOP(T.GE, _, _)) = cmphit d a
	173	\| munch_exp d (a as T.BINOP(T.GT, _, _)) = cmphit d a
	174	\| munch_exp d (a as T.BINOP(T.BE, _, _)) = cmphit d a
	175
075222c7 JW	176	\| munch_exp d (T.UNOP(T.NEG, e1)) =
	177	let
	178	val t = Temp.new "-val"
	179	val i = munch_exp (X.TEMP t) e1
	180	in
	181	(i) @
	182	[X.INSN (X.AL, X.MOVLIT (d, 0w0)),
	183	X.INSN (X.AL, X.SUB (d, X.TEMP t))]
	184	end
	185	\| 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
6ade8b0a	186	\| munch_exp d (T.UNOP(T.BANG, e)) =
0a24e44d	187	let
6ade8b0a	188	val (insns, pos, neg) = munch_cond e
0a24e44d	189	in
075222c7 JW	190	insns @
	191	[X.INSN (X.AL, X.MOVLIT (d, 0w0)),
	192	X.INSN (neg, X.MOVLIT (d, 0w1))]
5c79bb68	193	end
075222c7	194	\| munch_exp d (T.MEMORY (e1)) =
5c79bb68	195	let
075222c7 JW	196	val a = X.TEMP (Temp.new "addr")
075222c7 JW	197	val i = munch_exp a e1
5c79bb68	198	in
075222c7 JW	199	i @
075222c7 JW	200	[X.INSN (X.AL, X.LDR (d, a))]
0a24e44d	201	end
075222c7	202
5c79bb68	203	\| munch_exp d (T.ALLOC(exp)) =
1144856b	204	let
075222c7	205	val t1 = Temp.new "alloc"
5c79bb68	206	val l1 = Label.new()
075222c7 JW	207	val einsn = munch_exp (X.TEMP t1) exp
075222c7 JW	208	val insns = munch_exp d (T.CALL (Symbol.symbol "calloc", [T.TEMP t1, T.CONST 0w1]))
1144856b	209	in
075222c7	210	einsn @ insns
1144856b	211	end
5c79bb68 JW	212	(* \| 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 *)
	213	\| munch_exp d (T.COND(c,e1,e2)) =
	214	let
	215	val (insns, pos, neg) = munch_cond c
	216	val l1 = Label.new()
	217	val l2 = Label.new()
075222c7 JW	218	val i1 = munch_exp d e1
075222c7 JW	219	val i2 = munch_exp d e2
5c79bb68 JW	220	(* val _ = print ("cond: size " ^ Tm.sfx s1 ^ " from " ^ TU.Print.pp_exp e1 ^ ", " ^ Tm.sfx s2 ^ " from " ^ TU.Print.pp_exp e2 ^ "\n") *)
5c79bb68 JW	221	in
075222c7 JW	222	insns @
	223	[X.INSN (neg, X.MOVLBL (X.REG X.PC, l1))] @
	224	i1 @
	225	[X.INSN (X.AL, X.MOVLBL (X.REG X.PC, l2)),
	226	X.LABEL l1] @
	227	i2 @
	228	[X.LABEL l2]
5c79bb68	229	end
075222c7	230	\| munch_exp d (T.STMVAR (sl, e)) = let val i = munch_exp d e in List.concat (map munch_stm sl) @ i end
5c79bb68	231
5c79bb68 JW	232	and condhit e1 e2 (pos, neg) =
5c79bb68 JW	233	let
075222c7 JW	234	val t1 = X.TEMP (Temp.new ("var neq 1"))
	235	val t2 = X.TEMP (Temp.new ("var neq 2"))
	236	val i1 = munch_exp t1 e1
	237	val i2 = munch_exp t2 e2
5c79bb68	238	in
075222c7	239	(i1 @ i2 @ [X.INSN (X.AL, X.SUBS (t1, t2))], pos, neg)
5c79bb68	240	end
1144856b	241
6ade8b0a JW	242	(* munch_cond : T.exp -> X.insn list * X.cond * X.cond
	243	* munch_cond stm generates code to set flags, and then returns a conditional
	244	* to test if the expression was true and for if it was false.
	245	*)
	246	and munch_cond (T.UNOP (T.BANG, e)) =
0a24e44d	247	let
6ade8b0a	248	val (insns, pos, neg) = munch_cond e
0a24e44d	249	in
6ade8b0a	250	(insns, neg, pos)
0a24e44d	251	end
075222c7 JW	252	\| munch_cond (T.BINOP(T.NEQ, e1, e2)) = condhit e1 e2 (X.NE, X.EQ)
	253	\| munch_cond (T.BINOP(T.EQ, e1, e2)) = condhit e1 e2 (X.EQ, X.NE)
	254	\| munch_cond (T.BINOP(T.LE, e1, e2)) = condhit e1 e2 (X.LE, X.GT)
	255	\| munch_cond (T.BINOP(T.LT, e1, e2)) = condhit e1 e2 (X.LT, X.GE)
	256	\| munch_cond (T.BINOP(T.GT, e1, e2)) = condhit e1 e2 (X.GT, X.LE)
	257	\| munch_cond (T.BINOP(T.GE, e1, e2)) = condhit e1 e2 (X.GE, X.LT)
5c79bb68	258
075222c7	259	\| munch_cond (T.BINOP(T.BE, e1, e2)) = raise ErrorMsg.InternalError "memory safety not supported"
5c79bb68	260
6ade8b0a JW	261	\| munch_cond e =
6ade8b0a JW	262	let
075222c7 JW	263	val t = X.TEMP (Temp.new ("munch c"))
075222c7 JW	264	val i = munch_exp t e
6ade8b0a	265	in
075222c7	266	(i @ [ X.INSN (X.AL, X.MOVS (t,t)) ], X.NE, X.EQ)
6ade8b0a	267	end
12aa4087	268
075222c7 JW	269	(* munch_lval : T.exp -> X.operand
075222c7 JW	270	* 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.
1144856b	271	*)
075222c7 JW	272	and munch_lval (T.TEMP t) oper = [X.INSN (X.AL, X.MOV (oper, X.TEMP t))]
075222c7 JW	273	\| munch_lval (T.MEMORY m) oper =
1144856b	274	let
075222c7 JW	275	val t = X.TEMP (Tm.new "lv addr")
075222c7 JW	276	val i = munch_exp t m
1144856b	277	in
075222c7 JW	278	i @
075222c7 JW	279	[X.INSN (X.AL, X.STO (t, oper))]
1144856b	280	end
075222c7	281	\| munch_lval _ _ = raise ErrorMsg.InternalError "That wasn't really a valid lvalue..."
1144856b	282
0a24e44d	283	(* munch_stm : T.stm -> X.insn list *)
12aa4087	284	(* munch_stm stm generates code to execute stm *)
075222c7 JW	285	and munch_stm (T.MOVE (T.TEMP t1, T.TEMP t2)) = [X.INSN (X.AL, X.MOV(X.TEMP t1, X.TEMP t2))]
	286	\| munch_stm (T.MOVE (T.TEMP t, T.CONST n)) = [X.INSN (X.AL, X.MOVLIT(X.TEMP t, Word.fromLarge n))]
	287	\| munch_stm (T.MOVE (T.TEMP t, a as T.ARG (an))) =
5c79bb68	288	let
075222c7	289	val i = munch_exp (X.TEMP t) a
5c79bb68	290	in
075222c7	291	i
5c79bb68	292	end
075222c7	293	\| munch_stm (T.MOVE (T.TEMP t, a as T.CALL _)) = munch_exp (X.TEMP t) a
5c79bb68	294	\| munch_stm (T.MOVE (a, e2)) =
0a24e44d	295	let
075222c7 JW	296	val t = X.TEMP (Temp.new ("assign"))
	297	val i = munch_exp t e2
	298	val li = munch_lval a t
0a24e44d	299	in
075222c7	300	i @ li
0a24e44d	301	end
075222c7	302	\| munch_stm (T.RETURN(e)) =
12aa4087	303	let
075222c7 JW	304	val t = X.TEMP (Temp.new ("retval"))
075222c7 JW	305	val i = munch_exp t e
12aa4087	306	in
075222c7	307	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))]
12aa4087	308	end
5c79bb68	309	\| munch_stm (T.LABEL l) = [X.LABEL l]
075222c7	310	\| munch_stm (T.JUMP l) = [X.INSN (X.AL, X.MOVLBL (X.REG X.PC, l))]
0a24e44d JW	311	\| munch_stm (T.JUMPIFN(e, l)) =
0a24e44d JW	312	let
6ade8b0a	313	val (insns, pos, neg) = munch_cond e
0a24e44d	314	in
075222c7	315	insns @ [X.INSN (neg, X.MOVLBL (X.REG X.PC, l))]
0a24e44d	316	end
075222c7	317	\| munch_stm (T.EFFECT exp) = let val t = X.TEMP (Temp.new "throwaway") val i = munch_exp t exp in i end
12aa4087 JW	318
	319	fun codegen nil = nil
	320	\| codegen (stm::stms) = munch_stm stm @ codegen stms
	321	end