codegen/codegen.sml

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