-
Notifications
You must be signed in to change notification settings - Fork 2
/
codegen.ml
472 lines (426 loc) · 26.3 KB
/
codegen.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
(* Code generation: translate takes a semantically checked AST and
produces LLVM IR
LLVM tutorial: Make sure to read the OCaml version of the tutorial
http://llvm.org/docs/tutorial/index.html
Detailed documentation on the OCaml LLVM library:
http://llvm.moe/
http://llvm.moe/ocaml/
*)
module L = Llvm
module A = Ast
open Sast
module StringMap = Map.Make(String)
(* translate : Sast.program -> Llvm.module *)
let translate (globals, functions) =
let context = L.global_context () in
(* Create the LLVM compilation module into which
we will generate code *)
let the_module = L.create_module context "redpandas" in
(* Get types from the context *)
let i32_t = L.i32_type context
and i8_t = L.i8_type context
and i1_t = L.i1_type context
and float_t = L.double_type context
and void_t = L.void_type context
and pointer_t = L.pointer_type
and array_t = L.array_type
in
(* Return the LLVM type for a redpandas type *)
let ltype_of_typ = function
A.Int -> i32_t
| A.Bool -> i1_t
| A.Float -> float_t
| A.Void -> void_t
| A.String -> pointer_t i8_t
| A.Matrix(t,r,c) ->
let rows = match r with s -> s
| _ -> raise(Failure"Integer required for matrix dimension") in
let cols = match c with s -> s
| _ -> raise(Failure"Integer required for matrix dimension") in
(match t with
A.Int -> array_t (array_t i32_t cols) rows
| A.Float -> array_t (array_t float_t cols) rows
| _ -> raise(Failure"Invalid datatype for matrix"))
in
(* Create a map of global variables after creating each *)
let global_vars : L.llvalue StringMap.t =
let global_var m (t, n) =
let init = match t with
A.Float -> L.const_float (ltype_of_typ t) 0.0
| _ -> L.const_int (ltype_of_typ t) 0
in StringMap.add n (L.define_global n init the_module) m in
List.fold_left global_var StringMap.empty globals in
let printf_t : L.lltype =
L.var_arg_function_type i32_t [| L.pointer_type i8_t |] in
let printf_func : L.llvalue =
L.declare_function "printf" printf_t the_module in
let printbig_t : L.lltype =
L.function_type i32_t [| i32_t |] in
let printbig_func : L.llvalue =
L.declare_function "printbig" printbig_t the_module in
(* Define each function (arguments and return type) so we can
call it even before we've created its body *)
let function_decls : (L.llvalue * sfunc_decl) StringMap.t =
let function_decl m fdecl =
let name = fdecl.sfname
and formal_types =
Array.of_list (List.map (fun (t,_) -> ltype_of_typ t) fdecl.sformals)
in let ftype = L.function_type (ltype_of_typ fdecl.styp) formal_types in
StringMap.add name (L.define_function name ftype the_module, fdecl) m in
List.fold_left function_decl StringMap.empty functions in
(* Fill in the body of the given function *)
let build_function_body fdecl =
let (the_function, _) = StringMap.find fdecl.sfname function_decls in
let builder = L.builder_at_end context (L.entry_block the_function) in
let int_format_str = L.build_global_stringptr "%d\t" "fmt" builder
and string_format_str = L.build_global_stringptr "%s\n" "fmt" builder
and float_format_str = L.build_global_stringptr "%g\t" "fmt" builder in
(* Construct the function's "locals": formal arguments and locally
declared variables. Allocate each on the stack, initialize their
value, if appropriate, and remember their values in the "locals" map *)
let local_vars =
let add_formal m (t, n) p =
L.set_value_name n p;
let local = L.build_alloca (ltype_of_typ t) n builder in
ignore (L.build_store p local builder);
StringMap.add n local m
(* Allocate space for any locally declared variables and add the
* resulting registers to our map *)
and add_local m (t, n) =
let local_var = L.build_alloca (ltype_of_typ t) n builder
in StringMap.add n local_var m
in
let formals = List.fold_left2 add_formal StringMap.empty fdecl.sformals
(Array.to_list (L.params the_function)) in
List.fold_left add_local formals fdecl.slocals
in
(* Return the value for a variable or formal argument.
Check local names first, then global names *)
let lookup n = try StringMap.find n local_vars
with Not_found -> StringMap.find n global_vars
in
let accessValue s r c builder a =
let specific = L.build_gep (lookup s) [|L.const_int i32_t 0; r; c|] s builder in
if a then specific else L.build_load specific s builder
in
(* Construct code for an expression; return its value *)
let rec expr builder ((_, e) : sexpr) = match e with
SLiteral i -> L.const_int i32_t i
| SBoolLit b -> L.const_int i1_t (if b then 1 else 0)
| SFliteral l -> L.const_float_of_string float_t l
| SStrLit s -> L.build_global_stringptr s "tmp" builder
| SNoexpr -> L.const_int i32_t 0
| SId s -> L.build_load (lookup s) s builder
| SMat (t, mat) ->
let innertype = match t with
A.Float -> float_t
| A.Int -> i32_t
| _ -> i32_t
in
let lists = List.map (List.map (expr builder)) mat in
let innerArray = List.map Array.of_list lists in
let list2array = Array.of_list ((List.map (L.const_array innertype) innerArray)) in
L.const_array (array_t innertype (List.length (List.hd mat))) list2array
| SCol (c) -> L.const_int i32_t c
| SRow (r) -> L.const_int i32_t r
| STran (s,t) ->
let typ = match t with
Matrix(Int, _, _) -> i32_t | Matrix(Float, _, _) -> float_t| _ -> i32_t in
(match t with
Matrix(Int, c, r) | Matrix(Float, c, r) ->
let tempAlloc = L.build_alloca (array_t (array_t typ c) r) "tmpmat" builder in
for i=0 to (c-1) do
for j=0 to (r-1) do
let temp = accessValue s (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let l = L.build_gep tempAlloc [| L.const_int i32_t 0; L.const_int i32_t j; L.const_int i32_t i |] "tmpmat" builder in
ignore(L.build_store temp l builder);
done
done;
L.build_load (L.build_gep tempAlloc [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| _ -> L.const_int i32_t 0)
| SAccess (s,r,c) -> let a = expr builder r and b = expr builder c in
(accessValue s a b builder false)
| SAssign (s, e) -> let e' = expr builder e and
s' = (match s with
(_, SAccess(t,r,c)) -> let a = expr builder r and b = expr builder c in
accessValue t a b builder true
| (_,SId(t)) -> lookup t
| _ -> raise(Failure "Value is not assignable")) in
ignore(L.build_store e' s' builder); e'
| SBinop ((A.Float,_ ) as e1, op, e2) ->
let e1' = expr builder e1
and e2' = expr builder e2 in
(match op with
A.Add -> L.build_fadd
| A.Sub -> L.build_fsub
| A.Mult -> L.build_fmul
| A.Div -> L.build_fdiv
| A.Equal -> L.build_fcmp L.Fcmp.Oeq
| A.Neq -> L.build_fcmp L.Fcmp.One
| A.Less -> L.build_fcmp L.Fcmp.Olt
| A.Leq -> L.build_fcmp L.Fcmp.Ole
| A.Greater -> L.build_fcmp L.Fcmp.Ogt
| A.Geq -> L.build_fcmp L.Fcmp.Oge
| A.And | A.Or ->
raise (Failure "internal error: semant should have rejected and/or on float")
| _ -> raise (Failure "error: not a viable int to int operation")
) e1' e2' "tmp" builder
| SBinop (e1, op, e2) ->
let e1' = expr builder e1
and e2' = expr builder e2
and (typ1,_) = e1
and (typ2,_) = e2 in
let str1 = (match e1 with (_, SId(s)) -> s | _ -> "") in
let str2 = (match e2 with (_, SId(s)) -> s | _ -> "") in
(match (typ1, typ2) with
| (Int, Int) -> (match op with
A.Add -> L.build_add
| A.Sub -> L.build_sub
| A.Mult -> L.build_mul
| A.Div -> L.build_sdiv
| A.And -> L.build_and
| A.Or -> L.build_or
| A.Equal -> L.build_icmp L.Icmp.Eq
| A.Neq -> L.build_icmp L.Icmp.Ne
| A.Less -> L.build_icmp L.Icmp.Slt
| A.Leq -> L.build_icmp L.Icmp.Sle
| A.Greater -> L.build_icmp L.Icmp.Sgt
| A.Geq -> L.build_icmp L.Icmp.Sge
| _ -> raise (Failure "error: not a viable int to int operation") ) e1' e2' "tmp" builder
| (Matrix(Int, a1, b1), Matrix(Int, _, b2)) ->
(match op with
| A.Add ->
let temp = L.build_alloca (array_t (array_t i32_t b2) a1) "tmpmat" builder in
for i = 0 to (a1-1) do
for j = 0 to (b2-1) do
let mat1 = accessValue str1 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let mat2 = accessValue str2 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let final = L.build_add mat1 mat2 "tmp" builder in
let l = L.build_gep temp [| L.const_int i32_t 0; L.const_int i32_t i; L.const_int i32_t j |] "tmpmat" builder in
ignore(L.build_store final l builder);
done
done;
L.build_load (L.build_gep temp [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| A.Sub ->
let temp = L.build_alloca (array_t (array_t i32_t b2) a1) "tmpmat" builder in
for i = 0 to (a1-1) do
for j = 0 to (b2-1) do
let mat1 = accessValue str1 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let mat2 = accessValue str2 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let final = L.build_sub mat1 mat2 "tmp" builder in
let l = L.build_gep temp [| L.const_int i32_t 0; L.const_int i32_t i; L.const_int i32_t j |] "tmpmat" builder in
ignore(L.build_store final l builder);
done
done;
L.build_load (L.build_gep temp [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| A.Elmult ->
let temp = L.build_alloca (array_t (array_t i32_t b2) a1) "tmpmat" builder in
for i = 0 to (a1-1) do
for j = 0 to (b2-1) do
let mat1 = accessValue str1 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let mat2 = accessValue str2 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let final = L.build_mul mat1 mat2 "tmp" builder in
let l = L.build_gep temp [| L.const_int i32_t 0; L.const_int i32_t i; L.const_int i32_t j |] "tmpmat" builder in
ignore(L.build_store final l builder);
done
done;
L.build_load (L.build_gep temp [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| A.Eldiv ->
let temp = L.build_alloca (array_t (array_t i32_t b2) a1) "tmpmat" builder in
for i = 0 to (a1-1) do
for j = 0 to (b2-1) do
let mat1 = accessValue str1 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let mat2 = accessValue str2 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let final = L.build_sdiv mat1 mat2 "tmp" builder in
let l = L.build_gep temp [| L.const_int i32_t 0; L.const_int i32_t i; L.const_int i32_t j |] "tmpmat" builder in
ignore(L.build_store final l builder);
done
done;
L.build_load (L.build_gep temp [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| A.Mult ->
let temp = L.build_alloca (array_t (array_t i32_t b2) a1) "tmpmat" builder in
let temp_val = L.build_alloca i32_t "tmpval" builder in
ignore (L.build_store (L.const_int i32_t 0) temp_val builder);
for i = 0 to (a1-1) do
for j = 0 to (b2-1) do
ignore (L.build_store (L.const_int i32_t 0) temp_val builder);
for k = 0 to (b1-1) do
let mat1 = accessValue str1 (L.const_int i32_t i) (L.const_int i32_t k) builder false in
let mat2 = accessValue str2 (L.const_int i32_t k) (L.const_int i32_t j) builder false in
let final = L.build_mul mat1 mat2 "tmp" builder in
ignore(L.build_store (L.build_add final (L.build_load temp_val "addtmp" builder) "tmp" builder) temp_val builder);
done;
let l = L.build_gep temp [| L.const_int i32_t 0; L.const_int i32_t i; L.const_int i32_t j |] "tmpmat" builder in
ignore(L.build_store (L.build_load temp_val "restmp" builder) l builder);
done
done;
L.build_load (L.build_gep temp [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| _ -> raise (Failure "error: not a viable matrix to matrix operation")
)
| (Matrix(Float, a1, b1), Matrix(Float, _, b2)) ->
(match op with
| A.Add ->
let temp = L.build_alloca (array_t (array_t float_t b2) a1) "tmpmat" builder in
for i = 0 to (a1-1) do
for j = 0 to (b2-1) do
let mat1 = accessValue str1 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let mat2 = accessValue str2 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let final = L.build_fadd mat1 mat2 "tmp" builder in
let l = L.build_gep temp [| L.const_int i32_t 0; L.const_int i32_t i; L.const_int i32_t j |] "tmpmat" builder in
ignore(L.build_store final l builder);
done
done;
L.build_load (L.build_gep temp [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| A.Sub ->
let temp = L.build_alloca (array_t (array_t float_t b2) a1) "tmpmat" builder in
for i = 0 to (a1-1) do
for j = 0 to (b2-1) do
let mat1 = accessValue str1 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let mat2 = accessValue str2 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let final = L.build_fsub mat1 mat2 "tmp" builder in
let l = L.build_gep temp [| L.const_int i32_t 0; L.const_int i32_t i; L.const_int i32_t j |] "tmpmat" builder in
ignore(L.build_store final l builder);
done
done;
L.build_load (L.build_gep temp [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| A.Elmult ->
let temp = L.build_alloca (array_t (array_t float_t b2) a1) "tmpmat" builder in
for i = 0 to (a1-1) do
for j = 0 to (b2-1) do
let mat1 = accessValue str1 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let mat2 = accessValue str2 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let final = L.build_fmul mat1 mat2 "tmp" builder in
let l = L.build_gep temp [| L.const_int i32_t 0; L.const_int i32_t i; L.const_int i32_t j |] "tmpmat" builder in
ignore(L.build_store final l builder);
done
done;
L.build_load (L.build_gep temp [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| A.Eldiv ->
let temp = L.build_alloca (array_t (array_t float_t b2) a1) "tmpmat" builder in
for i = 0 to (a1-1) do
for j = 0 to (b2-1) do
let mat1 = accessValue str1 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let mat2 = accessValue str2 (L.const_int i32_t i) (L.const_int i32_t j) builder false in
let final = L.build_fdiv mat1 mat2 "tmp" builder in
let l = L.build_gep temp [| L.const_int i32_t 0; L.const_int i32_t i; L.const_int i32_t j |] "tmpmat" builder in
ignore(L.build_store final l builder);
done
done;
L.build_load (L.build_gep temp [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| A.Mult ->
let temp = L.build_alloca (array_t (array_t i32_t b2) a1) "tmpmat" builder in
let temp_val = L.build_alloca float_t "tmpval" builder in
ignore (L.build_store (L.const_float float_t 0.0) temp_val builder);
for i = 0 to (a1-1) do
for j = 0 to (b2-1) do
ignore (L.build_store (L.const_float float_t 0.0) temp_val builder);
for k = 0 to (b1-1) do
let mat1 = accessValue str1 (L.const_int i32_t i) (L.const_int i32_t k) builder false in
let mat2 = accessValue str2 (L.const_int i32_t k) (L.const_int i32_t j) builder false in
let final = L.build_fmul mat1 mat2 "tmp" builder in
ignore(L.build_store (L.build_fadd final (L.build_load temp_val "addtmp" builder) "tmp" builder) temp_val builder);
done;
let l = L.build_gep temp [| L.const_int i32_t 0; L.const_int i32_t i; L.const_int i32_t j |] "tmpmat" builder in
ignore(L.build_store (L.build_load temp_val "restmp" builder) l builder);
done
done;
L.build_load (L.build_gep temp [| L.const_int i32_t 0 |] "tmpmat" builder) "tmpmat" builder
| _ -> raise (Failure "error: not a viable matrix to matrix operation")
)
| _ -> (match op with
A.Add -> L.build_add
| A.Sub -> L.build_sub
| A.Mult -> L.build_mul
| A.Div -> L.build_sdiv
| A.And -> L.build_and
| A.Or -> L.build_or
| A.Equal -> L.build_icmp L.Icmp.Eq
| A.Neq -> L.build_icmp L.Icmp.Ne
| A.Less -> L.build_icmp L.Icmp.Slt
| A.Leq -> L.build_icmp L.Icmp.Sle
| A.Greater -> L.build_icmp L.Icmp.Sgt
| A.Geq -> L.build_icmp L.Icmp.Sge
| _ -> raise (Failure "error: not a viable operation") ) e1' e2' "tmp" builder
)
| SUnop(op, ((t, _) as e)) ->
let e' = expr builder e in
(match op with
A.Neg when t = A.Float -> L.build_fneg
| A.Neg -> L.build_neg
| A.Not -> L.build_not) e' "tmp" builder
| SCall ("print", [e]) | SCall ("printb", [e]) ->
L.build_call printf_func [| int_format_str ; (expr builder e) |]
"printf" builder
| SCall ("printbig", [e]) ->
L.build_call printbig_func [| (expr builder e) |] "printbig" builder
| SCall ("printf", [e]) ->
L.build_call printf_func [| float_format_str ; (expr builder e) |]
"printf" builder
| SCall ("printStr", [e]) ->
L.build_call printf_func [| string_format_str ; (expr builder e) |]
"printf" builder
| SCall (f, args) ->
let (fdef, fdecl) = StringMap.find f function_decls in
let llargs = List.rev (List.map (expr builder) (List.rev args)) in
let result = (match fdecl.styp with
A.Void -> ""
| _ -> f ^ "_result") in
L.build_call fdef (Array.of_list llargs) result builder
in
(* LLVM insists each basic block end with exactly one "terminator"
instruction that transfers control. This function runs "instr builder"
if the current block does not already have a terminator. Used,
e.g., to handle the "fall off the end of the function" case. *)
let add_terminal builder instr =
match L.block_terminator (L.insertion_block builder) with
Some _ -> ()
| None -> ignore (instr builder) in
(* Build the code for the given statement; return the builder for
the statement's successor (i.e., the next instruction will be built
after the one generated by this call) *)
let rec stmt builder = function
SBlock sl -> List.fold_left stmt builder sl
| SExpr e -> ignore(expr builder e); builder
| SReturn e -> ignore(match fdecl.styp with
(* Special "return nothing" instr *)
A.Void -> L.build_ret_void builder
(* Build return statement *)
| _ -> L.build_ret (expr builder e) builder );
builder
| SIf (predicate, then_stmt, else_stmt) ->
let bool_val = expr builder predicate in
let merge_bb = L.append_block context "merge" the_function in
let build_br_merge = L.build_br merge_bb in (* partial function *)
let then_bb = L.append_block context "then" the_function in
add_terminal (stmt (L.builder_at_end context then_bb) then_stmt)
build_br_merge;
let else_bb = L.append_block context "else" the_function in
add_terminal (stmt (L.builder_at_end context else_bb) else_stmt)
build_br_merge;
ignore(L.build_cond_br bool_val then_bb else_bb builder);
L.builder_at_end context merge_bb
| SWhile (predicate, body) ->
let pred_bb = L.append_block context "while" the_function in
ignore(L.build_br pred_bb builder);
let body_bb = L.append_block context "while_body" the_function in
add_terminal (stmt (L.builder_at_end context body_bb) body)
(L.build_br pred_bb);
let pred_builder = L.builder_at_end context pred_bb in
let bool_val = expr pred_builder predicate in
let merge_bb = L.append_block context "merge" the_function in
ignore(L.build_cond_br bool_val body_bb merge_bb pred_builder);
L.builder_at_end context merge_bb
(* Implement for loops as while loops *)
| SFor (e1, e2, e3, body) -> stmt builder
( SBlock [SExpr e1 ; SWhile (e2, SBlock [body ; SExpr e3]) ] )
in
(* Build the code for each statement in the function *)
let builder = stmt builder (SBlock fdecl.sbody) in
(* Add a return if the last block falls off the end *)
add_terminal builder (match fdecl.styp with
A.Void -> L.build_ret_void
| A.Float -> L.build_ret (L.const_float float_t 0.0)
| t -> L.build_ret (L.const_int (ltype_of_typ t) 0))
in
List.iter build_function_body functions;
the_module