X-Git-Url: http://git.joshuawise.com/snipe.git/blobdiff_plain/0a24e44d4e9f82f8d3d83de8e58c83c8cf2868b6..5e46186e8e7b8f4d9a28cb95954d8a75b6b34f81:/trans/trans.sml diff --git a/trans/trans.sml b/trans/trans.sml index 57e5faa..7c70af1 100644 --- a/trans/trans.sml +++ b/trans/trans.sml @@ -1,4 +1,4 @@ -(* L2 Compiler +(* L3 Compiler * AST -> IR Translator * Author: Kaustuv Chaudhuri * Modified by: Alex Vaynberg @@ -10,7 +10,7 @@ signature TRANS = sig (* translate abstract syntax tree to IR tree *) - val translate : Ast.program -> Tree.stm list + val translate : Ast.program -> Tree.program end structure Trans :> TRANS = @@ -38,121 +38,275 @@ struct | trans_oper A.GE = T.GE | trans_oper A.GT = T.GT | trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop" - - and 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" - and 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) - (* anything else should be impossible *) + 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 - (* trans_stms : Temp.temp Symbol.table -> (Label.label * Label.label) option -> A.stm list -> (Tree.stm list * Symbol.table) - * 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 env ls (A.Assign(id,e)::stms) = - let val t = Symbol.look' env id handle Option => Temp.new() - val env' = Symbol.bind env (id, t) - val (remainder, env') = trans_stms env' ls stms - in - (T.MOVE(T.TEMP(t), trans_exp env e) - :: remainder, env') - end - | trans_stms env ls (A.Return e::stms) = - let val (remainder, env') = trans_stms env ls stms - in - (T.RETURN (trans_exp env e) - :: remainder, env') - end - - | trans_stms env ls (A.If(e, s, NONE)::stms) = - let val l = Label.new () - val (strans, env') = trans_stms env ls s - val (remainder, env') = trans_stms env' ls stms + 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 - (T.JUMPIFN(trans_exp env e, l) + 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 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.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 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, Temp.sts (Type.size (typeof' vartypes exp)))) + stms, + Temp.sts (Type.size (AstUtils.Function.returntype (Symbol.look' funcs func)))) + | 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, Temp.sts (Type.size tipo)) + 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, Temp.sts (Type.size (deref (typeof' 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), Temp.Long), + trans_exp env vartypes exp2), + T.NULLPTR, + asubk) + in + if Type.issmall tipo + then T.MEMORY(d, Temp.sts (Type.size tipo)) + else d + end + | trans_exp env vartypes (A.New(tipo)) = + let + val t1 = T.TEMP (Temp.new "result" Temp.Quad) + in + T.STMVAR ( + [T.MOVE (t1, T.ALLOC (T.CONST (Word32.fromInt(sizeof tipo)))), + T.EFFECT (T.MEMORY (t1, Temp.Long))], + 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" Temp.Quad) + val ts = T.TEMP (Temp.new "size" Temp.Long) + 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, Temp.Long)))], + 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, Temp.Long), 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 *) + + (* 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 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" Temp.Quad) + in + case te1 + of T.MEMORY(m,s) => T.MOVE(t1, m) :: T.MOVE (T.MEMORY(t1,s), T.BINOP(trans_oper oop, T.MEMORY(t1,s), 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, Temp.sts (Type.size (typeof' vartypes e))) + :: remainder + end + | trans_stms vars vartypes ls (A.If(e, s, NONE)::stms) = + let + val l = Label.new () + val strans = trans_stms vars vartypes ls s + val remainder = trans_stms vars vartypes ls stms + in + (T.JUMPIFN(trans_exp vars vartypes e, l) :: strans @ [T.LABEL (l)] - @ remainder, env') - end - | trans_stms env ls (A.If(e, s, SOME s2)::stms) = - let val l = Label.new () + @ remainder) + end + | trans_stms vars vartypes ls (A.If(e, s, SOME s2)::stms) = + let + val l = Label.new () val l2 = Label.new () - val (s1trans, env') = trans_stms env ls s - val (s2trans, env') = trans_stms env' ls s2 - val (remainder, env') = trans_stms env' ls stms - in - (T.JUMPIFN(trans_exp env e, l) + 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 vartypes e, l) :: s1trans @ [T.JUMP (l2), T.LABEL (l)] @ s2trans @ [T.LABEL (l2)] - @ remainder, env') - end - | trans_stms env ls (A.For(s1, e, s2, s)::stms) = - let - val head = Label.new () - val tail = Label.new () - val loop = Label.new () - val (stm1, env') = if isSome s1 then trans_stms env NONE [valOf s1] else (nil, env) - val (strans, env') = trans_stms env' (SOME(loop,tail)) s - val (stm2, env') = if isSome s2 then trans_stms env' NONE [valOf s2] else (nil, env') - val (remainder, env') = trans_stms env' ls stms - in - (stm1 - @ [T.LABEL head, T.JUMPIFN(trans_exp env' e, tail)] - @ strans - @ [T.LABEL loop] - @ stm2 - @ [T.JUMP head, T.LABEL tail] - @ remainder, env') - end - | trans_stms env ls (A.While(e, s)::stms) = - let - val head = Label.new () - val tail = Label.new () - val (strans, env') = trans_stms env (SOME(head,tail)) s - val (remainder, env') = trans_stms env' ls stms - in - (T.LABEL head - :: T.JUMPIFN(trans_exp env e, tail) - :: strans - @ [T.JUMP head, T.LABEL tail] - @ remainder, env') - end - - | trans_stms env (SOME(b,e)) (A.Break::stms) = - let - val (remainder, env') = trans_stms env (SOME(b,e)) stms - in - ((T.JUMP e) :: remainder, env') - end - | trans_stms env NONE (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker" - | trans_stms env (SOME(b,e)) (A.Continue::stms) = - let - val (remainder, env') = trans_stms env (SOME(b,e)) stms - in - ((T.JUMP b) :: remainder, env') - end - | trans_stms env NONE (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker" - - | trans_stms env ls (A.Nop::stms) = trans_stms env ls stms - | trans_stms env ls (A.MarkedStm m :: stms) = trans_stms env ls ((Mark.data m) :: stms) - | trans_stms env _ nil = (nil, env) + @ remainder) + end + | 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 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 vartypes e, tail)] + @ strans + @ [T.LABEL loop] + @ stm2 + @ [T.JUMP head, T.LABEL tail] + @ remainder) + end + | trans_stms vars vartypes ls (A.While(e, s)::stms) = + let + val head = Label.new () + val tail = Label.new () + 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 vartypes e, tail) + :: strans + @ [T.JUMP head, T.LABEL tail] + @ remainder) + end + | 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 + in + ((T.JUMP e) :: remainder) + end + | 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 vartypes (SOME(b,e)) stms + in + ((T.JUMP b) :: remainder) + end + | 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 translate p = let val (trans, _) = trans_stms Symbol.empty NONE p in trans end + 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 allvars = foldr + (fn ((name, t),b) => + Symbol.bind b (name, Temp.new (Symbol.name(name)) (Temp.sts (Type.size t)))) + 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, Temp.size (Symbol.look' allvars argname)))) + numberedargs + in + (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l) + end + | trans_funcs nil = nil + in + trans_funcs funclist + end end