X-Git-Url: http://git.joshuawise.com/snipe.git/blobdiff_plain/6ade8b0a3251e44b34c6bdbbd9403e36d6fd6231..1144856ba9d6018d9922c6ede7e97779a0fe6373:/trans/trans.sml diff --git a/trans/trans.sml b/trans/trans.sml index 80802be..6148ce8 100644 --- a/trans/trans.sml +++ b/trans/trans.sml @@ -17,6 +17,7 @@ structure Trans :> TRANS = struct structure A = Ast + structure AU = AstUtils structure T = Tree fun trans_oper A.PLUS = T.ADD @@ -39,31 +40,156 @@ struct | 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 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')) = + let + val shit = Symbol.look' defs id' + fun eat (A.Struct(l)) = l + | eat (A.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) + 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 (A.Typedef id') = + let + val td = + case AU.Typedef.data (Symbol.look' defs id') + of A.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 (A.Pointer i) = i + | deref (A.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, AU.Type.size (typeof' vartypes exp))) + stms, + AU.Type.size (AU.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)))) + in + if (AU.Type.issmall (type_s id (typeof' vartypes exp))) + 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))) + 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)))))) + in + if (AU.Type.issmall (deref (typeof' vartypes exp1))) + then T.MEMORY(asubk) + else asubk + end + | trans_exp env vartypes (A.New(tipo)) = + T.ALLOC(T.CONST (Word32.fromInt(sizeof_v tipo))) + | 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) (* anything else should be impossible *) @@ -72,115 +198,123 @@ struct * 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, AU.Type.size (typeof' 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" 8) + val size = AU.Type.size (typeof' vartypes e2) in - T.MOVE(T.TEMP(t), trans_exp vars e) - :: remainder + 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) 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, AU.Type.size (typeof' 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, AU.Type.size (typeof' 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)) (AU.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)) + (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))) numberedargs in (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l) end | trans_funcs nil = nil + in - trans_funcs p + trans_funcs funclist end - end