Initial import of l3c

[snipe.git] / trans / trans.sml

(* L3 Compiler
 * AST -> IR Translator
 * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>
 * Modified by: Alex Vaynberg <alv@andrew.cmu.edu>
 * Modified: Frank Pfenning <fp@cs.cmu.edu>
 * Modified: Chris Lu <czl@andrew.cmu.edu>
 * Modified: Joshua Wise <jwise@andrew.cmu.edu>
 *)

signature TRANS =
sig
  (* translate abstract syntax tree to IR tree *)
  val translate : Ast.program -> Tree.func list
end

structure Trans :> TRANS = 
struct

  structure A = Ast
  structure T = Tree
  
  fun trans_oper A.PLUS = T.ADD
    | trans_oper A.MINUS = T.SUB
    | trans_oper A.TIMES = T.MUL
    | trans_oper A.DIVIDEDBY = T.DIV
    | trans_oper A.MODULO = T.MOD
    | trans_oper A.LSH = T.LSH
    | trans_oper A.RSH = T.RSH
    | trans_oper A.LOGOR = T.LOGOR
    | trans_oper A.LOGAND = T.LOGAND
    | trans_oper A.BITOR = T.BITOR
    | trans_oper A.BITXOR = T.BITXOR
    | trans_oper A.BITAND = T.BITAND
    | trans_oper A.NEQ = T.NEQ
    | trans_oper A.EQ = T.EQ
    | trans_oper A.LT = T.LT
    | trans_oper A.LE = T.LE
    | trans_oper A.GE = T.GE
    | trans_oper A.GT = T.GT
    | trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop"

  fun translate p =
    let
      val allfuncs = foldr (fn (A.Extern(_),b) => b
                             | (A.Function(_, id, _, _, _), b) => Symbol.bind b (id, () ))
                           Symbol.empty p

      fun trans_unop A.NEGATIVE = T.NEG
        | trans_unop A.BITNOT = T.BITNOT
        | trans_unop A.BANG = T.BANG
        | trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop"

      fun trans_exp env (A.Var(id)) =
        (* after type-checking, id must be declared; do not guard lookup *)
            T.TEMP (Symbol.look' env id)
        | trans_exp env (A.ConstExp c) = T.CONST(c)
        | trans_exp env (A.OpExp(oper, [e1, e2])) =
            T.BINOP(trans_oper oper, trans_exp env e1, trans_exp env e2)
        | trans_exp env (A.OpExp(oper, [e])) =
            T.UNOP(trans_unop oper, trans_exp env e)
        | trans_exp env (A.OpExp(oper, _)) =
            raise ErrorMsg.InternalError "expected one or two operands, got it in the oven"
        | trans_exp env (A.Marked(marked_exp)) =
            trans_exp env (Mark.data marked_exp)
        | trans_exp env (A.FuncCall(func, stms)) =
            T.CALL(func, List.map (trans_exp env) stms)

        (* anything else should be impossible *)

      (* trans_stms : Temp.temp Symbol.table -> (Label.label * Label.label) option -> A.stm list -> Tree.stm list
       * translates a statement to the corresponding IR
       * we pass around the environment and the current loop context, if any
       * (usually called ls, which contains a continue label and a break label)
       *)
      fun trans_stms vars ls (A.Assign(id,e)::stms) =
          let
            val t = Symbol.look' vars id handle Option => raise ErrorMsg.InternalError "Undeclared variable, should have been caught in typechecker..."
            val remainder = trans_stms vars ls stms
          in
            T.MOVE(T.TEMP(t), trans_exp vars e)
            :: remainder
          end
        | trans_stms vars ls (A.Return e::stms) =
          let
            val remainder = trans_stms vars ls stms
          in 
            T.RETURN (trans_exp vars e)
            :: remainder
          end
        
        | trans_stms vars ls (A.If(e, s, NONE)::stms) =
          let
            val l = Label.new ()
            val strans = trans_stms vars ls s
            val remainder = trans_stms vars ls stms
          in
            (T.JUMPIFN(trans_exp vars e, l)
            :: strans
            @ [T.LABEL (l)]
            @ remainder)
          end
        | trans_stms vars ls (A.If(e, s, SOME s2)::stms) =
          let
            val l = Label.new ()
            val l2 = Label.new ()
            val s1trans = trans_stms vars ls s
            val s2trans = trans_stms vars ls s2
            val remainder = trans_stms vars ls stms
          in
            (T.JUMPIFN(trans_exp vars e, l)
            :: s1trans
            @ [T.JUMP (l2), T.LABEL (l)]
            @ s2trans
            @ [T.LABEL (l2)]
            @ remainder)
          end
        | trans_stms vars ls (A.For(s1, e, s2, s)::stms) = 
          let
            val head = Label.new ()
            val tail = Label.new ()
            val loop = Label.new ()
            val stm1 = if isSome s1 then trans_stms vars NONE [valOf s1] else nil
            val strans = trans_stms vars (SOME(loop,tail)) s
            val stm2 = if isSome s2 then trans_stms vars NONE [valOf s2] else nil
            val remainder = trans_stms vars ls stms
          in
            (stm1
            @ [T.LABEL head, T.JUMPIFN(trans_exp vars e, tail)]
            @ strans
            @ [T.LABEL loop]
            @ stm2
            @ [T.JUMP head, T.LABEL tail]
            @ remainder)
          end
        | trans_stms vars ls (A.While(e, s)::stms) =
          let
            val head = Label.new ()
            val tail = Label.new ()
            val strans = trans_stms vars (SOME(head,tail)) s
            val remainder = trans_stms vars ls stms
          in
            (T.LABEL head
            :: T.JUMPIFN(trans_exp vars e, tail)
            :: strans
            @ [T.JUMP head, T.LABEL tail]
            @ remainder)
          end

        | trans_stms vars (SOME(b,e)) (A.Break::stms) =
          let
            val remainder = trans_stms vars (SOME(b,e)) stms
          in
            ((T.JUMP e) :: remainder)
          end
        | trans_stms vars  NONE       (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker"
        | trans_stms vars (SOME(b,e)) (A.Continue::stms) =
          let
            val remainder = trans_stms vars (SOME(b,e)) stms
          in
            ((T.JUMP b) :: remainder)
          end
        | trans_stms vars  NONE       (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker"
        | trans_stms vars ls (A.Nop::stms) = trans_stms vars ls stms
        | trans_stms vars ls (A.MarkedStm m :: stms) = trans_stms vars ls ((Mark.data m) :: stms)
        | trans_stms vars _ nil = nil

      fun trans_funcs (A.Extern(t, id, varl)::l) = trans_funcs l
        | trans_funcs (A.Function(t, id, args, vars, body)::l) = 
            let
              val (a,_) = ListPair.unzip (args @ vars)
              val allvars = foldr (fn (a,b) => Symbol.bind b (a, Temp.new(Symbol.name(a)))) Symbol.empty a
              val b = trans_stms allvars NONE body
              val (argn,_) = ListPair.unzip args
              val numberedargs = ListPair.zip (List.tabulate (length argn, fn x => x), argn)
              val argmv = map
                (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG n))
                numberedargs
            in
              (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)
            end
        | trans_funcs nil = nil
    in
      trans_funcs p
    end

end