Ajout du packaging d'unites de compilation (option -pack)

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

18 files changed, 409 insertions, 60 deletions

diff --git a/asmcomp/alpha/emit.mlp b/asmcomp/alpha/emit.mlp
index 15fc1750aa..b34c38f539 100644
--- a/asmcomp/alpha/emit.mlp
+++ b/asmcomp/alpha/emit.mlp
@@ -832,26 +832,26 @@ let begin_assembly() =
      of line numbers for the debugger, 'cos they make .o files larger
      and slow down linking. *)
   `	.file	1 \"{emit_string !Location.input_name}\"\n\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in
   `	.data\n`;
   `	.globl	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in
   `	.text\n`;
   `	.globl	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`
 
 let end_assembly () =
-  let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in
   `	.text\n`;
   `	.globl	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
-  let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in
   `	.data\n`;
   `	.globl	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   `	.quad	0\n`;
-  let lbl_frame = Compilenv.current_unit_name() ^ "_frametable" in
+  let lbl_frame = Compilenv.current_unit_name() ^ "__frametable" in
   `	{emit_string rdata_section}\n`;
   `	.globl	{emit_symbol lbl_frame}\n`;
   `{emit_symbol lbl_frame}:\n`;
diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp
index 88be03ce72..83cbfc6f04 100644
--- a/asmcomp/arm/emit.mlp
+++ b/asmcomp/arm/emit.mlp
@@ -648,26 +648,26 @@ let begin_assembly() =
   `sp           .req    r13\n`;
   `lr           .req    r14\n`;
   `pc           .req    r15\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in
   `	.data\n`;
   `	.global	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in
   `	.text\n`;
   `	.global	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`
 
 let end_assembly () =
-  let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in
   `	.text\n`;
   `	.global	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
-  let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in
   `	.data\n`;
   `	.global	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   `	.word	0\n`;
-  let lbl = Compilenv.current_unit_name() ^ "_frametable" in
+  let lbl = Compilenv.current_unit_name() ^ "__frametable" in
   `	.data\n`;
   `	.global	{emit_symbol lbl}\n`;
   `{emit_symbol lbl}:\n`;
diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml
index 45a31d22d4..6020f90a68 100644
--- a/asmcomp/asmlink.ml
+++ b/asmcomp/asmlink.ml
@@ -71,6 +71,12 @@ let check_consistency file_name unit crc =
   with Not_found ->
     Hashtbl.add crc_implementations unit.ui_name (file_name, crc)
 
+let extract_crcs table =
+  Hashtbl.fold (fun name (file_name, crc) accu -> (name, crc) :: accu)
+               table []
+let extract_crc_interfaces () = extract_crcs crc_interfaces
+let extract_crc_implementations () = extract_crcs crc_implementations
+
 (* Add C objects and options and "custom" info from a library descriptor.
    See bytecomp/bytelink.ml for comments on the order of C objects. *)
 
@@ -163,7 +169,8 @@ let make_startup_file ppf filename units_list =
   Location.input_name := "startup"; (* set the name of the "current" input *)
   Compilenv.reset "startup"; (* set the name of the "current" compunit *)
   Emit.begin_assembly();
-  let name_list = List.map (fun (info,_,_) -> info.ui_name) units_list in
+  let name_list =
+    List.flatten (List.map (fun (info,_,_) -> info.ui_defines) units_list) in
   compile_phrase (Cmmgen.entry_point name_list);
   let apply_functions = ref (IntSet.add 2 (IntSet.add 3 IntSet.empty)) in
   (* The callback functions always reference caml_apply[23] *)
@@ -191,9 +198,10 @@ let make_startup_file ppf filename units_list =
   compile_phrase
     (Cmmgen.globals_map
       (List.map
-        (fun name ->
-          let (auth_name,crc) = Hashtbl.find crc_interfaces name in (name,crc))
-        name_list));
+        (fun (unit,_,_) ->
+          let (auth_name,crc) = Hashtbl.find crc_interfaces unit.ui_name in
+          (unit.ui_name,crc))
+        units_list));
   compile_phrase(Cmmgen.data_segment_table ("startup" :: name_list));
   compile_phrase(Cmmgen.code_segment_table ("startup" :: name_list));
   compile_phrase
diff --git a/asmcomp/asmlink.mli b/asmcomp/asmlink.mli
index 1924860793..9c5f202681 100644
--- a/asmcomp/asmlink.mli
+++ b/asmcomp/asmlink.mli
@@ -18,6 +18,10 @@ open Format
 
 val link: formatter -> string list -> unit
 
+val check_consistency: string -> Compilenv.unit_infos -> Digest.t -> unit
+val extract_crc_interfaces: unit -> (string * Digest.t) list
+val extract_crc_implementations: unit -> (string * Digest.t) list
+
 type error =
     File_not_found of string
   | Not_an_object_file of string
diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml
new file mode 100644
index 0000000000..b66e9bfb69
--- /dev/null
+++ b/asmcomp/asmpackager.ml
@@ -0,0 +1,288 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
+   original compilation units as sub-modules. *)
+
+open Printf
+open Misc
+open Lambda
+open Clambda
+open Compilenv
+
+type error =
+    Illegal_renaming of string * string
+  | Forward_reference of string * string
+  | Linking_error
+  | Assembler_error of string
+  | File_not_found of string
+  | No_binutils
+
+exception Error of error
+
+(* Read the unit information from a .cmx file. *)
+
+let read_unit_info cmxfile =
+  let (info, crc) = Compilenv.read_unit_info cmxfile in
+  if info.ui_name
+  <> String.capitalize(Filename.basename(chop_extension_if_any cmxfile))
+  then raise(Error(Illegal_renaming(cmxfile, info.ui_name)));
+  Asmlink.check_consistency cmxfile info crc;
+  info
+
+(* Check absence of forward references *)
+
+let check_units cmxfiles units unit_names =
+  let rec check forbidden = function
+    [] -> ()
+  | (cmxfile, infos) :: tl ->
+      List.iter
+        (fun (unit, _) ->
+          if List.mem unit forbidden
+          then raise(Error(Forward_reference(cmxfile, unit))))
+        infos.ui_imports_cmx;
+      check (list_remove infos.ui_name forbidden) tl in
+  check unit_names (List.combine cmxfiles units)
+
+(* Rename symbols in an object file.  All defined symbols of the form
+   [T] or [T]__xxx, where [T] belongs to the list [units], are prefixed by 
+   [pref]__ .  Return the list of renamed symbols. *)
+
+let extract_symbols units symbolfile =
+  let symbs = ref [] in
+  let ic = open_in symbolfile in
+  begin try
+    while true do
+      let l = input_line ic in
+      try
+        let i = 3 + (try search_substring " T " l 0
+                     with Not_found -> search_substring " D " l 0) in
+        let j = try search_substring "__" l i
+                with Not_found -> String.length l in
+        if List.mem (String.sub l i (j - i)) units then
+          symbs := (String.sub l i (String.length l - i)) :: !symbs
+      with Not_found ->
+        ()
+    done
+  with End_of_file -> close_in ic
+     | x -> close_in ic; raise x
+  end;
+  !symbs
+
+let rename_in_object_file units pref objfile =
+  let symbolfile = Filename.temp_file "camlsymbols" "" in
+  try
+    let nm_cmdline =
+      sprintf "%s %s > %s" Config.binutils_nm objfile symbolfile in
+    if Ccomp.command nm_cmdline <> 0 then raise(Error Linking_error);
+    let symbols_to_rename =
+      extract_symbols units symbolfile in
+    let objcopy_cmdline =
+      sprintf "%s %s %s"
+        Config.binutils_objcopy
+        (String.concat " "
+          (List.map
+            (fun s -> sprintf "--redefine-sym '%s=%s__%s'" s pref s)
+            symbols_to_rename))
+        objfile in
+    (* FIXME: what if the command line is too long? *)
+    if Ccomp.command objcopy_cmdline <> 0 then raise(Error Linking_error);
+    remove_file symbolfile;
+    symbols_to_rename
+  with x ->
+    remove_file symbolfile;
+    raise x
+
+(* Rename function symbols and global symbols in value approximations *)
+
+let rename_approx mapping approx =
+
+  let ren_label lbl =
+    try Tbl.find lbl mapping with Not_found -> lbl in
+  let ren_ident id =
+    if Ident.persistent id
+    then Ident.create_persistent(ren_label(Ident.name id))
+    else id in
+
+  let rec ren_ulambda = function
+    Uvar id ->
+      Uvar(ren_ident id)
+  | Uconst cst ->
+      Uconst cst
+  | Udirect_apply(lbl, args) ->
+      Udirect_apply(ren_label lbl, List.map ren_ulambda args)
+  | Ugeneric_apply(fn, args) ->
+      Ugeneric_apply(ren_ulambda fn, List.map ren_ulambda args)
+  | Uclosure(fns, env) ->
+      (* never present in an inlined function body *)
+      assert false
+  | Uoffset(lam, ofs) -> Uoffset(ren_ulambda lam, ofs)
+  | Ulet(id, u, body) -> Ulet(id, ren_ulambda u, ren_ulambda body)
+  | Uletrec(defs, body) ->
+      (* never present in an inlined function body *)
+      assert false
+  | Uprim(prim, args) ->
+      let prim' =
+        match prim with
+          Pgetglobal id -> Pgetglobal(ren_ident id)
+        | Psetglobal id -> assert false (* never present in inlined fn body *)
+        | _ -> prim in
+      Uprim(prim', List.map ren_ulambda args)
+  | Uswitch(u, cases) ->
+      Uswitch(ren_ulambda u,
+        {cases with
+         us_actions_consts = Array.map ren_ulambda cases.us_actions_consts;
+         us_actions_blocks = Array.map ren_ulambda cases.us_actions_blocks})
+  | Ustaticfail(tag, args) ->
+      Ustaticfail(tag, List.map ren_ulambda args)
+  | Ucatch(nfail, ids, u1, u2) ->
+      Ucatch(nfail, ids, ren_ulambda u1, ren_ulambda u2)
+  | Utrywith(u1, id, u2) ->
+      Utrywith(ren_ulambda u1, id, ren_ulambda u2)
+  | Uifthenelse(u1, u2, u3) ->
+      Uifthenelse(ren_ulambda u1, ren_ulambda u2, ren_ulambda u3)
+  | Usequence(u1, u2) ->
+      Usequence(ren_ulambda u1, ren_ulambda u2)
+  | Uwhile(u1, u2) ->
+      Uwhile(ren_ulambda u1, ren_ulambda u2)
+  | Ufor(id, u1, u2, dir, u3) ->
+      Ufor(id, ren_ulambda u1, ren_ulambda u2, dir, ren_ulambda u3)
+  | Uassign(id, u) ->
+      Uassign(id, ren_ulambda u)
+  | Usend(u1, u2, ul) ->
+      Usend(ren_ulambda u1, ren_ulambda u2, List.map ren_ulambda ul) in
+
+  let rec ren_approx = function
+      Value_closure(fd, res) ->
+        let fd' =
+          {fd with
+           fun_label = ren_label fd.fun_label;
+           fun_inline =
+             match fd.fun_inline with
+               None -> None
+             | Some(params, body) -> Some(params, ren_ulambda body)} in
+        Value_closure(fd', ren_approx res)
+    | Value_tuple comps ->
+        Value_tuple (Array.map ren_approx comps)
+    | app -> app
+
+  in ren_approx approx
+
+(* Make the .cmx file for the package *)
+
+let build_package_cmx units unit_names target symbols_to_rename cmxfile =
+  let filter lst =
+    List.filter (fun (name, crc) -> not (List.mem name unit_names)) lst in
+  let union lst =
+    List.fold_left
+      (List.fold_left
+          (fun accu n -> if List.mem n accu then accu else n :: accu))
+      [] lst in
+  let mapping =
+    List.fold_left (fun tbl s -> Tbl.add s (target ^ "__" ^ s) tbl)
+                   Tbl.empty symbols_to_rename in
+  let pkg_infos =
+    { ui_name = target;
+      ui_defines =
+        map_end (fun s -> target ^ "__" ^ s) unit_names [target];
+      ui_imports_cmi = 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_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
+    } in
+  Compilenv.write_unit_info pkg_infos 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 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;
+  let ld_cmd =
+    sprintf "%s -o %s %s %s"
+            Config.native_partial_linker targetobj objtemp
+            (String.concat " " objfiles) in
+  let retcode = Ccomp.command ld_cmd in
+  remove_file objtemp;
+  if retcode <> 0 then raise(Error Linking_error)
+
+(* Make the .cmx and the .o for the package *)
+
+let package_object_files ppf cmxfiles targetcmx targetobj targetname =
+  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;
+  let symbols = rename_in_object_file unit_names targetname targetobj in
+  build_package_cmx units unit_names targetname symbols targetcmx
+
+(* The entry point *)
+
+let package_files ppf files targetcmx =
+  if Config.binutils_objcopy = "" || Config.binutils_nm = ""
+  then raise (Error No_binutils);
+  let cmxfiles =
+    List.map
+      (fun f ->
+        try find_in_path !Config.load_path f
+        with Not_found -> raise(Error(File_not_found f)))
+      files in
+  let prefix = chop_extension_if_any targetcmx in
+  let targetcmi = prefix ^ ".cmi" in
+  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
+  with x ->
+    remove_file targetcmi; remove_file targetcmx; remove_file targetobj;
+    raise x
+
+(* Error report *)
+
+open Format
+
+let report_error ppf = function
+    Illegal_renaming(file, id) ->
+      fprintf ppf "Wrong file naming: %s@ contains the code for@ %s"
+        file id
+  | Forward_reference(file, ident) ->
+      fprintf ppf "Forward reference to %s in file %s" ident file
+  | File_not_found file ->
+      fprintf ppf "File %s not found" file
+  | Assembler_error file ->
+      fprintf ppf "Error while assembling %s" file
+  | Linking_error ->
+      fprintf ppf "Error during partial linking"
+  | No_binutils ->
+      fprintf ppf "ocamlopt -pack is not supported on this platform.@ \
+                   Reason: the GNU `binutils' tools are not available"
diff --git a/asmcomp/asmpackager.mli b/asmcomp/asmpackager.mli
new file mode 100644
index 0000000000..ae16e198e4
--- /dev/null
+++ b/asmcomp/asmpackager.mli
@@ -0,0 +1,30 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                           Objective Caml                            *)
+(*                                                                     *)
+(*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
+(*                                                                     *)
+(*  Copyright 2002 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id$ *)
+
+(* "Package" a set of .cmx/.o files into one .cmx/.o file having the
+   original compilation units as sub-modules. *)
+
+val package_files: Format.formatter -> string list -> string -> unit
+
+type error =
+    Illegal_renaming of string * string
+  | Forward_reference of string * string
+  | Linking_error
+  | Assembler_error of string
+  | File_not_found of string
+  | No_binutils
+
+exception Error of error
+
+val report_error: Format.formatter -> error -> unit
diff --git a/asmcomp/closure.ml b/asmcomp/closure.ml
index 77c36095b4..6ab5098cbc 100644
--- a/asmcomp/closure.ml
+++ b/asmcomp/closure.ml
@@ -614,7 +614,7 @@ and close_functions fenv cenv fun_defs =
       (function
           (id, (Lfunction(kind, params, body) as def)) ->
             let label =
-              Compilenv.current_unit_name() ^ "_" ^ Ident.unique_name id in
+              Compilenv.current_unit_name() ^ "__" ^ Ident.unique_name id in
             let arity = List.length params in
             let fundesc =
               {fun_label = label;
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index aecc80ab3e..716634e83a 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -354,7 +354,7 @@ let new_const_label () =
 
 let new_const_symbol () =
   incr const_label;
-  Compilenv.current_unit_name () ^ "_" ^ string_of_int !const_label
+  Compilenv.current_unit_name () ^ "__" ^ string_of_int !const_label
 
 let structured_constants = ref ([] : (string * structured_constant) list)
 
@@ -1549,7 +1549,7 @@ let emit_all_constants cont =
 let compunit size ulam =
   let glob = Compilenv.current_unit_name () in
   let init_code = transl ulam in
-  let c1 = [Cfunction {fun_name = glob ^ "_entry"; fun_args = [];
+  let c1 = [Cfunction {fun_name = glob ^ "__entry"; fun_args = [];
                        fun_body = init_code; fun_fast = false}] in
   let c2 = transl_all_functions StringSet.empty c1 in
   let c3 = emit_all_constants c2 in
@@ -1557,6 +1557,15 @@ 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)) ::
+          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)
@@ -1685,7 +1694,7 @@ let entry_point namelist =
   let body =
     List.fold_right
       (fun name next ->
-        Csequence(Cop(Capply typ_void, [Cconst_symbol(name ^ "_entry")]),
+        Csequence(Cop(Capply typ_void, [Cconst_symbol(name ^ "__entry")]),
                   Csequence(incr_global_inited, next)))
       namelist (Cconst_int 1) in
   Cfunction {fun_name = "caml_program";
@@ -1710,8 +1719,8 @@ let globals_map namelist =
 
 let frame_table namelist =
   Cdata(Cdefine_symbol "caml_frametable" ::
-        List.map (fun name -> Csymbol_address(name ^ "_frametable")) namelist @
-        [cint_zero])
+        List.map (fun name -> Csymbol_address(name ^ "__frametable")) namelist
+                              @ [cint_zero])
 
 (* Generate the table of module data and code segments *)
 
@@ -1725,10 +1734,10 @@ let segment_table namelist symbol begname endname =
           [cint_zero])
 
 let data_segment_table namelist =
-  segment_table namelist "caml_data_segments" "_data_begin" "_data_end"
+  segment_table namelist "caml_data_segments" "__data_begin" "__data_end"
 
 let code_segment_table namelist =
-  segment_table namelist "caml_code_segments" "_code_begin" "_code_end"
+  segment_table namelist "caml_code_segments" "__code_begin" "__code_end"
 
 (* Initialize a predefined exception *)
 
diff --git a/asmcomp/cmmgen.mli b/asmcomp/cmmgen.mli
index 0bf27f8cd4..1d70a9b525 100644
--- a/asmcomp/cmmgen.mli
+++ b/asmcomp/cmmgen.mli
@@ -16,6 +16,7 @@
 
 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/asmcomp/compilenv.ml b/asmcomp/compilenv.ml
index 9677d5a5a8..0012cea4ed 100644
--- a/asmcomp/compilenv.ml
+++ b/asmcomp/compilenv.ml
@@ -37,6 +37,7 @@ exception Error of error
 
 type unit_infos =
   { mutable ui_name: string;                    (* Name of unit implemented *)
+    mutable ui_defines: string list;      (* Unit and sub-units implemented *)
     mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *)
     mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *)
     mutable ui_approx: value_approximation;     (* Approx of the structure *)
@@ -57,6 +58,7 @@ let global_approx_table =
 
 let current_unit =
   { ui_name = "";
+    ui_defines = [];
     ui_imports_cmi = [];
     ui_imports_cmx = [];
     ui_approx = Value_unknown;
@@ -67,6 +69,7 @@ let current_unit =
 let reset name =
   Hashtbl.clear global_approx_table;
   current_unit.ui_name <- name;
+  current_unit.ui_defines <- [name];
   current_unit.ui_imports_cmi <- [];
   current_unit.ui_imports_cmx <- [];
   current_unit.ui_curry_fun <- [];
@@ -139,16 +142,19 @@ let need_apply_fun n =
 
 (* Write the description of the current unit *)
 
-let save_unit_info filename =
-  current_unit.ui_imports_cmi <- Env.imported_units();
+let write_unit_info info filename =
   let oc = open_out_bin filename in
   output_string oc cmx_magic_number;
-  output_value oc current_unit;
+  output_value oc info;
   flush oc;
   let crc = Digest.file filename in
   Digest.output oc crc;
   close_out oc
 
+let save_unit_info filename =
+  current_unit.ui_imports_cmi <- Env.imported_units();
+  write_unit_info current_unit filename
+
 (* Error report *)
 
 open Format
diff --git a/asmcomp/compilenv.mli b/asmcomp/compilenv.mli
index db645d66a2..5ddf7cd276 100644
--- a/asmcomp/compilenv.mli
+++ b/asmcomp/compilenv.mli
@@ -28,6 +28,7 @@ open Clambda
 
 type unit_infos =
   { mutable ui_name: string;                    (* Name of unit implemented *)
+    mutable ui_defines: string list;      (* Unit and sub-units implemented *)
     mutable ui_imports_cmi: (string * Digest.t) list; (* Interfaces imported *)
     mutable ui_imports_cmx: (string * Digest.t) list; (* Infos imported *)
     mutable ui_approx: value_approximation;     (* Approx of the structure *)
@@ -62,6 +63,8 @@ val need_apply_fun: int -> unit
 
 val read_unit_info: string -> unit_infos * Digest.t
         (* Read infos and CRC from a [.cmx] file. *)
+val write_unit_info: unit_infos -> string -> unit
+        (* Save the given infos in the given file *)
 val save_unit_info: string -> unit
         (* Save the infos for the current unit in the given file *)
 
diff --git a/asmcomp/hppa/emit.mlp b/asmcomp/hppa/emit.mlp
index 322be0c673..7b164f35d0 100644
--- a/asmcomp/hppa/emit.mlp
+++ b/asmcomp/hppa/emit.mlp
@@ -1070,11 +1070,11 @@ let begin_assembly() =
   defined_symbols := StringSet.empty;
   called_symbols := StringSet.empty;
   Hashtbl.clear stub_label_table;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in
   `	.data\n`;
   emit_global lbl_begin;
   `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in
   `	.code\n`;
   emit_global lbl_begin;
   `{emit_symbol lbl_begin}:\n`
@@ -1083,15 +1083,15 @@ let begin_assembly() =
 let end_assembly() =
   if not hpux then emit_stubs();
   `	.code\n`;
-  let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in
   emit_global lbl_end;
   `{emit_symbol lbl_end}:\n`;
   `	.data\n`;
-  let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in
   emit_global lbl_end;
   `{emit_symbol lbl_end}:\n`;
   `	.long	0\n`;
-  let lbl = Compilenv.current_unit_name() ^ "_frametable" in
+  let lbl = Compilenv.current_unit_name() ^ "__frametable" in
   emit_global lbl;
   `{emit_symbol lbl}:\n`;
   `	.long	{emit_int (List.length !frame_descriptors)}\n`;
diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
index 961a8c3735..aa4e8db8ce 100644
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -805,26 +805,26 @@ let data l =
 (* Beginning / end of an assembly file *)
 
 let begin_assembly() =
-  let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in
   `	.data\n`;
   `	.globl	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in
   `	.text\n`;
   `	.globl	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`
 
 let end_assembly() =
-  let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in
   `	.text\n`;
   `	.globl	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   `	.data\n`;
-  let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in
   `	.globl	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   `	.long	0\n`;
-  let lbl = Compilenv.current_unit_name() ^ "_frametable" in
+  let lbl = Compilenv.current_unit_name() ^ "__frametable" in
   `	.globl	{emit_symbol lbl}\n`;
   `{emit_symbol lbl}:\n`;
   `	.long	{emit_int (List.length !frame_descriptors)}\n`;
diff --git a/asmcomp/i386/emit_nt.mlp b/asmcomp/i386/emit_nt.mlp
index 12ed86a51d..548f731789 100644
--- a/asmcomp/i386/emit_nt.mlp
+++ b/asmcomp/i386/emit_nt.mlp
@@ -789,28 +789,28 @@ let begin_assembly() =
   `	EXTERN _caml_alloc3: PROC\n`;
   `	EXTERN _array_bound_error: PROC\n`;
   `	.DATA\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in
   add_def_symbol lbl_begin;
   `	PUBLIC	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}	LABEL	DWORD\n`;
   `	.CODE\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in
   add_def_symbol lbl_begin;
   `	PUBLIC	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}	LABEL	DWORD\n`
 
 let end_assembly() =
   `	.CODE\n`;
-  let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in
   add_def_symbol lbl_end;
   `	PUBLIC	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}	LABEL	DWORD\n`;
   `	.DATA\n`;
-  let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in
   add_def_symbol lbl_end;
   `	PUBLIC	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}	LABEL	DWORD\n`;
-  let lbl = Compilenv.current_unit_name() ^ "_frametable" in
+  let lbl = Compilenv.current_unit_name() ^ "__frametable" in
   add_def_symbol lbl;
   `	PUBLIC	{emit_symbol lbl}\n`;
   `{emit_symbol lbl}	DWORD	{emit_int (List.length !frame_descriptors)}\n`;
diff --git a/asmcomp/ia64/emit.mlp b/asmcomp/ia64/emit.mlp
index e0ad7bd98b..9cfc8f0181 100644
--- a/asmcomp/ia64/emit.mlp
+++ b/asmcomp/ia64/emit.mlp
@@ -1302,18 +1302,18 @@ let data l =
 
 let begin_assembly() =
   `	.data\n`;
-  emit_define_symbol (Compilenv.current_unit_name() ^ "_data_begin");
+  emit_define_symbol (Compilenv.current_unit_name() ^ "__data_begin");
   `	.text\n`;
-  emit_define_symbol (Compilenv.current_unit_name() ^ "_code_begin")
+  emit_define_symbol (Compilenv.current_unit_name() ^ "__code_begin")
 
 let end_assembly () =
   `	.data\n`;
-  emit_define_symbol (Compilenv.current_unit_name() ^ "_data_end");
+  emit_define_symbol (Compilenv.current_unit_name() ^ "__data_end");
   `	.text\n`;
-  emit_define_symbol (Compilenv.current_unit_name() ^ "_code_end");
+  emit_define_symbol (Compilenv.current_unit_name() ^ "__code_end");
   `	.rodata\n`;
   `	.align 8\n`;
-  emit_define_symbol (Compilenv.current_unit_name() ^ "_frametable");
+  emit_define_symbol (Compilenv.current_unit_name() ^ "__frametable");
   `	data8	{emit_int (List.length !frame_descriptors)}\n`;
   List.iter emit_frame !frame_descriptors;
   frame_descriptors := []
diff --git a/asmcomp/mips/emit.mlp b/asmcomp/mips/emit.mlp
index 86112b000a..193a12df20 100644
--- a/asmcomp/mips/emit.mlp
+++ b/asmcomp/mips/emit.mlp
@@ -560,11 +560,11 @@ let begin_assembly() =
   `	.noalias $16,$sp; .noalias $16,$30; .noalias $17,$sp; .noalias $17,$30\n`;
   `	.noalias $18,$sp; .noalias $18,$30; .noalias $19,$sp; .noalias $19,$30\n`;
   `	.noalias $20,$sp; .noalias $20,$30; .noalias $21,$sp; .noalias $21,$30\n\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in
   `	.data\n`;
   `	.globl	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in
   `	.text\n`;
   `	.globl	{emit_symbol lbl_begin}\n`;
   `	.ent	{emit_symbol lbl_begin}\n`;
@@ -572,18 +572,18 @@ let begin_assembly() =
   `	.end	{emit_symbol lbl_begin}\n`
 
 let end_assembly () =
-  let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in
   `	.text\n`;
   `	.globl	{emit_symbol lbl_end}\n`;
   `	.ent	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   `	.end	{emit_symbol lbl_end}\n`;
-  let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in
   `	.data\n`;
   `	.globl	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   `	.word	0\n`;
-  let lbl = Compilenv.current_unit_name() ^ "_frametable" in
+  let lbl = Compilenv.current_unit_name() ^ "__frametable" in
   `	.rdata\n`;
   `	.globl	{emit_symbol lbl}\n`;
   `{emit_symbol lbl}:\n`;
diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp
index e96dd297ff..534d270cd6 100644
--- a/asmcomp/power/emit.mlp
+++ b/asmcomp/power/emit.mlp
@@ -1042,11 +1042,11 @@ let begin_assembly() =
   jumptbl_entries := [];
   lbl_jumptbl := 0;
   (* Emit the beginning of the segments *)
-  let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in
   emit_string data_space;
   declare_global_data lbl_begin;
   `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in
   emit_string code_space;
   declare_global_data lbl_begin;
   `{emit_symbol lbl_begin}:\n`
@@ -1079,17 +1079,17 @@ let end_assembly() =
     StringSet.iter emit_external !external_functions;
   (* Emit the end of the segments *)
   emit_string code_space;
-  let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in
   declare_global_data lbl_end;
   `{emit_symbol lbl_end}:\n`;
   emit_string data_space;
-  let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in
   declare_global_data lbl_end;
   `{emit_symbol lbl_end}:\n`;
   `	.long	0\n`;
   (* Emit the frame descriptors *)
   emit_string rodata_space;
-  let lbl = Compilenv.current_unit_name() ^ "_frametable" in
+  let lbl = Compilenv.current_unit_name() ^ "__frametable" in
   declare_global_data lbl;
   `{emit_symbol lbl}:\n`;
   `	.long	{emit_int (List.length !frame_descriptors)}\n`;
diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp
index bee1c3d5d3..8478acc1f4 100644
--- a/asmcomp/sparc/emit.mlp
+++ b/asmcomp/sparc/emit.mlp
@@ -653,26 +653,26 @@ let data l =
 (* Beginning / end of an assembly file *)
 
 let begin_assembly() =
-  let lbl_begin = Compilenv.current_unit_name() ^ "_data_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__data_begin" in
   `	.data\n`;
   `	.global	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`;
-  let lbl_begin = Compilenv.current_unit_name() ^ "_code_begin" in
+  let lbl_begin = Compilenv.current_unit_name() ^ "__code_begin" in
   `	.text\n`;
   `	.global	{emit_symbol lbl_begin}\n`;
   `{emit_symbol lbl_begin}:\n`
 
 let end_assembly() =
   `	.text\n`;
-  let lbl_end = Compilenv.current_unit_name() ^ "_code_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__code_end" in
   `	.global	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   `	.data\n`;
-  let lbl_end = Compilenv.current_unit_name() ^ "_data_end" in
+  let lbl_end = Compilenv.current_unit_name() ^ "__data_end" in
   `	.global	{emit_symbol lbl_end}\n`;
   `{emit_symbol lbl_end}:\n`;
   `	.word	0\n`;
-  let lbl = Compilenv.current_unit_name() ^ "_frametable" in
+  let lbl = Compilenv.current_unit_name() ^ "__frametable" in
   `	.global	{emit_symbol lbl}\n`;
   `{emit_symbol lbl}:\n`;
   `	.word	{emit_int (List.length !frame_descriptors)}\n`;