bytecomp/translmod.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id$ *)
  14
  15 (* Translation from typed abstract syntax to lambda terms,
  16    for the module language *)
  17
  18 open Misc
  19 open Asttypes
  20 open Longident
  21 open Path
  22 open Types
  23 open Typedtree
  24 open Primitive
  25 open Lambda
  26 open Translobj
  27 open Translcore
  28 open Translclass
  29
  30 type error =
  31   Circular_dependency of Ident.t
  32
  33 exception Error of Location.t * error
  34
  35 (* Compile a coercion *)
  36
  37 let rec apply_coercion restr arg =
  38   match restr with
  39     Tcoerce_none ->
  40       arg
  41   | Tcoerce_structure pos_cc_list ->
  42       name_lambda arg (fun id ->
  43         Lprim(Pmakeblock(0, Immutable),
  44               List.map (apply_coercion_field id) pos_cc_list))
  45   | Tcoerce_functor(cc_arg, cc_res) ->
  46       let param = Ident.create "funarg" in
  47       name_lambda arg (fun id ->
  48         Lfunction(Curried, [param],
  49           apply_coercion cc_res
  50             (Lapply(Lvar id, [apply_coercion cc_arg (Lvar param)]))))
  51   | Tcoerce_primitive p ->
  52       transl_primitive p
  53
  54 and apply_coercion_field id (pos, cc) =
  55   apply_coercion cc (Lprim(Pfield pos, [Lvar id]))
  56
  57 (* Compose two coercions
  58    apply_coercion c1 (apply_coercion c2 e) behaves like
  59    apply_coercion (compose_coercions c1 c2) e. *)
  60
  61 let rec compose_coercions c1 c2 =
  62   match (c1, c2) with
  63     (Tcoerce_none, c2) -> c2
  64   | (c1, Tcoerce_none) -> c1
  65   | (Tcoerce_structure pc1, Tcoerce_structure pc2) ->
  66       let v2 = Array.of_list pc2 in
  67       Tcoerce_structure
  68         (List.map
  69           (function (p1, Tcoerce_primitive p) ->
  70                       (p1, Tcoerce_primitive p)
  71                   | (p1, c1) ->
  72                       let (p2, c2) = v2.(p1) in (p2, compose_coercions c1 c2))
  73              pc1)
  74   | (Tcoerce_functor(arg1, res1), Tcoerce_functor(arg2, res2)) ->
  75       Tcoerce_functor(compose_coercions arg2 arg1,
  76                       compose_coercions res1 res2)
  77   | (_, _) ->
  78       fatal_error "Translmod.compose_coercions"
  79
  80 (* Record the primitive declarations occuring in the module compiled *)
  81
  82 let primitive_declarations = ref ([] : string list)
  83
  84 (* Keep track of the root path (from the root of the namespace to the
  85    currently compiled module expression).  Useful for naming exceptions. *)
  86
  87 let global_path glob = Some(Pident glob)
  88 let functor_path path param =
  89   match path with
  90     None -> None
  91   | Some p -> Some(Papply(p, Pident param))
  92 let field_path path field =
  93   match path with
  94     None -> None
  95   | Some p -> Some(Pdot(p, Ident.name field, Path.nopos))
  96
  97 (* Utilities for compiling "module rec" definitions *)
  98
  99 let mod_prim name =
 100   try
 101     transl_path
 102       (fst (Env.lookup_value (Ldot (Lident "CamlinternalMod", name))
 103                              Env.empty))
 104   with Not_found ->
 105     fatal_error ("Primitive " ^ name ^ " not found.")
 106
 107 let undefined_location loc =
 108   (* Confer Translcore.assert_failed *)
 109   let fname = match loc.Location.loc_start.Lexing.pos_fname with
 110               | "" -> !Location.input_name
 111               | x -> x in
 112   let pos = loc.Location.loc_start in
 113   let line = pos.Lexing.pos_lnum in
 114   let char = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
 115   Lconst(Const_block(0,
 116                      [Const_base(Const_string fname);
 117                       Const_base(Const_int line);
 118                       Const_base(Const_int char)]))
 119
 120 let init_shape modl =
 121   let rec init_shape_mod env mty =
 122     match Mtype.scrape env mty with
 123       Tmty_ident _ ->
 124         raise Not_found
 125     | Tmty_signature sg ->
 126         Const_block(0, [Const_block(0, init_shape_struct env sg)])
 127     | Tmty_functor(id, arg, res) ->
 128         raise Not_found (* can we do better? *)
 129   and init_shape_struct env sg =
 130     match sg with
 131       [] -> []
 132     | Tsig_value(id, vdesc) :: rem ->
 133         let init_v =
 134           match Ctype.expand_head env vdesc.val_type with
 135             {desc = Tarrow(_,_,_,_)} ->
 136               Const_pointer 0 (* camlinternalMod.Function *)
 137           | {desc = Tconstr(p, _, _)} when Path.same p Predef.path_lazy_t ->
 138               Const_pointer 1 (* camlinternalMod.Lazy *)
 139           | _ -> raise Not_found in
 140         init_v :: init_shape_struct env rem
 141     | Tsig_type(id, tdecl, _) :: rem ->
 142         init_shape_struct (Env.add_type id tdecl env) rem
 143     | Tsig_exception(id, edecl) :: rem ->
 144         raise Not_found
 145     | Tsig_module(id, mty, _) :: rem ->
 146         init_shape_mod env mty ::
 147         init_shape_struct (Env.add_module id mty env) rem
 148     | Tsig_modtype(id, minfo) :: rem ->
 149         init_shape_struct (Env.add_modtype id minfo env) rem
 150     | Tsig_class(id, cdecl, _) :: rem ->
 151         Const_pointer 2 (* camlinternalMod.Class *)
 152         :: init_shape_struct env rem
 153     | Tsig_cltype(id, ctyp, _) :: rem ->
 154         init_shape_struct env rem
 155   in
 156   try
 157     Some(undefined_location modl.mod_loc,
 158          Lconst(init_shape_mod modl.mod_env modl.mod_type))
 159   with Not_found ->
 160     None
 161
 162 (* Reorder bindings to honor dependencies.  *)
 163
 164 type binding_status = Undefined | Inprogress | Defined
 165
 166 let reorder_rec_bindings bindings =
 167   let id = Array.of_list (List.map (fun (id,_,_,_) -> id) bindings)
 168   and loc = Array.of_list (List.map (fun (_,loc,_,_) -> loc) bindings)
 169   and init = Array.of_list (List.map (fun (_,_,init,_) -> init) bindings)
 170   and rhs = Array.of_list (List.map (fun (_,_,_,rhs) -> rhs) bindings) in
 171   let fv = Array.map Lambda.free_variables rhs in
 172   let num_bindings = Array.length id in
 173   let status = Array.create num_bindings Undefined in
 174   let res = ref [] in
 175   let rec emit_binding i =
 176     match status.(i) with
 177       Defined -> ()
 178     | Inprogress -> raise(Error(loc.(i), Circular_dependency id.(i)))
 179     | Undefined ->
 180         if init.(i) = None then begin
 181           status.(i) <- Inprogress;
 182           for j = 0 to num_bindings - 1 do
 183             if IdentSet.mem id.(j) fv.(i) then emit_binding j
 184           done
 185         end;
 186         res := (id.(i), init.(i), rhs.(i)) :: !res;
 187         status.(i) <- Defined in
 188   for i = 0 to num_bindings - 1 do
 189     match status.(i) with
 190       Undefined -> emit_binding i
 191     | Inprogress -> assert false
 192     | Defined -> ()
 193   done;
 194   List.rev !res
 195
 196 (* Generate lambda-code for a reordered list of bindings *)
 197
 198 let eval_rec_bindings bindings cont =
 199   let rec bind_inits = function
 200     [] ->
 201       bind_strict bindings
 202   | (id, None, rhs) :: rem ->
 203       bind_inits rem
 204   | (id, Some(loc, shape), rhs) :: rem ->
 205       Llet(Strict, id, Lapply(mod_prim "init_mod", [loc; shape]),
 206            bind_inits rem)
 207   and bind_strict = function
 208     [] ->
 209       patch_forwards bindings
 210   | (id, None, rhs) :: rem ->
 211       Llet(Strict, id, rhs, bind_strict rem)
 212   | (id, Some(loc, shape), rhs) :: rem ->
 213       bind_strict rem
 214   and patch_forwards = function
 215     [] ->
 216       cont
 217   | (id, None, rhs) :: rem ->
 218       patch_forwards rem
 219   | (id, Some(loc, shape), rhs) :: rem ->
 220       Lsequence(Lapply(mod_prim "update_mod", [shape; Lvar id; rhs]),
 221                 patch_forwards rem)
 222   in
 223     bind_inits bindings
 224
 225 let compile_recmodule compile_rhs bindings cont =
 226   eval_rec_bindings
 227     (reorder_rec_bindings
 228       (List.map
 229         (fun (id, modl) ->
 230                   (id, modl.mod_loc, init_shape modl, compile_rhs id modl))
 231         bindings))
 232     cont
 233
 234 (* Compile a module expression *)
 235
 236 let rec transl_module cc rootpath mexp =
 237   match mexp.mod_desc with
 238     Tmod_ident path ->
 239       apply_coercion cc (transl_path path)
 240   | Tmod_structure str ->
 241       transl_structure [] cc rootpath str
 242   | Tmod_functor(param, mty, body) ->
 243       let bodypath = functor_path rootpath param in
 244       oo_wrap mexp.mod_env true
 245         (function
 246         | Tcoerce_none ->
 247             Lfunction(Curried, [param],
 248                       transl_module Tcoerce_none bodypath body)
 249         | Tcoerce_functor(ccarg, ccres) ->
 250             let param' = Ident.create "funarg" in
 251             Lfunction(Curried, [param'],
 252                       Llet(Alias, param, apply_coercion ccarg (Lvar param'),
 253                            transl_module ccres bodypath body))
 254         | _ ->
 255             fatal_error "Translmod.transl_module")
 256         cc
 257   | Tmod_apply(funct, arg, ccarg) ->
 258       oo_wrap mexp.mod_env true
 259         (apply_coercion cc)
 260         (Lapply(transl_module Tcoerce_none None funct,
 261                 [transl_module ccarg None arg]))
 262   | Tmod_constraint(arg, mty, ccarg) ->
 263       transl_module (compose_coercions cc ccarg) rootpath arg
 264
 265 and transl_structure fields cc rootpath = function
 266     [] ->
 267       begin match cc with
 268         Tcoerce_none ->
 269           Lprim(Pmakeblock(0, Immutable),
 270                 List.map (fun id -> Lvar id) (List.rev fields))
 271       | Tcoerce_structure pos_cc_list ->
 272           let v = Array.of_list (List.rev fields) in
 273           Lprim(Pmakeblock(0, Immutable),
 274                 List.map
 275                   (fun (pos, cc) ->
 276                     match cc with
 277                       Tcoerce_primitive p -> transl_primitive p
 278                     | _ -> apply_coercion cc (Lvar v.(pos)))
 279                   pos_cc_list)
 280       | _ ->
 281           fatal_error "Translmod.transl_structure"
 282       end
 283   | Tstr_eval expr :: rem ->
 284       Lsequence(transl_exp expr, transl_structure fields cc rootpath rem)
 285   | Tstr_value(rec_flag, pat_expr_list) :: rem ->
 286       let ext_fields = rev_let_bound_idents pat_expr_list @ fields in
 287       transl_let rec_flag pat_expr_list
 288                  (transl_structure ext_fields cc rootpath rem)
 289   | Tstr_primitive(id, descr) :: rem ->
 290       begin match descr.val_kind with
 291         Val_prim p -> primitive_declarations :=
 292                         p.Primitive.prim_name :: !primitive_declarations
 293       | _ -> ()
 294       end;
 295       transl_structure fields cc rootpath rem
 296   | Tstr_type(decls) :: rem ->
 297       transl_structure fields cc rootpath rem
 298   | Tstr_exception(id, decl) :: rem ->
 299       Llet(Strict, id, transl_exception id (field_path rootpath id) decl,
 300            transl_structure (id :: fields) cc rootpath rem)
 301   | Tstr_exn_rebind(id, path) :: rem ->
 302       Llet(Strict, id, transl_path path,
 303            transl_structure (id :: fields) cc rootpath rem)
 304   | Tstr_module(id, modl) :: rem ->
 305       Llet(Strict, id,
 306            transl_module Tcoerce_none (field_path rootpath id) modl,
 307            transl_structure (id :: fields) cc rootpath rem)
 308   | Tstr_recmodule bindings :: rem ->
 309       let ext_fields = List.rev_append (List.map fst bindings) fields in
 310       compile_recmodule
 311         (fun id modl ->
 312           transl_module Tcoerce_none (field_path rootpath id) modl)
 313         bindings
 314         (transl_structure ext_fields cc rootpath rem)
 315   | Tstr_modtype(id, decl) :: rem ->
 316       transl_structure fields cc rootpath rem
 317   | Tstr_open path :: rem ->
 318       transl_structure fields cc rootpath rem
 319   | Tstr_class cl_list :: rem ->
 320       let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
 321       Lletrec(List.map
 322                 (fun (id, arity, meths, cl, vf) ->
 323                   (id, transl_class ids id arity meths cl vf))
 324                 cl_list,
 325               transl_structure (List.rev ids @ fields) cc rootpath rem)
 326   | Tstr_cltype cl_list :: rem ->
 327       transl_structure fields cc rootpath rem
 328   | Tstr_include(modl, ids) :: rem ->
 329       let mid = Ident.create "include" in
 330       let rec rebind_idents pos newfields = function
 331         [] ->
 332           transl_structure newfields cc rootpath rem
 333       | id :: ids ->
 334           Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]),
 335                rebind_idents (pos + 1) (id :: newfields) ids) in
 336       Llet(Strict, mid, transl_module Tcoerce_none None modl,
 337            rebind_idents 0 fields ids)
 338
 339 (* Update forward declaration in Translcore *)
 340 let _ =
 341   Translcore.transl_module := transl_module
 342
 343 (* Compile an implementation *)
 344
 345 let transl_implementation module_name (str, cc) =
 346   reset_labels ();
 347   primitive_declarations := [];
 348   let module_id = Ident.create_persistent module_name in
 349   Lprim(Psetglobal module_id,
 350         [transl_label_init
 351             (transl_structure [] cc (global_path module_id) str)])
 352
 353 (* A variant of transl_structure used to compile toplevel structure definitions
 354    for the native-code compiler. Store the defined values in the fields
 355    of the global as soon as they are defined, in order to reduce register
 356    pressure.  Also rewrites the defining expressions so that they
 357    refer to earlier fields of the structure through the fields of
 358    the global, not by their names.
 359    "map" is a table from defined idents to (pos in global block, coercion).
 360    "prim" is a list of (pos in global block, primitive declaration). *)
 361
 362 let transl_store_structure glob map prims str =
 363   let rec transl_store subst = function
 364     [] ->
 365       lambda_unit
 366   | Tstr_eval expr :: rem ->
 367       Lsequence(subst_lambda subst (transl_exp expr),
 368                 transl_store subst rem)
 369   | Tstr_value(rec_flag, pat_expr_list) :: rem ->
 370       let ids = let_bound_idents pat_expr_list in
 371       let lam = transl_let rec_flag pat_expr_list (store_idents ids) in
 372       Lsequence(subst_lambda subst lam,
 373                 transl_store (add_idents false ids subst) rem)
 374   | Tstr_primitive(id, descr) :: rem ->
 375       begin match descr.val_kind with
 376         Val_prim p -> primitive_declarations :=
 377                         p.Primitive.prim_name :: !primitive_declarations
 378       | _ -> ()
 379       end;
 380       transl_store subst rem
 381   | Tstr_type(decls) :: rem ->
 382       transl_store subst rem
 383   | Tstr_exception(id, decl) :: rem ->
 384       let lam = transl_exception id (field_path (global_path glob) id) decl in
 385       Lsequence(Llet(Strict, id, lam, store_ident id),
 386                 transl_store (add_ident false id subst) rem)
 387   | Tstr_exn_rebind(id, path) :: rem ->
 388       let lam = subst_lambda subst (transl_path path) in
 389       Lsequence(Llet(Strict, id, lam, store_ident id),
 390                 transl_store (add_ident false id subst) rem)
 391   | Tstr_module(id, modl) :: rem ->
 392       let lam =
 393         transl_module Tcoerce_none (field_path (global_path glob) id) modl in
 394       (* Careful: the module value stored in the global may be different
 395          from the local module value, in case a coercion is applied.
 396          If so, keep using the local module value (id) in the remainder of
 397          the compilation unit (add_ident true returns subst unchanged).
 398          If not, we can use the value from the global
 399          (add_ident true adds id -> Pgetglobal... to subst). *)
 400       Llet(Strict, id, subst_lambda subst lam,
 401         Lsequence(store_ident id, transl_store(add_ident true id subst) rem))
 402   | Tstr_recmodule bindings :: rem ->
 403       let ids = List.map fst bindings in
 404       compile_recmodule
 405         (fun id modl ->
 406           subst_lambda subst
 407             (transl_module Tcoerce_none
 408                            (field_path (global_path glob) id) modl))
 409         bindings
 410         (Lsequence(store_idents ids,
 411                    transl_store (add_idents true ids subst) rem))
 412   | Tstr_modtype(id, decl) :: rem ->
 413       transl_store subst rem
 414   | Tstr_open path :: rem ->
 415       transl_store subst rem
 416   | Tstr_class cl_list :: rem ->
 417       let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
 418       let lam =
 419         Lletrec(List.map
 420                   (fun (id, arity, meths, cl, vf) ->
 421                      (id, transl_class ids id arity meths cl vf))
 422                   cl_list,
 423                 store_idents ids) in
 424       Lsequence(subst_lambda subst lam,
 425                 transl_store (add_idents false ids subst) rem)
 426   | Tstr_cltype cl_list :: rem ->
 427       transl_store subst rem
 428   | Tstr_include(modl, ids) :: rem ->
 429       let mid = Ident.create "include" in
 430       let rec store_idents pos = function
 431         [] -> transl_store (add_idents true ids subst) rem
 432       | id :: idl ->
 433           Llet(Alias, id, Lprim(Pfield pos, [Lvar mid]),
 434                Lsequence(store_ident id, store_idents (pos + 1) idl)) in
 435       Llet(Strict, mid,
 436            subst_lambda subst (transl_module Tcoerce_none None modl),
 437            store_idents 0 ids)
 438
 439   and store_ident id =
 440     try
 441       let (pos, cc) = Ident.find_same id map in
 442       let init_val = apply_coercion cc (Lvar id) in
 443       Lprim(Psetfield(pos, false), [Lprim(Pgetglobal glob, []); init_val])
 444     with Not_found ->
 445       fatal_error("Translmod.store_ident: " ^ Ident.unique_name id)
 446
 447   and store_idents idlist =
 448     make_sequence store_ident idlist
 449
 450   and add_ident may_coerce id subst =
 451     try
 452       let (pos, cc) = Ident.find_same id map in
 453       match cc with
 454         Tcoerce_none ->
 455           Ident.add id (Lprim(Pfield pos, [Lprim(Pgetglobal glob, [])])) subst
 456       | _ ->
 457           if may_coerce then subst else assert false
 458     with Not_found ->
 459       assert false
 460
 461   and add_idents may_coerce idlist subst =
 462     List.fold_right (add_ident may_coerce) idlist subst
 463
 464   and store_primitive (pos, prim) cont =
 465     Lsequence(Lprim(Psetfield(pos, false),
 466                     [Lprim(Pgetglobal glob, []); transl_primitive prim]),
 467               cont)
 468
 469   in List.fold_right store_primitive prims (transl_store Ident.empty str)
 470
 471 (* Build the list of value identifiers defined by a toplevel structure
 472    (excluding primitive declarations). *)
 473
 474 let rec defined_idents = function
 475     [] -> []
 476   | Tstr_eval expr :: rem -> defined_idents rem
 477   | Tstr_value(rec_flag, pat_expr_list) :: rem ->
 478       let_bound_idents pat_expr_list @ defined_idents rem
 479   | Tstr_primitive(id, descr) :: rem -> defined_idents rem
 480   | Tstr_type decls :: rem -> defined_idents rem
 481   | Tstr_exception(id, decl) :: rem -> id :: defined_idents rem
 482   | Tstr_exn_rebind(id, path) :: rem -> id :: defined_idents rem
 483   | Tstr_module(id, modl) :: rem -> id :: defined_idents rem
 484   | Tstr_recmodule decls :: rem -> List.map fst decls @ defined_idents rem
 485   | Tstr_modtype(id, decl) :: rem -> defined_idents rem
 486   | Tstr_open path :: rem -> defined_idents rem
 487   | Tstr_class cl_list :: rem ->
 488       List.map (fun (i, _, _, _, _) -> i) cl_list @ defined_idents rem
 489   | Tstr_cltype cl_list :: rem -> defined_idents rem
 490   | Tstr_include(modl, ids) :: rem -> ids @ defined_idents rem
 491
 492 (* Transform a coercion and the list of value identifiers defined by
 493    a toplevel structure into a table [id -> (pos, coercion)],
 494    with [pos] being the position in the global block where the value of
 495    [id] must be stored, and [coercion] the coercion to be applied to it.
 496    A given identifier may appear several times
 497    in the coercion (if it occurs several times in the signature); remember
 498    to assign it the position of its last occurrence.
 499    Identifiers that are not exported are assigned positions at the
 500    end of the block (beyond the positions of all exported idents).
 501    Also compute the total size of the global block,
 502    and the list of all primitives exported as values. *)
 503
 504 let build_ident_map restr idlist =
 505   let rec natural_map pos map prims = function
 506     [] ->
 507       (map, prims, pos)
 508   | id :: rem ->
 509       natural_map (pos+1) (Ident.add id (pos, Tcoerce_none) map) prims rem in
 510   match restr with
 511     Tcoerce_none ->
 512       natural_map 0 Ident.empty [] idlist
 513   | Tcoerce_structure pos_cc_list ->
 514       let idarray = Array.of_list idlist in
 515       let rec export_map pos map prims undef = function
 516         [] ->
 517           natural_map pos map prims undef
 518       | (source_pos, Tcoerce_primitive p) :: rem ->
 519           export_map (pos + 1) map ((pos, p) :: prims) undef rem
 520       | (source_pos, cc) :: rem ->
 521           let id = idarray.(source_pos) in
 522           export_map (pos + 1) (Ident.add id (pos, cc) map)
 523                      prims (list_remove id undef) rem
 524       in export_map 0 Ident.empty [] idlist pos_cc_list
 525   | _ ->
 526       fatal_error "Translmod.build_ident_map"
 527
 528 (* Compile an implementation using transl_store_structure
 529    (for the native-code compiler). *)
 530
 531 let transl_store_implementation module_name (str, restr) =
 532   reset_labels ();
 533   primitive_declarations := [];
 534   let module_id = Ident.create_persistent module_name in
 535   let (map, prims, size) = build_ident_map restr (defined_idents str) in
 536   transl_store_label_init module_id size
 537     (transl_store_structure module_id map prims) str
 538   (*size, transl_label_init (transl_store_structure module_id map prims str)*)
 539
 540 (* Compile a toplevel phrase *)
 541
 542 let toploop_ident = Ident.create_persistent "Toploop"
 543 let toploop_getvalue_pos = 0 (* position of getvalue in module Toploop *)
 544 let toploop_setvalue_pos = 1 (* position of setvalue in module Toploop *)
 545
 546 let aliased_idents = ref Ident.empty
 547
 548 let set_toplevel_unique_name id =
 549   aliased_idents :=
 550     Ident.add id (Ident.unique_toplevel_name id) !aliased_idents
 551
 552 let toplevel_name id =
 553   try Ident.find_same id !aliased_idents
 554   with Not_found -> Ident.name id
 555
 556 let toploop_getvalue id =
 557   Lapply(Lprim(Pfield toploop_getvalue_pos,
 558                  [Lprim(Pgetglobal toploop_ident, [])]),
 559          [Lconst(Const_base(Const_string (toplevel_name id)))])
 560
 561 let toploop_setvalue id lam =
 562   Lapply(Lprim(Pfield toploop_setvalue_pos,
 563                  [Lprim(Pgetglobal toploop_ident, [])]),
 564          [Lconst(Const_base(Const_string (toplevel_name id))); lam])
 565
 566 let toploop_setvalue_id id = toploop_setvalue id (Lvar id)
 567
 568 let close_toplevel_term lam =
 569   IdentSet.fold (fun id l -> Llet(Strict, id, toploop_getvalue id, l))
 570                 (free_variables lam) lam
 571
 572 let transl_toplevel_item = function
 573     Tstr_eval expr ->
 574       transl_exp expr
 575   | Tstr_value(rec_flag, pat_expr_list) ->
 576       let idents = let_bound_idents pat_expr_list in
 577       transl_let rec_flag pat_expr_list
 578                  (make_sequence toploop_setvalue_id idents)
 579   | Tstr_primitive(id, descr) ->
 580       lambda_unit
 581   | Tstr_type(decls) ->
 582       lambda_unit
 583   | Tstr_exception(id, decl) ->
 584       toploop_setvalue id (transl_exception id None decl)
 585   | Tstr_exn_rebind(id, path) ->
 586       toploop_setvalue id (transl_path path)
 587   | Tstr_module(id, modl) ->
 588       (* we need to use the unique name for the module because of issues
 589          with "open" (PR#1672) *)
 590       set_toplevel_unique_name id;
 591       toploop_setvalue id
 592                         (transl_module Tcoerce_none (Some(Pident id)) modl)
 593   | Tstr_recmodule bindings ->
 594       let idents = List.map fst bindings in
 595       compile_recmodule
 596         (fun id modl -> transl_module Tcoerce_none (Some(Pident id)) modl)
 597         bindings
 598         (make_sequence toploop_setvalue_id idents)
 599   | Tstr_modtype(id, decl) ->
 600       lambda_unit
 601   | Tstr_open path ->
 602       lambda_unit
 603   | Tstr_class cl_list ->
 604       (* we need to use unique names for the classes because there might
 605          be a value named identically *)
 606       let ids = List.map (fun (i, _, _, _, _) -> i) cl_list in
 607       List.iter set_toplevel_unique_name ids;
 608       Lletrec(List.map
 609                 (fun (id, arity, meths, cl, vf) ->
 610                    (id, transl_class ids id arity meths cl vf))
 611                 cl_list,
 612               make_sequence
 613                 (fun (id, _, _, _, _) -> toploop_setvalue_id id)
 614                 cl_list)
 615   | Tstr_cltype cl_list ->
 616       lambda_unit
 617   | Tstr_include(modl, ids) ->
 618       let mid = Ident.create "include" in
 619       let rec set_idents pos = function
 620         [] ->
 621           lambda_unit
 622       | id :: ids ->
 623           Lsequence(toploop_setvalue id (Lprim(Pfield pos, [Lvar mid])),
 624                     set_idents (pos + 1) ids) in
 625       Llet(Strict, mid, transl_module Tcoerce_none None modl, set_idents 0 ids)
 626
 627 let transl_toplevel_item_and_close itm =
 628   close_toplevel_term (transl_label_init (transl_toplevel_item itm))
 629
 630 let transl_toplevel_definition str =
 631   reset_labels ();
 632   make_sequence transl_toplevel_item_and_close str
 633
 634 (* Compile the initialization code for a packed library *)
 635
 636 let get_component = function
 637     None -> Lconst const_unit
 638   | Some id -> Lprim(Pgetglobal id, [])
 639
 640 let transl_package component_names target_name coercion =
 641   let components =
 642     match coercion with
 643       Tcoerce_none ->
 644         List.map get_component component_names
 645     | Tcoerce_structure pos_cc_list ->
 646         let g = Array.of_list component_names in
 647         List.map
 648           (fun (pos, cc) -> apply_coercion cc (get_component g.(pos)))
 649           pos_cc_list
 650     | _ ->
 651         assert false in
 652   Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
 653
 654 let transl_store_package component_names target_name coercion =
 655   let rec make_sequence fn pos arg =
 656     match arg with
 657       [] -> lambda_unit
 658     | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in
 659   match coercion with
 660     Tcoerce_none ->
 661       (List.length component_names,
 662        make_sequence
 663          (fun pos id ->
 664            Lprim(Psetfield(pos, false),
 665                  [Lprim(Pgetglobal target_name, []);
 666                   get_component id]))
 667          0 component_names)
 668   | Tcoerce_structure pos_cc_list ->
 669       let id = Array.of_list component_names in
 670       (List.length pos_cc_list,
 671        make_sequence
 672          (fun dst (src, cc) ->
 673            Lprim(Psetfield(dst, false),
 674                  [Lprim(Pgetglobal target_name, []);
 675                   apply_coercion cc (get_component id.(src))]))
 676          0 pos_cc_list)
 677   | _ -> assert false
 678
 679 (* Error report *)
 680
 681 open Format
 682
 683 let report_error ppf = function
 684     Circular_dependency id ->
 685       fprintf ppf
 686         "@[Cannot safely evaluate the definition@ of the recursively-defined module %a@]"
 687         Printtyp.ident id