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 module language *)
18
19open Misc
20open Asttypes
21open Path
22open Types
23open Typedtree
24open Lambda
25open Translobj
26open Translcore
27open Translclass
28open Debuginfo.Scoped_location
29
30type unsafe_component =
31 | Unsafe_module_binding
32 | Unsafe_functor
33 | Unsafe_non_function
34 | Unsafe_typext
35
36type unsafe_info =
37 | Unsafe of {
38 reason:unsafe_component;
39 loc:Location.t;
40 path: Path.t
41 }
42 | Unnamed
43
44type error =
45 Circular_dependency of (Ident.t * unsafe_info) list
46| Conflicting_inline_attributes
47
48exception Error of Location.t * error
49
50let cons_opt x_opt xs =
51 match x_opt with
52 | None -> xs
53 | Some x -> x :: xs
54
55(* Keep track of the root path (from the root of the namespace to the
56 currently compiled module expression). Useful for naming extensions. *)
57
58let global_path glob = Some(Pident glob)
59let functor_path path param =
60 match path with
61 None -> None
62 | Some p -> Some(Papply(p, Pident param))
63let field_path path field =
64 match path with
65 None -> None
66 | Some p -> Some(Pdot(p, Ident.name field))
67
68(* Compile type extensions *)
69
70let transl_type_extension ~scopes env rootpath tyext body =
71 List.fold_right
72 (fun ext body ->
73 let lam =
74 transl_extension_constructor ~scopes env
75 (field_path rootpath ext.ext_id) ext
76 in
77 Llet(Strict, Pgenval, ext.ext_id, lam, body))
78 tyext.tyext_constructors
79 body
80
81(* Compile a coercion *)
82
83let rec apply_coercion loc strict restr arg =
84 match restr with
85 Tcoerce_none ->
86 arg
87 | Tcoerce_structure(pos_cc_list, id_pos_list) ->
88 name_lambda strict arg (fun id ->
89 let get_field pos =
90 if pos < 0 then lambda_unit
91 else Lprim(Pfield (pos, Pointer, Mutable), [Lvar id], loc)
92 in
93 let lam =
94 Lprim(Pmakeblock(0, Immutable, None),
95 List.map (apply_coercion_field loc get_field) pos_cc_list,
96 loc)
97 in
98 wrap_id_pos_list loc id_pos_list get_field lam)
99 | Tcoerce_functor(cc_arg, cc_res) ->
100 let param = Ident.create_local "funarg" in
101 let carg = apply_coercion loc Alias cc_arg (Lvar param) in
102 apply_coercion_result loc strict arg [param, Pgenval] [carg] cc_res
103 | Tcoerce_primitive { pc_loc = _; pc_desc; pc_env; pc_type; } ->
104 Translprim.transl_primitive loc pc_desc pc_env pc_type None
105 | Tcoerce_alias (env, path, cc) ->
106 let lam = transl_module_path loc env path in
107 name_lambda strict arg
108 (fun _ -> apply_coercion loc Alias cc lam)
109
110and apply_coercion_field loc get_field (pos, cc) =
111 apply_coercion loc Alias cc (get_field pos)
112
113and apply_coercion_result loc strict funct params args cc_res =
114 match cc_res with
115 | Tcoerce_functor(cc_arg, cc_res) ->
116 let param = Ident.create_local "funarg" in
117 let arg = apply_coercion loc Alias cc_arg (Lvar param) in
118 apply_coercion_result loc strict funct
119 ((param, Pgenval) :: params) (arg :: args) cc_res
120 | _ ->
121 name_lambda strict funct
122 (fun id ->
123 lfunction
124 ~kind:Curried
125 ~params:(List.rev params)
126 ~return:Pgenval
127 ~attr:{ default_function_attribute with
128 is_a_functor = true;
129 stub = true;
130 may_fuse_arity = true; }
131 ~loc
132 ~body:(apply_coercion
133 loc Strict cc_res
134 (Lapply{
135 ap_loc=loc;
136 ap_func=Lvar id;
137 ap_args=List.rev args;
138 ap_tailcall=Default_tailcall;
139 ap_inlined=Default_inline;
140 ap_specialised=Default_specialise;
141 })))
142
143and wrap_id_pos_list loc id_pos_list get_field lam =
144 let fv = free_variables lam in
145 (*Format.eprintf "%a@." Printlambda.lambda lam;
146 Ident.Set.iter (fun id -> Format.eprintf "%a " Ident.print id) fv;
147 Format.eprintf "@.";*)
148 let (lam, _fv, s) =
149 List.fold_left (fun (lam, fv, s) (id',pos,c) ->
150 if Ident.Set.mem id' fv then
151 let id'' = Ident.create_local (Ident.name id') in
152 let rhs = apply_coercion loc Alias c (get_field pos) in
153 let fv_rhs = free_variables rhs in
154 (Llet(Alias, Pgenval, id'', rhs, lam),
155 Ident.Set.union fv fv_rhs,
156 Ident.Map.add id' id'' s)
157 else (lam, fv, s))
158 (lam, fv, Ident.Map.empty) id_pos_list
159 in
160 if s == Ident.Map.empty then lam else Lambda.rename s lam
161
162
163(* Compose two coercions
164 apply_coercion c1 (apply_coercion c2 e) behaves like
165 apply_coercion (compose_coercions c1 c2) e. *)
166
167let rec compose_coercions c1 c2 =
168 match (c1, c2) with
169 (Tcoerce_none, c2) -> c2
170 | (c1, Tcoerce_none) -> c1
171 | (Tcoerce_structure (pc1, ids1), Tcoerce_structure (pc2, ids2)) ->
172 let v2 = Array.of_list pc2 in
173 let ids1 =
174 List.map (fun (id,pos1,c1) ->
175 if pos1 < 0 then (id, pos1, c1)
176 else
177 let (pos2,c2) = v2.(pos1) in
178 (id, pos2, compose_coercions c1 c2))
179 ids1
180 in
181 Tcoerce_structure
182 (List.map
183 (fun pc ->
184 match pc with
185 | _, (Tcoerce_primitive _ | Tcoerce_alias _) ->
186 (* These cases do not take an argument (the position is -1),
187 so they do not need adjusting. *)
188 pc
189 | (p1, c1) ->
190 let (p2, c2) = v2.(p1) in
191 (p2, compose_coercions c1 c2))
192 pc1,
193 ids1 @ ids2)
194 | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) ->
195 Tcoerce_functor(compose_coercions arg2 arg1,
196 compose_coercions res1 res2)
197 | (c1, Tcoerce_alias (env, path, c2)) ->
198 Tcoerce_alias (env, path, compose_coercions c1 c2)
199 | (_, _) ->
200 fatal_error "Translmod.compose_coercions"
201
202(*
203let apply_coercion a b c =
204 Format.eprintf "@[<2>apply_coercion@ %a@]@." Includemod.print_coercion b;
205 apply_coercion a b c
206
207let compose_coercions c1 c2 =
208 let c3 = compose_coercions c1 c2 in
209 let open Includemod in
210 Format.eprintf "@[<2>compose_coercions@ (%a)@ (%a) =@ %a@]@."
211 print_coercion c1 print_coercion c2 print_coercion c3;
212 c3
213*)
214
215(* Record the primitive declarations occurring in the module compiled *)
216
217let primitive_declarations = ref ([] : Primitive.description list)
218let record_primitive = function
219 | {val_kind=Val_prim p;val_loc} ->
220 Translprim.check_primitive_arity val_loc p;
221 primitive_declarations := p :: !primitive_declarations
222 | _ -> ()
223
224(* Utilities for compiling "module rec" definitions *)
225
226let mod_prim = Lambda.transl_prim "CamlinternalMod"
227
228let undefined_location loc =
229 let (fname, line, char) = Location.get_pos_info loc.Location.loc_start in
230 Lconst(Const_block(0,
231 [Const_immstring fname;
232 const_int line;
233 const_int char]))
234
235exception Initialization_failure of unsafe_info
236
237let init_shape id modl =
238 let rec init_shape_mod path loc env mty =
239 match Mtype.scrape env mty with
240 Mty_ident _
241 | Mty_alias _ ->
242 let info = Unsafe {reason=Unsafe_module_binding;loc; path} in
243 raise (Initialization_failure info)
244 | Mty_signature sg ->
245 Const_block(0, [Const_block(0, init_shape_struct path env sg)])
246 | Mty_functor _ ->
247 (* can we do better? *)
248 let info = Unsafe {reason=Unsafe_functor;loc; path} in
249 raise (Initialization_failure info)
250 and init_shape_struct path env sg =
251 match sg with
252 [] -> []
253 | Sig_value(subid, {val_kind=Val_reg; val_type=ty; val_loc=loc},_) :: rem ->
254 let new_path = Pdot(path, Ident.name subid) in
255 let init_v =
256 match get_desc (Ctype.expand_head env ty) with
257 Tarrow(_,_,_,_) ->
258 const_int 0 (* camlinternalMod.Function *)
259 | Tconstr(p, _, _) when Path.same p Predef.path_lazy_t ->
260 const_int 1 (* camlinternalMod.Lazy *)
261 | _ ->
262 let info =
263 Unsafe {reason=Unsafe_non_function; loc; path=new_path} in
264 raise (Initialization_failure info)
265 in
266 init_v :: init_shape_struct new_path env rem
267 | Sig_value(_, {val_kind=Val_prim _}, _) :: rem ->
268 init_shape_struct path env rem
269 | Sig_value _ :: _rem ->
270 assert false
271 | Sig_type(id, tdecl, _, _) :: rem ->
272 init_shape_struct path (Env.add_type ~check:false id tdecl env) rem
273 | Sig_typext (subid, {ext_loc=loc},_,_) :: _ ->
274 let new_path = Pdot(path, Ident.name subid) in
275 let info = Unsafe {reason=Unsafe_typext; loc; path=new_path} in
276 raise (Initialization_failure info)
277 | Sig_module(id, Mp_present, md, _, _) :: rem ->
278 init_shape_mod (
279 Pdot(path, Ident.name id)) md.md_loc env md.md_type ::
280 init_shape_struct path (Env.add_module_declaration ~check:false
281 id Mp_present md env) rem
282 | Sig_module(id, Mp_absent, md, _, _) :: rem ->
283 init_shape_struct
284 path (Env.add_module_declaration ~check:false
285 id Mp_absent md env) rem
286 | Sig_modtype(id, minfo, _) :: rem ->
287 init_shape_struct path (Env.add_modtype id minfo env) rem
288 | Sig_class _ :: rem ->
289 const_int 2 (* camlinternalMod.Class *)
290 :: init_shape_struct path env rem
291 | Sig_class_type _ :: rem ->
292 init_shape_struct path env rem
293 in
294 try
295 Ok(undefined_location modl.mod_loc,
296 Lconst(
297 init_shape_mod (Path.Pident id) modl.mod_loc modl.mod_env modl.mod_type)
298 )
299 with Initialization_failure reason -> Result.Error(reason)
300
301(* Reorder bindings to honor dependencies. *)
302
303type binding_status =
304 | Undefined
305 | Inprogress of int option (** parent node *)
306 | Defined
307
308type id_or_ignore_loc =
309 | Id of Ident.t
310 | Ignore_loc of Lambda.scoped_location
311
312let extract_unsafe_cycle id status init cycle_start =
313 let info i = match init.(i) with
314 | Result.Error r ->
315 begin match id.(i) with
316 | Id id -> id, r
317 | Ignore_loc _ ->
318 assert false (* Can't refer to something without a name. *)
319 end
320 | Ok _ -> assert false in
321 let rec collect stop l i = match status.(i) with
322 | Inprogress None | Undefined | Defined -> assert false
323 | Inprogress Some i when i = stop -> info i :: l
324 | Inprogress Some i -> collect stop (info i::l) i in
325 collect cycle_start [] cycle_start
326
327let reorder_rec_bindings bindings =
328 let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings)
329 and loc = Array.of_list (List.map (fun (_,loc,_,_) -> loc) bindings)
330 and init = Array.of_list (List.map (fun (_,_,init,_) -> init) bindings)
331 and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in
332 let fv = Array.map Lambda.free_variables rhs in
333 let num_bindings = Array.length id in
334 let status = Array.make num_bindings Undefined in
335 let res = ref [] in
336 let is_unsafe i = match init.(i) with
337 | Ok _ -> false
338 | Result.Error _ -> true in
339 let init_res i = match init.(i) with
340 | Result.Error _ -> None
341 | Ok(a,b) -> Some(a,b) in
342 let rec emit_binding parent i =
343 match status.(i) with
344 Defined -> ()
345 | Inprogress _ ->
346 status.(i) <- Inprogress parent;
347 let cycle = extract_unsafe_cycle id status init i in
348 raise(Error(loc.(i), Circular_dependency cycle))
349 | Undefined ->
350 if is_unsafe i then begin
351 status.(i) <- Inprogress parent;
352 for j = 0 to num_bindings - 1 do
353 match id.(j) with
354 | Id id when Ident.Set.mem id fv.(i) -> emit_binding (Some i) j
355 | _ -> ()
356 done
357 end;
358 res := (id.(i), init_res i, rhs.(i)) :: !res;
359 status.(i) <- Defined in
360 for i = 0 to num_bindings - 1 do
361 match status.(i) with
362 Undefined -> emit_binding None i
363 | Inprogress _ -> assert false
364 | Defined -> ()
365 done;
366 List.rev !res
367
368(* Generate lambda-code for a reordered list of bindings *)
369
370let eval_rec_bindings bindings cont =
371 let rec bind_inits = function
372 [] ->
373 bind_strict bindings
374 | (Ignore_loc _, _, _) :: rem
375 | (_, None, _) :: rem ->
376 bind_inits rem
377 | (Id id, Some(loc, shape), _rhs) :: rem ->
378 Llet(Strict, Pgenval, id,
379 Lapply{
380 ap_loc=Loc_unknown;
381 ap_func=mod_prim "init_mod";
382 ap_args=[loc; shape];
383 ap_tailcall=Default_tailcall;
384 ap_inlined=Default_inline;
385 ap_specialised=Default_specialise;
386 },
387 bind_inits rem)
388 and bind_strict = function
389 [] ->
390 patch_forwards bindings
391 | (Ignore_loc loc, None, rhs) :: rem ->
392 Lsequence(Lprim(Pignore, [rhs], loc), bind_strict rem)
393 | (Id id, None, rhs) :: rem ->
394 Llet(Strict, Pgenval, id, rhs, bind_strict rem)
395 | (_id, Some _, _rhs) :: rem ->
396 bind_strict rem
397 and patch_forwards = function
398 [] ->
399 cont
400 | (Ignore_loc _, _, _rhs) :: rem
401 | (_, None, _rhs) :: rem ->
402 patch_forwards rem
403 | (Id id, Some(_loc, shape), rhs) :: rem ->
404 Lsequence(
405 Lapply {
406 ap_loc=Loc_unknown;
407 ap_func=mod_prim "update_mod";
408 ap_args=[shape; Lvar id; rhs];
409 ap_tailcall=Default_tailcall;
410 ap_inlined=Default_inline;
411 ap_specialised=Default_specialise;
412 },
413 patch_forwards rem)
414 in
415 bind_inits bindings
416
417let compile_recmodule ~scopes compile_rhs bindings cont =
418 eval_rec_bindings
419 (reorder_rec_bindings
420 (List.map
421 (fun {mb_id=id; mb_name; mb_expr=modl; _} ->
422 let id_or_ignore_loc, shape =
423 match id with
424 | None ->
425 let loc = of_location ~scopes mb_name.loc in
426 Ignore_loc loc, Result.Error Unnamed
427 | Some id -> Id id, init_shape id modl
428 in
429 (id_or_ignore_loc, modl.mod_loc, shape, compile_rhs id modl))
430 bindings))
431 cont
432
433(* Code to translate class entries in a structure *)
434
435let transl_class_bindings ~scopes cl_list =
436 let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in
437 (ids,
438 List.map
439 (fun ({ci_id_class=id; ci_expr=cl; ci_virt=vf}, meths) ->
440 let def, rkind = transl_class ~scopes ids id meths cl vf in
441 (id, rkind, def))
442 cl_list)
443
444(* Compile one or more functors, merging curried functors to produce
445 multi-argument functors. Any [@inline] attribute on a functor that is
446 merged must be consistent with any other [@inline] attribute(s) on the
447 functor(s) being merged with. Such an attribute will be placed on the
448 resulting merged functor. *)
449
450let merge_inline_attributes attr1 attr2 loc =
451 match Lambda.merge_inline_attributes attr1 attr2 with
452 | Some attr -> attr
453 | None -> raise (Error (to_location loc, Conflicting_inline_attributes))
454
455let merge_functors ~scopes mexp coercion root_path =
456 let rec merge ~scopes mexp coercion path acc inline_attribute =
457 let finished = acc, mexp, path, coercion, inline_attribute in
458 match mexp.mod_desc with
459 | Tmod_functor (param, body) ->
460 let inline_attribute' =
461 Translattribute.get_inline_attribute mexp.mod_attributes
462 in
463 let arg_coercion, res_coercion =
464 match coercion with
465 | Tcoerce_none -> Tcoerce_none, Tcoerce_none
466 | Tcoerce_functor (arg_coercion, res_coercion) ->
467 arg_coercion, res_coercion
468 | _ -> fatal_error "Translmod.merge_functors: bad coercion"
469 in
470 let loc = of_location ~scopes mexp.mod_loc in
471 let path, param =
472 match param with
473 | Unit -> None, Ident.create_local "*"
474 | Named (None, _, _) ->
475 let id = Ident.create_local "_" in
476 functor_path path id, id
477 | Named (Some id, _, _) -> functor_path path id, id
478 in
479 let inline_attribute =
480 merge_inline_attributes inline_attribute inline_attribute' loc
481 in
482 merge ~scopes body res_coercion path ((param, loc, arg_coercion) :: acc)
483 inline_attribute
484 | _ -> finished
485 in
486 merge ~scopes mexp coercion root_path [] Default_inline
487
488let rec compile_functor ~scopes mexp coercion root_path loc =
489 let functor_params_rev, body, body_path, res_coercion, inline_attribute =
490 merge_functors ~scopes mexp coercion root_path
491 in
492 assert (List.length functor_params_rev >= 1); (* cf. [transl_module] *)
493 let params, body =
494 List.fold_left (fun (params, body) (param, loc, arg_coercion) ->
495 let param' = Ident.rename param in
496 let arg = apply_coercion loc Alias arg_coercion (Lvar param') in
497 let params = (param', Pgenval) :: params in
498 let body = Llet (Alias, Pgenval, param, arg, body) in
499 params, body)
500 ([], transl_module ~scopes res_coercion body_path body)
501 functor_params_rev
502 in
503 lfunction
504 ~kind:Curried
505 ~params
506 ~return:Pgenval
507 ~attr:{
508 inline = inline_attribute;
509 specialise = Default_specialise;
510 local = Default_local;
511 poll = Default_poll;
512 is_a_functor = true;
513 stub = false;
514 tmc_candidate = false;
515 may_fuse_arity = true;
516 }
517 ~loc
518 ~body
519
520(* Compile a module expression *)
521
522and transl_module ~scopes cc rootpath mexp =
523 let loc = of_location ~scopes mexp.mod_loc in
524 match mexp.mod_desc with
525 | Tmod_ident (path,_) ->
526 apply_coercion loc Strict cc
527 (transl_module_path loc mexp.mod_env path)
528 | Tmod_structure str ->
529 transl_struct ~scopes loc [] cc rootpath str
530 | Tmod_functor _ ->
531 oo_wrap mexp.mod_env true (fun () ->
532 compile_functor ~scopes mexp cc rootpath loc) ()
533 | Tmod_apply(funct, arg, ccarg) ->
534 let translated_arg = transl_module ~scopes ccarg None arg in
535 transl_apply ~scopes ~loc ~cc mexp.mod_env funct translated_arg
536 | Tmod_apply_unit funct ->
537 transl_apply ~scopes ~loc ~cc mexp.mod_env funct lambda_unit
538 | Tmod_constraint(arg, _, _, ccarg) ->
539 transl_module ~scopes (compose_coercions cc ccarg) rootpath arg
540 | Tmod_unpack(arg, _) ->
541 apply_coercion loc Strict cc (Translcore.transl_exp ~scopes arg)
542
543and transl_apply ~scopes ~loc ~cc mod_env funct translated_arg =
544 let inlined_attribute =
545 Translattribute.get_inlined_attribute_on_module funct
546 in
547 oo_wrap mod_env true
548 (apply_coercion loc Strict cc)
549 (Lapply{
550 ap_loc=loc;
551 ap_func=transl_module ~scopes Tcoerce_none None funct;
552 ap_args=[translated_arg];
553 ap_tailcall=Default_tailcall;
554 ap_inlined=inlined_attribute;
555 ap_specialised=Default_specialise})
556
557and transl_struct ~scopes loc fields cc rootpath {str_final_env; str_items; _} =
558 transl_structure ~scopes loc fields cc rootpath str_final_env str_items
559
560(* The function transl_structure is called by the bytecode compiler.
561 Some effort is made to compile in top to bottom order, in order to display
562 warning by increasing locations. *)
563and transl_structure ~scopes loc fields cc rootpath final_env = function
564 [] ->
565 let body =
566 match cc with
567 Tcoerce_none ->
568 Lprim(Pmakeblock(0, Immutable, None),
569 List.map (fun id -> Lvar id) (List.rev fields), loc)
570 | Tcoerce_structure(pos_cc_list, id_pos_list) ->
571 (* Do not ignore id_pos_list ! *)
572 (*Format.eprintf "%a@.@[" Includemod.print_coercion cc;
573 List.iter (fun l -> Format.eprintf "%a@ " Ident.print l)
574 fields;
575 Format.eprintf "@]@.";*)
576 let v = Array.of_list (List.rev fields) in
577 let get_field pos =
578 if pos < 0 then lambda_unit
579 else Lvar v.(pos)
580 in
581 let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in
582 let lam =
583 Lprim(Pmakeblock(0, Immutable, None),
584 List.map
585 (fun (pos, cc) ->
586 match cc with
587 Tcoerce_primitive p ->
588 Translprim.transl_primitive
589 (of_location ~scopes p.pc_loc)
590 p.pc_desc p.pc_env p.pc_type None
591 | _ -> apply_coercion loc Strict cc (get_field pos))
592 pos_cc_list, loc)
593 and id_pos_list =
594 List.filter (fun (id,_,_) -> not (Ident.Set.mem id ids))
595 id_pos_list
596 in
597 wrap_id_pos_list loc id_pos_list get_field lam
598 | _ ->
599 fatal_error "Translmod.transl_structure"
600 in
601 (* This debugging event provides information regarding the structure
602 items. It is ignored by the OCaml debugger but is used by
603 Js_of_ocaml to preserve variable names. *)
604 if !Clflags.debug && not !Clflags.native_code then
605 Levent(body,
606 {lev_loc = loc;
607 lev_kind = Lev_pseudo;
608 lev_repr = None;
609 lev_env = final_env})
610 else
611 body
612 | item :: rem ->
613 transl_struct_item ~scopes fields rootpath item
614 (fun fields ->
615 transl_structure ~scopes loc fields cc rootpath final_env rem)
616
617and transl_struct_item ~scopes fields rootpath item next =
618 match item.str_desc with
619 | Tstr_eval (expr, _) ->
620 let body = next fields in
621 Lsequence(transl_exp ~scopes expr, body)
622 | Tstr_value(rec_flag, pat_expr_list) ->
623 (* Translate bindings first *)
624 let mk_lam_let =
625 transl_let ~scopes ~in_structure:true rec_flag pat_expr_list in
626 let ext_fields =
627 List.rev_append (let_bound_idents pat_expr_list) fields in
628 (* Then, translate remainder of struct *)
629 let body = next ext_fields in
630 mk_lam_let body
631 | Tstr_primitive descr ->
632 record_primitive descr.val_val;
633 next fields
634 | Tstr_type _ ->
635 next fields
636 | Tstr_typext(tyext) ->
637 let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in
638 let body = next (List.rev_append ids fields) in
639 transl_type_extension ~scopes item.str_env rootpath tyext body
640 | Tstr_exception ext ->
641 let id = ext.tyexn_constructor.ext_id in
642 let path = field_path rootpath id in
643 let body = next (id::fields) in
644 Llet(Strict, Pgenval, id,
645 transl_extension_constructor ~scopes
646 item.str_env
647 path
648 ext.tyexn_constructor, body)
649 | Tstr_module ({mb_presence=Mp_present} as mb) ->
650 let id = mb.mb_id in
651 (* Translate module first *)
652 let subscopes = match id with
653 | None -> scopes
654 | Some id -> enter_module_definition ~scopes id in
655 let module_body =
656 transl_module ~scopes:subscopes Tcoerce_none
657 (Option.bind id (field_path rootpath)) mb.mb_expr
658 in
659 let module_body =
660 Translattribute.add_inline_attribute module_body mb.mb_loc
661 mb.mb_attributes
662 in
663 (* Translate remainder second *)
664 let body = next (cons_opt id fields) in
665 begin match id with
666 | None ->
667 Lsequence (Lprim(Pignore, [module_body],
668 of_location ~scopes mb.mb_name.loc), body)
669 | Some id ->
670 Llet(pure_module mb.mb_expr, Pgenval, id, module_body, body)
671 end
672 | Tstr_module ({mb_presence=Mp_absent}) ->
673 next fields
674 | Tstr_recmodule bindings ->
675 let ext_fields =
676 List.rev_append (List.filter_map (fun mb -> mb.mb_id) bindings)
677 fields
678 in
679 let body = next ext_fields in
680 let lam =
681 compile_recmodule ~scopes (fun id modl ->
682 match id with
683 | None -> transl_module ~scopes Tcoerce_none None modl
684 | Some id ->
685 transl_module
686 ~scopes:(enter_module_definition ~scopes id)
687 Tcoerce_none (field_path rootpath id) modl
688 ) bindings body
689 in
690 lam
691 | Tstr_class cl_list ->
692 let (ids, class_bindings) = transl_class_bindings ~scopes cl_list in
693 let body = next (List.rev_append ids fields) in
694 Value_rec_compiler.compile_letrec class_bindings body
695 | Tstr_include incl ->
696 let ids = bound_value_identifiers incl.incl_type in
697 let modl = incl.incl_mod in
698 let mid = Ident.create_local "include" in
699 let rec rebind_idents pos newfields = function
700 [] ->
701 next newfields
702 | id :: ids ->
703 let body =
704 rebind_idents (pos + 1) (id :: newfields) ids
705 in
706 Llet(Alias, Pgenval, id,
707 Lprim(Pfield (pos, Pointer, Mutable),
708 [Lvar mid], of_location ~scopes incl.incl_loc), body)
709 in
710 let body = rebind_idents 0 fields ids in
711 Llet(pure_module modl, Pgenval, mid,
712 transl_module ~scopes Tcoerce_none None modl, body)
713
714 | Tstr_open od ->
715 let pure = pure_module od.open_expr in
716 (* this optimization shouldn't be needed because Simplif would
717 actually remove the [Llet] when it's not used.
718 But since [scan_used_globals] runs before Simplif, we need to do
719 it. *)
720 begin match od.open_bound_items with
721 | [] when pure = Alias ->
722 next fields
723 | _ ->
724 let ids = bound_value_identifiers od.open_bound_items in
725 let mid = Ident.create_local "open" in
726 let rec rebind_idents pos newfields = function
727 [] -> next newfields
728 | id :: ids ->
729 let body =
730 rebind_idents (pos + 1) (id :: newfields) ids
731 in
732 Llet(Alias, Pgenval, id,
733 Lprim(Pfield (pos, Pointer, Mutable), [Lvar mid],
734 of_location ~scopes od.open_loc), body)
735 in
736 let body = rebind_idents 0 fields ids in
737 Llet(pure, Pgenval, mid,
738 transl_module ~scopes Tcoerce_none None od.open_expr, body)
739 end
740 | Tstr_modtype _
741 | Tstr_class_type _
742 | Tstr_attribute _ ->
743 next fields
744
745(* Update forward declaration in Translcore *)
746let _ =
747 Translcore.transl_module := transl_module;
748 Translcore.transl_struct_item := transl_struct_item
749
750(* Introduce dependencies on modules referenced only by "external". *)
751
752let scan_used_globals lam =
753 let is_compunit id = not (Ident.is_predef id) in
754 let globals = ref Ident.Set.empty in
755 let rec scan lam =
756 Lambda.iter_head_constructor scan lam;
757 match lam with
758 Lprim ((Pgetglobal id | Psetglobal id), _, _) when (is_compunit id) ->
759 globals := Ident.Set.add id !globals
760 | _ -> ()
761 in
762 scan lam; !globals
763
764let required_globals ~flambda body =
765 let globals = scan_used_globals body in
766 let add_global id req =
767 if not flambda && Ident.Set.mem id globals then
768 req
769 else
770 Ident.Set.add id req
771 in
772 let required =
773 List.fold_left
774 (fun acc path -> add_global (Path.head path) acc)
775 (if flambda then globals else Ident.Set.empty)
776 (Translprim.get_used_primitives ())
777 in
778 let required =
779 List.fold_right add_global (Env.get_required_globals ()) required
780 in
781 Env.reset_required_globals ();
782 Translprim.clear_used_primitives ();
783 required
784
785(* Compile an implementation *)
786
787let module_block_size component_names coercion =
788 match coercion with
789 | Tcoerce_none -> List.length component_names
790 | Tcoerce_structure (l, _) -> List.length l
791 | Tcoerce_functor _
792 | Tcoerce_primitive _
793 | Tcoerce_alias _ -> assert false
794
795let transl_implementation_flambda module_name (str, cc) =
796 reset_labels ();
797 primitive_declarations := [];
798 Translprim.clear_used_primitives ();
799 let module_id = Ident.create_persistent module_name in
800 let scopes = enter_module_definition ~scopes:empty_scopes module_id in
801 let body =
802 Translobj.transl_label_init
803 (fun () -> transl_struct ~scopes Loc_unknown [] cc
804 (global_path module_id) str)
805 in
806 let size =
807 module_block_size (bound_value_identifiers str.str_type) cc in
808 { module_ident = module_id;
809 main_module_block_size = size;
810 required_globals = required_globals ~flambda:true body;
811 code = body }
812
813let transl_implementation module_name (str, cc) =
814 let implementation =
815 transl_implementation_flambda module_name (str, cc)
816 in
817 let code =
818 Lprim (Psetglobal implementation.module_ident, [implementation.code],
819 Loc_unknown)
820 in
821 { implementation with code }
822
823(* Build the list of value identifiers defined by a toplevel structure
824 (excluding primitive declarations). *)
825
826let rec defined_idents = function
827 [] -> []
828 | item :: rem ->
829 match item.str_desc with
830 | Tstr_eval _ -> defined_idents rem
831 | Tstr_value(_rec_flag, pat_expr_list) ->
832 let_bound_idents pat_expr_list @ defined_idents rem
833 | Tstr_primitive _ -> defined_idents rem
834 | Tstr_type _ -> defined_idents rem
835 | Tstr_typext tyext ->
836 List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
837 @ defined_idents rem
838 | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: defined_idents rem
839 | Tstr_module {mb_id = Some id; mb_presence=Mp_present} ->
840 id :: defined_idents rem
841 | Tstr_module ({mb_id = None}
842 |{mb_presence=Mp_absent}) -> defined_idents rem
843 | Tstr_recmodule decls ->
844 List.filter_map (fun mb -> mb.mb_id) decls @ defined_idents rem
845 | Tstr_modtype _ -> defined_idents rem
846 | Tstr_open od ->
847 bound_value_identifiers od.open_bound_items @ defined_idents rem
848 | Tstr_class cl_list ->
849 List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ defined_idents rem
850 | Tstr_class_type _ -> defined_idents rem
851 | Tstr_include incl ->
852 bound_value_identifiers incl.incl_type @ defined_idents rem
853 | Tstr_attribute _ -> defined_idents rem
854
855(* second level idents (module M = struct ... let id = ... end),
856 and all sub-levels idents *)
857let rec more_idents = function
858 [] -> []
859 | item :: rem ->
860 match item.str_desc with
861 | Tstr_eval _ -> more_idents rem
862 | Tstr_value _ -> more_idents rem
863 | Tstr_primitive _ -> more_idents rem
864 | Tstr_type _ -> more_idents rem
865 | Tstr_typext _ -> more_idents rem
866 | Tstr_exception _ -> more_idents rem
867 | Tstr_recmodule _ -> more_idents rem
868 | Tstr_modtype _ -> more_idents rem
869 | Tstr_open od ->
870 let rest = more_idents rem in
871 begin match od.open_expr.mod_desc with
872 | Tmod_structure str -> all_idents str.str_items @ rest
873 | _ -> rest
874 end
875 | Tstr_class _ -> more_idents rem
876 | Tstr_class_type _ -> more_idents rem
877 | Tstr_include{incl_mod={mod_desc =
878 Tmod_constraint ({mod_desc = Tmod_structure str},
879 _, _, _)
880 | Tmod_structure str }} ->
881 all_idents str.str_items @ more_idents rem
882 | Tstr_include _ -> more_idents rem
883 | Tstr_module
884 {mb_presence=Mp_present; mb_expr={mod_desc = Tmod_structure str}}
885 | Tstr_module
886 {mb_presence=Mp_present;
887 mb_expr={mod_desc=
888 Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} ->
889 all_idents str.str_items @ more_idents rem
890 | Tstr_module _ -> more_idents rem
891 | Tstr_attribute _ -> more_idents rem
892
893and all_idents = function
894 [] -> []
895 | item :: rem ->
896 match item.str_desc with
897 | Tstr_eval _ -> all_idents rem
898 | Tstr_value(_rec_flag, pat_expr_list) ->
899 let_bound_idents pat_expr_list @ all_idents rem
900 | Tstr_primitive _ -> all_idents rem
901 | Tstr_type _ -> all_idents rem
902 | Tstr_typext tyext ->
903 List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
904 @ all_idents rem
905 | Tstr_exception ext -> ext.tyexn_constructor.ext_id :: all_idents rem
906 | Tstr_recmodule decls ->
907 List.filter_map (fun mb -> mb.mb_id) decls @ all_idents rem
908 | Tstr_modtype _ -> all_idents rem
909 | Tstr_open od ->
910 let rest = all_idents rem in
911 begin match od.open_expr.mod_desc with
912 | Tmod_structure str ->
913 bound_value_identifiers od.open_bound_items
914 @ all_idents str.str_items
915 @ rest
916 | _ -> bound_value_identifiers od.open_bound_items @ rest
917 end
918 | Tstr_class cl_list ->
919 List.map (fun (ci, _) -> ci.ci_id_class) cl_list @ all_idents rem
920 | Tstr_class_type _ -> all_idents rem
921
922 | Tstr_include{incl_type;
923 incl_mod={mod_desc =
924 ( Tmod_constraint({mod_desc=Tmod_structure str}, _, _, _)
925 | Tmod_structure str )}} ->
926 bound_value_identifiers incl_type
927 @ all_idents str.str_items
928 @ all_idents rem
929 | Tstr_include incl ->
930 bound_value_identifiers incl.incl_type @ all_idents rem
931
932 | Tstr_module
933 { mb_id = Some id;
934 mb_presence=Mp_present;
935 mb_expr={mod_desc = Tmod_structure str} }
936 | Tstr_module
937 { mb_id = Some id;
938 mb_presence = Mp_present;
939 mb_expr =
940 {mod_desc =
941 Tmod_constraint ({mod_desc = Tmod_structure str}, _, _, _)}} ->
942 id :: all_idents str.str_items @ all_idents rem
943 | Tstr_module {mb_id = Some id;mb_presence=Mp_present} ->
944 id :: all_idents rem
945 | Tstr_module ({mb_id = None} | {mb_presence=Mp_absent}) -> all_idents rem
946 | Tstr_attribute _ -> all_idents rem
947
948
949(* A variant of transl_structure used to compile toplevel structure definitions
950 for the native-code compiler. Store the defined values in the fields
951 of the global as soon as they are defined, in order to reduce register
952 pressure. Also rewrites the defining expressions so that they
953 refer to earlier fields of the structure through the fields of
954 the global, not by their names.
955 "map" is a table from defined idents to (pos in global block, coercion).
956 "prim" is a list of (pos in global block, primitive declaration). *)
957
958let transl_store_subst = ref Ident.Map.empty
959 (** In the native toplevel, this reference is threaded through successive
960 calls of transl_store_structure *)
961
962let nat_toplevel_name id =
963 try match Ident.Map.find id !transl_store_subst with
964 | Lprim(Pfield (pos, _, _),
965 [Lprim(Pgetglobal glob, [], _)], _) -> (glob,pos)
966 | _ -> raise Not_found
967 with Not_found ->
968 fatal_error("Translmod.nat_toplevel_name: " ^ Ident.unique_name id)
969
970let field_of_str loc str =
971 let ids = Array.of_list (defined_idents str.str_items) in
972 fun (pos, cc) ->
973 match cc with
974 | Tcoerce_primitive { pc_loc = _; pc_desc; pc_env; pc_type; } ->
975 Translprim.transl_primitive loc pc_desc pc_env pc_type None
976 | Tcoerce_alias (env, path, cc) ->
977 let lam = transl_module_path loc env path in
978 apply_coercion loc Alias cc lam
979 | _ -> apply_coercion loc Strict cc (Lvar ids.(pos))
980
981
982let transl_store_structure ~scopes glob map prims aliases str =
983 let no_env_update _ _ env = env in
984 let rec transl_store ~scopes rootpath subst cont = function
985 [] ->
986 transl_store_subst := subst;
987 Lambda.subst no_env_update subst cont
988 | item :: rem ->
989 match item.str_desc with
990 | Tstr_eval (expr, _attrs) ->
991 Lsequence(Lambda.subst no_env_update subst
992 (transl_exp ~scopes expr),
993 transl_store ~scopes rootpath subst cont rem)
994 | Tstr_value(rec_flag, pat_expr_list) ->
995 let ids = let_bound_idents pat_expr_list in
996 let lam =
997 transl_let ~scopes ~in_structure:true rec_flag pat_expr_list
998 (store_idents Loc_unknown ids)
999 in
1000 Lsequence(Lambda.subst no_env_update subst lam,
1001 transl_store ~scopes rootpath
1002 (add_idents false ids subst) cont rem)
1003 | Tstr_primitive descr ->
1004 record_primitive descr.val_val;
1005 transl_store ~scopes rootpath subst cont rem
1006 | Tstr_type _ ->
1007 transl_store ~scopes rootpath subst cont rem
1008 | Tstr_typext(tyext) ->
1009 let ids =
1010 List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
1011 in
1012 let lam =
1013 transl_type_extension ~scopes item.str_env rootpath tyext
1014 (store_idents Loc_unknown ids)
1015 in
1016 Lsequence(Lambda.subst no_env_update subst lam,
1017 transl_store ~scopes rootpath
1018 (add_idents false ids subst) cont rem)
1019 | Tstr_exception ext ->
1020 let id = ext.tyexn_constructor.ext_id in
1021 let path = field_path rootpath id in
1022 let loc = of_location ~scopes ext.tyexn_constructor.ext_loc in
1023 let lam =
1024 transl_extension_constructor ~scopes
1025 item.str_env
1026 path
1027 ext.tyexn_constructor
1028 in
1029 Lsequence(Llet(Strict, Pgenval, id,
1030 Lambda.subst no_env_update subst lam,
1031 store_ident loc id),
1032 transl_store ~scopes rootpath
1033 (add_ident false id subst) cont rem)
1034 | Tstr_module
1035 {mb_id=None; mb_name; mb_presence=Mp_present; mb_expr=modl;
1036 mb_loc=loc; mb_attributes} ->
1037 let lam =
1038 Translattribute.add_inline_attribute
1039 (transl_module ~scopes Tcoerce_none None modl)
1040 loc mb_attributes
1041 in
1042 Lsequence(
1043 Lprim(Pignore,[Lambda.subst no_env_update subst lam],
1044 of_location ~scopes mb_name.loc),
1045 transl_store ~scopes rootpath subst cont rem
1046 )
1047 | Tstr_module{mb_id=Some id;mb_loc=loc;mb_presence=Mp_present;
1048 mb_expr={mod_desc = Tmod_structure str}} ->
1049 let loc = of_location ~scopes loc in
1050 let lam =
1051 transl_store
1052 ~scopes:(enter_module_definition ~scopes id)
1053 (field_path rootpath id) subst
1054 lambda_unit str.str_items
1055 in
1056 (* Careful: see next case *)
1057 let subst = !transl_store_subst in
1058 Lsequence(lam,
1059 Llet(Strict, Pgenval, id,
1060 Lambda.subst no_env_update subst
1061 (Lprim(Pmakeblock(0, Immutable, None),
1062 List.map (fun id -> Lvar id)
1063 (defined_idents str.str_items), loc)),
1064 Lsequence(store_ident loc id,
1065 transl_store ~scopes rootpath
1066 (add_ident true id subst)
1067 cont rem)))
1068 | Tstr_module{
1069 mb_id=Some id;mb_loc=loc;mb_presence=Mp_present;
1070 mb_expr= {
1071 mod_desc = Tmod_constraint (
1072 {mod_desc = Tmod_structure str}, _, _,
1073 (Tcoerce_structure (map, _) as _cc))}
1074 } ->
1075 (* Format.printf "coerc id %s: %a@." (Ident.unique_name id)
1076 Includemod.print_coercion cc; *)
1077 let loc = of_location ~scopes loc in
1078 let lam =
1079 transl_store
1080 ~scopes:(enter_module_definition ~scopes id)
1081 (field_path rootpath id) subst
1082 lambda_unit str.str_items
1083 in
1084 (* Careful: see next case *)
1085 let subst = !transl_store_subst in
1086 let field = field_of_str loc str in
1087 Lsequence(lam,
1088 Llet(Strict, Pgenval, id,
1089 Lambda.subst no_env_update subst
1090 (Lprim(Pmakeblock(0, Immutable, None),
1091 List.map field map, loc)),
1092 Lsequence(store_ident loc id,
1093 transl_store ~scopes rootpath
1094 (add_ident true id subst)
1095 cont rem)))
1096 | Tstr_module
1097 {mb_id=Some id; mb_presence=Mp_present; mb_expr=modl;
1098 mb_loc=loc; mb_attributes} ->
1099 let lam =
1100 Translattribute.add_inline_attribute
1101 (transl_module
1102 ~scopes:(enter_module_definition ~scopes id)
1103 Tcoerce_none (field_path rootpath id) modl)
1104 loc mb_attributes
1105 in
1106 (* Careful: the module value stored in the global may be different
1107 from the local module value, in case a coercion is applied.
1108 If so, keep using the local module value (id) in the remainder of
1109 the compilation unit (add_ident true returns subst unchanged).
1110 If not, we can use the value from the global
1111 (add_ident true adds id -> Pgetglobal... to subst). *)
1112 Llet(Strict, Pgenval, id, Lambda.subst no_env_update subst lam,
1113 Lsequence(store_ident (of_location ~scopes loc) id,
1114 transl_store ~scopes rootpath
1115 (add_ident true id subst)
1116 cont rem))
1117 | Tstr_module ({mb_presence=Mp_absent}) ->
1118 transl_store ~scopes rootpath subst cont rem
1119 | Tstr_recmodule bindings ->
1120 let ids = List.filter_map (fun mb -> mb.mb_id) bindings in
1121 compile_recmodule ~scopes
1122 (fun id modl ->
1123 Lambda.subst no_env_update subst
1124 (match id with
1125 | None ->
1126 transl_module ~scopes Tcoerce_none None modl
1127 | Some id ->
1128 transl_module
1129 ~scopes:(enter_module_definition ~scopes id)
1130 Tcoerce_none (field_path rootpath id) modl))
1131 bindings
1132 (Lsequence(store_idents Loc_unknown ids,
1133 transl_store ~scopes rootpath
1134 (add_idents true ids subst) cont rem))
1135 | Tstr_class cl_list ->
1136 let (ids, class_bindings) = transl_class_bindings ~scopes cl_list in
1137 let lam =
1138 Value_rec_compiler.compile_letrec class_bindings
1139 (store_idents Loc_unknown ids)
1140 in
1141 Lsequence(Lambda.subst no_env_update subst lam,
1142 transl_store ~scopes rootpath (add_idents false ids subst)
1143 cont rem)
1144
1145 | Tstr_include({
1146 incl_loc=loc;
1147 incl_mod= {
1148 mod_desc = Tmod_constraint (
1149 ({mod_desc = Tmod_structure str}), _, _,
1150 (Tcoerce_structure _ | Tcoerce_none))}
1151 | ({ mod_desc = Tmod_structure str});
1152 incl_type;
1153 } as incl) ->
1154 let lam =
1155 transl_store ~scopes None subst lambda_unit str.str_items
1156 (* It is tempting to pass rootpath instead of None
1157 in order to give a more precise name to exceptions
1158 in the included structured, but this would introduce
1159 a difference of behavior compared to bytecode. *)
1160 in
1161 let subst = !transl_store_subst in
1162 let field = field_of_str (of_location ~scopes loc) str in
1163 let ids0 = bound_value_identifiers incl_type in
1164 let rec loop ids args =
1165 match ids, args with
1166 | [], [] ->
1167 transl_store ~scopes rootpath (add_idents true ids0 subst)
1168 cont rem
1169 | id :: ids, arg :: args ->
1170 Llet(Alias, Pgenval, id,
1171 Lambda.subst no_env_update subst (field arg),
1172 Lsequence(store_ident (of_location ~scopes loc) id,
1173 loop ids args))
1174 | _ -> assert false
1175 in
1176 let map =
1177 match incl.incl_mod.mod_desc with
1178 | Tmod_constraint (_, _, _, Tcoerce_structure (map, _)) ->
1179 map
1180 | Tmod_structure _
1181 | Tmod_constraint (_, _, _, Tcoerce_none) ->
1182 List.init (List.length ids0) (fun i -> i, Tcoerce_none)
1183 | _ -> assert false
1184 in
1185 Lsequence(lam, loop ids0 map)
1186
1187 | Tstr_include incl ->
1188 let ids = bound_value_identifiers incl.incl_type in
1189 let modl = incl.incl_mod in
1190 let mid = Ident.create_local "include" in
1191 let loc = incl.incl_loc in
1192 let rec store_idents pos = function
1193 | [] -> transl_store
1194 ~scopes rootpath (add_idents true ids subst) cont rem
1195 | id :: idl ->
1196 Llet(Alias, Pgenval, id,
1197 Lprim(Pfield (pos, Pointer, Mutable), [Lvar mid],
1198 of_location ~scopes loc),
1199 Lsequence(store_ident (of_location ~scopes loc) id,
1200 store_idents (pos + 1) idl))
1201 in
1202 Llet(Strict, Pgenval, mid,
1203 Lambda.subst no_env_update subst
1204 (transl_module ~scopes Tcoerce_none None modl),
1205 store_idents 0 ids)
1206 | Tstr_open od ->
1207 begin match od.open_expr.mod_desc with
1208 | Tmod_structure str ->
1209 let lam =
1210 transl_store ~scopes rootpath subst lambda_unit str.str_items
1211 in
1212 let loc = of_location ~scopes od.open_loc in
1213 let ids = Array.of_list (defined_idents str.str_items) in
1214 let ids0 = bound_value_identifiers od.open_bound_items in
1215 let subst = !transl_store_subst in
1216 let rec store_idents pos = function
1217 | [] -> transl_store ~scopes rootpath
1218 (add_idents true ids0 subst) cont rem
1219 | id :: idl ->
1220 Llet(Alias, Pgenval, id, Lvar ids.(pos),
1221 Lsequence(store_ident loc id,
1222 store_idents (pos + 1) idl))
1223 in
1224 Lsequence(lam, Lambda.subst no_env_update subst
1225 (store_idents 0 ids0))
1226 | _ ->
1227 let pure = pure_module od.open_expr in
1228 (* this optimization shouldn't be needed because Simplif would
1229 actually remove the [Llet] when it's not used.
1230 But since [scan_used_globals] runs before Simplif, we need to
1231 do it. *)
1232 match od.open_bound_items with
1233 | [] when pure = Alias ->
1234 transl_store ~scopes rootpath subst cont rem
1235 | _ ->
1236 let ids = bound_value_identifiers od.open_bound_items in
1237 let mid = Ident.create_local "open" in
1238 let loc = of_location ~scopes od.open_loc in
1239 let rec store_idents pos = function
1240 [] -> transl_store ~scopes rootpath
1241 (add_idents true ids subst) cont rem
1242 | id :: idl ->
1243 Llet(Alias, Pgenval, id,
1244 Lprim(Pfield (pos, Pointer, Mutable),
1245 [Lvar mid], loc),
1246 Lsequence(store_ident loc id,
1247 store_idents (pos + 1) idl))
1248 in
1249 Llet(
1250 pure, Pgenval, mid,
1251 Lambda.subst no_env_update subst
1252 (transl_module ~scopes Tcoerce_none None od.open_expr),
1253 store_idents 0 ids)
1254 end
1255 | Tstr_modtype _
1256 | Tstr_class_type _
1257 | Tstr_attribute _ ->
1258 transl_store ~scopes rootpath subst cont rem
1259
1260 and store_ident loc id =
1261 try
1262 let (pos, cc) = Ident.find_same id map in
1263 let init_val = apply_coercion loc Alias cc (Lvar id) in
1264 Lprim(Psetfield(pos, Pointer, Root_initialization),
1265 [Lprim(Pgetglobal glob, [], loc); init_val],
1266 loc)
1267 with Not_found ->
1268 fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)
1269
1270 and store_idents loc idlist =
1271 make_sequence (store_ident loc) idlist
1272
1273 and add_ident may_coerce id subst =
1274 try
1275 let (pos, cc) = Ident.find_same id map in
1276 match cc with
1277 Tcoerce_none ->
1278 Ident.Map.add id
1279 (Lprim(Pfield (pos, Pointer, Immutable),
1280 [Lprim(Pgetglobal glob, [], Loc_unknown)],
1281 Loc_unknown))
1282 subst
1283 | _ ->
1284 if may_coerce then subst else assert false
1285 with Not_found ->
1286 assert false
1287
1288 and add_idents may_coerce idlist subst =
1289 List.fold_right (add_ident may_coerce) idlist subst
1290
1291 and store_primitive (pos, prim) cont =
1292 Lsequence(Lprim(Psetfield(pos, Pointer, Root_initialization),
1293 [Lprim(Pgetglobal glob, [], Loc_unknown);
1294 Translprim.transl_primitive Loc_unknown
1295 prim.pc_desc prim.pc_env prim.pc_type None],
1296 Loc_unknown),
1297 cont)
1298
1299 and store_alias (pos, env, path, cc) =
1300 let path_lam = transl_module_path Loc_unknown env path in
1301 let init_val = apply_coercion Loc_unknown Strict cc path_lam in
1302 Lprim(Psetfield(pos, Pointer, Root_initialization),
1303 [Lprim(Pgetglobal glob, [], Loc_unknown);
1304 init_val],
1305 Loc_unknown)
1306 in
1307 let aliases = make_sequence store_alias aliases in
1308 List.fold_right store_primitive prims
1309 (transl_store ~scopes (global_path glob) !transl_store_subst aliases str)
1310
1311(* Transform a coercion and the list of value identifiers defined by
1312 a toplevel structure into a table [id -> (pos, coercion)],
1313 with [pos] being the position in the global block where the value of
1314 [id] must be stored, and [coercion] the coercion to be applied to it.
1315 A given identifier may appear several times
1316 in the coercion (if it occurs several times in the signature); remember
1317 to assign it the position of its last occurrence.
1318 Identifiers that are not exported are assigned positions at the
1319 end of the block (beyond the positions of all exported idents).
1320 Also compute the total size of the global block,
1321 and the list of all primitives exported as values. *)
1322
1323let build_ident_map restr idlist more_ids =
1324 let rec natural_map pos map prims aliases = function
1325 | [] ->
1326 (map, prims, aliases, pos)
1327 | id :: rem ->
1328 natural_map (pos+1)
1329 (Ident.add id (pos, Tcoerce_none) map) prims aliases rem
1330 in
1331 let (map, prims, aliases, pos) =
1332 match restr with
1333 | Tcoerce_none ->
1334 natural_map 0 Ident.empty [] [] idlist
1335 | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
1336 (* ignore _id_pos_list as the ids are already bound *)
1337 let idarray = Array.of_list idlist in
1338 let rec export_map pos map prims aliases undef = function
1339 | [] ->
1340 natural_map pos map prims aliases undef
1341 | (_source_pos, Tcoerce_primitive p) :: rem ->
1342 export_map (pos + 1) map
1343 ((pos, p) :: prims) aliases undef rem
1344 | (_source_pos, Tcoerce_alias(env, path, cc)) :: rem ->
1345 export_map (pos + 1) map prims
1346 ((pos, env, path, cc) :: aliases) undef rem
1347 | (source_pos, cc) :: rem ->
1348 let id = idarray.(source_pos) in
1349 export_map (pos + 1) (Ident.add id (pos, cc) map)
1350 prims aliases (list_remove id undef) rem
1351 in
1352 export_map 0 Ident.empty [] [] idlist pos_cc_list
1353 | _ ->
1354 fatal_error "Translmod.build_ident_map"
1355 in
1356 natural_map pos map prims aliases more_ids
1357
1358(* Compile an implementation using transl_store_structure
1359 (for the native-code compiler). *)
1360
1361let transl_store_gen ~scopes module_name ({ str_items = str }, restr) topl =
1362 reset_labels ();
1363 primitive_declarations := [];
1364 Translprim.clear_used_primitives ();
1365 let module_id = Ident.create_persistent module_name in
1366 let (map, prims, aliases, size) =
1367 build_ident_map restr (defined_idents str) (more_idents str) in
1368 let f = function
1369 | [ { str_desc = Tstr_eval (expr, _attrs) } ] when topl ->
1370 assert (size = 0);
1371 Lambda.subst (fun _ _ env -> env) !transl_store_subst
1372 (transl_exp ~scopes expr)
1373 | str -> transl_store_structure ~scopes module_id map prims aliases str
1374 in
1375 transl_store_label_init module_id size f str
1376 (*size, transl_label_init (transl_store_structure module_id map prims str)*)
1377
1378let transl_store_phrases module_name str =
1379 let scopes =
1380 enter_module_definition ~scopes:empty_scopes
1381 (Ident.create_persistent module_name)
1382 in
1383 transl_store_gen ~scopes module_name (str,Tcoerce_none) true
1384
1385let transl_store_implementation module_name (str, restr) =
1386 let s = !transl_store_subst in
1387 transl_store_subst := Ident.Map.empty;
1388 let module_ident = Ident.create_persistent module_name in
1389 let scopes = enter_module_definition ~scopes:empty_scopes module_ident in
1390 let (i, code) = transl_store_gen ~scopes module_name (str, restr) false in
1391 transl_store_subst := s;
1392 { Lambda.main_module_block_size = i;
1393 code;
1394 (* module_ident is not used by closure, but this allow to share
1395 the type with the flambda version *)
1396 module_ident;
1397 required_globals = required_globals ~flambda:true code }
1398
1399(* Compile a toplevel phrase *)
1400
1401let toploop_ident = Ident.create_persistent "Toploop"
1402let toploop_getvalue_pos = 0 (* position of getvalue in module Toploop *)
1403let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *)
1404
1405let aliased_idents = ref Ident.empty
1406
1407let set_toplevel_unique_name id =
1408 aliased_idents :=
1409 Ident.add id (Ident.unique_toplevel_name id) !aliased_idents
1410
1411let toplevel_name id =
1412 try Ident.find_same id !aliased_idents
1413 with Not_found -> Ident.name id
1414
1415let toploop_getvalue id =
1416 Lapply{
1417 ap_loc=Loc_unknown;
1418 ap_func=Lprim(Pfield (toploop_getvalue_pos, Pointer, Mutable),
1419 [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)],
1420 Loc_unknown);
1421 ap_args=[Lconst(Const_immstring (toplevel_name id))];
1422 ap_tailcall=Default_tailcall;
1423 ap_inlined=Default_inline;
1424 ap_specialised=Default_specialise;
1425 }
1426
1427let toploop_setvalue id lam =
1428 Lapply{
1429 ap_loc=Loc_unknown;
1430 ap_func=Lprim(Pfield (toploop_setvalue_pos, Pointer, Mutable),
1431 [Lprim(Pgetglobal toploop_ident, [], Loc_unknown)],
1432 Loc_unknown);
1433 ap_args=
1434 [Lconst(Const_immstring (toplevel_name id));
1435 lam];
1436 ap_tailcall=Default_tailcall;
1437 ap_inlined=Default_inline;
1438 ap_specialised=Default_specialise;
1439 }
1440
1441let toploop_setvalue_id id = toploop_setvalue id (Lvar id)
1442
1443let close_toplevel_term lam =
1444 Ident.Set.fold (fun id l -> Llet(Strict, Pgenval, id,
1445 toploop_getvalue id, l))
1446 (free_variables lam) lam
1447
1448let transl_toplevel_item ~scopes item =
1449 match item.str_desc with
1450 Tstr_eval (expr, _)
1451 | Tstr_value(Nonrecursive,
1452 [{vb_pat = {pat_desc=Tpat_any};vb_expr = expr}]) ->
1453 (* special compilation for toplevel "let _ = expr", so
1454 that Toploop can display the result of the expression.
1455 Otherwise, the normal compilation would result
1456 in a Lsequence returning unit. *)
1457 transl_exp ~scopes expr
1458 | Tstr_value(rec_flag, pat_expr_list) ->
1459 let idents = let_bound_idents pat_expr_list in
1460 transl_let ~scopes ~in_structure:true rec_flag pat_expr_list
1461 (make_sequence toploop_setvalue_id idents)
1462 | Tstr_typext(tyext) ->
1463 let idents =
1464 List.map (fun ext -> ext.ext_id) tyext.tyext_constructors
1465 in
1466 (* we need to use unique name in case of multiple
1467 definitions of the same extension constructor in the toplevel *)
1468 List.iter set_toplevel_unique_name idents;
1469 transl_type_extension ~scopes item.str_env None tyext
1470 (make_sequence toploop_setvalue_id idents)
1471 | Tstr_exception ext ->
1472 set_toplevel_unique_name ext.tyexn_constructor.ext_id;
1473 toploop_setvalue ext.tyexn_constructor.ext_id
1474 (transl_extension_constructor ~scopes
1475 item.str_env None ext.tyexn_constructor)
1476 | Tstr_module {mb_id=None; mb_presence=Mp_present; mb_expr=modl} ->
1477 transl_module ~scopes Tcoerce_none None modl
1478 | Tstr_module {mb_id=Some id; mb_presence=Mp_present; mb_expr=modl} ->
1479 (* we need to use the unique name for the module because of issues
1480 with "open" (PR#8133) *)
1481 set_toplevel_unique_name id;
1482 let lam = transl_module
1483 ~scopes:(enter_module_definition ~scopes id)
1484 Tcoerce_none (Some(Pident id)) modl in
1485 toploop_setvalue id lam
1486 | Tstr_recmodule bindings ->
1487 let idents = List.filter_map (fun mb -> mb.mb_id) bindings in
1488 compile_recmodule ~scopes
1489 (fun id modl ->
1490 match id with
1491 | None ->
1492 transl_module ~scopes Tcoerce_none None modl
1493 | Some id ->
1494 transl_module
1495 ~scopes:(enter_module_definition ~scopes id)
1496 Tcoerce_none (Some (Pident id)) modl)
1497 bindings
1498 (make_sequence toploop_setvalue_id idents)
1499 | Tstr_class cl_list ->
1500 (* we need to use unique names for the classes because there might
1501 be a value named identically *)
1502 let (ids, class_bindings) = transl_class_bindings ~scopes cl_list in
1503 List.iter set_toplevel_unique_name ids;
1504 Value_rec_compiler.compile_letrec class_bindings
1505 (make_sequence toploop_setvalue_id ids)
1506 | Tstr_include incl ->
1507 let ids = bound_value_identifiers incl.incl_type in
1508 let modl = incl.incl_mod in
1509 let mid = Ident.create_local "include" in
1510 let rec set_idents pos = function
1511 [] ->
1512 lambda_unit
1513 | id :: ids ->
1514 Lsequence(toploop_setvalue id
1515 (Lprim(Pfield (pos, Pointer, Mutable),
1516 [Lvar mid], Loc_unknown)),
1517 set_idents (pos + 1) ids) in
1518 Llet(Strict, Pgenval, mid,
1519 transl_module ~scopes Tcoerce_none None modl, set_idents 0 ids)
1520 | Tstr_primitive descr ->
1521 record_primitive descr.val_val;
1522 lambda_unit
1523 | Tstr_open od ->
1524 let pure = pure_module od.open_expr in
1525 (* this optimization shouldn't be needed because Simplif would
1526 actually remove the [Llet] when it's not used.
1527 But since [scan_used_globals] runs before Simplif, we need to do
1528 it. *)
1529 begin match od.open_bound_items with
1530 | [] when pure = Alias -> lambda_unit
1531 | _ ->
1532 let ids = bound_value_identifiers od.open_bound_items in
1533 let mid = Ident.create_local "open" in
1534 let rec set_idents pos = function
1535 [] ->
1536 lambda_unit
1537 | id :: ids ->
1538 Lsequence(toploop_setvalue id
1539 (Lprim(Pfield (pos, Pointer, Mutable),
1540 [Lvar mid], Loc_unknown)),
1541 set_idents (pos + 1) ids)
1542 in
1543 Llet(pure, Pgenval, mid,
1544 transl_module ~scopes Tcoerce_none None od.open_expr,
1545 set_idents 0 ids)
1546 end
1547 | Tstr_module ({mb_presence=Mp_absent}) ->
1548 lambda_unit
1549 | Tstr_modtype _
1550 | Tstr_type _
1551 | Tstr_class_type _
1552 | Tstr_attribute _ ->
1553 lambda_unit
1554
1555let transl_toplevel_item_and_close ~scopes itm =
1556 close_toplevel_term
1557 (transl_label_init (fun () -> transl_toplevel_item ~scopes itm))
1558
1559let transl_toplevel_definition str =
1560 reset_labels ();
1561 Translprim.clear_used_primitives ();
1562 make_sequence
1563 (transl_toplevel_item_and_close ~scopes:empty_scopes)
1564 str.str_items
1565
1566(* Compile the initialization code for a packed library *)
1567
1568let get_component = function
1569 None -> Lconst const_unit
1570 | Some id -> Lprim(Pgetglobal id, [], Loc_unknown)
1571
1572let transl_package_flambda component_names coercion =
1573 module_block_size component_names coercion,
1574 apply_coercion Loc_unknown Strict coercion
1575 (Lprim(Pmakeblock(0, Immutable, None),
1576 List.map get_component component_names,
1577 Loc_unknown))
1578
1579let transl_package component_names target_name coercion =
1580 let components =
1581 Lprim(Pmakeblock(0, Immutable, None),
1582 List.map get_component component_names, Loc_unknown) in
1583 Lprim(Psetglobal target_name,
1584 [apply_coercion Loc_unknown Strict coercion components],
1585 Loc_unknown)
1586 (*
1587 let components =
1588 match coercion with
1589 Tcoerce_none ->
1590 List.map get_component component_names
1591 | Tcoerce_structure (pos_cc_list, id_pos_list) ->
1592 (* ignore id_pos_list as the ids are already bound *)
1593 let g = Array.of_list component_names in
1594 List.map
1595 (fun (pos, cc) -> apply_coercion Strict cc (get_component g.(pos)))
1596 pos_cc_list
1597 | _ ->
1598 assert false in
1599 Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
1600 *)
1601
1602let transl_store_package component_names target_name coercion =
1603 let rec make_sequence fn pos arg =
1604 match arg with
1605 [] -> lambda_unit
1606 | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in
1607 match coercion with
1608 Tcoerce_none ->
1609 (List.length component_names,
1610 make_sequence
1611 (fun pos id ->
1612 Lprim(Psetfield(pos, Pointer, Root_initialization),
1613 [Lprim(Pgetglobal target_name, [], Loc_unknown);
1614 get_component id],
1615 Loc_unknown))
1616 0 component_names)
1617 | Tcoerce_structure (pos_cc_list, _id_pos_list) ->
1618 let components =
1619 Lprim(Pmakeblock(0, Immutable, None),
1620 List.map get_component component_names,
1621 Loc_unknown)
1622 in
1623 let blk = Ident.create_local "block" in
1624 (List.length pos_cc_list,
1625 Llet (Strict, Pgenval, blk,
1626 apply_coercion Loc_unknown Strict coercion components,
1627 make_sequence
1628 (fun pos _id ->
1629 Lprim(Psetfield(pos, Pointer, Root_initialization),
1630 [Lprim(Pgetglobal target_name, [], Loc_unknown);
1631 Lprim(Pfield (pos, Pointer, Mutable),
1632 [Lvar blk], Loc_unknown)],
1633 Loc_unknown))
1634 0 pos_cc_list))
1635 (*
1636 (* ignore id_pos_list as the ids are already bound *)
1637 let id = Array.of_list component_names in
1638 (List.length pos_cc_list,
1639 make_sequence
1640 (fun dst (src, cc) ->
1641 Lprim(Psetfield(dst, false),
1642 [Lprim(Pgetglobal target_name, []);
1643 apply_coercion Strict cc (get_component id.(src))]))
1644 0 pos_cc_list)
1645 *)
1646 | _ -> assert false
1647
1648(* Error report *)
1649
1650open Format_doc
1651module Style = Misc.Style
1652
1653let print_cycle ppf cycle =
1654 let print_ident ppf (x,_) = pp_print_string ppf (Ident.name x) in
1655 let pp_sep ppf () = fprintf ppf "@ -> " in
1656 fprintf ppf "%a%a%s"
1657 (pp_print_list ~pp_sep print_ident) cycle
1658 pp_sep ()
1659 (Ident.name @@ fst @@ List.hd cycle)
1660
1661let rec collect_components = function
1662 | Pident id -> [Ident.name id]
1663 | Pdot (p, s) -> collect_components p @ [s]
1664 | Papply (p, _) -> collect_components p
1665 | Pextra_ty (p, _) -> collect_components p
1666
1667let get_relative_path top_module path =
1668 let comps = collect_components path in
1669 let comps =
1670 match comps with
1671 | h :: (_ :: _ as t) when h = top_module -> t
1672 | _ -> comps
1673 in
1674 String.concat "." comps
1675
1676
1677let explanation_submsg (id, unsafe_info) =
1678 match unsafe_info with
1679 | Unnamed -> assert false (* can't be part of a cycle. *)
1680 | Unsafe {reason; loc; path} ->
1681 let print fmt =
1682 let printer =
1683 let top_module = Ident.name id in
1684 let guilty = get_relative_path top_module path in
1685 doc_printf fmt
1686 Style.inline_code top_module
1687 Style.inline_code guilty in
1688 Location.mkloc printer loc in
1689 match reason with
1690 | Unsafe_module_binding ->
1691 print "Module %a defines an unsafe module, %a ."
1692 | Unsafe_functor ->
1693 print "Module %a defines an unsafe functor, %a ."
1694 | Unsafe_typext ->
1695 print "Module %a defines an unsafe extension constructor, %a ."
1696 | Unsafe_non_function ->
1697 print "Module %a defines an unsafe value, %a ."
1698
1699let report_error loc = function
1700 | Circular_dependency cycle ->
1701 let[@manual.ref "s:recursive-modules"] manual_ref = [ 12; 2 ] in
1702 Location.errorf ~loc ~sub:(List.map explanation_submsg cycle)
1703 "Cannot safely evaluate the definition of the following cycle@ \
1704 of recursively-defined modules:@ %a.@ \
1705 There are no safe modules in this cycle@ %a."
1706 print_cycle cycle Misc.print_see_manual manual_ref
1707 | Conflicting_inline_attributes ->
1708 Location.errorf "@[Conflicting %a attributes@]"
1709 Style.inline_code "inline"
1710
1711let () =
1712 Location.register_error_of_exn
1713 (function
1714 | Error (loc, err) -> Some (report_error loc err)
1715 | _ ->
1716 None
1717 )
1718
1719let reset () =
1720 primitive_declarations := [];
1721 transl_store_subst := Ident.Map.empty;
1722 aliased_idents := Ident.empty;
1723 Env.reset_required_globals ();
1724 Translprim.clear_used_primitives ()