Source file compile_from_lambda.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
open Utils
module A = Ast
module L = Lcalc.Ast
module D = Dcalc.Ast
type ctxt = {
func_dict : A.TopLevelName.t L.VarMap.t;
decl_ctx : D.decl_ctx;
var_dict : A.LocalName.t L.VarMap.t;
inside_definition_of : A.LocalName.t option;
context_name : string;
}
let rec translate_expr (ctxt : ctxt) (expr : 'm L.marked_expr) :
A.block * A.expr Marked.pos =
match Marked.unmark expr with
| L.EVar v ->
let local_var =
try A.EVar (L.VarMap.find (L.Var.t v) ctxt.var_dict)
with Not_found -> A.EFunc (L.VarMap.find (L.Var.t v) ctxt.func_dict)
in
[], (local_var, D.pos expr)
| L.ETuple (args, Some s_name) ->
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, new_arg :: new_args)
([], []) args
in
let new_args = List.rev new_args in
let args_stmts = List.rev args_stmts in
args_stmts, (A.EStruct (new_args, s_name), D.pos expr)
| L.ETuple (_, None) ->
failwith "Non-struct tuples cannot be compiled to scalc"
| L.ETupleAccess (e1, num_field, Some s_name, _) ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let field_name =
fst
(List.nth (D.StructMap.find s_name ctxt.decl_ctx.ctx_structs) num_field)
in
e1_stmts, (A.EStructFieldAccess (new_e1, field_name, s_name), D.pos expr)
| L.ETupleAccess (_, _, None, _) ->
failwith "Non-struct tuples cannot be compiled to scalc"
| L.EInj (e1, num_cons, e_name, _) ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let cons_name =
fst (List.nth (D.EnumMap.find e_name ctxt.decl_ctx.ctx_enums) num_cons)
in
e1_stmts, (A.EInj (new_e1, cons_name, e_name), D.pos expr)
| L.EApp (f, args) ->
let f_stmts, new_f = translate_expr ctxt f in
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, new_arg :: new_args)
([], []) args
in
let new_args = List.rev new_args in
f_stmts @ args_stmts, (A.EApp (new_f, new_args), D.pos expr)
| L.EArray args ->
let args_stmts, new_args =
List.fold_left
(fun (args_stmts, new_args) arg ->
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ args_stmts, new_arg :: new_args)
([], []) args
in
let new_args = List.rev new_args in
args_stmts, (A.EArray new_args, D.pos expr)
| L.EOp op -> [], (A.EOp op, D.pos expr)
| L.ELit l -> [], (A.ELit l, D.pos expr)
| _ ->
let tmp_var =
A.LocalName.fresh
(
(match ctxt.inside_definition_of with
| None -> ctxt.context_name
| Some v ->
let v = Marked.unmark (A.LocalName.get_info v) in
let tmp_rex = Re.Pcre.regexp "^temp_" in
if Re.Pcre.pmatch ~rex:tmp_rex v then v else "temp_" ^ v),
D.pos expr )
in
let ctxt =
{
ctxt with
inside_definition_of = Some tmp_var;
context_name = Marked.unmark (A.LocalName.get_info tmp_var);
}
in
let tmp_stmts = translate_statements ctxt expr in
( (A.SLocalDecl ((tmp_var, D.pos expr), (D.TAny, D.pos expr)), D.pos expr)
:: tmp_stmts,
(A.EVar tmp_var, D.pos expr) )
and translate_statements (ctxt : ctxt) (block_expr : 'm L.marked_expr) : A.block
=
match Marked.unmark block_expr with
| L.EAssert e ->
let e_stmts, new_e = translate_expr ctxt e in
e_stmts @ [A.SAssert (Marked.unmark new_e), D.pos block_expr]
| L.EApp ((L.EAbs (binder, taus), binder_mark), args) ->
let binder_pos = D.mark_pos binder_mark in
let vars, body = Bindlib.unmbind binder in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) taus in
let ctxt =
{
ctxt with
var_dict =
List.fold_left
(fun var_dict (x, _) ->
L.VarMap.add (L.Var.t x)
(A.LocalName.fresh (Bindlib.name_of x, binder_pos))
var_dict)
ctxt.var_dict vars_tau;
}
in
let local_decls =
List.map
(fun (x, tau) ->
( A.SLocalDecl
((L.VarMap.find (L.Var.t x) ctxt.var_dict, binder_pos), tau),
binder_pos ))
vars_tau
in
let vars_args =
List.map2
(fun (x, tau) arg ->
(L.VarMap.find (L.Var.t x) ctxt.var_dict, binder_pos), tau, arg)
vars_tau args
in
let def_blocks =
List.map
(fun (x, _tau, arg) ->
let ctxt =
{
ctxt with
inside_definition_of = Some (Marked.unmark x);
context_name =
Marked.unmark (A.LocalName.get_info (Marked.unmark x));
}
in
let arg_stmts, new_arg = translate_expr ctxt arg in
arg_stmts @ [A.SLocalDef (x, new_arg), binder_pos])
vars_args
in
let rest_of_block = translate_statements ctxt body in
local_decls @ List.flatten def_blocks @ rest_of_block
| L.EAbs (binder, taus) ->
let vars, body = Bindlib.unmbind binder in
let binder_pos = D.pos block_expr in
let vars_tau = List.map2 (fun x tau -> x, tau) (Array.to_list vars) taus in
let closure_name =
match ctxt.inside_definition_of with
| None -> A.LocalName.fresh (ctxt.context_name, D.pos block_expr)
| Some x -> x
in
let ctxt =
{
ctxt with
var_dict =
List.fold_left
(fun var_dict (x, _) ->
L.VarMap.add (L.Var.t x)
(A.LocalName.fresh (Bindlib.name_of x, binder_pos))
var_dict)
ctxt.var_dict vars_tau;
inside_definition_of = None;
}
in
let new_body = translate_statements ctxt body in
[
( A.SInnerFuncDef
( (closure_name, binder_pos),
{
func_params =
List.map
(fun (var, tau) ->
(L.VarMap.find (L.Var.t var) ctxt.var_dict, binder_pos), tau)
vars_tau;
func_body = new_body;
} ),
binder_pos );
]
| L.EMatch (e1, args, e_name) ->
let e1_stmts, new_e1 = translate_expr ctxt e1 in
let new_args =
List.fold_left
(fun new_args arg ->
match Marked.unmark arg with
| L.EAbs (binder, _) ->
let vars, body = Bindlib.unmbind binder in
assert (Array.length vars = 1);
let var = vars.(0) in
let scalc_var =
A.LocalName.fresh (Bindlib.name_of var, D.pos arg)
in
let ctxt =
{
ctxt with
var_dict = L.VarMap.add (L.Var.t var) scalc_var ctxt.var_dict;
}
in
let new_arg = translate_statements ctxt body in
(new_arg, scalc_var) :: new_args
| _ -> assert false
)
[] args
in
let new_args = List.rev new_args in
e1_stmts @ [A.SSwitch (new_e1, e_name, new_args), D.pos block_expr]
| L.EIfThenElse (cond, e_true, e_false) ->
let cond_stmts, s_cond = translate_expr ctxt cond in
let s_e_true = translate_statements ctxt e_true in
let s_e_false = translate_statements ctxt e_false in
cond_stmts @ [A.SIfThenElse (s_cond, s_e_true, s_e_false), D.pos block_expr]
| L.ECatch (e_try, except, e_catch) ->
let s_e_try = translate_statements ctxt e_try in
let s_e_catch = translate_statements ctxt e_catch in
[A.STryExcept (s_e_try, except, s_e_catch), D.pos block_expr]
| L.ERaise except ->
(match ctxt.inside_definition_of with
| None -> []
| Some x ->
[
( A.SLocalDef
((x, D.pos block_expr), (Ast.EVar Ast.dead_value, D.pos block_expr)),
D.pos block_expr );
])
@ [A.SRaise except, D.pos block_expr]
| _ -> (
let e_stmts, new_e = translate_expr ctxt block_expr in
e_stmts
@
match e_stmts with
| (A.SRaise _, _) :: _ ->
[]
| _ ->
[
( (match ctxt.inside_definition_of with
| None -> A.SReturn (Marked.unmark new_e)
| Some x -> A.SLocalDef (Marked.same_mark_as x new_e, new_e)),
D.pos block_expr );
])
let rec translate_scope_body_expr
(scope_name : D.ScopeName.t)
(decl_ctx : D.decl_ctx)
(var_dict : A.LocalName.t L.VarMap.t)
(func_dict : A.TopLevelName.t L.VarMap.t)
(scope_expr : ('m L.expr, 'm) D.scope_body_expr) : A.block =
match scope_expr with
| Result e ->
let block, new_e =
translate_expr
{
decl_ctx;
func_dict;
var_dict;
inside_definition_of = None;
context_name = Marked.unmark (D.ScopeName.get_info scope_name);
}
e
in
block @ [A.SReturn (Marked.unmark new_e), Marked.get_mark new_e]
| ScopeLet scope_let ->
let let_var, scope_let_next = Bindlib.unbind scope_let.scope_let_next in
let let_var_id =
A.LocalName.fresh (Bindlib.name_of let_var, scope_let.scope_let_pos)
in
let new_var_dict = L.VarMap.add (L.Var.t let_var) let_var_id var_dict in
(match scope_let.scope_let_kind with
| D.Assertion ->
translate_statements
{
decl_ctx;
func_dict;
var_dict;
inside_definition_of = Some let_var_id;
context_name = Marked.unmark (D.ScopeName.get_info scope_name);
}
scope_let.scope_let_expr
| _ ->
let let_expr_stmts, new_let_expr =
translate_expr
{
decl_ctx;
func_dict;
var_dict;
inside_definition_of = Some let_var_id;
context_name = Marked.unmark (D.ScopeName.get_info scope_name);
}
scope_let.scope_let_expr
in
let_expr_stmts
@ [
( A.SLocalDecl
((let_var_id, scope_let.scope_let_pos), scope_let.scope_let_typ),
scope_let.scope_let_pos );
( A.SLocalDef ((let_var_id, scope_let.scope_let_pos), new_let_expr),
scope_let.scope_let_pos );
])
@ translate_scope_body_expr scope_name decl_ctx new_var_dict func_dict
scope_let_next
let translate_program (p : 'm L.program) : A.program =
{
decl_ctx = p.D.decl_ctx;
scopes =
(let _, new_scopes =
D.fold_left_scope_defs
~f:(fun (func_dict, new_scopes) scope_def scope_var ->
let scope_input_var, scope_body_expr =
Bindlib.unbind scope_def.scope_body.scope_body_expr
in
let input_pos =
Marked.get_mark (D.ScopeName.get_info scope_def.scope_name)
in
let scope_input_var_id =
A.LocalName.fresh (Bindlib.name_of scope_input_var, input_pos)
in
let var_dict =
L.VarMap.singleton (L.Var.t scope_input_var) scope_input_var_id
in
let new_scope_body =
translate_scope_body_expr scope_def.D.scope_name p.decl_ctx
var_dict func_dict scope_body_expr
in
let func_id =
A.TopLevelName.fresh (Bindlib.name_of scope_var, Pos.no_pos)
in
let func_dict =
L.VarMap.add (L.Var.t scope_var) func_id func_dict
in
( func_dict,
{
Ast.scope_body_name = scope_def.D.scope_name;
Ast.scope_body_var = func_id;
scope_body_func =
{
A.func_params =
[
( (scope_input_var_id, input_pos),
( D.TTuple
( List.map snd
(D.StructMap.find
scope_def.D.scope_body
.D.scope_body_input_struct
p.D.decl_ctx.ctx_structs),
Some
scope_def.D.scope_body
.D.scope_body_input_struct ),
input_pos ) );
];
A.func_body = new_scope_body;
};
}
:: new_scopes ))
~init:
( (if !Cli.avoid_exceptions_flag then
L.VarMap.singleton L.handle_default_opt A.handle_default_opt
else L.VarMap.singleton L.handle_default A.handle_default),
[] )
p.D.scopes
in
List.rev new_scopes);
}