X-Git-Url: http://git.joshuawise.com/snipe.git/blobdiff_plain/1144856ba9d6018d9922c6ede7e97779a0fe6373..a644da892dbd55a7be1aed029dafebe28d26d27e:/trans/trans.sml?ds=inline diff --git a/trans/trans.sml b/trans/trans.sml index 6148ce8..ec66fd5 100644 --- a/trans/trans.sml +++ b/trans/trans.sml @@ -10,14 +10,13 @@ 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 @@ -43,72 +42,24 @@ struct 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 @@ -116,11 +67,11 @@ struct 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) @@ -132,8 +83,8 @@ struct 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 @@ -146,7 +97,9 @@ struct 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])) = @@ -158,38 +111,85 @@ struct | 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 *) @@ -198,23 +198,22 @@ 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 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) = @@ -274,7 +273,7 @@ struct @ [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 @@ -299,7 +298,7 @@ struct 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) @@ -307,7 +306,7 @@ struct 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)