Joshua Wise's Git repositories - snipe.git/blob

1 (* L3 Compiler

2 * AST -> IR Translator

3 * Author: Kaustuv Chaudhuri <kaustuv+@cs.cmu.edu>

4 * Modified by: Alex Vaynberg <alv@andrew.cmu.edu>

5 * Modified: Frank Pfenning <fp@cs.cmu.edu>

6 * Modified: Chris Lu <czl@andrew.cmu.edu>

7 * Modified: Joshua Wise <jwise@andrew.cmu.edu>

8 *)

9

10 signature TRANS =

11 sig

12 (* translate abstract syntax tree to IR tree *)

13 val translate : Ast.program -> Tree.program

14 end

15

16 structure Trans :> TRANS =

17 struct

18

19 structure A = Ast

20 structure T = Tree

21

22 fun trans_oper A.PLUS = T.ADD

23 | trans_oper A.MINUS = T.SUB

24 | trans_oper A.TIMES = T.MUL

25 | trans_oper A.DIVIDEDBY = T.DIV

26 | trans_oper A.MODULO = T.MOD

27 | trans_oper A.LSH = T.LSH

28 | trans_oper A.RSH = T.RSH

29 | trans_oper A.LOGOR = T.LOGOR

30 | trans_oper A.LOGAND = T.LOGAND

31 | trans_oper A.BITOR = T.BITOR

32 | trans_oper A.BITXOR = T.BITXOR

33 | trans_oper A.BITAND = T.BITAND

34 | trans_oper A.NEQ = T.NEQ

35 | trans_oper A.EQ = T.EQ

36 | trans_oper A.LT = T.LT

37 | trans_oper A.LE = T.LE

38 | trans_oper A.GE = T.GE

39 | trans_oper A.GT = T.GT

40 | trans_oper _ = raise ErrorMsg.InternalError "expected AST binop, got AST unop"

41

42 fun translate (defs, funcs) =

43 let

44 val funclist = Symbol.elemsi funcs

45 val _ = Type.alignment_reset()

46 val _ = Type.sizeof_reset()

47 fun sizeof a = Type.sizeof defs a

48 fun alignment a = Type.alignment defs a

49 fun align t curpos = Type.align defs t curpos

50

51 fun offset_s id (Type.Typedef(id')) =

52 let

53 val shit = Symbol.look' defs id'

54 fun eat (Type.Struct(l)) = l

55 | eat (Type.MarkedTypedef(a)) = eat (Mark.data a)

56 fun offset_s' ((id1,t)::l') curofs =

57 let

58 val a = align t curofs

59 in

60 if Symbol.compare(id,id1) = EQUAL

61 then a

62 else offset_s' l' (a + sizeof t)

63 end

64 | offset_s' nil _ = raise ErrorMsg.InternalError "looking for offset of something that isn't in the structure"

65 in

66 offset_s' (eat shit) 0

67 end

68 | offset_s _ _ = raise ErrorMsg.InternalError "cannot find offset into non-typedef"

69

70 fun type_s id (Type.Typedef id') =

71 let

72 val td =

73 case Type.defdata (Symbol.look' defs id')

74 of Type.Struct d => d

75 | _ => raise ErrorMsg.InternalError "data didn't return struct"

76 fun type_s' ((id',t)::l) =

77 if (Symbol.compare (id, id') = EQUAL)

78 then t

79 else type_s' l

80 | type_s' nil = raise ErrorMsg.InternalError "struct member not found in type_s"

81 in

82 type_s' td

83 end

84 | type_s id _ = raise ErrorMsg.InternalError "cannot find internal type non-typedef"

85

86 fun deref (Type.Pointer i) = i

87 | deref (Type.Array i) = i

88 | deref _ = raise ErrorMsg.InternalError "cannot deref non-pointer"

89

90 fun trans_unop A.NEGATIVE = T.NEG

91 | trans_unop A.BITNOT = T.BITNOT

92 | trans_unop A.BANG = T.BANG

93 | trans_unop _ = raise ErrorMsg.InternalError "expected AST unop, got AST binop"

94

95 fun typeof' vartypes exp = TypeChecker.typeof (defs, funcs) vartypes NONE exp

96

97 fun trans_exp env vartypes (A.Var(id)) =

98 (* after type-checking, id must be declared; do not guard lookup *)

99 T.TEMP (Symbol.look' env id)

100 | trans_exp env vartypes (A.ConstExp c) = T.CONST(c)

101 | trans_exp env vartypes (A.OpExp(oper, [e1, e2])) =

102 T.BINOP(trans_oper oper, trans_exp env vartypes e1, trans_exp env vartypes e2)

103 | trans_exp env vartypes (A.OpExp(oper, [e])) =

104 T.UNOP(trans_unop oper, trans_exp env vartypes e)

105 | trans_exp env vartypes (A.OpExp(oper, _)) =

106 raise ErrorMsg.InternalError "expected one or two operands, got it in the oven"

107 | trans_exp env vartypes (A.Marked(marked_exp)) =

108 trans_exp env vartypes (Mark.data marked_exp)

109 | trans_exp env vartypes (A.FuncCall(func, stms)) =

110 T.CALL(func,

111 List.map

112 (fn exp => (trans_exp env vartypes exp, Temp.sts (Type.size (typeof' vartypes exp))))

113 stms,

114 Temp.sts (Type.size (AstUtils.Function.returntype (Symbol.look' funcs func))))

115 | trans_exp env vartypes (A.Member (exp, id)) =

116 let

117 val apk = T.BINOP (T.ADD, trans_exp env vartypes exp, T.CONST (Word32.fromInt (offset_s id (typeof' vartypes exp))))

118 val tipo = type_s id (typeof' vartypes exp)

119 in

120 if Type.issmall tipo

121 then T.MEMORY(apk, Temp.sts (Type.size tipo))

122 else apk

123 end

124 | trans_exp env vartypes (A.DerefMember (exp, id)) =

125 trans_exp env vartypes (A.Member (A.Dereference (exp), id))

126 | trans_exp env vartypes (A.Dereference(exp)) =

127 if (Type.issmall (deref (typeof' vartypes exp)))

128 then T.MEMORY(trans_exp env vartypes exp, Temp.sts (Type.size (deref (typeof' vartypes exp))))

129 else trans_exp env vartypes exp

130 | trans_exp env vartypes (A.ArrIndex(exp1, exp2)) =

131 let

132 val asubk = T.BINOP(T.ADD, trans_exp env vartypes exp1,

133 T.BINOP(T.MUL, trans_exp env vartypes exp2,

134 T.CONST(Word32.fromInt(sizeof (deref (typeof' vartypes exp1))))))

135 val tipo = deref (typeof' vartypes exp1)

136 val d =

137 if not (Flag.isset Flags.safe)

138 then asubk

139 else T.COND (T.BINOP

140 (T.BE,

141 T.MEMORY (T.BINOP (

142 T.SUB,

143 trans_exp env vartypes exp1,

144 T.CONST 0w8), Temp.Long),

145 trans_exp env vartypes exp2),

146 T.NULLPTR,

147 asubk)

148 in

149 if Type.issmall tipo

150 then T.MEMORY(d, Temp.sts (Type.size tipo))

151 else d

152 end

153 | trans_exp env vartypes (A.New(tipo)) =

154 let

155 val t1 = T.TEMP (Temp.new "result" Temp.Quad)

156 in

157 T.STMVAR (

158 [T.MOVE (t1, T.ALLOC (T.CONST (Word32.fromInt(sizeof tipo)))),

159 T.EFFECT (T.MEMORY (t1, Temp.Long))],

160 t1)

161 end

162 | trans_exp env vartypes (A.NewArr(tipo, exp)) =

163 let

164 val size = T.BINOP(T.MUL, trans_exp env vartypes exp, T.CONST(Word32.fromInt(sizeof tipo)))

165 val t1 = T.TEMP (Temp.new "allocated address" Temp.Quad)

166 val ts = T.TEMP (Temp.new "size" Temp.Long)

167 in

168 if not (Flag.isset Flags.safe)

169 then T.STMVAR ([T.MOVE (t1, T.ALLOC size),

170 T.EFFECT (T.COND (T.BINOP (T.EQ, trans_exp env vartypes exp, T.CONST 0w0), T.CONST 0w0, T.MEMORY (t1, Temp.Long)))],

171 t1)

172 else T.COND (T.BINOP(T.EQ, size, T.CONST 0w0),

173 T.NULLPTR,

174 T.STMVAR (

175 [T.MOVE(t1,

176 T.COND(

177 T.BINOP(T.LT, size, T.CONST 0w0),

178 T.NULLPTR,

179 T.ALLOC (T.BINOP (T.ADD, size, T.CONST 0w8)))

180 ),

181 T.MOVE(T.MEMORY (t1, Temp.Long), trans_exp env vartypes exp)],

182 T.BINOP(T.ADD, t1, T.CONST 0w8)))

183 end

184 | trans_exp env vartypes (A.Null) = T.NULLPTR

185 | 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)

186

187 (* anything else should be impossible *)

188

189 (* trans_stms : Temp.temp Symbol.table -> (Label.label * Label.label) option -> A.stm list -> Tree.stm list

190 * translates a statement to the corresponding IR

191 * we pass around the environment and the current loop context, if any

192 * (usually called ls, which contains a continue label and a break label)

193 *)

194 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)

195 | trans_stms vars vartypes ls (A.AsnOp(oop,e1,e2)::stms) =

196 let

197 val te1 = trans_exp vars vartypes e1

198 val te2 = trans_exp vars vartypes e2

199 val t1 = T.TEMP (Temp.new "memory deref cache" Temp.Quad)

200 in

201 case te1

202 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)

203 | _ => T.MOVE(te1, T.BINOP(trans_oper oop, te1, te2)) :: (trans_stms vars vartypes ls stms)

204 end

205 | trans_stms vars vartypes ls (A.Return e::stms) =

206 let

207 val remainder = trans_stms vars vartypes ls stms

208 in

209 T.RETURN (trans_exp vars vartypes e, Temp.sts (Type.size (typeof' vartypes e)))

210 :: remainder

211 end

212 | trans_stms vars vartypes ls (A.If(e, s, NONE)::stms) =

213 let

214 val l = Label.new ()

215 val strans = trans_stms vars vartypes ls s

216 val remainder = trans_stms vars vartypes ls stms

217 in

218 (T.JUMPIFN(trans_exp vars vartypes e, l)

219 :: strans

220 @ [T.LABEL (l)]

221 @ remainder)

222 end

223 | trans_stms vars vartypes ls (A.If(e, s, SOME s2)::stms) =

224 let

225 val l = Label.new ()

226 val l2 = Label.new ()

227 val s1trans = trans_stms vars vartypes ls s

228 val s2trans = trans_stms vars vartypes ls s2

229 val remainder = trans_stms vars vartypes ls stms

230 in

231 (T.JUMPIFN(trans_exp vars vartypes e, l)

232 :: s1trans

233 @ [T.JUMP (l2), T.LABEL (l)]

234 @ s2trans

235 @ [T.LABEL (l2)]

236 @ remainder)

237 end

238 | trans_stms vars vartypes ls (A.For(s1, e, s2, s)::stms) =

239 let

240 val head = Label.new ()

241 val tail = Label.new ()

242 val loop = Label.new ()

243 val stm1 = if isSome s1 then trans_stms vars vartypes NONE [valOf s1] else nil

244 val strans = trans_stms vars vartypes (SOME(loop,tail)) s

245 val stm2 = if isSome s2 then trans_stms vars vartypes NONE [valOf s2] else nil

246 val remainder = trans_stms vars vartypes ls stms

247 in

248 (stm1

249 @ [T.LABEL head, T.JUMPIFN(trans_exp vars vartypes e, tail)]

250 @ strans

251 @ [T.LABEL loop]

252 @ stm2

253 @ [T.JUMP head, T.LABEL tail]

254 @ remainder)

255 end

256 | trans_stms vars vartypes ls (A.While(e, s)::stms) =

257 let

258 val head = Label.new ()

259 val tail = Label.new ()

260 val strans = trans_stms vars vartypes (SOME(head,tail)) s

261 val remainder = trans_stms vars vartypes ls stms

262 in

263 (T.LABEL head

264 :: T.JUMPIFN(trans_exp vars vartypes e, tail)

265 :: strans

266 @ [T.JUMP head, T.LABEL tail]

267 @ remainder)

268 end

269 | trans_stms vars vartypes ls (A.Effect(e)::stms) = (T.EFFECT (trans_exp vars vartypes e)) :: (trans_stms vars vartypes ls stms)

270 | trans_stms vars vartypes (SOME(b,e)) (A.Break::stms) =

271 let

272 val remainder = trans_stms vars vartypes (SOME(b,e)) stms

273 in

274 ((T.JUMP e) :: remainder)

275 end

276 | trans_stms vars vartypes NONE (A.Break::_) = raise ErrorMsg.InternalError "Break from invalid location... should have been caught in typechecker"

277 | trans_stms vars vartypes (SOME(b,e)) (A.Continue::stms) =

278 let

279 val remainder = trans_stms vars vartypes (SOME(b,e)) stms

280 in

281 ((T.JUMP b) :: remainder)

282 end

283 | trans_stms vars vartypes NONE (A.Continue::_) = raise ErrorMsg.InternalError "Continue from invalid location... should have been caught in typechecker"

284 | trans_stms vars vartypes ls (A.Nop::stms) = trans_stms vars vartypes ls stms

285 | trans_stms vars vartypes ls (A.MarkedStm m :: stms) = trans_stms vars vartypes ls ((Mark.data m) :: stms)

286 | trans_stms vars vartypes _ nil = nil

287

288 fun trans_funcs ((id, A.Extern(_, _))::l) = trans_funcs l

289 | trans_funcs ((id, A.MarkedFunction a)::l) = trans_funcs ((id, Mark.data a)::l)

290 | trans_funcs ((id, A.Function(t, args, vars, body))::l) =

291 let

292 val allvars = foldr

293 (fn ((name, t),b) =>

294 Symbol.bind b (name, Temp.new (Symbol.name(name)) (Temp.sts (Type.size t))))

295 Symbol.empty

296 (args @ vars)

297 val vartypes = foldr (fn ((i, t), b) => Symbol.bind b (i, t)) Symbol.empty (args @ vars)

298 val b = trans_stms allvars vartypes NONE body

299 val (argn,_) = ListPair.unzip args

300 val numberedargs = ListPair.zip (List.tabulate (length argn, fn x => x), argn)

301 val argmv = map

302 (fn (n, argname) => T.MOVE(T.TEMP (Symbol.look' allvars argname), T.ARG (n, Temp.size (Symbol.look' allvars argname))))

303 numberedargs

304 in

305 (T.FUNCTION(id, argmv @ b)) :: (trans_funcs l)

306 end

307 | trans_funcs nil = nil

308

309 in

310 trans_funcs funclist

311 end

312 end