Initial import of l3c

[snipe.git] / trans / tree.sml

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

signature TREE =
sig

  datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE
  datatype unop = NEG | BITNOT | BANG

  type Blarg = int

  datatype exp = 
      CONST of Word32.word
    | TEMP of Temp.temp
    | ARG of Blarg (* I am j4cbo *)
    | BINOP of binop * exp * exp
    | UNOP of unop * exp
    | CALL of Ast.ident * exp list
  and stm =
      MOVE of exp * exp
    | RETURN of exp
    | LABEL of Label.label
    | JUMPIFN of exp * Label.label
    | JUMP of Label.label
  and func =
      FUNCTION of Ast.ident * stm list

  type program = func list

  structure Print :
  sig
    val pp_exp : exp -> string
    val pp_stm : stm -> string
    val pp_program : program -> string
  end
end

structure Tree :> TREE =
struct

  datatype binop = ADD | SUB | MUL | DIV | MOD | LSH | RSH | LOGOR | LOGAND | BITOR | BITAND | BITXOR | NEQ | EQ | LT | GT | LE | GE
  datatype unop = NEG | BITNOT | BANG

  type Blarg = int

  datatype exp = 
      CONST of Word32.word
    | TEMP of Temp.temp
    | ARG of Blarg
    | BINOP of binop * exp * exp
    | UNOP of unop * exp
    | CALL of Ast.ident * exp list
  and stm =
      MOVE of exp * exp
    | RETURN of exp
    | LABEL of Label.label
    | JUMPIFN of exp * Label.label
    | JUMP of Label.label
  and func =
      FUNCTION of Ast.ident * stm list

  type program = func list

  structure Print = 
  struct

    exception Aaaasssssss

    fun pp_binop ADD = "+"
      | pp_binop SUB = "-"
      | pp_binop MUL = "*"
      | pp_binop DIV = "/"
      | pp_binop MOD = "%"
      | pp_binop LSH = "<<"
      | pp_binop RSH = ">>"
      | pp_binop LOGOR = "||"
      | pp_binop LOGAND = "&&"
      | pp_binop BITOR = "|"
      | pp_binop BITAND = "&"
      | pp_binop BITXOR = "^"
      | pp_binop NEQ = "!="
      | pp_binop EQ = "=="
      | pp_binop LE = "<="
      | pp_binop LT = "<"
      | pp_binop GE = ">="
      | pp_binop GT = ">"
    
    fun pp_unop NEG = "-"
      | pp_unop BITNOT = "~"
      | pp_unop BANG = "!"

    fun pp_exp (CONST(x)) = Word32Signed.toString x
      | pp_exp (TEMP(t)) = Temp.name t
      | pp_exp (ARG(n)) = "arg#"^Int.toString n
      | pp_exp (BINOP (binop, e1, e2)) =
	  "(" ^ pp_exp e1 ^ " " ^ pp_binop binop ^ " " ^ pp_exp e2 ^ ")"
      | pp_exp (UNOP (unop, e1)) =
          pp_unop unop ^ "(" ^ pp_exp e1 ^ ")"
      | pp_exp (CALL (f, l)) =
          Symbol.name f ^ "(" ^ (String.concatWith ", " (List.map pp_exp l)) ^ ")"

    fun pp_stm (MOVE (e1,e2)) =
	  pp_exp e1 ^ "  <--  " ^ pp_exp e2
      | pp_stm (RETURN e) =
	  "return " ^ pp_exp e
      | pp_stm (LABEL l) =
          Label.name l ^ ":"
      | pp_stm (JUMP l) = 
          "jump "^Label.name l
      | pp_stm (JUMPIFN (e, l)) =
          "jump "^Label.name l^" if! "^pp_exp e

    fun pp_program (nil) = ""
      | pp_program (FUNCTION(id, stms)::funcs) =
          (Symbol.name id) ^
          "\n{\n" ^
          (foldr (fn (a,b) => (pp_stm a) ^ "\n" ^ b) "" stms) ^
          "}\n" ^
          pp_program funcs
  end
end