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 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. *)
  71         let
  72           val nargs = length l
  73           val nstack = if (nargs <= 4)
  74                        then 0
  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)*)
  82
  83           val dests = List.tabulate (nargs, fn x => argdest (x+1))
  84           val hf = List.map hasfixed l
  85           val (d_hf, l_hf) = ListPair.unzip (ListPair.foldr
  86             (fn (a,b,c) => if b then a::c else c)
  87             nil
  88             (ListPair.zip (dests,l), hf)
  89           )
  90           val (d_nohf, l_nohf) = ListPair.unzip (ListPair.foldr
  91             (fn (a,b,c) => if b then c else a::c)
  92             nil
  93             (ListPair.zip (dests,l), hf)
  94           )
  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))
  99           val argpushes = List.map
 100             (fn (dest, t) => [X.INSN (X.AL, X.MOV (dest, X.TEMP t))])
 101             (ListPair.zip (d_hf, temps))
 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")
 108         in
 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))]
 118         end
 119     (*| munch_exp d (T.BINOP(T.ADD, e1, T.CONST n)) = binophit_c d X.ADD e1 n
 120     | munch_exp d (T.BINOP(T.ADD, T.CONST n, e1)) = binophit_c d X.ADD e1 n
 121     | munch_exp d (T.BINOP(T.ADD, e1, T.TEMP t)) = binophit_t d X.ADD e1 t
 122     | munch_exp d (T.BINOP(T.ADD, T.TEMP t, e1)) = binophit_t d X.ADD e1 t*)
 123     | munch_exp d (T.BINOP(T.ADD, e1, e2)) = binophit d X.ADD e1 e2
 124
 125     (*| munch_exp d (T.BINOP(T.SUB, e1, T.CONST n)) = binophit_c d X.SUB e1 n
 126     | munch_exp d (T.BINOP(T.SUB, e1, T.TEMP t)) = binophit_t d X.SUB e1 t*)
 127     | munch_exp d (T.BINOP(T.SUB, e1, e2)) = binophit d X.SUB e1 e2
 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
 133     | munch_exp d (T.BINOP(T.BITAND, e1, e2)) = binophit d X.AND e1 e2
 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))))
 138
 139     | munch_exp d (a as T.BINOP(T.LOGAND, e1, e2)) =
 140         let
 141           val (insn1, pos1, neg1) = munch_cond e1
 142           val (insn2, pos2, neg2) = munch_cond e2
 143           val l = Label.new ()
 144         in
 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]
 151         end
 152     | munch_exp d (a as T.BINOP(T.LOGOR, e1, e2)) =
 153         let
 154           val (insn1, pos1, neg1) = munch_cond e1
 155           val (insn2, pos2, neg2) = munch_cond e2
 156           val t1 = X.TEMP (Tm.new "logand 1")
 157           val t2 = X.TEMP (Tm.new "logand 2")
 158           val l = Label.new ()
 159         in
 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]
 167         end
 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
 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
 186     | munch_exp d (T.UNOP(T.BANG, e)) =
 187         let
 188           val (insns, pos, neg) = munch_cond e
 189         in
 190           insns @
 191           [X.INSN (X.AL, X.MOVLIT (d, 0w0)),
 192            X.INSN (neg, X.MOVLIT (d, 0w1))]
 193         end
 194     | munch_exp d (T.MEMORY (e1)) =
 195         let
 196           val a = X.TEMP (Temp.new "addr")
 197           val i = munch_exp a e1
 198         in
 199           i @
 200           [X.INSN (X.AL, X.LDR (d, a))]
 201         end
 202
 203     | munch_exp d (T.ALLOC(exp)) =
 204         let
 205           val t1 = Temp.new "alloc"
 206           val l1 = Label.new()
 207           val einsn = munch_exp (X.TEMP t1) exp
 208           val insns = munch_exp d (T.CALL (Symbol.symbol "calloc", [T.TEMP t1, T.CONST 0w1]))
 209         in
 210           einsn @ insns
 211         end
 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()
 218           val i1 = munch_exp d e1
 219           val i2 = munch_exp d e2
 220 (*          val _ = print ("cond: size " ^ Tm.sfx s1 ^ " from " ^ TU.Print.pp_exp e1 ^ ", " ^ Tm.sfx s2 ^ " from " ^ TU.Print.pp_exp e2 ^ "\n") *)
 221         in
 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]
 229         end
 230     | munch_exp d (T.STMVAR (sl, e)) = let val i = munch_exp d e in List.concat (map munch_stm sl) @ i end
 231
 232   and condhit e1 e2 (pos, neg) =
 233     let
 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
 238     in
 239       (i1 @ i2 @ [X.INSN (X.AL, X.SUBS (t1, t2))], pos, neg)
 240     end
 241
 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)) =
 247         let
 248           val (insns, pos, neg) = munch_cond e
 249         in
 250           (insns, neg, pos)
 251         end
 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)
 258
 259     | munch_cond (T.BINOP(T.BE, e1, e2)) = raise ErrorMsg.InternalError "memory safety not supported"
 260
 261     | munch_cond e =
 262       let
 263         val t = X.TEMP (Temp.new ("munch c"))
 264         val i = munch_exp t e
 265       in
 266         (i @ [ X.INSN (X.AL, X.MOVS (t,t)) ], X.NE, X.EQ)
 267       end
 268
 269   (* munch_lval : T.exp -> X.operand
 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.
 271    *)
 272   and munch_lval (T.TEMP t) oper = [X.INSN (X.AL, X.MOV (oper, X.TEMP t))]
 273     | munch_lval (T.MEMORY m) oper =
 274       let
 275         val t = X.TEMP (Tm.new "lv addr")
 276         val i = munch_exp t m
 277       in
 278         i @
 279         [X.INSN (X.AL, X.STO (t, oper))]
 280       end
 281     | munch_lval _ _ = raise ErrorMsg.InternalError "That wasn't really a valid lvalue..."
 282
 283   (* munch_stm : T.stm -> X.insn list *)
 284   (* munch_stm stm generates code to execute stm *)
 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))) =
 288         let
 289           val i = munch_exp (X.TEMP t) a
 290         in
 291           i
 292         end
 293     | munch_stm (T.MOVE (T.TEMP t, a as T.CALL _)) = munch_exp (X.TEMP t) a
 294     | munch_stm (T.MOVE (a, e2)) =
 295         let
 296           val t = X.TEMP (Temp.new ("assign"))
 297           val i = munch_exp t e2
 298           val li = munch_lval a t
 299         in
 300           i @ li
 301         end
 302     | munch_stm (T.RETURN(e)) =
 303         let
 304           val t = X.TEMP (Temp.new ("retval"))
 305           val i = munch_exp t e
 306         in
 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))]
 308         end
 309     | munch_stm (T.LABEL l) = [X.LABEL l]
 310     | munch_stm (T.JUMP l) = [X.INSN (X.AL, X.MOVLBL (X.REG X.PC, l))]
 311     | munch_stm (T.JUMPIFN(e, l)) =
 312        let
 313          val (insns, pos, neg) = munch_cond e
 314        in
 315          insns @ [X.INSN (neg, X.MOVLBL (X.REG X.PC, l))]
 316        end
 317     | munch_stm (T.EFFECT exp) = let val t = X.TEMP (Temp.new "throwaway") val i = munch_exp t exp in i end
 318
 319   fun codegen nil = nil
 320     | codegen (stm::stms) = munch_stm stm @ codegen stms
 321 end