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