Skip to content

Commit 8e7208f

Browse files
kkysenkkysen
committed
Working on codegen.
1 parent cb6068c commit 8e7208f

File tree

2 files changed

+212
-13
lines changed

2 files changed

+212
-13
lines changed

‎src/codegen.ml

Lines changed: 201 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,29 @@ module Scope = Map.Make (String)
66

77
type scope = LL.llvalue Scope.t
88

9+
type num_kind =
10+
| UnSigned
11+
| Signed
12+
| Float
13+
14+
let type_num_kind (t : type_) : num_kind option =
15+
match t with
16+
| IntType t ->
17+
Some
18+
(match t.unsigned with
19+
| true -> UnSigned
20+
| false -> Signed)
21+
| FloatType _ -> Some Float
22+
| PointerType _ -> Some UnSigned
23+
| _ -> None
24+
;;
25+
26+
let float_type_bits (t : float_type) : int =
27+
match t with
28+
| F32 -> 32
29+
| F64 -> 64
30+
;;
31+
932
let compile ~(lir : lir) ~(ctx : LL.llcontext) ~(mod_ : LL.llmodule) : unit =
1033
let rec compile_type (t : type_) : LL.lltype =
1134
match t with
@@ -61,20 +84,182 @@ let compile ~(lir : lir) ~(ctx : LL.llcontext) ~(mod_ : LL.llmodule) : unit =
6184
globals @ functions)
6285
in
6386

64-
let compile_expr (expr : expr) ~(scope : scope) : LL.llvalue =
65-
ignore expr;
66-
ignore scope;
67-
failwith "TODO"
87+
let compile_const (lit : literal) (t : type_) : LL.llvalue =
88+
let t = compile_type t in
89+
match lit with
90+
| Int i -> LL.const_int t i
91+
| Float f -> LL.const_float t f
92+
in
93+
94+
let rec compile_expr (expr : expr) ~(scope : scope) ~(irb : LL.llbuilder)
95+
: LL.llvalue
96+
=
97+
let {type_ = t; value} = expr in
98+
let value =
99+
match value with
100+
| Literal lit -> compile_const lit t
101+
| Var name -> Scope.find_exn scope name
102+
| UnaryOp (op, expr) ->
103+
let value = compile_expr expr ~scope ~irb in
104+
let t = LL.type_of value in
105+
let op =
106+
match op with
107+
| Negate -> LL.build_neg
108+
| Not -> LL.build_icmp LL.Icmp.Ne (LL.const_int t 0)
109+
| BitNot -> LL.build_not
110+
| AddressOf ->
111+
fun v n irb ->
112+
let var = LL.build_alloca t n irb in
113+
let store = LL.build_store v var irb in
114+
ignore store;
115+
var
116+
| Dereference -> LL.build_load
117+
in
118+
let value = op value "" irb in
119+
value
120+
| BinaryOp (lhs, op, rhs) ->
121+
let kind = type_num_kind expr.type_ in
122+
let lhs = compile_expr lhs ~scope ~irb in
123+
let rhs = compile_expr rhs ~scope ~irb in
124+
let op =
125+
match op with
126+
| Assign -> fun v p _n irb -> LL.build_store v p irb
127+
| Arithmetic op -> (
128+
let kind = Option.value_exn kind in
129+
match op with
130+
| Add -> LL.build_add
131+
| Subtract -> LL.build_sub
132+
| Multiply -> LL.build_mul
133+
| Divide -> (
134+
match kind with
135+
| UnSigned -> LL.build_udiv
136+
| Signed -> LL.build_sdiv
137+
| Float -> LL.build_fdiv)
138+
| Modulo -> (
139+
match kind with
140+
| UnSigned -> LL.build_urem
141+
| Signed -> LL.build_srem
142+
| Float -> LL.build_frem)
143+
| And | BitAnd -> LL.build_and
144+
| Or | BitOr -> LL.build_or
145+
| BitXor -> LL.build_xor
146+
| LeftShift -> LL.build_shl
147+
| RightShift -> (
148+
match kind with
149+
| UnSigned -> LL.build_lshr
150+
| Signed -> LL.build_ashr
151+
| Float -> failwith "float shift impossible"))
152+
| Comparison op -> (
153+
let kind = Option.value_exn kind in
154+
match kind with
155+
| UnSigned ->
156+
let pred =
157+
match op with
158+
| Equal -> LL.Icmp.Eq
159+
| NotEqual -> LL.Icmp.Ne
160+
| LessThan -> LL.Icmp.Ult
161+
| LessThanOrEqual -> LL.Icmp.Ule
162+
| GreaterThan -> LL.Icmp.Ugt
163+
| GreaterThanOrEqual -> LL.Icmp.Uge
164+
in
165+
LL.build_icmp pred
166+
| Signed ->
167+
let pred =
168+
match op with
169+
| Equal -> LL.Icmp.Eq
170+
| NotEqual -> LL.Icmp.Ne
171+
| LessThan -> LL.Icmp.Slt
172+
| LessThanOrEqual -> LL.Icmp.Sle
173+
| GreaterThan -> LL.Icmp.Sgt
174+
| GreaterThanOrEqual -> LL.Icmp.Sge
175+
in
176+
LL.build_icmp pred
177+
| Float ->
178+
let pred =
179+
match op with
180+
| Equal -> LL.Fcmp.Oeq
181+
| NotEqual -> LL.Fcmp.One
182+
| LessThan -> LL.Fcmp.Olt
183+
| LessThanOrEqual -> LL.Fcmp.Ole
184+
| GreaterThan -> LL.Fcmp.Ogt
185+
| GreaterThanOrEqual -> LL.Fcmp.Oge
186+
in
187+
LL.build_fcmp pred)
188+
in
189+
let value = op lhs rhs "" irb in
190+
value
191+
| Cast expr ->
192+
let value = compile_expr expr ~scope ~irb in
193+
let u = expr.type_ in
194+
let nop v _t _n _b = v in
195+
let op =
196+
match (u, t) with
197+
| (IntType u, IntType t) -> (
198+
match (u.unsigned, t.unsigned) with
199+
| (true, true) ->
200+
if u.bits < t.bits
201+
then LL.build_zext
202+
else if u.bits > t.bits
203+
then LL.build_trunc
204+
else nop
205+
| (false, false) ->
206+
if u.bits < t.bits
207+
then LL.build_sext
208+
else if u.bits > t.bits
209+
then LL.build_trunc
210+
else nop
211+
| (_, _) -> LL.build_bitcast)
212+
| (FloatType u, FloatType t) ->
213+
let ubits = float_type_bits u in
214+
let tbits = float_type_bits t in
215+
if ubits < tbits
216+
then LL.build_fpext
217+
else if ubits > tbits
218+
then LL.build_fptrunc
219+
else nop
220+
| (IntType u, FloatType _t) -> (
221+
match u.unsigned with
222+
| true -> LL.build_uitofp
223+
| false -> LL.build_sitofp)
224+
| (FloatType _u, IntType t) -> (
225+
match t.unsigned with
226+
| true -> LL.build_fptoui
227+
| false -> LL.build_fptosi)
228+
| (IntType _u, PointerType _v) -> LL.build_inttoptr
229+
| (PointerType _u, IntType _v) -> LL.build_ptrtoint
230+
| (_, _) -> LL.build_bitcast
231+
in
232+
let value = op value (compile_type t) "" irb in
233+
value
234+
| Call {callee; call_args = args} ->
235+
let callee = compile_expr callee ~scope ~irb in
236+
let args = args |> Array.map ~f:(compile_expr ~scope ~irb) in
237+
let value = LL.build_call callee args "" irb in
238+
value
239+
| If {condition; then_case; else_case} -> (
240+
let _condition = compile_expr condition ~scope ~irb in
241+
ignore then_case;
242+
ignore else_case;
243+
failwith "TODO: if"
244+
)
245+
| GoTo _expr -> (
246+
failwith "TODO goto"
247+
)
248+
| Block exprs ->
249+
exprs
250+
|> List.fold ~init:None ~f:(fun _ expr ->
251+
Some (compile_expr expr ~scope ~irb))
252+
|> Option.value_exn
253+
in
254+
value
68255
in
69256

70257
let compile_global (g : global) : unit =
71258
let {global_name = name; global_type = t; global_value = value} = g in
72259
let g = Scope.find_exn global_scope name in
73260
match value with
74261
| Some value ->
75-
let value =
76-
compile_expr {type_ = t; value = Literal value} ~scope:Scope.empty
77-
in
262+
let value = compile_const value t in
78263
LL.set_initializer value g
79264
| None ->
80265
LL.set_externally_initialized true g;
@@ -83,13 +268,19 @@ let compile ~(lir : lir) ~(ctx : LL.llcontext) ~(mod_ : LL.llmodule) : unit =
83268

84269
let compile_func_decl (decl : func_decl) (f : LL.llvalue) : unit =
85270
let {arg_names; func_value} = decl in
271+
let entry = LL.entry_block f in
272+
let irb = LL.builder_at_end ctx entry in
86273
let scope =
87274
Array.zip_exn arg_names (LL.params f)
88275
|> Array.fold ~init:global_scope ~f:(fun scope (name, param) ->
89-
LL.set_value_name name param;
90-
Scope.add_exn scope ~key:name ~data:param)
276+
LL.set_value_name (name ^ ".param") param;
277+
let t = LL.type_of param in
278+
let local = LL.build_alloca t name irb in
279+
let store = LL.build_store param local irb in
280+
ignore store;
281+
Scope.add_exn scope ~key:name ~data:local)
91282
in
92-
let ret_val = compile_expr func_value ~scope in
283+
let ret_val = compile_expr func_value ~scope ~irb in
93284
ignore ret_val;
94285
failwith "TODO"
95286
in

‎src/lir.ml

Lines changed: 11 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -55,8 +55,7 @@ type unary_op =
5555
| Dereference
5656
[@@deriving yojson]
5757

58-
type binary_op =
59-
| Assign
58+
type arithmetic_binary_op =
6059
| Add
6160
| Subtract
6261
| Multiply
@@ -69,6 +68,9 @@ type binary_op =
6968
| BitXor
7069
| LeftShift
7170
| RightShift
71+
[@@deriving yojson]
72+
73+
type comparison_op =
7274
| Equal
7375
| NotEqual
7476
| LessThan
@@ -77,6 +79,12 @@ type binary_op =
7779
| GreaterThanOrEqual
7880
[@@deriving yojson]
7981

82+
type binary_op =
83+
| Assign
84+
| Arithmetic of arithmetic_binary_op
85+
| Comparison of comparison_op
86+
[@@deriving yojson]
87+
8088
type label = string [@@deriving yojson]
8189

8290
type call_expr = {
@@ -101,7 +109,7 @@ and raw_expr =
101109
| Call of call_expr
102110
| If of if_expr
103111
| GoTo of expr
104-
| Block of expr list
112+
| Block of expr list (* non-empty *)
105113
[@@deriving yojson]
106114

107115
and expr = {

0 commit comments

Comments
 (0)