signature TRANS =
sig
(* translate abstract syntax tree to IR tree *)
- val translate : Ast.program -> Tree.func list
+ val translate : Ast.program -> Tree.program
end
structure Trans :> TRANS =
struct
structure A = Ast
- structure AU = AstUtils
structure T = Tree
fun trans_oper A.PLUS = T.ADD
fun translate (defs, funcs) =
let
val funclist = Symbol.elemsi funcs
+ val _ = Type.alignment_reset()
+ val _ = Type.sizeof_reset()
+ fun sizeof a = Type.sizeof defs a
+ fun alignment a = Type.alignment defs a
+ fun align t curpos = Type.align defs t curpos
- val alignments = ref Symbol.empty (* Ref for memoization. *)
- fun alignment A.Int = 4
- | alignment (A.Typedef(id)) =
- (case Symbol.look (!alignments) id
- of NONE =>
- let
- val r = alignment_s (Symbol.look' defs id)
- val _ = (alignments := (Symbol.bind (!alignments) (id, r)))
- in
- r
- end
- | SOME r => r)
- | alignment (A.Pointer(_)) = 8
- | alignment (A.Array(_)) = 8
- | alignment (A.TNull) = raise ErrorMsg.InternalError "alignmentof TNull?"
- and alignment_s (A.Struct(members)) =
- foldl
- (fn ((_,t),al) => Int.max (al, alignment t))
- 1
- members
- | alignment_s (A.MarkedTypedef(a)) = alignment_s (Mark.data a)
-
- fun align t curpos =
- let
- val al = alignment t
- in
- if (curpos mod al) = 0
- then curpos
- else curpos + al - (curpos mod al)
- end
-
- val sizes = ref Symbol.empty
- fun sizeof_v A.Int = 4
- | sizeof_v (A.Typedef(id)) =
- (case Symbol.look (!sizes) id
- of NONE =>
- let
- val r = sizeof_s (Symbol.look' defs id)
- val _ = (sizes := (Symbol.bind (!sizes) (id, r)))
- in
- r
- end
- | SOME r => r)
- | sizeof_v (A.Pointer(_)) = 8
- | sizeof_v (A.Array(_)) = 8
- | sizeof_v (A.TNull) = raise ErrorMsg.InternalError "sizeof TNull?"
- and sizeof_s (A.Struct(l)) =
- foldl
- (fn ((_,t),curpos) => align t curpos + sizeof_v t)
- 0
- l
- | sizeof_s (A.MarkedTypedef(a)) = sizeof_s (Mark.data a)
-
- fun offset_s id (A.Typedef(id')) =
+ fun offset_s id (Type.Typedef(id')) =
let
val shit = Symbol.look' defs id'
- fun eat (A.Struct(l)) = l
- | eat (A.MarkedTypedef(a)) = eat (Mark.data a)
+ fun eat (Type.Struct(l)) = l
+ | eat (Type.MarkedTypedef(a)) = eat (Mark.data a)
fun offset_s' ((id1,t)::l') curofs =
let
val a = align t curofs
in
if Symbol.compare(id,id1) = EQUAL
then a
- else offset_s' l' (a + sizeof_v t)
+ else offset_s' l' (a + sizeof t)
end
| offset_s' nil _ = raise ErrorMsg.InternalError "looking for offset of something that isn't in the structure"
in
end
| offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef"
- fun type_s id (A.Typedef id') =
+ fun type_s id (Type.Typedef id') =
let
val td =
- case AU.Typedef.data (Symbol.look' defs id')
- of A.Struct d => d
+ case Type.defdata (Symbol.look' defs id')
+ of Type.Struct d => d
| _ => raise ErrorMsg.InternalError "data didn't return struct"
fun type_s' ((id',t)::l) =
if (Symbol.compare (id, id') = EQUAL)
end
| type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef"
- fun deref (A.Pointer i) = i
- | deref (A.Array i) = i
+ fun deref (Type.Pointer i) = i
+ | deref (Type.Array i) = i
| deref _ = raise ErrorMsg.InternalError "cannot deref non-pointer"
fun trans_unop A.NEGATIVE = T.NEG
fun trans_exp env vartypes (A.Var(id)) =
(* after type-checking, id must be declared; do not guard lookup *)
T.TEMP (Symbol.look' env id)
+ | trans_exp env vartypes (A.Cast (ty, e)) = trans_exp env vartypes e (* lurrr *)
| trans_exp env vartypes (A.ConstExp c) = T.CONST(c)
+ | trans_exp env vartypes (A.StringExp s) = T.STRING(Stringref.new s)
| trans_exp env vartypes (A.OpExp(oper, [e1, e2])) =
T.BINOP(trans_oper oper, trans_exp env vartypes e1, trans_exp env vartypes e2)
| trans_exp env vartypes (A.OpExp(oper, [e])) =
| trans_exp env vartypes (A.FuncCall(func, stms)) =
T.CALL(func,
List.map
- (fn exp => (trans_exp env vartypes exp, AU.Type.size (typeof' vartypes exp)))
- stms,
- AU.Type.size (AU.Function.returntype (Symbol.look' funcs func)) )
+ (fn exp => (trans_exp env vartypes exp))
+ stms)
| trans_exp env vartypes (A.Member (exp, id)) =
let
val apk = T.BINOP (T.ADD, trans_exp env vartypes exp, T.CONST (Word32.fromInt (offset_s id (typeof' vartypes exp))))
+ val tipo = type_s id (typeof' vartypes exp)
in
- if (AU.Type.issmall (type_s id (typeof' vartypes exp)))
+ if Type.issmall tipo
then T.MEMORY(apk)
else apk
end
| trans_exp env vartypes (A.DerefMember (exp, id)) =
trans_exp env vartypes (A.Member (A.Dereference (exp), id))
| trans_exp env vartypes (A.Dereference(exp)) =
- if (AU.Type.issmall (deref (typeof' vartypes exp)))
+ if (Type.issmall (deref (typeof' vartypes exp)))
then T.MEMORY(trans_exp env vartypes exp)
else trans_exp env vartypes exp
| trans_exp env vartypes (A.ArrIndex(exp1, exp2)) =
let
val asubk = T.BINOP(T.ADD, trans_exp env vartypes exp1,
- T.BINOP(T.MUL, trans_exp env vartypes exp2,
- T.CONST(Word32.fromInt(sizeof_v (deref (typeof' vartypes exp1))))))
+ if sizeof (deref (typeof' vartypes exp1)) = 1
+ then trans_exp env vartypes exp2
+ else T.BINOP(T.MUL, trans_exp env vartypes exp2,
+ T.CONST(Word32.fromInt(sizeof (deref (typeof' vartypes exp1))))
+ )
+ )
+ val tipo = deref (typeof' vartypes exp1)
+ val d =
+ if not (Flag.isset Flags.safe)
+ then asubk
+ else T.COND (T.BINOP
+ (T.BE,
+ T.MEMORY (T.BINOP (
+ T.SUB,
+ trans_exp env vartypes exp1,
+ T.CONST 0w8)),
+ trans_exp env vartypes exp2),
+ T.NULLPTR,
+ asubk)
in
- if (AU.Type.issmall (deref (typeof' vartypes exp1)))
- then T.MEMORY(asubk)
- else asubk
+ if Type.issmall tipo
+ then T.MEMORY(d)
+ else d
end
| trans_exp env vartypes (A.New(tipo)) =
- T.ALLOC(T.CONST (Word32.fromInt(sizeof_v tipo)))
+ let
+ val t1 = T.TEMP (Temp.new "result")
+ in
+ T.STMVAR (
+ [T.MOVE (t1, T.ALLOC (T.CONST (Word32.fromInt(sizeof tipo)))),
+ T.EFFECT (T.MEMORY (t1))],
+ t1)
+ end
| trans_exp env vartypes (A.NewArr(tipo, exp)) =
- T.ALLOC(T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof_v tipo))))
- | trans_exp env vartypes (A.Null) = T.CONST(0w0)
+ let
+ val size = if (sizeof tipo) = 1
+ then trans_exp env vartypes exp
+ else T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof tipo)))
+ val t1 = T.TEMP (Temp.new "allocated address")
+ val ts = T.TEMP (Temp.new "size")
+ in
+ if not (Flag.isset Flags.safe)
+ then T.STMVAR ([T.MOVE (t1, T.ALLOC size),
+ T.EFFECT (T.COND (T.BINOP (T.EQ, trans_exp env vartypes exp, T.CONST 0w0), T.CONST 0w0, T.MEMORY (t1)))],
+ t1)
+ else T.COND (T.BINOP(T.EQ, size, T.CONST 0w0),
+ T.NULLPTR,
+ T.STMVAR (
+ [T.MOVE(t1,
+ T.COND(
+ T.BINOP(T.LT, size, T.CONST 0w0),
+ T.NULLPTR,
+ T.ALLOC (T.BINOP (T.ADD, size, T.CONST 0w8)))
+ ),
+ T.MOVE(T.MEMORY (t1), trans_exp env vartypes exp)],
+ T.BINOP(T.ADD, t1, T.CONST 0w8)))
+ end
+ | trans_exp env vartypes (A.Null) = T.NULLPTR
+ | trans_exp env vartypes (A.Conditional(c,e1,e2)) = T.COND(trans_exp env vartypes c, trans_exp env vartypes e1, trans_exp env vartypes e2)
(* anything else should be impossible *)
* 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 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)
+ fun trans_stms vars vartypes ls (A.Assign(e1,e2)::stms) = T.MOVE(trans_exp vars vartypes e1, trans_exp vars vartypes e2)::(trans_stms vars vartypes ls stms)
| trans_stms vars vartypes ls (A.AsnOp(oop,e1,e2)::stms) =
let
val te1 = trans_exp vars vartypes e1
val te2 = trans_exp vars vartypes e2
- val t1 = T.TEMP (Temp.new "memory deref cache" 8)
- val size = AU.Type.size (typeof' vartypes e2)
+ val t1 = T.TEMP (Temp.new "memory deref cache")
in
case te1
- 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)
- | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2), size) :: (trans_stms vars vartypes ls stms)
+ of T.MEMORY(m) => T.MOVE(t1, m) :: T.MOVE (T.MEMORY(t1), T.BINOP(trans_oper oop, T.MEMORY(t1), te2)) :: (trans_stms vars vartypes ls stms)
+ | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2)) :: (trans_stms vars vartypes ls stms)
end
| trans_stms vars vartypes ls (A.Return e::stms) =
let
val remainder = trans_stms vars vartypes ls stms
in
- T.RETURN (trans_exp vars vartypes e, AU.Type.size (typeof' vartypes e))
+ T.RETURN (trans_exp vars vartypes e)
:: remainder
end
| trans_stms vars vartypes ls (A.If(e, s, NONE)::stms) =
@ [T.JUMP head, T.LABEL tail]
@ remainder)
end
- | 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)
+ | trans_stms vars vartypes ls (A.Effect(e)::stms) = (T.EFFECT (trans_exp vars vartypes e)) :: (trans_stms vars vartypes ls stms)
| trans_stms vars vartypes (SOME(b,e)) (A.Break::stms) =
let
val remainder = trans_stms vars vartypes (SOME(b,e)) stms
let
val allvars = foldr
(fn ((name, t),b) =>
- Symbol.bind b (name, Temp.new (Symbol.name(name)) (AU.Type.size t)))
+ Symbol.bind b (name, Temp.new (Symbol.name(name))))
Symbol.empty
(args @ vars)
val vartypes = foldr (fn ((i, t), b) => Symbol.bind b (i, t)) Symbol.empty (args @ vars)
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, Temp.size (Symbol.look' allvars argname)), Temp.size (Symbol.look' allvars argname)))
+ (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG (n)))
numberedargs
in
(T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)
git.joshuawise.com / snipe.git / blobdiff