trans/trans.sml

   1 (* L2 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.stm list
  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   and trans_unop A.NEGATIVE = T.NEG
  43     | trans_unop A.BITNOT = T.BITNOT
  44     | trans_unop A.BANG = T.BANG
  45     | trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop"
  46
  47   and trans_exp env (A.Var(id)) =
  48       (* after type-checking, id must be declared; do not guard lookup *)
  49         T.TEMP (Symbol.look' env id)
  50     | trans_exp env (A.ConstExp c) = T.CONST(c)
  51     | trans_exp env (A.OpExp(oper, [e1, e2])) =
  52         T.BINOP(trans_oper oper, trans_exp env e1, trans_exp env e2)
  53     | trans_exp env (A.OpExp(oper, [e])) =
  54         T.UNOP(trans_unop oper, trans_exp env e)
  55     | trans_exp env (A.OpExp(oper, _)) =
  56         raise ErrorMsg.InternalError "expected one or two operands, got it in the oven"
  57     | trans_exp env (A.Marked(marked_exp)) =
  58         trans_exp env (Mark.data marked_exp)
  59     (* anything else should be impossible *)
  60
  61   (* trans_stms : Temp.temp Symbol.table -> (Label.label * Label.label) option -> A.stm list -> (Tree.stm list * Symbol.table)
  62    * translates a statement to the corresponding IR
  63    * we pass around the environment and the current loop context, if any
  64    * (usually called ls, which contains a continue label and a break label)
  65    *)
  66   fun trans_stms env ls (A.Assign(id,e)::stms) =
  67       let val t = Symbol.look' env id handle Option => Temp.new()
  68           val env' = Symbol.bind env (id, t)
  69           val (remainder, env') = trans_stms env' ls stms
  70       in
  71           (T.MOVE(T.TEMP(t), trans_exp env e)
  72           :: remainder, env')
  73       end
  74     | trans_stms env ls (A.Return e::stms) =
  75       let val (remainder, env') = trans_stms env ls stms
  76       in
  77         (T.RETURN (trans_exp env e)
  78         :: remainder, env')
  79       end
  80
  81     | trans_stms env ls (A.If(e, s, NONE)::stms) =
  82         let val l = Label.new ()
  83             val (strans, env') = trans_stms env ls s
  84             val (remainder, env') = trans_stms env' ls stms
  85         in
  86             (T.JUMPIFN(trans_exp env e, l)
  87             :: strans
  88             @ [T.LABEL (l)]
  89             @ remainder, env')
  90         end
  91     | trans_stms env ls (A.If(e, s, SOME s2)::stms) =
  92         let val l = Label.new ()
  93             val l2 = Label.new ()
  94             val (s1trans, env') = trans_stms env ls s
  95             val (s2trans, env') = trans_stms env' ls s2
  96             val (remainder, env') = trans_stms env' ls stms
  97         in
  98             (T.JUMPIFN(trans_exp env e, l)
  99             :: s1trans
 100             @ [T.JUMP (l2), T.LABEL (l)]
 101             @ s2trans
 102             @ [T.LABEL (l2)]
 103             @ remainder, env')
 104         end
 105     | trans_stms env ls (A.For(s1, e, s2, s)::stms) =
 106         let
 107           val head = Label.new ()
 108           val tail = Label.new ()
 109           val loop = Label.new ()
 110           val (stm1, env') = if isSome s1 then trans_stms env NONE [valOf s1] else (nil, env)
 111           val (strans, env') = trans_stms env' (SOME(loop,tail)) s
 112           val (stm2, env') = if isSome s2 then trans_stms env' NONE [valOf s2] else (nil, env')
 113           val (remainder, env') = trans_stms env' ls stms
 114         in
 115           (stm1
 116           @ [T.LABEL head, T.JUMPIFN(trans_exp env' e, tail)]
 117           @ strans
 118           @ [T.LABEL loop]
 119           @ stm2
 120           @ [T.JUMP head, T.LABEL tail]
 121           @ remainder, env')
 122         end
 123     | trans_stms env ls (A.While(e, s)::stms) =
 124        let
 125          val head = Label.new ()
 126          val tail = Label.new ()
 127          val (strans, env') = trans_stms env (SOME(head,tail)) s
 128          val (remainder, env') = trans_stms env' ls stms
 129        in
 130          (T.LABEL head
 131          :: T.JUMPIFN(trans_exp env e, tail)
 132          :: strans
 133          @ [T.JUMP head, T.LABEL tail]
 134          @ remainder, env')
 135        end
 136
 137     | trans_stms env (SOME(b,e)) (A.Break::stms) =
 138         let
 139           val (remainder, env') = trans_stms env (SOME(b,e)) stms
 140         in
 141           ((T.JUMP e) :: remainder, env')
 142         end
 143     | trans_stms env  NONE       (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker"
 144     | trans_stms env (SOME(b,e)) (A.Continue::stms) =
 145         let
 146           val (remainder, env') = trans_stms env (SOME(b,e)) stms
 147         in
 148           ((T.JUMP b) :: remainder, env')
 149         end
 150     | trans_stms env  NONE       (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker"
 151
 152     | trans_stms env ls (A.Nop::stms) = trans_stms env ls stms
 153     | trans_stms env ls (A.MarkedStm m :: stms) = trans_stms env ls ((Mark.data m) :: stms)
 154     | trans_stms env _ nil = (nil, env)
 155
 156   fun translate p = let val (trans, _) = trans_stms Symbol.empty NONE p in trans end
 157
 158 end