Initial import of l5c

[snipe.git] / trans / treeutils.sml

diff --git a/trans/treeutils.sml b/trans/treeutils.sml
new file mode 100644 (file)
index 0000000..b5217b0
--- /dev/null
+++ b/trans/treeutils.sml
@@ -0,0 +1,104 @@
+signature TREEUTILS =
+sig
+  val effect : Tree.exp -> bool
+  val effect_stm : Tree.stm -> bool
+
+  structure Print :
+  sig
+    val pp_exp : Tree.exp -> string
+    val pp_stm : Tree.stm -> string
+    val pp_program : Tree.program -> string
+  end
+end
+
+structure TreeUtils :> TREEUTILS =
+struct
+  structure T = Tree
+
+  (* effect : T.exp -> bool
+   * true iff the given expression has an effect.
+   *)
+  fun effect (T.CONST _) = false
+    | effect (T.TEMP _) = false
+    | effect (T.ARG _) = false
+    | effect (T.BINOP(T.DIV, _, _)) = true
+    | effect (T.BINOP(T.MOD, _, _)) = true
+    | effect (T.CALL _) = true
+    | effect (T.BINOP(_, a, b)) = (effect a) orelse (effect b)
+    | effect (T.UNOP (_, a)) = effect a
+    | effect (T.MEMORY _) = true
+    | effect (T.ALLOC _) = true
+    | effect (T.COND (a, b, c)) = (effect a) orelse (effect b) orelse (effect c)
+    | effect (T.STMVAR (sl, e)) = true (* Has to be, to be safe <--- jwise is an assclown, he was too lazy to write a effect_stm *)
+    | effect (T.NULLPTR) = false
+
+  fun effect_stm (T.MOVE (e1,e2)) = effect e1 orelse effect e2
+    | effect_stm (T.RETURN (e1,e2)) = effect e1 orelse effect e1
+    | effect_stm (T.EFFECT e) = effect e
+    | effect_stm (T.JUMPIFN (e,_)) = effect e
+    | effect_stm _ = false
+
+  structure Print = 
+  struct
+    exception Aaaasssssss
+
+    fun pp_binop T.ADD = "+"
+      | pp_binop T.SUB = "-"
+      | pp_binop T.MUL = "*"
+      | pp_binop T.DIV = "/"
+      | pp_binop T.MOD = "%"
+      | pp_binop T.LSH = "<<"
+      | pp_binop T.RSH = ">>"
+      | pp_binop T.LOGOR = "||"
+      | pp_binop T.LOGAND = "&&"
+      | pp_binop T.BITOR = "|"
+      | pp_binop T.BITAND = "&"
+      | pp_binop T.BITXOR = "^"
+      | pp_binop T.NEQ = "!="
+      | pp_binop T.EQ = "=="
+      | pp_binop T.LE = "<="
+      | pp_binop T.LT = "<"
+      | pp_binop T.GE = ">="
+      | pp_binop T.GT = ">"
+      | pp_binop T.BE = "[BE]"
+    
+    fun pp_unop T.NEG = "-"
+      | pp_unop T.BITNOT = "~"
+      | pp_unop T.BANG = "!"
+
+    fun pp_exp (T.CONST(x)) = Word32Signed.toString x
+      | pp_exp (T.TEMP(t)) = Temp.name t
+      | pp_exp (T.ARG(n, sz)) = "arg#"^Int.toString n
+      | pp_exp (T.BINOP (binop, e1, e2)) =
+         "(" ^ pp_exp e1 ^ " " ^ pp_binop binop ^ " " ^ pp_exp e2 ^ ")"
+      | pp_exp (T.UNOP (unop, e1)) =
+          pp_unop unop ^ "(" ^ pp_exp e1 ^ ")"
+      | pp_exp (T.CALL (f, l, sz)) =
+          Symbol.name f ^ "(" ^ (String.concatWith ", " (List.map (fn (e, _) => pp_exp e) l)) ^ ")"
+      | pp_exp (T.MEMORY (exp, sz)) = "M(" ^ Temp.sfx sz ^ ")[" ^ pp_exp exp ^ "]"
+      | pp_exp (T.ALLOC(e)) = "NEW(" ^ pp_exp e ^ ")"
+      | pp_exp (T.COND(c,e1,e2)) = "(" ^ pp_exp c ^ ") ? (" ^ pp_exp e1 ^ ") : (" ^ pp_exp e2 ^ ")"
+      | pp_exp (T.STMVAR(sl,v)) = "({" ^ (foldr (fn (st,s) => (pp_stm st) ^ "; " ^ s) "" sl) ^ (pp_exp v) ^ "})"
+      | pp_exp (T.NULLPTR) = "NULL"
+
+    and pp_stm (T.MOVE (e1,e2)) =
+         pp_exp e1 ^ "  <--  " ^ pp_exp e2
+      | pp_stm (T.RETURN (e, sz)) =
+         "return " ^ pp_exp e
+      | pp_stm (T.EFFECT e) = pp_exp e
+      | pp_stm (T.LABEL l) =
+          Label.name l ^ ":"
+      | pp_stm (T.JUMP l) = 
+          "jump "^Label.name l
+      | pp_stm (T.JUMPIFN (e, l)) =
+          "jump "^Label.name l^" if! "^pp_exp e
+
+    fun pp_program (nil) = ""
+      | pp_program (T.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