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       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))]
  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 (Word32.toLarge 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 =
  83               let
  84                 val t = Temp.new "argdest"
  85                 val t2 = Temp.new "argptr"
  86               in
  87                 (X.TEMP t, (* Dude, I *love* this shit. *)
  88                  [ X.INSN (X.AL, X.MOVLIT (X.TEMP t2, Word.fromInt (0x10000 - (n - 4 + 1)))),
  89                    X.INSN (X.AL, X.ADD (X.TEMP t2, X.REG X.SP)),
  90                    X.INSN (X.AL, X.STO (X.TEMP t2, X.TEMP t)) ] )
  91               end
  92
  93           val dests = List.tabulate (nargs, fn x => argdest (x+1))
  94           val hf = List.map hasfixed l
  95           val (d_hf, l_hf) = ListPair.unzip (ListPair.foldr
  96             (fn (a,b,c) => if b then a::c else c)
  97             nil
  98             (ListPair.zip (dests,l), hf)
  99           )
 100           val (d_nohf, l_nohf) = ListPair.unzip (ListPair.foldr
 101             (fn (a,b,c) => if b then c else a::c)
 102             nil
 103             (ListPair.zip (dests,l), hf)
 104           )
 105           val temps = List.map (fn _ => Temp.new ("arg")) l_hf
 106           val argevals_hf = List.map
 107             (fn (t,exp) => munch_exp (X.TEMP t) exp)
 108             (ListPair.zip (temps, l_hf))
 109           val argpushes = List.map
 110             (fn ((dest, _), t) => [X.INSN (X.AL, X.MOV (dest, X.TEMP t))])
 111             (ListPair.zip (d_hf, temps))
 112           val argevals_nohf = List.map
 113             (fn ((d,_),exp) => munch_exp d exp)
 114             (ListPair.zip (d_nohf, l_nohf))
 115           val shittodo = List.concat (List.map (fn (_, shit) => shit) (d_hf @ d_nohf))
 116
 117           val t_stackb = Temp.new ("stackb")
 118           val t_target = Temp.new ("target")
 119         in
 120           List.concat argevals_hf @
 121           List.concat argpushes @
 122           List.concat argevals_nohf @
 123           shittodo @
 124           (if stackb > 0
 125            then [ X.INSN (X.AL, X.MOVLIT (X.TEMP t_stackb, Word.fromInt stackb)),
 126                   X.INSN (X.AL, X.MOVSYM (X.TEMP t_target, name)),
 127                   X.INSN (X.AL, X.SUB (X.REG X.SP, X.TEMP t_stackb)),
 128                   X.INSN (X.AL, X.CALL (X.REG X.SP, X.TEMP t_target, nargs)),
 129                   X.INSN (X.AL, X.ADD (X.REG X.SP, X.TEMP t_stackb)),
 130                   X.INSN (X.AL, X.MOV (d, X.REG X.R0))]
 131            else [ X.INSN (X.AL, X.MOVSYM (X.TEMP t_target, name)),
 132                   X.INSN (X.AL, X.CALL (X.REG X.SP, X.TEMP t_target, nargs)),
 133                   X.INSN (X.AL, X.MOV (d, X.REG X.R0))]
 134           )
 135         end
 136     (*| munch_exp d (T.BINOP(T.ADD, e1, T.CONST n)) = binophit_c d X.ADD e1 n
 137     | munch_exp d (T.BINOP(T.ADD, T.CONST n, e1)) = binophit_c d X.ADD e1 n
 138     | munch_exp d (T.BINOP(T.ADD, e1, T.TEMP t)) = binophit_t d X.ADD e1 t
 139     | munch_exp d (T.BINOP(T.ADD, T.TEMP t, e1)) = binophit_t d X.ADD e1 t*)
 140     | munch_exp d (T.BINOP(T.ADD, e1, e2)) = binophit d X.ADD e1 e2
 141
 142     (*| munch_exp d (T.BINOP(T.SUB, e1, T.CONST n)) = binophit_c d X.SUB e1 n
 143     | munch_exp d (T.BINOP(T.SUB, e1, T.TEMP t)) = binophit_t d X.SUB e1 t*)
 144     | munch_exp d (T.BINOP(T.SUB, e1, e2)) = binophit d X.SUB e1 e2
 145     | munch_exp d (T.BINOP(T.MUL, e1, e2)) = munch_exp d (T.CALL (Symbol.symbol "__blarg_mul", [e1, e2]))
 146     | munch_exp d (T.BINOP(T.DIV, e1, e2)) = munch_exp d (T.CALL (Symbol.symbol "__blarg_div", [e1, e2]))
 147     | munch_exp d (T.BINOP(T.MOD, e1, e2)) = munch_exp d (T.CALL (Symbol.symbol "__blarg_mod", [e1, e2]))
 148     | munch_exp d (T.BINOP(T.LSH, e1, e2)) = binophit d X.SHL e1 e2
 149     | munch_exp d (T.BINOP(T.RSH, e1, e2)) = binophit d X.SHR e1 e2
 150     | munch_exp d (T.BINOP(T.BITAND, e1, e2)) = binophit d X.AND e1 e2
 151     | 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))))
 152     | munch_exp d (T.BINOP(T.BITXOR, e1, e2)) =
 153         munch_exp d (T.BINOP(T.BITOR, T.BINOP(T.BITAND, e1, T.UNOP(T.BITNOT, e2)),
 154                                       T.BINOP(T.BITAND, e2, T.UNOP(T.BITNOT, e1))))
 155
 156     | munch_exp d (a as T.BINOP(T.LOGAND, e1, e2)) =
 157         let
 158           val (insn1, pos1, neg1) = munch_cond e1
 159           val (insn2, pos2, neg2) = munch_cond e2
 160           val l = Label.new ()
 161         in
 162           (insn1) @
 163           [X.INSN (X.AL, X.MOVLIT (d, 0w0)),
 164            X.INSN (neg1, 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.LOGOR, e1, e2)) =
 170         let
 171           val (insn1, pos1, neg1) = munch_cond e1
 172           val (insn2, pos2, neg2) = munch_cond e2
 173           val t1 = X.TEMP (Tm.new "logand 1")
 174           val t2 = X.TEMP (Tm.new "logand 2")
 175           val l = Label.new ()
 176         in
 177           (insn1) @
 178           [X.INSN (X.AL, X.MOVLIT (d, 0w0)),
 179            X.INSN (pos1, X.MOVLIT (d, 0w1)),
 180            X.INSN (pos1, X.MOVLBL (X.REG X.PC, l))] @
 181           (insn2) @
 182           [X.INSN (pos2, X.MOVLIT (d, 0w1)),
 183            X.LABEL l]
 184         end
 185     | munch_exp d (a as T.BINOP(T.EQ, _, _)) = cmphit d a
 186     | munch_exp d (a as T.BINOP(T.NEQ, _, _)) = cmphit d a
 187     | munch_exp d (a as T.BINOP(T.LE, _, _)) = cmphit d a
 188     | munch_exp d (a as T.BINOP(T.LT, _, _)) = cmphit d a
 189     | munch_exp d (a as T.BINOP(T.GE, _, _)) = cmphit d a
 190     | munch_exp d (a as T.BINOP(T.GT, _, _)) = cmphit d a
 191     | munch_exp d (a as T.BINOP(T.BE, _, _)) = cmphit d a
 192
 193     | munch_exp d (T.UNOP(T.NEG, e1)) =
 194         let
 195           val t = Temp.new "-val"
 196           val i = munch_exp (X.TEMP t) e1
 197         in
 198           (i) @
 199           [X.INSN (X.AL, X.MOVLIT (d, 0w0)),
 200            X.INSN (X.AL, X.SUB (d, X.TEMP t))]
 201         end
 202     | 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
 203     | munch_exp d (T.UNOP(T.BANG, e)) =
 204         let
 205           val (insns, pos, neg) = munch_cond e
 206         in
 207           insns @
 208           [X.INSN (X.AL, X.MOVLIT (d, 0w0)),
 209            X.INSN (neg, X.MOVLIT (d, 0w1))]
 210         end
 211     | munch_exp d (T.MEMORY (e1)) =
 212         let
 213           val a = X.TEMP (Temp.new "addr")
 214           val i = munch_exp a e1
 215         in
 216           i @
 217           [X.INSN (X.AL, X.LDR (d, a))]
 218         end
 219
 220     | munch_exp d (T.ALLOC(exp)) =
 221         let
 222           val t1 = Temp.new "alloc"
 223           val l1 = Label.new()
 224           val einsn = munch_exp (X.TEMP t1) exp
 225           val insns = munch_exp d (T.CALL (Symbol.symbol "calloc", [T.TEMP t1, T.CONST 0w1]))
 226         in
 227           einsn @ insns
 228         end
 229 (*    | 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 *)
 230     | munch_exp d (T.COND(c,e1,e2)) =
 231         let
 232           val (insns, pos, neg) = munch_cond c
 233           val l1 = Label.new()
 234           val l2 = Label.new()
 235           val i1 = munch_exp d e1
 236           val i2 = munch_exp d e2
 237 (*          val _ = print ("cond: size " ^ Tm.sfx s1 ^ " from " ^ TU.Print.pp_exp e1 ^ ", " ^ Tm.sfx s2 ^ " from " ^ TU.Print.pp_exp e2 ^ "\n") *)
 238         in
 239           insns @
 240           [X.INSN (neg, X.MOVLBL (X.REG X.PC, l1))] @
 241           i1 @
 242           [X.INSN (X.AL, X.MOVLBL (X.REG X.PC, l2)),
 243            X.LABEL l1] @
 244           i2 @
 245           [X.LABEL l2]
 246         end
 247     | munch_exp d (T.STMVAR (sl, e)) = let val i = munch_exp d e in List.concat (map munch_stm sl) @ i end
 248
 249   and condhit e1 e2 (pos, neg) =
 250     let
 251       val t1 = X.TEMP (Temp.new ("var cond 1"))
 252       val t2 = X.TEMP (Temp.new ("var cond 2"))
 253       val i1 = munch_exp t1 e1
 254       val i2 = munch_exp t2 e2
 255     in
 256       (i1 @ i2 @ [X.INSN (X.AL, X.SUBS (t1, t2))], pos, neg)
 257     end
 258
 259   (* munch_cond : T.exp -> X.insn list * X.cond * X.cond
 260    * munch_cond stm generates code to set flags, and then returns a conditional
 261    * to test if the expression was true and for if it was false.
 262    *)
 263   and munch_cond (T.UNOP (T.BANG, e)) =
 264         let
 265           val (insns, pos, neg) = munch_cond e
 266         in
 267           (insns, neg, pos)
 268         end
 269     | munch_cond (T.BINOP(T.NEQ, e1, e2)) = condhit e1 e2 (X.NE, X.EQ)
 270     | munch_cond (T.BINOP(T.EQ, e1, e2)) =  condhit e1 e2 (X.EQ, X.NE)
 271     | munch_cond (T.BINOP(T.LE, e1, e2)) =  condhit e1 e2 (X.LE, X.GT)
 272     | munch_cond (T.BINOP(T.LT, e1, e2)) =  condhit e1 e2 (X.LT, X.GE)
 273     | munch_cond (T.BINOP(T.GT, e1, e2)) =  condhit e1 e2 (X.GT, X.LE)
 274     | munch_cond (T.BINOP(T.GE, e1, e2)) =  condhit e1 e2 (X.GE, X.LT)
 275
 276     | munch_cond (T.BINOP(T.BE, e1, e2)) = raise ErrorMsg.InternalError "memory safety not supported"
 277
 278     | munch_cond e =
 279       let
 280         val t = X.TEMP (Temp.new ("munch c"))
 281         val i = munch_exp t e
 282       in
 283         (i @ [ X.INSN (X.AL, X.MOVS (t,t)) ], X.NE, X.EQ)
 284       end
 285
 286   (* munch_lval : T.exp -> X.operand
 287    * 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.
 288    *)
 289   and munch_lval (T.TEMP t) oper = [X.INSN (X.AL, X.MOV (X.TEMP t, oper))]
 290     | munch_lval (T.MEMORY m) oper =
 291       let
 292         val t = X.TEMP (Tm.new "lv addr")
 293         val i = munch_exp t m
 294       in
 295         i @
 296         [X.INSN (X.AL, X.STO (t, oper))]
 297       end
 298     | munch_lval _ _ = raise ErrorMsg.InternalError "That wasn't really a valid lvalue..."
 299
 300   (* munch_stm : T.stm -> X.insn list *)
 301   (* munch_stm stm generates code to execute stm *)
 302   and munch_stm (T.MOVE (T.TEMP t1, T.TEMP t2)) = [X.INSN (X.AL, X.MOV(X.TEMP t1, X.TEMP t2))]
 303     | munch_stm (T.MOVE (T.TEMP t, T.CONST n)) = [X.INSN (X.AL, X.MOVLIT(X.TEMP t, Word.fromLarge (Word32.toLarge n)))]
 304     | munch_stm (T.MOVE (T.TEMP t, a as T.ARG (an))) =
 305         let
 306           val i = munch_exp (X.TEMP t) a
 307         in
 308           i
 309         end
 310     | munch_stm (T.MOVE (T.TEMP t, a as T.CALL _)) = munch_exp (X.TEMP t) a
 311     | munch_stm (T.MOVE (a, e2)) =
 312         let
 313           val t = X.TEMP (Temp.new ("assign"))
 314           val i = munch_exp t e2
 315           val li = munch_lval a t
 316         in
 317           i @ li
 318         end
 319     | munch_stm (T.RETURN(e)) =
 320         let
 321           val t = X.TEMP (Temp.new ("retval"))
 322           val i = munch_exp t e
 323         in
 324           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))]
 325         end
 326     | munch_stm (T.LABEL l) = [X.LABEL l]
 327     | munch_stm (T.JUMP l) = [X.INSN (X.AL, X.MOVLBL (X.REG X.PC, l))]
 328     | munch_stm (T.JUMPIFN(e, l)) =
 329        let
 330          val (insns, pos, neg) = munch_cond e
 331        in
 332          insns @ [X.INSN (neg, X.MOVLBL (X.REG X.PC, l))]
 333        end
 334     | munch_stm (T.EFFECT exp) = let val t = X.TEMP (Temp.new "throwaway") val i = munch_exp t exp in i end
 335
 336   fun codegen nil = nil
 337     | codegen (stm::stms) = munch_stm stm @ codegen stms
 338 end