Pour l'option -pack, permettre de donner une interface explicite (via un .mli) au module synthetise

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@5422 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

11 files changed, 116 insertions, 78 deletions

diff --git a/Changes b/Changes
index 42b4d97d7..1be012b7e 100644
--- a/Changes
+++ b/Changes
@@ -19,6 +19,8 @@ Both compilers:
   relaxed some other checks.
 - Fixed wrong code that was generated for "for i = a to max_int"
   or "for i = a downto min_int".
+- An explicit interface Mod.mli can now be provided for the module obtained
+  by ocamlc -pack -o Mod.cmo ... or ocamlopt -pack -o Mod.cmx ...
 
 Native-code compiler:
 - Fixed bug in ocamlopt -pack related to tracking of imported modules.
diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml
index 72096903d..a428b8b45 100644
--- a/asmcomp/asmpackager.ml
+++ b/asmcomp/asmpackager.ml
@@ -211,17 +211,15 @@ let build_package_cmx units unit_names target symbols_to_rename cmxfile =
     map_end (fun s -> target ^ "__" ^ s)
             (List.concat (List.map (fun info -> info.ui_defines) units))
             [target] in
+  let approx =
+    Compilenv.global_approx (Ident.create_persistent target) in
   let pkg_infos =
     { ui_name = target;
       ui_defines = defines;
       ui_imports_cmi = (target, Env.crc_of_unit target) ::
                        filter(Asmlink.extract_crc_interfaces());
       ui_imports_cmx = filter(Asmlink.extract_crc_implementations());
-      ui_approx =
-        Value_tuple
-          (Array.map
-            (fun info -> rename_approx mapping info.ui_approx)
-            (Array.of_list units));
+      ui_approx = rename_approx mapping approx;
       ui_curry_fun = union(List.map (fun info -> info.ui_curry_fun) units);
       ui_apply_fun = union(List.map (fun info -> info.ui_apply_fun) units);
       ui_force_link = List.exists (fun info -> info.ui_force_link) units
@@ -230,20 +228,16 @@ let build_package_cmx units unit_names target symbols_to_rename cmxfile =
 
 (* Make the .o file for the package (not renamed yet) *)
 
-let make_package_object ppf unit_names objfiles targetobj targetname =
-  let asmtemp = Filename.temp_file "camlpackage" Config.ext_asm in
+let make_package_object ppf unit_names objfiles
+                        targetobj targetname coercion =
   let objtemp = Filename.temp_file "camlpackage" Config.ext_obj in
-  let oc = open_out asmtemp in
-  Emitaux.output_channel := oc;
   Location.input_name := targetname; (* set the name of the "current" input *)
   Compilenv.reset targetname; (* set the name of the "current" compunit *)
-  Emit.begin_assembly();
-  List.iter (Asmgen.compile_phrase ppf) (Cmmgen.package unit_names targetname);
-  Emit.end_assembly();
-  close_out oc;
-  if Proc.assemble_file asmtemp objtemp <> 0 then
-    raise(Error(Assembler_error asmtemp));
-  remove_file asmtemp;
+  Asmgen.compile_implementation
+    (chop_extension_if_any objtemp) ppf
+    (Translmod.transl_store_package
+       (List.map Ident.create_persistent unit_names)
+       (Ident.create_persistent targetname) coercion);
   let ld_cmd =
     sprintf "%s -o %s %s %s"
             Config.native_partial_linker 
@@ -256,13 +250,14 @@ let make_package_object ppf unit_names objfiles targetobj targetname =
 
 (* Make the .cmx and the .o for the package *)
 
-let package_object_files ppf cmxfiles targetcmx targetobj targetname =
+let package_object_files ppf cmxfiles targetcmx 
+                         targetobj targetname coercion =
   let units = map_left_right read_unit_info cmxfiles in
   let unit_names = List.map (fun info -> info.ui_name) units in
   check_units cmxfiles units unit_names;
   let objfiles =
     List.map (fun f -> chop_extension_if_any f ^ Config.ext_obj) cmxfiles in
-  make_package_object ppf unit_names objfiles targetobj targetname;
+  make_package_object ppf unit_names objfiles targetobj targetname coercion;
   let symbols = rename_in_object_file unit_names targetname targetobj in
   build_package_cmx units unit_names targetname symbols targetcmx
 
@@ -282,10 +277,10 @@ let package_files ppf files targetcmx =
   let targetobj = prefix ^ Config.ext_obj in
   let targetname = String.capitalize(Filename.basename prefix) in
   try
-    Typemod.package_units cmxfiles targetcmi targetname;
-    package_object_files ppf cmxfiles targetcmx targetobj targetname
+    let coercion = Typemod.package_units cmxfiles targetcmi targetname in
+    package_object_files ppf cmxfiles targetcmx targetobj targetname coercion
   with x ->
-    remove_file targetcmi; remove_file targetcmx; remove_file targetobj;
+    remove_file targetcmx; remove_file targetobj;
     raise x
 
 (* Error report *)
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index b71187ff3..a9779bdbe 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -1632,16 +1632,6 @@ let compunit size ulam =
          Cdefine_symbol glob;
          Cskip(size * size_addr)] :: c3
 
-(* Translate a package *)
-
-let package unit_names target =
-  [Cdata (Cint(block_header 0 (List.length unit_names)) ::
-          Cglobal_symbol target ::
-          Cdefine_symbol target ::
-          List.map (fun s -> Csymbol_address s) unit_names);
-   Cfunction {fun_name = target ^ "__entry"; fun_args = [];
-              fun_body = Ctuple[]; fun_fast = false}]
-
 (* Generate an application function:
      (defun caml_applyN (a1 ... aN clos)
        (if (= clos.arity N)
diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli
index 1d70a9b52..0bf27f8cd 100644
--- a/asmcomp/cmmgen.mli
+++ b/asmcomp/cmmgen.mli
@@ -16,7 +16,6 @@
 
 val compunit: int -> Clambda.ulambda -> Cmm.phrase list
 
-val package: string list -> string -> Cmm.phrase list
 val apply_function: int -> Cmm.phrase
 val curry_function: int -> Cmm.phrase list
 val entry_point: string list -> Cmm.phrase
diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml
index cf33545ad..7894007e7 100644
--- a/bytecomp/bytepackager.ml
+++ b/bytecomp/bytepackager.ml
@@ -130,40 +130,21 @@ let rec rename_append_bytecode_list oc mapping defined ofs = function
         oc mapping (Ident.create_persistent compunit.cu_name :: defined)
         (ofs + size) rem
 
-(* Generate the code that builds the tuple representing the package
-   module:
-     GETGLOBAL M.An
-     PUSHGETGLOBAL M.An-1
-     ...
-     PUSHGETGLOBAL M.A1
-     MAKEBLOCK tag = 0 size = n
-     SETGLOBAL M
-*)
-
-let build_global_target oc target_name mapping ofs =
-  let out_word n =
-    output_byte oc n;
-    output_byte oc (n lsr 8);
-    output_byte oc (n lsr 16);
-    output_byte oc (n lsr 24) in
-  let rec build_global first pos = function
-    [] ->
-      out_word opMAKEBLOCK;             (* pos *)
-      out_word (List.length mapping);   (* pos + 4 *)
-      out_word 0;                       (* pos + 8 *)
-      out_word opSETGLOBAL;             (* pos + 12 *)
-      out_word 0;                       (* pos + 16 *)
-      relocs := (Reloc_setglobal target_name, pos + 16) :: !relocs
-  | (oldname, newname) :: rem ->
-      out_word (if first then opGETGLOBAL else opPUSHGETGLOBAL); (* pos *)
-      out_word 0;                       (* pos + 4 *)
-      relocs := (Reloc_getglobal newname, pos + 4) :: !relocs;
-      build_global false (pos + 8) rem in
-  build_global true ofs (List.rev mapping)
+(* Generate the code that builds the tuple representing the package module *)
+
+let build_global_target oc target_name mapping pos coercion =
+  let lam =
+    Translmod.transl_package (List.map snd mapping)
+                             (Ident.create_persistent target_name) coercion in
+  let instrs =
+    Bytegen.compile_implementation target_name lam in
+  let rel =
+    Emitcode.to_packed_file oc instrs in
+  relocs := List.map (fun (r, ofs) -> (r, pos + ofs)) rel @ !relocs
 
 (* Build the .cmo file obtained by packaging the given .cmo files. *)
 
-let package_object_files objfiles targetfile targetname =
+let package_object_files objfiles targetfile targetname coercion =
   let units =
     List.map (fun f -> (f, read_unit_info f)) objfiles in
   let unit_names =
@@ -181,9 +162,10 @@ let package_object_files objfiles targetfile targetname =
     output_binary_int oc 0;
     let pos_code = pos_out oc in
     let ofs = rename_append_bytecode_list oc mapping [] 0 units in
-    build_global_target oc (Ident.create_persistent targetname) mapping ofs;
+    build_global_target oc targetname mapping ofs coercion;
     let pos_debug = pos_out oc in
-    if !Clflags.debug && !events <> [] then output_value oc (List.rev !events);
+    if !Clflags.debug && !events <> [] then
+      output_value oc (List.rev !events);
     let pos_final = pos_out oc in
     let imports =
       List.filter
@@ -220,10 +202,10 @@ let package_files files targetfile =
   let targetcmi = prefix ^ ".cmi" in
   let targetname = String.capitalize(Filename.basename prefix) in
   try
-    Typemod.package_units objfiles targetcmi targetname;
-    package_object_files objfiles targetfile targetname
+    let coercion = Typemod.package_units objfiles targetcmi targetname in
+    package_object_files objfiles targetfile targetname coercion
   with x ->
-    remove_file targetcmi; remove_file targetfile; raise x
+    remove_file targetfile; raise x
 
 (* Error report *)
 
diff --git a/bytecomp/emitcode.ml b/bytecomp/emitcode.ml
index 4613241fc..a2ee15a82 100644
--- a/bytecomp/emitcode.ml
+++ b/bytecomp/emitcode.ml
@@ -425,3 +425,13 @@ let to_memory init_code fun_code =
   and code_size = !out_position in
   init();
   (code, code_size, reloc)
+
+(* Emission to a file for a packed library *)
+
+let to_packed_file outchan code =
+  init();
+  emit code;
+  output outchan !out_buffer 0 !out_position;
+  let reloc = !reloc_info in
+  init();
+  reloc
diff --git a/bytecomp/emitcode.mli b/bytecomp/emitcode.mli
index 14b64221e..226f86997 100644
--- a/bytecomp/emitcode.mli
+++ b/bytecomp/emitcode.mli
@@ -76,4 +76,10 @@ val to_memory: instruction list -> instruction list ->
              block of relocatable bytecode
              size of this block
              relocation information *)
-
+val to_packed_file:
+  out_channel -> instruction list -> (reloc_info * int) list
+        (* Arguments:
+             channel on output file
+             list of instructions to emit
+           Result:
+             relocation information (reversed) *)
diff --git a/bytecomp/translmod.ml b/bytecomp/translmod.ml
index 99e1e89ae..b48c06639 100644
--- a/bytecomp/translmod.ml
+++ b/bytecomp/translmod.ml
@@ -453,3 +453,44 @@ let transl_toplevel_item_and_close itm =
 let transl_toplevel_definition str =
   reset_labels ();
   make_sequence transl_toplevel_item_and_close str
+
+(* Compile the initialization code for a packed library *)
+
+let transl_package component_names target_name coercion =
+  let components =
+    match coercion with
+      Tcoerce_none ->
+        List.map (fun id -> Lprim(Pgetglobal id, [])) component_names
+    | Tcoerce_structure pos_cc_list ->
+        let g = Array.of_list component_names in
+        List.map
+          (fun (pos, cc) -> apply_coercion cc (Lprim(Pgetglobal g.(pos), [])))
+          pos_cc_list
+    | _ ->
+        assert false in
+  Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
+
+let transl_store_package component_names target_name coercion =
+  let rec make_sequence fn pos arg =
+    match arg with
+      [] -> lambda_unit
+    | hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in
+  match coercion with
+    Tcoerce_none ->
+      (List.length component_names,
+       make_sequence
+         (fun pos id ->
+           Lprim(Psetfield(pos, false),
+                 [Lprim(Pgetglobal target_name, []);
+                  Lprim(Pgetglobal id, [])]))
+         0 component_names)
+  | Tcoerce_structure pos_cc_list ->
+      let id = Array.of_list component_names in
+      (List.length pos_cc_list,
+       make_sequence
+         (fun dst (src, cc) ->
+           Lprim(Psetfield(dst, false),
+                 [Lprim(Pgetglobal target_name, []);
+                  apply_coercion cc (Lprim(Pgetglobal id.(src), []))]))
+         0 pos_cc_list)
+  | _ -> assert false
diff --git a/bytecomp/translmod.mli b/bytecomp/translmod.mli
index ffcb0a7eb..bd9a5dfd9 100644
--- a/bytecomp/translmod.mli
+++ b/bytecomp/translmod.mli
@@ -22,6 +22,10 @@ val transl_implementation: string -> structure * module_coercion -> lambda
 val transl_store_implementation:
       string -> structure * module_coercion -> int * lambda
 val transl_toplevel_definition: structure -> lambda
+val transl_package: Ident.t list -> Ident.t -> module_coercion -> lambda
+val transl_store_package:
+      Ident.t list -> Ident.t -> module_coercion -> int * lambda
+
 val toplevel_name: Ident.t -> string
 
 val primitive_declarations: string list ref
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 89963b0d7..73c48525a 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -564,14 +564,23 @@ let package_units objfiles cmifile modulename =
       objfiles in
   (* Compute signature of packaged unit *)
   let sg = package_signatures Subst.identity units in
-  (* Determine imports *)
-  let unit_names = List.map fst units in
-  let imports =
-    List.filter
-      (fun (name, crc) -> not (List.mem name unit_names))
-      (Env.imported_units()) in
-  (* Write packaged signature *)
-  Env.save_signature_with_imports sg modulename cmifile imports
+  (* See if explicit interface is provided *)
+  let mlifile =
+    chop_extension_if_any cmifile ^ !Config.interface_suffix in
+  if Sys.file_exists mlifile then begin
+    let dclsig = Env.read_signature modulename cmifile in
+    Includemod.compunit "(obtained by packing)" sg mlifile dclsig 
+  end else begin
+    (* Determine imports *)
+    let unit_names = List.map fst units in
+    let imports =
+      List.filter
+        (fun (name, crc) -> not (List.mem name unit_names))
+        (Env.imported_units()) in
+    (* Write packaged signature *)
+    Env.save_signature_with_imports sg modulename cmifile imports;
+    Tcoerce_none
+  end
 
 (* Error report *)
 
diff --git a/typing/typemod.mli b/typing/typemod.mli
index 7017dcf0d..63f1f6614 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -32,7 +32,7 @@ val check_nongen_schemes:
 val simplify_signature: signature -> signature
 
 val package_units:
-        string list -> string -> string -> unit
+        string list -> string -> string -> Typedtree.module_coercion
 
 type error =
     Unbound_module of Longident.t