anil.recoil.org
My working unpac repository
1(**************************************************************************)
2(* *)
3(* OCaml *)
4(* *)
5(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6(* *)
7(* Copyright 1996 Institut National de Recherche en Informatique et *)
8(* en Automatique. *)
9(* *)
10(* All rights reserved. This file is distributed under the terms of *)
11(* the GNU Lesser General Public License version 2.1, with the *)
12(* special exception on linking described in the file LICENSE. *)
13(* *)
14(**************************************************************************)
15
16(* Translation from typed abstract syntax to lambda terms,
17 for the core language *)
18
19open Misc
20open Asttypes
21open Primitive
22open Types
23open Data_types
24open Typedtree
25open Typeopt
26open Lambda
27open Debuginfo.Scoped_location
28
29type error =
30 Free_super_var
31 | Unreachable_reached
32
33exception Error of Location.t * error
34
35let use_dup_for_constant_mutable_arrays_bigger_than = 4
36
37(* Forward declaration -- to be filled in by Translmod.transl_module *)
38let transl_module =
39 ref((fun ~scopes:_ _cc _rootpath _modl -> assert false) :
40 scopes:scopes -> module_coercion -> Path.t option ->
41 module_expr -> lambda)
42
43let transl_struct_item =
44 ref ((fun ~scopes:_ _fields _rootpath _stri _next -> assert false) :
45 scopes:scopes -> Ident.t list -> Path.t option ->
46 structure_item -> (Ident.t list -> lambda) -> lambda)
47
48let transl_object =
49 ref (fun ~scopes:_ _id _s _cl -> assert false :
50 scopes:scopes -> Ident.t -> string list -> class_expr -> lambda)
51
52(* Compile an exception/extension definition *)
53
54let prim_fresh_oo_id =
55 Pccall (Primitive.simple ~name:"caml_fresh_oo_id" ~arity:1 ~alloc:false)
56
57let transl_extension_constructor ~scopes env path ext =
58 let path =
59 Printtyp.wrap_printing_env env ~error:true (fun () ->
60 Option.map (Out_type.rewrite_double_underscore_paths env) path)
61 in
62 let name =
63 match path, !Clflags.for_package with
64 None, _ -> Ident.name ext.ext_id
65 | Some p, None -> Path.name p
66 | Some p, Some pack -> Printf.sprintf "%s.%s" pack (Path.name p)
67 in
68 let loc = of_location ~scopes ext.ext_loc in
69 match ext.ext_kind with
70 Text_decl _ ->
71 Lprim (Pmakeblock (Obj.object_tag, Immutable, None),
72 [Lconst (Const_immstring name);
73 Lprim (prim_fresh_oo_id, [Lconst (const_int 0)], loc)],
74 loc)
75 | Text_rebind(path, _lid) ->
76 transl_extension_path loc env path
77
78(* To propagate structured constants *)
79
80exception Not_constant
81
82let extract_constant = function
83 Lconst sc -> sc
84 | _ -> raise Not_constant
85
86let extract_float = function
87 Const_float f -> f
88 | _ -> fatal_error "Translcore.extract_float"
89
90(* Insertion of debugging events *)
91
92let event_before ~scopes exp lam =
93 Translprim.event_before (of_location ~scopes exp.exp_loc) exp lam
94
95let event_after ~scopes exp lam =
96 Translprim.event_after (of_location ~scopes exp.exp_loc) exp lam
97
98let event_function ~scopes exp lam =
99 if !Clflags.debug && not !Clflags.native_code then
100 let repr = Some (ref 0) in
101 let (info, body) = lam repr in
102 (info,
103 Levent(body, {lev_loc = of_location ~scopes exp.exp_loc;
104 lev_kind = Lev_function;
105 lev_repr = repr;
106 lev_env = exp.exp_env}))
107 else
108 lam None
109
110(* Assertions *)
111
112let assert_failed loc ~scopes exp =
113 let slot =
114 transl_extension_path Loc_unknown
115 Env.initial Predef.path_assert_failure
116 in
117 let (fname, line, char) =
118 Location.get_pos_info loc.Location.loc_start
119 in
120 let loc = of_location ~scopes exp.exp_loc in
121 Lprim(Praise Raise_regular, [event_after ~scopes exp
122 (Lprim(Pmakeblock(0, Immutable, None),
123 [slot;
124 Lconst(Const_block(0,
125 [Const_immstring fname;
126 Const_int line;
127 Const_int char]))], loc))], loc)
128
129(* In cases where we're careful to preserve syntactic arity, we disable
130 the arity fusion attempted by simplif.ml *)
131let function_attribute_disallowing_arity_fusion =
132 { default_function_attribute with may_fuse_arity = false }
133
134let rec cut n l =
135 if n = 0 then ([],l) else
136 match l with [] -> failwith "Translcore.cut"
137 | a::l -> let (l1,l2) = cut (n-1) l in (a::l1,l2)
138
139(* [fuse_method_arity] is what ensures that a n-ary method is compiled as a
140 (n+1)-ary function, where the first parameter is self. It fuses together the
141 self and method parameters.
142
143 Input: fun self -> fun method_param_1 ... method_param_n -> body
144 Output: fun self method_param_1 ... method_param_n -> body
145
146 It detects whether the AST is a method by the presence of [Texp_poly] on the
147 inner function. This is only ever added to methods.
148*)
149let fuse_method_arity parent_params parent_body =
150 match parent_body with
151 | Tfunction_body
152 { exp_desc = Texp_function (method_params, method_body);
153 exp_extra;
154 }
155 when
156 List.exists
157 (function (Texp_poly _, _, _) -> true | _ -> false)
158 exp_extra
159 -> parent_params @ method_params, method_body
160 | _ -> parent_params, parent_body
161
162(* Translation of expressions *)
163
164let rec iter_exn_names f pat =
165 match pat.pat_desc with
166 | Tpat_var (id, _, _) -> f id
167 | Tpat_alias (p, id, _, _, _) ->
168 f id;
169 iter_exn_names f p
170 | _ -> ()
171
172let transl_ident loc env ty path desc =
173 match desc.val_kind with
174 | Val_prim p ->
175 Translprim.transl_primitive loc p env ty (Some path)
176 | Val_anc _ ->
177 raise(Error(to_location loc, Free_super_var))
178 | Val_reg | Val_self _ ->
179 transl_value_path loc env path
180 | _ -> fatal_error "Translcore.transl_exp: bad Texp_ident"
181
182let is_omitted = function
183 | Arg _ -> false
184 | Omitted () -> true
185
186let rec transl_exp ~scopes e =
187 transl_exp1 ~scopes ~in_new_scope:false e
188
189(* ~in_new_scope tracks whether we just opened a new scope.
190
191 When we just opened a new scope, we avoid introducing an extraneous anonymous
192 function scope and instead inherit the new scope. E.g., [let f x = ...] is
193 parsed as a let-bound Pexp_function node [let f = fun x -> ...].
194 We give it f's scope.
195*)
196and transl_exp1 ~scopes ~in_new_scope e =
197 let eval_once =
198 (* Whether classes for immediate objects must be cached *)
199 match e.exp_desc with
200 Texp_function _ | Texp_for _ | Texp_while _ -> false
201 | _ -> true
202 in
203 if eval_once then transl_exp0 ~scopes ~in_new_scope e else
204 Translobj.oo_wrap e.exp_env true (transl_exp0 ~scopes ~in_new_scope) e
205
206and transl_exp0 ~in_new_scope ~scopes e =
207 match e.exp_desc with
208 | Texp_ident(path, _, desc) ->
209 transl_ident (of_location ~scopes e.exp_loc)
210 e.exp_env e.exp_type path desc
211 | Texp_constant cst ->
212 Lambda.lambda_of_const cst
213 | Texp_let(rec_flag, pat_expr_list, body) ->
214 transl_let ~scopes rec_flag pat_expr_list
215 (event_before ~scopes body (transl_exp ~scopes body))
216 | Texp_function (params, body) ->
217 let scopes =
218 if in_new_scope then scopes
219 else enter_anonymous_function ~scopes
220 in
221 transl_function ~scopes e params body
222 | Texp_apply({ exp_desc = Texp_ident(path, _, {val_kind = Val_prim p});
223 exp_type = prim_type } as funct, oargs)
224 when List.length oargs >= p.prim_arity
225 && List.for_all (fun (_, arg) -> not (is_omitted arg)) oargs ->
226 let argl, extra_args = cut p.prim_arity oargs in
227 let arg_exps =
228 List.map (function _, Arg x -> x | _, Omitted () -> assert false) argl
229 in
230 let args = transl_list ~scopes arg_exps in
231 let prim_exp = if extra_args = [] then Some e else None in
232 let lam =
233 Translprim.transl_primitive_application
234 (of_location ~scopes e.exp_loc) p e.exp_env prim_type path
235 prim_exp args arg_exps
236 in
237 if extra_args = [] then lam
238 else begin
239 let tailcall = Translattribute.get_tailcall_attribute funct in
240 let inlined = Translattribute.get_inlined_attribute funct in
241 let specialised = Translattribute.get_specialised_attribute funct in
242 let e = { e with exp_desc = Texp_apply(funct, oargs) } in
243 event_after ~scopes e
244 (transl_apply ~scopes ~tailcall ~inlined ~specialised
245 lam extra_args (of_location ~scopes e.exp_loc))
246 end
247 | Texp_apply(funct, oargs) ->
248 let tailcall = Translattribute.get_tailcall_attribute funct in
249 let inlined = Translattribute.get_inlined_attribute funct in
250 let specialised = Translattribute.get_specialised_attribute funct in
251 let e = { e with exp_desc = Texp_apply(funct, oargs) } in
252 event_after ~scopes e
253 (transl_apply ~scopes ~tailcall ~inlined ~specialised
254 (transl_exp ~scopes funct) oargs (of_location ~scopes e.exp_loc))
255 | Texp_match(arg, pat_expr_list, [], partial) ->
256 transl_match ~scopes e arg pat_expr_list partial
257 | Texp_match(arg, pat_expr_list, eff_pat_expr_list, partial) ->
258 (* need to separate the values from exceptions for transl_handler *)
259 let split_case (val_cases, exn_cases as acc)
260 ({ c_lhs; c_rhs } as case) =
261 if c_rhs.exp_desc = Texp_unreachable then acc else
262 let val_pat, exn_pat = split_pattern c_lhs in
263 match val_pat, exn_pat with
264 | None, None -> assert false
265 | Some pv, None ->
266 { case with c_lhs = pv } :: val_cases, exn_cases
267 | None, Some pe ->
268 val_cases, { case with c_lhs = pe } :: exn_cases
269 | Some pv, Some pe ->
270 { case with c_lhs = pv } :: val_cases,
271 { case with c_lhs = pe } :: exn_cases
272 in
273 let pat_expr_list, exn_pat_expr_list =
274 let x, y = List.fold_left split_case ([], []) pat_expr_list in
275 List.rev x, List.rev y
276 in
277 transl_handler ~scopes e arg (Some (pat_expr_list, partial))
278 exn_pat_expr_list eff_pat_expr_list
279 | Texp_try(body, pat_expr_list, []) ->
280 let id = Typecore.name_cases "exn" pat_expr_list in
281 Ltrywith(transl_exp ~scopes body, id,
282 Matching.for_trywith ~scopes e.exp_loc (Lvar id)
283 (transl_cases_try ~scopes pat_expr_list))
284 | Texp_try(body, exn_pat_expr_list, eff_pat_expr_list) ->
285 transl_handler ~scopes e body None exn_pat_expr_list eff_pat_expr_list
286 | Texp_tuple el ->
287 let ll, shape = transl_list_with_shape ~scopes (List.map snd el) in
288 begin try
289 Lconst(Const_block(0, List.map extract_constant ll))
290 with Not_constant ->
291 Lprim(Pmakeblock(0, Immutable, Some shape), ll,
292 (of_location ~scopes e.exp_loc))
293 end
294 | Texp_construct(_, cstr, args) ->
295 let ll, shape = transl_list_with_shape ~scopes args in
296 if cstr.cstr_inlined <> None then begin match ll with
297 | [x] -> x
298 | _ -> assert false
299 end else begin match cstr.cstr_tag with
300 Cstr_constant n ->
301 Lconst(const_int n)
302 | Cstr_unboxed ->
303 (match ll with [v] -> v | _ -> assert false)
304 | Cstr_block n ->
305 begin try
306 Lconst(Const_block(n, List.map extract_constant ll))
307 with Not_constant ->
308 Lprim(Pmakeblock(n, Immutable, Some shape), ll,
309 of_location ~scopes e.exp_loc)
310 end
311 | Cstr_extension(path, is_const) ->
312 let lam = transl_extension_path
313 (of_location ~scopes e.exp_loc) e.exp_env path in
314 if is_const then lam
315 else
316 Lprim(Pmakeblock(0, Immutable, Some (Pgenval :: shape)),
317 lam :: ll, of_location ~scopes e.exp_loc)
318 end
319 | Texp_extension_constructor (_, path) ->
320 transl_extension_path (of_location ~scopes e.exp_loc) e.exp_env path
321 | Texp_variant(l, arg) ->
322 let tag = Btype.hash_variant l in
323 begin match arg with
324 None -> Lconst(const_int tag)
325 | Some arg ->
326 let lam = transl_exp ~scopes arg in
327 try
328 Lconst(Const_block(0, [const_int tag;
329 extract_constant lam]))
330 with Not_constant ->
331 Lprim(Pmakeblock(0, Immutable, None),
332 [Lconst(const_int tag); lam],
333 of_location ~scopes e.exp_loc)
334 end
335 | Texp_record {fields; representation; extended_expression} ->
336 transl_record ~scopes e.exp_loc e.exp_env
337 fields representation extended_expression
338 | Texp_atomic_loc (arg, _, lbl) ->
339 let shape = Some [Typeopt.value_kind arg.exp_env arg.exp_type; Pintval] in
340 let (arg, lbl) = transl_atomic_loc ~scopes arg lbl in
341 let loc = of_location ~scopes e.exp_loc in
342 Lprim (Pmakeblock (0, Immutable, shape), [arg; lbl], loc)
343 | Texp_field (arg, _, ({ lbl_atomic = Atomic; _ } as lbl)) ->
344 let arg, lbl = transl_atomic_loc ~scopes arg lbl in
345 let loc = of_location ~scopes e.exp_loc in
346 Lprim (Patomic_load, [arg; lbl], loc)
347 | Texp_field (arg, _, lbl) ->
348 let targ = transl_exp ~scopes arg in
349 begin match lbl.lbl_repres with
350 Record_regular | Record_inlined _ ->
351 Lprim (Pfield (lbl.lbl_pos, maybe_pointer e, lbl.lbl_mut), [targ],
352 of_location ~scopes e.exp_loc)
353 | Record_unboxed _ -> targ
354 | Record_float ->
355 Lprim (Pfloatfield lbl.lbl_pos, [targ],
356 of_location ~scopes e.exp_loc)
357 | Record_extension _ ->
358 Lprim (Pfield (lbl.lbl_pos + 1, maybe_pointer e, lbl.lbl_mut), [targ],
359 of_location ~scopes e.exp_loc)
360 end
361 | Texp_setfield (arg, _, ({ lbl_atomic = Atomic; _ } as lbl), newval) ->
362 let prim =
363 Primitive.simple
364 ~name:"caml_atomic_exchange_field" ~arity:3 ~alloc:false
365 in
366 let arg, lbl = transl_atomic_loc ~scopes arg lbl in
367 let newval = transl_exp ~scopes newval in
368 let loc = of_location ~scopes e.exp_loc in
369 Lprim (
370 Pignore,
371 [Lprim (Pccall prim, [arg; lbl; newval], loc)],
372 loc
373 )
374 | Texp_setfield(arg, _, lbl, newval) ->
375 let access =
376 match lbl.lbl_repres with
377 Record_regular
378 | Record_inlined _ ->
379 Psetfield(lbl.lbl_pos, maybe_pointer newval, Assignment)
380 | Record_unboxed _ -> assert false
381 | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
382 | Record_extension _ ->
383 Psetfield (lbl.lbl_pos + 1, maybe_pointer newval, Assignment)
384 in
385 Lprim(access, [transl_exp ~scopes arg; transl_exp ~scopes newval],
386 of_location ~scopes e.exp_loc)
387 | Texp_array (amut, expr_list) ->
388 let kind = array_kind e in
389 let ll = transl_list ~scopes expr_list in
390 let loc = of_location ~scopes e.exp_loc in
391 let makearray mutability =
392 Lprim (Pmakearray (kind, mutability), ll, loc)
393 in
394 let duparray_to_mutable array =
395 Lprim (Pduparray (kind, Mutable), [array], loc)
396 in
397 let imm_array = makearray Immutable in
398 begin try
399 (* For native code the decision as to which compilation strategy to
400 use is made later. This enables the Flambda passes to lift certain
401 kinds of array definitions to symbols. *)
402 (* Deactivate constant optimization if array is small enough *)
403 if amut = Asttypes.Mutable &&
404 List.length ll <= use_dup_for_constant_mutable_arrays_bigger_than
405 then begin
406 raise Not_constant
407 end;
408 begin match List.map extract_constant ll with
409 | exception Not_constant
410 when kind = Pfloatarray && amut = Asttypes.Mutable ->
411 (* We cannot currently lift mutable [Pintarray] arrays safely in
412 Flambda because [caml_modify] might be called upon them
413 (e.g. from code operating on polymorphic arrays, or functions
414 such as [caml_array_blit].
415 To avoid having different Lambda code for bytecode/Closure
416 vs. Flambda, we always generate [Pduparray] for mutable arrays
417 here, and deal with it in [Bytegen] (or in the case of Closure,
418 in [Cmmgen], which already has to handle [Pduparray Pmakearray
419 Pfloatarray] in the case where the array turned out to be
420 inconstant).
421 When not [Pfloatarray], the exception propagates to the handler
422 below. *)
423 duparray_to_mutable imm_array
424 | cl ->
425 let const =
426 match kind with
427 | Paddrarray | Pintarray ->
428 Lconst(Const_block(0, cl))
429 | Pfloatarray ->
430 Lconst(Const_float_array(List.map extract_float cl))
431 | Pgenarray ->
432 raise Not_constant (* can this really happen? *)
433 in
434 match amut with
435 | Mutable -> duparray_to_mutable const
436 | Immutable -> const
437 end
438 with Not_constant ->
439 makearray amut
440 end
441 | Texp_ifthenelse(cond, ifso, Some ifnot) ->
442 Lifthenelse(transl_exp ~scopes cond,
443 event_before ~scopes ifso (transl_exp ~scopes ifso),
444 event_before ~scopes ifnot (transl_exp ~scopes ifnot))
445 | Texp_ifthenelse(cond, ifso, None) ->
446 Lifthenelse(transl_exp ~scopes cond,
447 event_before ~scopes ifso (transl_exp ~scopes ifso),
448 lambda_unit)
449 | Texp_sequence(expr1, expr2) ->
450 Lsequence(transl_exp ~scopes expr1,
451 event_before ~scopes expr2 (transl_exp ~scopes expr2))
452 | Texp_while(cond, body) ->
453 Lwhile(transl_exp ~scopes cond,
454 event_before ~scopes body (transl_exp ~scopes body))
455 | Texp_for(param, _, low, high, dir, body) ->
456 Lfor(param, transl_exp ~scopes low, transl_exp ~scopes high, dir,
457 event_before ~scopes body (transl_exp ~scopes body))
458 | Texp_send(expr, met) ->
459 let lam =
460 let loc = of_location ~scopes e.exp_loc in
461 match met with
462 | Tmeth_val id ->
463 let obj = transl_exp ~scopes expr in
464 Lsend (Self, Lvar id, obj, [], loc)
465 | Tmeth_name nm ->
466 let obj = transl_exp ~scopes expr in
467 let (tag, cache) = Translobj.meth obj nm in
468 let kind = if cache = [] then Public else Cached in
469 Lsend (kind, tag, obj, cache, loc)
470 | Tmeth_ancestor(meth, path_self) ->
471 let self = transl_value_path loc e.exp_env path_self in
472 Lapply {ap_loc = loc;
473 ap_func = Lvar meth;
474 ap_args = [self];
475 ap_tailcall = Default_tailcall;
476 ap_inlined = Default_inline;
477 ap_specialised = Default_specialise}
478 in
479 event_after ~scopes e lam
480 | Texp_new (cl, {Location.loc=loc}, _) ->
481 let loc = of_location ~scopes loc in
482 Lapply{
483 ap_loc=loc;
484 ap_func=
485 Lprim(Pfield (0, Pointer, Mutable),
486 [transl_class_path loc e.exp_env cl], loc);
487 ap_args=[lambda_unit];
488 ap_tailcall=Default_tailcall;
489 ap_inlined=Default_inline;
490 ap_specialised=Default_specialise;
491 }
492 | Texp_instvar(path_self, path, _) ->
493 let loc = of_location ~scopes e.exp_loc in
494 let self = transl_value_path loc e.exp_env path_self in
495 let var = transl_value_path loc e.exp_env path in
496 Lprim(Pfield_computed, [self; var], loc)
497 | Texp_setinstvar(path_self, path, _, expr) ->
498 let loc = of_location ~scopes e.exp_loc in
499 let self = transl_value_path loc e.exp_env path_self in
500 let var = transl_value_path loc e.exp_env path in
501 transl_setinstvar ~scopes loc self var expr
502 | Texp_override(path_self, modifs) ->
503 let loc = of_location ~scopes e.exp_loc in
504 let self = transl_value_path loc e.exp_env path_self in
505 let cpy = Ident.create_local "copy" in
506 Llet(Strict, Pgenval, cpy,
507 Lapply{
508 ap_loc=Loc_unknown;
509 ap_func=Translobj.oo_prim "copy";
510 ap_args=[self];
511 ap_tailcall=Default_tailcall;
512 ap_inlined=Default_inline;
513 ap_specialised=Default_specialise;
514 },
515 List.fold_right
516 (fun (id, _, expr) rem ->
517 Lsequence(transl_setinstvar ~scopes Loc_unknown
518 (Lvar cpy) (Lvar id) expr, rem))
519 modifs
520 (Lvar cpy))
521 | Texp_pack modl ->
522 !transl_module ~scopes Tcoerce_none None modl
523 | Texp_assert ({exp_desc=Texp_construct(_, {cstr_name="false"}, _)}, loc) ->
524 assert_failed loc ~scopes e
525 | Texp_assert (cond, loc) ->
526 if !Clflags.noassert
527 then lambda_unit
528 else Lifthenelse (transl_exp ~scopes cond, lambda_unit,
529 assert_failed loc ~scopes e)
530 | Texp_lazy e ->
531 (* when e needs no computation (constants, identifiers, ...), we
532 optimize the translation just as Lazy.lazy_from_val would
533 do *)
534 begin match Typeopt.classify_lazy_argument e with
535 | `Constant_or_function ->
536 (* A constant expr (of type <> float if [Config.flat_float_array] is
537 true) gets compiled as itself. *)
538 transl_exp ~scopes e
539 | `Float_that_cannot_be_shortcut
540 | `Identifier `Forward_value ->
541 Lprim (Pmakelazyblock Forward_tag,
542 [transl_exp ~scopes e],
543 of_location ~scopes e.exp_loc)
544 | `Identifier `Other ->
545 transl_exp ~scopes e
546 | `Other ->
547 (* other cases compile to a lazy block holding a function *)
548 let fn = lfunction ~kind:Curried
549 ~params:[Ident.create_local "param", Pgenval]
550 ~return:Pgenval
551 (* The translation of [e] may be a function, in
552 which case disallowing arity fusion gives a very
553 small performance improvement.
554 *)
555 ~attr:function_attribute_disallowing_arity_fusion
556 ~loc:(of_location ~scopes e.exp_loc)
557 ~body:(transl_exp ~scopes e) in
558 Lprim(Pmakelazyblock Lazy_tag, [fn],
559 of_location ~scopes e.exp_loc)
560 end
561 | Texp_object (cs, meths) ->
562 let cty = cs.cstr_type in
563 let cl = Ident.create_local "object" in
564 !transl_object ~scopes cl meths
565 { cl_desc = Tcl_structure cs;
566 cl_loc = e.exp_loc;
567 cl_type = Cty_signature cty;
568 cl_env = e.exp_env;
569 cl_attributes = [];
570 }
571 | Texp_letop{let_; ands; param; body; partial} ->
572 event_after ~scopes e
573 (transl_letop ~scopes e.exp_loc e.exp_env let_ ands param body partial)
574 | Texp_unreachable ->
575 raise (Error (e.exp_loc, Unreachable_reached))
576 | Texp_struct_item (si, e) ->
577 !transl_struct_item ~scopes [] None si (fun _ -> transl_exp ~scopes e)
578
579and pure_module m =
580 match m.mod_desc with
581 Tmod_ident _ -> Alias
582 | Tmod_constraint (m,_,_,_) -> pure_module m
583 | _ -> Strict
584
585and transl_list ~scopes expr_list =
586 List.map (transl_exp ~scopes) expr_list
587
588and transl_list_with_shape ~scopes expr_list =
589 let transl_with_shape e =
590 let shape = Typeopt.value_kind e.exp_env e.exp_type in
591 transl_exp ~scopes e, shape
592 in
593 List.split (List.map transl_with_shape expr_list)
594
595and transl_guard ~scopes guard rhs =
596 let expr = event_before ~scopes rhs (transl_exp ~scopes rhs) in
597 match guard with
598 | None -> expr
599 | Some cond ->
600 event_before ~scopes cond
601 (Lifthenelse(transl_exp ~scopes cond, expr, staticfail))
602
603and transl_cont cont c_cont body =
604 match cont, c_cont with
605 | Some id1, Some id2 -> Llet(Alias, Pgenval, id2, Lvar id1, body)
606 | None, None
607 | Some _, None -> body
608 | None, Some _ -> assert false
609
610and transl_case ~scopes ?cont {c_lhs; c_cont; c_guard; c_rhs} =
611 (c_lhs, transl_cont cont c_cont (transl_guard ~scopes c_guard c_rhs))
612
613and transl_cases ~scopes ?cont cases =
614 let cases =
615 List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in
616 List.map (transl_case ~scopes ?cont) cases
617
618and transl_case_try ~scopes {c_lhs; c_guard; c_rhs} =
619 iter_exn_names Translprim.add_exception_ident c_lhs;
620 Misc.try_finally
621 (fun () -> c_lhs, transl_guard ~scopes c_guard c_rhs)
622 ~always:(fun () ->
623 iter_exn_names Translprim.remove_exception_ident c_lhs)
624
625and transl_cases_try ~scopes cases =
626 let cases =
627 List.filter (fun c -> c.c_rhs.exp_desc <> Texp_unreachable) cases in
628 List.map (transl_case_try ~scopes) cases
629
630and transl_tupled_cases ~scopes patl_expr_list =
631 let patl_expr_list =
632 List.filter (fun (_,_,e) -> e.exp_desc <> Texp_unreachable)
633 patl_expr_list in
634 List.map (fun (patl, guard, expr) -> (patl, transl_guard ~scopes guard expr))
635 patl_expr_list
636
637and transl_apply ~scopes
638 ?(tailcall=Default_tailcall)
639 ?(inlined = Default_inline)
640 ?(specialised = Default_specialise)
641 lam sargs loc
642 =
643 let lapply funct args =
644 match funct with
645 Lsend(k, lmet, lobj, largs, _) ->
646 Lsend(k, lmet, lobj, largs @ args, loc)
647 | Levent(Lsend(k, lmet, lobj, largs, _), _) ->
648 Lsend(k, lmet, lobj, largs @ args, loc)
649 | Lapply ap ->
650 Lapply {ap with ap_args = ap.ap_args @ args; ap_loc = loc}
651 | lexp ->
652 Lapply {
653 ap_loc=loc;
654 ap_func=lexp;
655 ap_args=args;
656 ap_tailcall=tailcall;
657 ap_inlined=inlined;
658 ap_specialised=specialised;
659 }
660 in
661 (* Build a function application.
662 Particular care is required for out-of-order partial applications.
663 The following code guarantees that:
664 * arguments are evaluated right-to-left according to their order in
665 the type of the function, before the function is called;
666 * side-effects occurring after receiving a non-optional parameter
667 will occur exactly when all the arguments up to this parameter
668 have been received;
669 * side-effects occurring after receiving an optional parameter
670 will occur at the latest when all the arguments up to the first
671 non-optional parameter that follows it have been received.
672 *)
673 let rec build_apply lam args = function
674 (Omitted (), optional) :: l ->
675 (* Out-of-order partial application; we will need to build a closure *)
676 let defs = ref [] in
677 let protect name lam =
678 match lam with
679 Lvar _ | Lconst _ -> lam
680 | _ ->
681 let id = Ident.create_local name in
682 defs := (id, lam) :: !defs;
683 Lvar id
684 in
685 (* If all arguments in [args] were optional, delay their application
686 until after this one is received *)
687 let args, args' =
688 if List.for_all (fun (_,opt) -> opt) args then [], args
689 else args, []
690 in
691 let lam =
692 if args = [] then lam else lapply lam (List.rev_map fst args)
693 in
694 (* Evaluate the function, applied to the arguments in [args] *)
695 let handle = protect "func" lam in
696 (* Evaluate the arguments whose applications was delayed;
697 if we already passed here this is a no-op. *)
698 let args' =
699 List.map (fun (arg, opt) -> protect "arg" arg, opt) args'
700 in
701 (* Evaluate the remaining arguments;
702 if we already passed here this is a no-op. *)
703 let l =
704 List.map
705 (fun (arg, opt) -> Typedtree.map_apply_arg (protect "arg") arg, opt)
706 l
707 in
708 let id_arg = Ident.create_local "param" in
709 (* Process remaining arguments and build closure *)
710 let body =
711 match build_apply handle ((Lvar id_arg, optional)::args') l with
712 Lfunction{kind = Curried; params = ids; return; body; attr; loc}
713 when List.length ids < Lambda.max_arity () ->
714 lfunction ~kind:Curried ~params:((id_arg, Pgenval)::ids)
715 ~return ~body ~attr ~loc
716 | body ->
717 lfunction ~kind:Curried ~params:[id_arg, Pgenval]
718 ~return:Pgenval ~body
719 ~attr:default_stub_attribute ~loc
720 in
721 (* Wrap "protected" definitions, starting from the left,
722 so that evaluation is right-to-left. *)
723 List.fold_right
724 (fun (id, lam) body -> Llet(Strict, Pgenval, id, lam, body))
725 !defs body
726 | (Arg arg, optional) :: l ->
727 build_apply lam ((arg, optional) :: args) l
728 | [] ->
729 lapply lam (List.rev_map fst args)
730 in
731 let transl_arg arg = Typedtree.map_apply_arg (transl_exp ~scopes) arg in
732 (build_apply lam [] (List.map (fun (l, arg) ->
733 transl_arg arg,
734 Btype.is_optional l)
735 sargs)
736 : Lambda.lambda)
737
738(* There are two cases in function translation:
739 - [Tupled]. It takes a tupled argument, and we can flatten it.
740 - [Curried]. It takes each argument individually.
741
742 We first try treating the function as taking a flattened tupled argument (in
743 [trans_tupled_function]) and, if that doesn't work, we fall back to treating
744 the function as taking each argument individually (in
745 [trans_curried_function]).
746*)
747and transl_function_without_attributes ~scopes loc repr params body =
748 let return =
749 match body with
750 | Tfunction_body body ->
751 value_kind body.exp_env body.exp_type
752 | Tfunction_cases { cases = { c_rhs } :: _ } ->
753 value_kind c_rhs.exp_env c_rhs.exp_type
754 | Tfunction_cases { cases = [] } ->
755 (* With Camlp4/ppx, a pattern matching might be empty *)
756 Pgenval
757 in
758 transl_tupled_function ~scopes loc return repr params body
759
760and transl_tupled_function ~scopes loc return repr params body =
761 (* Cases are eligible for flattening if they belong to the only param. *)
762 let eligible_cases =
763 match params, body with
764 | [], Tfunction_cases { cases; partial } ->
765 Some (cases, partial)
766 | [ { fp_kind = Tparam_pat pat; fp_partial } ], Tfunction_body body ->
767 let case =
768 { c_lhs = pat; c_cont = None; c_guard = None; c_rhs = body }
769 in
770 Some ([ case ], fp_partial)
771 | _ -> None
772 in
773 match eligible_cases with
774 | Some (({ c_lhs = { pat_desc = Tpat_tuple pl } } :: _) as cases, partial)
775 when !Clflags.native_code
776 && List.length pl <= (Lambda.max_arity ()) ->
777 begin try
778 let size = List.length pl in
779 let pats_expr_list =
780 List.map
781 (fun {c_lhs; c_guard; c_rhs} ->
782 (Matching.flatten_pattern size c_lhs, c_guard, c_rhs))
783 cases in
784 let kinds =
785 (* All the patterns might not share the same types. We must take the
786 union of the patterns types *)
787 match pats_expr_list with
788 | [] -> assert false
789 | (pats, _, _) :: cases ->
790 let first_case_kinds =
791 List.map (fun pat -> value_kind pat.pat_env pat.pat_type) pats
792 in
793 List.fold_left
794 (fun kinds (pats, _, _) ->
795 List.map2 (fun kind pat ->
796 value_kind_union kind
797 (value_kind pat.pat_env pat.pat_type))
798 kinds pats)
799 first_case_kinds cases
800 in
801 let tparams =
802 List.map (fun kind -> Ident.create_local "param", kind) kinds
803 in
804 let params = List.map fst tparams in
805 ((Tupled, tparams, return),
806 Matching.for_tupled_function ~scopes loc params
807 (transl_tupled_cases ~scopes pats_expr_list) partial)
808 with Matching.Cannot_flatten ->
809 transl_curried_function ~scopes loc return repr params body
810 end
811 | _ -> transl_curried_function ~scopes loc return repr params body
812
813and transl_curried_function ~scopes loc return repr params body =
814 let cases_param, body =
815 match body with
816 | Tfunction_body body ->
817 None, event_before ~scopes body (transl_exp ~scopes body)
818 | Tfunction_cases { cases; partial; param; loc = cases_loc } ->
819 let kind =
820 match cases with
821 | [] ->
822 (* With Camlp4/ppx, a pattern matching might be empty *)
823 Pgenval
824 | {c_lhs=pat} :: other_cases ->
825 (* All the patterns might not share the same types. We must take the
826 union of the patterns types *)
827 List.fold_left (fun k {c_lhs=pat} ->
828 Typeopt.value_kind_union k
829 (value_kind pat.pat_env pat.pat_type))
830 (value_kind pat.pat_env pat.pat_type) other_cases
831 in
832 let body =
833 Matching.for_function ~scopes cases_loc repr (Lvar param)
834 (transl_cases ~scopes cases) partial
835 in
836 Some (param, kind), body
837 in
838 let body, params =
839 List.fold_right (fun fp (body, params) ->
840 let param = fp.fp_param in
841 let param_loc = fp.fp_loc in
842 match fp.fp_kind with
843 | Tparam_pat pat ->
844 let kind = value_kind pat.pat_env pat.pat_type in
845 let body =
846 Matching.for_function ~scopes param_loc None (Lvar param)
847 [ pat, body ]
848 fp.fp_partial
849 in
850 body, (param, kind) :: params
851 | Tparam_optional_default (pat, default_arg) ->
852 let default_arg =
853 event_before ~scopes default_arg (transl_exp ~scopes default_arg)
854 in
855 let body =
856 Matching.for_optional_arg_default
857 ~scopes param_loc pat body ~default_arg ~param
858 in
859 (* The optional param is Pgenval as it's an option. *)
860 body, (param, Pgenval) :: params)
861 params
862 (body, Option.to_list cases_param)
863 in
864 (* chunk params according to Lambda.max_arity. If Lambda.max_arity = n and
865 N>n, then the translation of an N-ary typedtree function is an n-ary lambda
866 function returning the translation of an (N-n)-ary typedtree function.
867 *)
868 let params, return, body =
869 match Misc.Stdlib.List.chunks_of (Lambda.max_arity ()) params with
870 | [] ->
871 Misc.fatal_error "attempted to translate a function with zero arguments"
872 | first_chunk :: rest_of_chunks ->
873 let body, return =
874 List.fold_right
875 (fun chunk (body, return) ->
876 let attr = function_attribute_disallowing_arity_fusion in
877 let loc = of_location ~scopes loc in
878 let body =
879 lfunction ~kind:Curried ~params:chunk ~return ~body ~attr ~loc
880 in
881 (* we return Pgenval (for a function) after the rightmost chunk. *)
882 body, Pgenval)
883 rest_of_chunks
884 (body, return)
885 in
886 first_chunk, return, body
887 in
888 ((Curried, params, return), body)
889
890and transl_function ~scopes e params body =
891 let ((kind, params, return), body) =
892 event_function ~scopes e
893 (function repr ->
894 let params, body = fuse_method_arity params body in
895 transl_function_without_attributes ~scopes e.exp_loc repr params body)
896 in
897 let attr = function_attribute_disallowing_arity_fusion in
898 let loc = of_location ~scopes e.exp_loc in
899 let lam = lfunction ~kind ~params ~return ~body ~attr ~loc in
900 let attrs =
901 (* Collect attributes from the Pexp_newtype node for locally abstract types.
902 Otherwise we'd ignore the attribute in, e.g.:
903 fun [@inline] (type a) x -> ...
904 *)
905 List.fold_left
906 (fun attrs (extra_exp, _, extra_attrs) ->
907 match extra_exp with
908 | Texp_newtype _ -> extra_attrs @ attrs
909 | (Texp_constraint _ | Texp_coerce _ | Texp_poly _) -> attrs)
910 e.exp_attributes e.exp_extra
911 in
912 Translattribute.add_function_attributes lam e.exp_loc attrs
913
914(* Like transl_exp, but used when a new scope was just introduced. *)
915and transl_scoped_exp ~scopes expr =
916 transl_exp1 ~scopes ~in_new_scope:true expr
917
918(* Decides whether a pattern binding should introduce a new scope. *)
919and transl_bound_exp ~scopes ~in_structure pat expr =
920 let should_introduce_scope =
921 match expr.exp_desc with
922 | Texp_function _ -> true
923 | _ when in_structure -> true
924 | _ -> false in
925 match pat_bound_idents pat with
926 | (id :: _) when should_introduce_scope ->
927 transl_scoped_exp ~scopes:(enter_value_definition ~scopes id) expr
928 | _ -> transl_exp ~scopes expr
929
930(*
931 Notice: transl_let consumes (ie compiles) its pat_expr_list argument,
932 and returns a function that will take the body of the lambda-let construct.
933 This complication allows choosing any compilation order for the
934 bindings and body of let constructs.
935*)
936and transl_let ~scopes ?(in_structure=false) rec_flag pat_expr_list =
937 match rec_flag with
938 Nonrecursive ->
939 let rec transl = function
940 [] ->
941 fun body -> body
942 | {vb_pat=pat; vb_expr=expr; vb_rec_kind=_; vb_attributes=attr; vb_loc}
943 :: rem ->
944 let lam = transl_bound_exp ~scopes ~in_structure pat expr in
945 let lam = Translattribute.add_function_attributes lam vb_loc attr in
946 let mk_body = transl rem in
947 fun body ->
948 Matching.for_let ~scopes pat.pat_loc lam pat (mk_body body)
949 in transl pat_expr_list
950 | Recursive ->
951 let idlist =
952 List.map
953 (fun {vb_pat=pat} -> match pat.pat_desc with
954 Tpat_var (id,_,_) -> id
955 | _ -> assert false)
956 pat_expr_list in
957 let transl_case {vb_expr=expr; vb_attributes; vb_rec_kind = rkind;
958 vb_loc; vb_pat} id =
959 let def = transl_bound_exp ~scopes ~in_structure vb_pat expr in
960 let def =
961 Translattribute.add_function_attributes def vb_loc vb_attributes
962 in
963 ( id, rkind, def ) in
964 let lam_bds = List.map2 transl_case pat_expr_list idlist in
965 fun body -> Value_rec_compiler.compile_letrec lam_bds body
966
967and transl_setinstvar ~scopes loc self var expr =
968 Lprim(Psetfield_computed (maybe_pointer expr, Assignment),
969 [self; var; transl_exp ~scopes expr], loc)
970
971and transl_record ~scopes loc env fields repres opt_init_expr =
972 let size = Array.length fields in
973 (* Determine if there are "enough" fields (only relevant if this is a
974 functional-style record update *)
975 let no_init = match opt_init_expr with None -> true | _ -> false in
976 if no_init || size < Config.max_young_wosize
977 then begin
978 (* Allocate new record with given fields (and remaining fields
979 taken from init_expr if any *)
980 let init_id = Ident.create_local "init" in
981 let lv =
982 Array.mapi
983 (fun i (_, definition) ->
984 match definition with
985 | Kept (typ, mut) ->
986 let field_kind = value_kind env typ in
987 let access =
988 match repres with
989 Record_regular | Record_inlined _ ->
990 Pfield (i, maybe_pointer_type env typ, mut)
991 | Record_unboxed _ -> assert false
992 | Record_extension _ ->
993 Pfield (i + 1, maybe_pointer_type env typ, mut)
994 | Record_float -> Pfloatfield i in
995 Lprim(access, [Lvar init_id],
996 of_location ~scopes loc),
997 field_kind
998 | Overridden (_lid, expr) ->
999 let field_kind = value_kind expr.exp_env expr.exp_type in
1000 transl_exp ~scopes expr, field_kind)
1001 fields
1002 in
1003 let ll, shape = List.split (Array.to_list lv) in
1004 let mut =
1005 if Array.exists (fun (lbl, _) -> lbl.lbl_mut = Mutable) fields
1006 then Mutable
1007 else Immutable in
1008 let lam =
1009 try
1010 if mut = Mutable then raise Not_constant;
1011 let cl = List.map extract_constant ll in
1012 match repres with
1013 | Record_regular -> Lconst(Const_block(0, cl))
1014 | Record_inlined tag -> Lconst(Const_block(tag, cl))
1015 | Record_unboxed _ -> Lconst(match cl with [v] -> v | _ -> assert false)
1016 | Record_float ->
1017 Lconst(Const_float_array(List.map extract_float cl))
1018 | Record_extension _ ->
1019 raise Not_constant
1020 with Not_constant ->
1021 let loc = of_location ~scopes loc in
1022 match repres with
1023 Record_regular ->
1024 Lprim(Pmakeblock(0, mut, Some shape), ll, loc)
1025 | Record_inlined tag ->
1026 Lprim(Pmakeblock(tag, mut, Some shape), ll, loc)
1027 | Record_unboxed _ -> (match ll with [v] -> v | _ -> assert false)
1028 | Record_float ->
1029 Lprim(Pmakearray (Pfloatarray, mut), ll, loc)
1030 | Record_extension path ->
1031 let slot = transl_extension_path loc env path in
1032 Lprim(Pmakeblock(0, mut, Some (Pgenval :: shape)), slot :: ll, loc)
1033 in
1034 begin match opt_init_expr with
1035 None -> lam
1036 | Some init_expr -> Llet(Strict, Pgenval, init_id,
1037 transl_exp ~scopes init_expr, lam)
1038 end
1039 end else begin
1040 (* Take a shallow copy of the init record, then mutate the fields
1041 of the copy *)
1042 let copy_id = Ident.create_local "newrecord" in
1043 let update_field cont (lbl, definition) =
1044 match definition with
1045 | Kept _ -> cont
1046 | Overridden (_lid, expr) ->
1047 let upd =
1048 match repres with
1049 Record_regular
1050 | Record_inlined _ ->
1051 Psetfield(lbl.lbl_pos, maybe_pointer expr, Assignment)
1052 | Record_unboxed _ -> assert false
1053 | Record_float -> Psetfloatfield (lbl.lbl_pos, Assignment)
1054 | Record_extension _ ->
1055 Psetfield(lbl.lbl_pos + 1, maybe_pointer expr, Assignment)
1056 in
1057 Lsequence(Lprim(upd, [Lvar copy_id; transl_exp ~scopes expr],
1058 of_location ~scopes loc),
1059 cont)
1060 in
1061 begin match opt_init_expr with
1062 None -> assert false
1063 | Some init_expr ->
1064 Llet(Strict, Pgenval, copy_id,
1065 Lprim(Pduprecord (repres, size), [transl_exp ~scopes init_expr],
1066 of_location ~scopes loc),
1067 Array.fold_left update_field (Lvar copy_id) fields)
1068 end
1069 end
1070
1071and transl_atomic_loc ~scopes arg lbl =
1072 let arg = transl_exp ~scopes arg in
1073 let offset =
1074 match lbl.lbl_repres with
1075 | Record_regular
1076 | Record_inlined _ -> 0
1077 | Record_float ->
1078 fatal_error
1079 "Translcore.transl_atomic_loc: atomic field in float record"
1080 | Record_unboxed _ ->
1081 fatal_error
1082 "Translcore.transl_atomic_loc: atomic field in unboxed record"
1083 | Record_extension _ -> 1
1084 in
1085 let lbl = Lconst (Const_int (lbl.lbl_pos + offset)) in
1086 (arg, lbl)
1087
1088and transl_match ~scopes e arg pat_expr_list partial =
1089 let rewrite_case (val_cases, exn_cases, static_handlers as acc)
1090 ({ c_lhs; c_guard; c_rhs } as case) =
1091 if c_rhs.exp_desc = Texp_unreachable then acc else
1092 let val_pat, exn_pat = split_pattern c_lhs in
1093 match val_pat, exn_pat with
1094 | None, None -> assert false
1095 | Some pv, None ->
1096 let val_case =
1097 transl_case ~scopes { case with c_lhs = pv }
1098 in
1099 val_case :: val_cases, exn_cases, static_handlers
1100 | None, Some pe ->
1101 let exn_case = transl_case_try ~scopes { case with c_lhs = pe } in
1102 val_cases, exn_case :: exn_cases, static_handlers
1103 | Some pv, Some pe ->
1104 assert (c_guard = None);
1105 let lbl = next_raise_count () in
1106 let static_raise ids =
1107 Lstaticraise (lbl, List.map (fun id -> Lvar id) ids)
1108 in
1109 (* Simplif doesn't like it if binders are not uniq, so we make sure to
1110 use different names in the value and the exception branches. *)
1111 let ids_full = Typedtree.pat_bound_idents_full pv in
1112 let ids = List.map (fun (id, _, _, _) -> id) ids_full in
1113 let ids_kinds =
1114 List.map (fun (id, _, ty, _) -> id, Typeopt.value_kind pv.pat_env ty)
1115 ids_full
1116 in
1117 let vids = List.map Ident.rename ids in
1118 let pv = alpha_pat (List.combine ids vids) pv in
1119 (* Also register the names of the exception so Re-raise happens. *)
1120 iter_exn_names Translprim.add_exception_ident pe;
1121 let rhs =
1122 Misc.try_finally
1123 (fun () -> event_before ~scopes c_rhs
1124 (transl_exp ~scopes c_rhs))
1125 ~always:(fun () ->
1126 iter_exn_names Translprim.remove_exception_ident pe)
1127 in
1128 (pv, static_raise vids) :: val_cases,
1129 (pe, static_raise ids) :: exn_cases,
1130 (lbl, ids_kinds, rhs) :: static_handlers
1131 in
1132 let val_cases, exn_cases, static_handlers =
1133 let x, y, z = List.fold_left rewrite_case ([], [], []) pat_expr_list in
1134 List.rev x, List.rev y, List.rev z
1135 in
1136 (* In presence of exception patterns, the code we generate for
1137
1138 match <scrutinees> with
1139 | <val-patterns> -> <val-actions>
1140 | <exn-patterns> -> <exn-actions>
1141
1142 looks like
1143
1144 staticcatch
1145 (try (exit <val-exit> <scrutinees>)
1146 with <exn-patterns> -> <exn-actions>)
1147 with <val-exit> <val-ids> ->
1148 match <val-ids> with <val-patterns> -> <val-actions>
1149
1150 In particular, the 'exit' in the value case ensures that the
1151 value actions run outside the try..with exception handler.
1152 *)
1153 let static_catch scrutinees val_ids handler =
1154 let id = Typecore.name_pattern "exn" (List.map fst exn_cases) in
1155 let static_exception_id = next_raise_count () in
1156 Lstaticcatch
1157 (Ltrywith (Lstaticraise (static_exception_id, scrutinees), id,
1158 Matching.for_trywith ~scopes e.exp_loc (Lvar id) exn_cases),
1159 (static_exception_id, val_ids),
1160 handler)
1161 in
1162 let classic =
1163 match arg, exn_cases with
1164 | {exp_desc = Texp_tuple argl}, [] ->
1165 assert (static_handlers = []);
1166 Matching.for_multiple_match ~scopes e.exp_loc
1167 (transl_list ~scopes (List.map snd argl)) val_cases partial
1168 | {exp_desc = Texp_tuple argl}, _ :: _ ->
1169 let argl = List.map snd argl in
1170 let val_ids =
1171 List.map
1172 (fun arg ->
1173 Typecore.name_pattern "val" [],
1174 Typeopt.value_kind arg.exp_env arg.exp_type
1175 )
1176 argl
1177 in
1178 let lvars = List.map (fun (id, _) -> Lvar id) val_ids in
1179 static_catch (transl_list ~scopes argl) val_ids
1180 (Matching.for_multiple_match ~scopes e.exp_loc
1181 lvars val_cases partial)
1182 | arg, [] ->
1183 assert (static_handlers = []);
1184 Matching.for_function ~scopes e.exp_loc
1185 None (transl_exp ~scopes arg) val_cases partial
1186 | arg, _ :: _ ->
1187 let val_id = Typecore.name_pattern "val" (List.map fst val_cases) in
1188 let k = Typeopt.value_kind arg.exp_env arg.exp_type in
1189 static_catch [transl_exp ~scopes arg] [val_id, k]
1190 (Matching.for_function ~scopes e.exp_loc
1191 None (Lvar val_id) val_cases partial)
1192 in
1193 List.fold_left (fun body (static_exception_id, val_ids, handler) ->
1194 Lstaticcatch (body, (static_exception_id, val_ids), handler)
1195 ) classic static_handlers
1196
1197and prim_alloc_stack =
1198 Pccall (Primitive.simple ~name:"caml_alloc_stack" ~arity:3 ~alloc:true)
1199
1200and transl_handler ~scopes e body val_caselist exn_caselist eff_caselist =
1201 let val_fun =
1202 match val_caselist with
1203 | None ->
1204 let param = Ident.create_local "param" in
1205 lfunction ~kind:Curried ~params:[param, Pgenval]
1206 ~return:Pgenval ~body:(Lvar param)
1207 ~attr:default_function_attribute ~loc:Loc_unknown
1208 | Some (val_caselist, partial) ->
1209 let val_cases = transl_cases ~scopes val_caselist in
1210 let param = Typecore.name_cases "param" val_caselist in
1211 let body =
1212 Matching.for_function ~scopes e.exp_loc None (Lvar param) val_cases
1213 partial
1214 in
1215 lfunction ~kind:Curried ~params:[param, Pgenval]
1216 ~return:Pgenval ~attr:default_function_attribute
1217 ~loc:Loc_unknown ~body
1218 in
1219 let exn_fun =
1220 let exn_cases = transl_cases ~scopes exn_caselist in
1221 let param = Typecore.name_cases "exn" exn_caselist in
1222 let body = Matching.for_trywith ~scopes e.exp_loc (Lvar param) exn_cases in
1223 lfunction ~kind:Curried ~params:[param, Pgenval] ~return:Pgenval
1224 ~attr:default_function_attribute ~loc:Loc_unknown ~body
1225 in
1226 let eff_fun =
1227 let param = Typecore.name_cases "eff" eff_caselist in
1228 let cont = Ident.create_local "k" in
1229 let cont_tail = Ident.create_local "ktail" in
1230 let eff_cases = transl_cases ~scopes ~cont eff_caselist in
1231 let body =
1232 Matching.for_handler ~scopes e.exp_loc (Lvar param) (Lvar cont)
1233 (Lvar cont_tail) eff_cases
1234 in
1235 lfunction ~kind:Curried
1236 ~params:[(param, Pgenval); (cont, Pgenval); (cont_tail, Pgenval)]
1237 ~return:Pgenval ~attr:default_function_attribute ~loc:Loc_unknown ~body
1238 in
1239 let (body_fun, arg) =
1240 match transl_exp ~scopes body with
1241 | Lapply { ap_func = fn; ap_args = [arg]; _ }
1242 when is_evaluated fn && is_evaluated arg -> (fn, arg)
1243 | body ->
1244 let param = Ident.create_local "param" in
1245 (lfunction ~kind:Curried ~params:[param, Pgenval] ~return:Pgenval
1246 ~attr:default_function_attribute ~loc:Loc_unknown
1247 ~body,
1248 Lconst(Const_int 0))
1249 in
1250 let alloc_stack =
1251 Lprim(prim_alloc_stack, [val_fun; exn_fun; eff_fun], Loc_unknown)
1252 in
1253 Lprim(Prunstack, [alloc_stack; body_fun; arg],
1254 of_location ~scopes e.exp_loc)
1255
1256and transl_letop ~scopes loc env let_ ands param case partial =
1257 let rec loop prev_lam = function
1258 | [] -> prev_lam
1259 | and_ :: rest ->
1260 let left_id = Ident.create_local "left" in
1261 let right_id = Ident.create_local "right" in
1262 let op =
1263 transl_ident (of_location ~scopes and_.bop_op_name.loc) env
1264 and_.bop_op_type and_.bop_op_path and_.bop_op_val
1265 in
1266 let exp = transl_exp ~scopes and_.bop_exp in
1267 let lam =
1268 bind Strict right_id exp
1269 (Lapply{
1270 ap_loc = of_location ~scopes and_.bop_loc;
1271 ap_func = op;
1272 ap_args=[Lvar left_id; Lvar right_id];
1273 ap_tailcall = Default_tailcall;
1274 ap_inlined = Default_inline;
1275 ap_specialised = Default_specialise;
1276 })
1277 in
1278 bind Strict left_id prev_lam (loop lam rest)
1279 in
1280 let op =
1281 transl_ident (of_location ~scopes let_.bop_op_name.loc) env
1282 let_.bop_op_type let_.bop_op_path let_.bop_op_val
1283 in
1284 let exp = loop (transl_exp ~scopes let_.bop_exp) ands in
1285 let func =
1286 let (kind, params, return), body =
1287 event_function ~scopes case.c_rhs
1288 (function repr ->
1289 let loc = case.c_rhs.exp_loc in
1290 let ghost_loc = { loc with loc_ghost = true } in
1291 transl_function_without_attributes ~scopes loc repr []
1292 (Tfunction_cases
1293 { cases = [case]; param; partial; loc = ghost_loc;
1294 exp_extra = None; attributes = []; }))
1295 in
1296 let attr = function_attribute_disallowing_arity_fusion in
1297 let loc = of_location ~scopes case.c_rhs.exp_loc in
1298 lfunction ~kind ~params ~return ~body ~attr ~loc
1299 in
1300 Lapply{
1301 ap_loc = of_location ~scopes loc;
1302 ap_func = op;
1303 ap_args=[exp; func];
1304 ap_tailcall = Default_tailcall;
1305 ap_inlined = Default_inline;
1306 ap_specialised = Default_specialise;
1307 }
1308
1309(* Wrapper for class compilation *)
1310
1311(*
1312let transl_exp = transl_exp_wrap
1313
1314let transl_let rec_flag pat_expr_list body =
1315 match pat_expr_list with
1316 [] -> body
1317 | (_, expr) :: _ ->
1318 Translobj.oo_wrap expr.exp_env false
1319 (transl_let rec_flag pat_expr_list) body
1320*)
1321
1322(* Error report *)
1323
1324open Format_doc
1325
1326let report_error_doc ppf = function
1327 | Free_super_var ->
1328 fprintf ppf
1329 "Ancestor names can only be used to select inherited methods"
1330 | Unreachable_reached ->
1331 fprintf ppf "Unreachable expression was reached"
1332
1333let () =
1334 Location.register_error_of_exn
1335 (function
1336 | Error (loc, err) ->
1337 Some (Location.error_of_printer ~loc report_error_doc err)
1338 | _ ->
1339 None
1340 )
1341
1342let report_error = Format_doc.compat report_error_doc