trans/trans.sml

   1 (* L3 Compiler
   2  * AST -> IR Translator
   3  * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
   4  * Modified by: Alex Vaynberg <alv@andrew.cmu.edu>
   5  * Modified: Frank Pfenning <fp@cs.cmu.edu>
   6  * Modified: Chris Lu <czl@andrew.cmu.edu>
   7  * Modified: Joshua Wise <jwise@andrew.cmu.edu>
   8  *)
   9
  10 signature TRANS =
  11 sig
  12   (* translate abstract syntax tree to IR tree *)
  13   val translate : Ast.program -> Tree.program
  14 end
  15
  16 structure Trans :> TRANS =
  17 struct
  18
  19   structure A = Ast
  20   structure T = Tree
  21
  22   fun trans_oper A.PLUS = T.ADD
  23     | trans_oper A.MINUS = T.SUB
  24     | trans_oper A.TIMES = T.MUL
  25     | trans_oper A.DIVIDEDBY = T.DIV
  26     | trans_oper A.MODULO = T.MOD
  27     | trans_oper A.LSH = T.LSH
  28     | trans_oper A.RSH = T.RSH
  29     | trans_oper A.LOGOR = T.LOGOR
  30     | trans_oper A.LOGAND = T.LOGAND
  31     | trans_oper A.BITOR = T.BITOR
  32     | trans_oper A.BITXOR = T.BITXOR
  33     | trans_oper A.BITAND = T.BITAND
  34     | trans_oper A.NEQ = T.NEQ
  35     | trans_oper A.EQ = T.EQ
  36     | trans_oper A.LT = T.LT
  37     | trans_oper A.LE = T.LE
  38     | trans_oper A.GE = T.GE
  39     | trans_oper A.GT = T.GT
  40     | trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop"
  41
  42   fun translate (defs, funcs) =
  43     let
  44       val funclist = Symbol.elemsi funcs
  45       val _ = Type.alignment_reset()
  46       val _ = Type.sizeof_reset()
  47       fun sizeof a = Type.sizeof defs a
  48       fun alignment a = Type.alignment defs a
  49       fun align t curpos = Type.align defs t curpos
  50
  51       fun offset_s id (Type.Typedef(id')) =
  52         let
  53           val shit = Symbol.look' defs id'
  54           fun eat (Type.Struct(l)) = l
  55             | eat (Type.MarkedTypedef(a)) = eat (Mark.data a)
  56           fun offset_s' ((id1,t)::l') curofs =
  57             let
  58               val a = align t curofs
  59             in
  60               if Symbol.compare(id,id1) = EQUAL
  61                 then a
  62               else offset_s' l' (a + sizeof t)
  63             end
  64             | offset_s' nil _ = raise ErrorMsg.InternalError "looking for offset of something that isn't in the structure"
  65         in
  66           offset_s' (eat shit) 0
  67         end
  68         | offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef"
  69
  70       fun type_s id (Type.Typedef id') =
  71         let
  72           val td =
  73             case Type.defdata (Symbol.look' defs id')
  74             of Type.Struct d => d
  75              | _ => raise ErrorMsg.InternalError "data didn't return struct"
  76           fun type_s' ((id',t)::l) =
  77             if (Symbol.compare (id, id') = EQUAL)
  78             then t
  79             else type_s' l
  80             | type_s' nil = raise ErrorMsg.InternalError "struct member not found in type_s"
  81         in
  82           type_s' td
  83         end
  84         | type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef"
  85
  86       fun deref (Type.Pointer i) = i
  87         | deref (Type.Array i) = i
  88         | deref _ = raise ErrorMsg.InternalError "cannot deref non-pointer"
  89
  90       fun trans_unop A.NEGATIVE = T.NEG
  91         | trans_unop A.BITNOT = T.BITNOT
  92         | trans_unop A.BANG = T.BANG
  93         | trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop"
  94
  95       fun typeof' vartypes exp = TypeChecker.typeof (defs, funcs) vartypes NONE exp
  96
  97       fun trans_exp env vartypes (A.Var(id)) =
  98         (* after type-checking, id must be declared; do not guard lookup *)
  99             T.TEMP (Symbol.look' env id)
 100         | trans_exp env vartypes (A.ConstExp c) = T.CONST(c)
 101         | trans_exp env vartypes (A.OpExp(oper, [e1, e2])) =
 102             T.BINOP(trans_oper oper, trans_exp env vartypes e1, trans_exp env vartypes e2)
 103         | trans_exp env vartypes (A.OpExp(oper, [e])) =
 104             T.UNOP(trans_unop oper, trans_exp env vartypes e)
 105         | trans_exp env vartypes (A.OpExp(oper, _)) =
 106             raise ErrorMsg.InternalError "expected one or two operands, got it in the oven"
 107         | trans_exp env vartypes (A.Marked(marked_exp)) =
 108             trans_exp env vartypes (Mark.data marked_exp)
 109         | trans_exp env vartypes (A.FuncCall(func, stms)) =
 110             T.CALL(func,
 111               List.map
 112                 (fn exp => (trans_exp env vartypes exp, Temp.sts (Type.size (typeof' vartypes exp))))
 113                 stms,
 114               Temp.sts (Type.size (AstUtils.Function.returntype (Symbol.look' funcs func))))
 115         | trans_exp env vartypes (A.Member (exp, id)) =
 116             let
 117               val apk = T.BINOP (T.ADD, trans_exp env vartypes exp, T.CONST (Word32.fromInt (offset_s id (typeof' vartypes exp))))
 118               val tipo = type_s id (typeof' vartypes exp)
 119             in
 120               if Type.issmall tipo
 121               then T.MEMORY(apk, Temp.sts (Type.size tipo))
 122               else apk
 123             end
 124         | trans_exp env vartypes (A.DerefMember (exp, id)) =
 125             trans_exp env vartypes (A.Member (A.Dereference (exp), id))
 126         | trans_exp env vartypes (A.Dereference(exp)) =
 127             if (Type.issmall (deref (typeof' vartypes exp)))
 128             then T.MEMORY(trans_exp env vartypes exp, Temp.sts (Type.size (deref (typeof' vartypes exp))))
 129             else trans_exp env vartypes exp
 130         | trans_exp env vartypes (A.ArrIndex(exp1, exp2)) =
 131             let
 132               val asubk = T.BINOP(T.ADD, trans_exp env vartypes exp1,
 133                                   T.BINOP(T.MUL, trans_exp env vartypes exp2,
 134                                           T.CONST(Word32.fromInt(sizeof (deref (typeof' vartypes exp1))))))
 135               val tipo = deref (typeof' vartypes exp1)
 136               val d =
 137                 if not (Flag.isset Flags.safe)
 138                 then asubk
 139                 else T.COND (T.BINOP
 140                               (T.BE,
 141                                T.MEMORY (T.BINOP (
 142                                  T.SUB,
 143                                  trans_exp env vartypes exp1,
 144                                  T.CONST 0w8), Temp.Long),
 145                                trans_exp env vartypes exp2),
 146                              T.NULLPTR,
 147                              asubk)
 148             in
 149               if Type.issmall tipo
 150               then T.MEMORY(d, Temp.sts (Type.size tipo))
 151               else d
 152             end
 153         | trans_exp env vartypes (A.New(tipo)) =
 154             let
 155               val t1 = T.TEMP (Temp.new "result" Temp.Quad)
 156             in
 157               T.STMVAR (
 158                 [T.MOVE (t1, T.ALLOC (T.CONST (Word32.fromInt(sizeof tipo)))),
 159                  T.EFFECT (T.MEMORY (t1, Temp.Long))],
 160                 t1)
 161             end
 162         | trans_exp env vartypes (A.NewArr(tipo, exp)) =
 163             let
 164               val size = T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof tipo)))
 165               val t1 = T.TEMP (Temp.new "allocated address" Temp.Quad)
 166               val ts = T.TEMP (Temp.new "size" Temp.Long)
 167             in
 168               if not (Flag.isset Flags.safe)
 169               then T.STMVAR ([T.MOVE (t1, T.ALLOC size),
 170                               T.EFFECT (T.COND (T.BINOP (T.EQ, trans_exp env vartypes exp, T.CONST 0w0), T.CONST 0w0, T.MEMORY (t1, Temp.Long)))],
 171                              t1)
 172               else T.COND (T.BINOP(T.EQ, size, T.CONST 0w0),
 173                            T.NULLPTR,
 174                            T.STMVAR (
 175                              [T.MOVE(t1,
 176                                 T.COND(
 177                                   T.BINOP(T.LT, size, T.CONST 0w0),
 178                                   T.NULLPTR,
 179                                   T.ALLOC (T.BINOP (T.ADD, size, T.CONST 0w8)))
 180                                 ),
 181                               T.MOVE(T.MEMORY (t1, Temp.Long), trans_exp env vartypes exp)],
 182                              T.BINOP(T.ADD, t1, T.CONST 0w8)))
 183             end
 184         | trans_exp env vartypes (A.Null) = T.NULLPTR
 185         | trans_exp env vartypes (A.Conditional(c,e1,e2)) = T.COND(trans_exp env vartypes c, trans_exp env vartypes e1, trans_exp env vartypes e2)
 186
 187         (* anything else should be impossible *)
 188
 189       (* trans_stms : Temp.temp Symbol.table -> (Label.label * Label.label) option -> A.stm list -> Tree.stm list
 190        * translates a statement to the corresponding IR
 191        * we pass around the environment and the current loop context, if any
 192        * (usually called ls, which contains a continue label and a break label)
 193        *)
 194       fun trans_stms vars vartypes ls (A.Assign(e1,e2)::stms) = T.MOVE(trans_exp vars vartypes e1, trans_exp vars vartypes e2)::(trans_stms vars vartypes ls stms)
 195         | trans_stms vars vartypes ls (A.AsnOp(oop,e1,e2)::stms) =
 196           let
 197             val te1 = trans_exp vars vartypes e1
 198             val te2 = trans_exp vars vartypes e2
 199             val t1 = T.TEMP (Temp.new "memory deref cache" Temp.Quad)
 200           in
 201             case te1
 202             of T.MEMORY(m,s) => T.MOVE(t1, m) :: T.MOVE (T.MEMORY(t1,s), T.BINOP(trans_oper oop, T.MEMORY(t1,s), te2)) :: (trans_stms vars vartypes ls stms)
 203              | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2)) :: (trans_stms vars vartypes ls stms)
 204           end
 205         | trans_stms vars vartypes ls (A.Return e::stms) =
 206           let
 207             val remainder = trans_stms vars vartypes ls stms
 208           in
 209             T.RETURN (trans_exp vars vartypes e, Temp.sts (Type.size (typeof' vartypes e)))
 210             :: remainder
 211           end
 212         | trans_stms vars vartypes ls (A.If(e, s, NONE)::stms) =
 213           let
 214             val l = Label.new ()
 215             val strans = trans_stms vars vartypes ls s
 216             val remainder = trans_stms vars vartypes ls stms
 217           in
 218             (T.JUMPIFN(trans_exp vars vartypes e, l)
 219             :: strans
 220             @ [T.LABEL (l)]
 221             @ remainder)
 222           end
 223         | trans_stms vars vartypes ls (A.If(e, s, SOME s2)::stms) =
 224           let
 225             val l = Label.new ()
 226             val l2 = Label.new ()
 227             val s1trans = trans_stms vars vartypes ls s
 228             val s2trans = trans_stms vars vartypes ls s2
 229             val remainder = trans_stms vars vartypes ls stms
 230           in
 231             (T.JUMPIFN(trans_exp vars vartypes e, l)
 232             :: s1trans
 233             @ [T.JUMP (l2), T.LABEL (l)]
 234             @ s2trans
 235             @ [T.LABEL (l2)]
 236             @ remainder)
 237           end
 238         | trans_stms vars vartypes ls (A.For(s1, e, s2, s)::stms) =
 239           let
 240             val head = Label.new ()
 241             val tail = Label.new ()
 242             val loop = Label.new ()
 243             val stm1 = if isSome s1 then trans_stms vars vartypes NONE [valOf s1] else nil
 244             val strans = trans_stms vars vartypes (SOME(loop,tail)) s
 245             val stm2 = if isSome s2 then trans_stms vars vartypes NONE [valOf s2] else nil
 246             val remainder = trans_stms vars vartypes ls stms
 247           in
 248             (stm1
 249             @ [T.LABEL head, T.JUMPIFN(trans_exp vars vartypes e, tail)]
 250             @ strans
 251             @ [T.LABEL loop]
 252             @ stm2
 253             @ [T.JUMP head, T.LABEL tail]
 254             @ remainder)
 255           end
 256         | trans_stms vars vartypes ls (A.While(e, s)::stms) =
 257           let
 258             val head = Label.new ()
 259             val tail = Label.new ()
 260             val strans = trans_stms vars vartypes (SOME(head,tail)) s
 261             val remainder = trans_stms vars vartypes ls stms
 262           in
 263             (T.LABEL head
 264             :: T.JUMPIFN(trans_exp vars vartypes e, tail)
 265             :: strans
 266             @ [T.JUMP head, T.LABEL tail]
 267             @ remainder)
 268           end
 269         | trans_stms vars vartypes ls (A.Effect(e)::stms) = (T.EFFECT (trans_exp vars vartypes e)) :: (trans_stms vars vartypes ls stms)
 270         | trans_stms vars vartypes (SOME(b,e)) (A.Break::stms) =
 271           let
 272             val remainder = trans_stms vars vartypes (SOME(b,e)) stms
 273           in
 274             ((T.JUMP e) :: remainder)
 275           end
 276         | trans_stms vars vartypes  NONE       (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker"
 277         | trans_stms vars vartypes (SOME(b,e)) (A.Continue::stms) =
 278           let
 279             val remainder = trans_stms vars vartypes (SOME(b,e)) stms
 280           in
 281             ((T.JUMP b) :: remainder)
 282           end
 283         | trans_stms vars vartypes  NONE       (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker"
 284         | trans_stms vars vartypes ls (A.Nop::stms) = trans_stms vars vartypes ls stms
 285         | trans_stms vars vartypes ls (A.MarkedStm m :: stms) = trans_stms vars vartypes ls ((Mark.data m) :: stms)
 286         | trans_stms vars vartypes _ nil = nil
 287
 288       fun trans_funcs ((id, A.Extern(_, _))::l) = trans_funcs l
 289         | trans_funcs ((id, A.MarkedFunction a)::l) = trans_funcs ((id, Mark.data a)::l)
 290         | trans_funcs ((id, A.Function(t, args, vars, body))::l) =
 291             let
 292               val allvars = foldr
 293                               (fn ((name, t),b) =>
 294                                 Symbol.bind b (name, Temp.new (Symbol.name(name)) (Temp.sts (Type.size t))))
 295                               Symbol.empty
 296                               (args @ vars)
 297               val vartypes = foldr (fn ((i, t), b) => Symbol.bind b (i, t)) Symbol.empty (args @ vars)
 298               val b = trans_stms allvars vartypes NONE body
 299               val (argn,_) = ListPair.unzip args
 300               val numberedargs = ListPair.zip (List.tabulate (length argn, fn x => x), argn)
 301               val argmv = map
 302                 (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG (n, Temp.size (Symbol.look' allvars argname))))
 303                 numberedargs
 304             in
 305               (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)
 306             end
 307         | trans_funcs nil = nil
 308
 309     in
 310       trans_funcs funclist
 311     end
 312 end