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 =
| trans_oper A.GT = T.GT
| trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop"
- fun translate p =
+ fun translate (defs, funcs) =
let
- val allfuncs = foldr (fn (A.Extern(_),b) => b
- | (A.Function(_, id, _, _, _), b) => Symbol.bind b (id, () ))
- Symbol.empty p
+ 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
+
+ fun offset_s id (Type.Typedef(id')) =
+ let
+ val shit = Symbol.look' defs id'
+ 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 t)
+ end
+ | offset_s' nil _ = raise ErrorMsg.InternalError "looking for offset of something that isn't in the structure"
+ in
+ offset_s' (eat shit) 0
+ end
+ | offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef"
+
+ fun type_s id (Type.Typedef id') =
+ let
+ val td =
+ 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)
+ then t
+ else type_s' l
+ | type_s' nil = raise ErrorMsg.InternalError "struct member not found in type_s"
+ in
+ type_s' td
+ end
+ | type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef"
+
+ 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
| trans_unop A.BITNOT = T.BITNOT
| trans_unop A.BANG = T.BANG
| trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop"
+
+ fun typeof' vartypes exp = TypeChecker.typeof (defs, funcs) vartypes NONE exp
- fun trans_exp env (A.Var(id)) =
+ 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 (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, _)) =
+ | trans_exp env vartypes (A.ConstExp c) = T.CONST(c)
+ | 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])) =
+ T.UNOP(trans_unop oper, trans_exp env vartypes e)
+ | trans_exp env vartypes (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)
+ | trans_exp env vartypes (A.Marked(marked_exp)) =
+ trans_exp env vartypes (Mark.data marked_exp)
+ | trans_exp env vartypes (A.FuncCall(func, stms)) =
+ T.CALL(func,
+ List.map
+ (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 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 (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 (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 Type.issmall tipo
+ then T.MEMORY(d)
+ else d
+ end
+ | trans_exp env vartypes (A.New(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)) =
+ let
+ val size = 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 ls (A.Assign(id,e)::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 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
+ val te1 = trans_exp vars vartypes e1
+ val te2 = trans_exp vars vartypes e2
+ val t1 = T.TEMP (Temp.new "memory deref cache")
in
- T.MOVE(T.TEMP(t), trans_exp vars e)
- :: remainder
+ case te1
+ 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 ls (A.Return e::stms) =
+ | trans_stms vars vartypes ls (A.Return e::stms) =
let
- val remainder = trans_stms vars ls stms
+ val remainder = trans_stms vars vartypes ls stms
in
- T.RETURN (trans_exp vars e)
+ T.RETURN (trans_exp vars vartypes e)
:: remainder
end
-
- | trans_stms vars ls (A.If(e, s, NONE)::stms) =
+ | trans_stms vars vartypes 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
+ val strans = trans_stms vars vartypes ls s
+ val remainder = trans_stms vars vartypes ls stms
in
- (T.JUMPIFN(trans_exp vars e, l)
+ (T.JUMPIFN(trans_exp vars vartypes e, l)
:: strans
@ [T.LABEL (l)]
@ remainder)
end
- | trans_stms vars ls (A.If(e, s, SOME s2)::stms) =
+ | trans_stms vars vartypes 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
+ val s1trans = trans_stms vars vartypes ls s
+ val s2trans = trans_stms vars vartypes ls s2
+ val remainder = trans_stms vars vartypes ls stms
in
- (T.JUMPIFN(trans_exp vars e, l)
+ (T.JUMPIFN(trans_exp vars vartypes 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) =
+ | trans_stms vars vartypes 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
+ val stm1 = if isSome s1 then trans_stms vars vartypes NONE [valOf s1] else nil
+ val strans = trans_stms vars vartypes (SOME(loop,tail)) s
+ val stm2 = if isSome s2 then trans_stms vars vartypes NONE [valOf s2] else nil
+ val remainder = trans_stms vars vartypes ls stms
in
(stm1
- @ [T.LABEL head, T.JUMPIFN(trans_exp vars e, tail)]
+ @ [T.LABEL head, T.JUMPIFN(trans_exp vars vartypes e, tail)]
@ strans
@ [T.LABEL loop]
@ stm2
@ [T.JUMP head, T.LABEL tail]
@ remainder)
end
- | trans_stms vars ls (A.While(e, s)::stms) =
+ | trans_stms vars vartypes 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
+ val strans = trans_stms vars vartypes (SOME(head,tail)) s
+ val remainder = trans_stms vars vartypes ls stms
in
(T.LABEL head
- :: T.JUMPIFN(trans_exp vars e, tail)
+ :: T.JUMPIFN(trans_exp vars vartypes e, tail)
:: strans
@ [T.JUMP head, T.LABEL tail]
@ remainder)
end
-
- | trans_stms vars (SOME(b,e)) (A.Break::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 (SOME(b,e)) stms
+ val remainder = trans_stms vars vartypes (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) =
+ | trans_stms vars vartypes NONE (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker"
+ | trans_stms vars vartypes (SOME(b,e)) (A.Continue::stms) =
let
- val remainder = trans_stms vars (SOME(b,e)) stms
+ val remainder = trans_stms vars vartypes (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
+ | trans_stms vars vartypes NONE (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker"
+ | trans_stms vars vartypes ls (A.Nop::stms) = trans_stms vars vartypes ls stms
+ | trans_stms vars vartypes ls (A.MarkedStm m :: stms) = trans_stms vars vartypes ls ((Mark.data m) :: stms)
+ | trans_stms vars vartypes _ nil = nil
- fun trans_funcs (A.Extern(t, id, varl)::l) = trans_funcs l
- | trans_funcs (A.Function(t, id, args, vars, body)::l) =
+ fun trans_funcs ((id, A.Extern(_, _))::l) = trans_funcs l
+ | trans_funcs ((id, A.MarkedFunction a)::l) = trans_funcs ((id, Mark.data a)::l)
+ | trans_funcs ((id, A.Function(t, 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 allvars = foldr
+ (fn ((name, t),b) =>
+ 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 b = trans_stms allvars vartypes 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))
+ (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
+ trans_funcs funclist
end
-
end
git.joshuawise.com / snipe.git / blobdiff