Create .cmi files atomically (MPR#7472)

Changes

@@ -169,6 +169,11 @@ Working version
 * GPR#1189: allow MSVC ports to use -l option in ocamlmklib
   (David Allsopp)
 
+- MPR#7472: ensure .cmi files are created atomically,
+  to avoid corruption of .cmi files produced simultaneously by a run
+  of ocamlc and a run of ocamlopt.
+  (Xavier Leroy, from a suggestion by Gerd Stolpmann)
+
 ### Other libraries:
 
 - GPR#1178: remove the Num library for arbitrary-precision arithmetic.

typing/cmt_format.ml

@@ -166,30 +166,31 @@ let record_value_dependency vd1 vd2 =
 
 let save_cmt filename modname binary_annots sourcefile initial_env cmi =
   if !Clflags.binary_annotations && not !Clflags.print_types then begin
-    let oc = open_out_bin filename in
-    let this_crc =
-      match cmi with
-      | None -> None
-      | Some cmi -> Some (output_cmi filename oc cmi)
-    in
-    let source_digest = Misc.may_map Digest.file sourcefile in
-    let cmt = {
-      cmt_modname = modname;
-      cmt_annots = clear_env binary_annots;
-      cmt_value_dependencies = !value_deps;
-      cmt_comments = Lexer.comments ();
-      cmt_args = Sys.argv;
-      cmt_sourcefile = sourcefile;
-      cmt_builddir =  Sys.getcwd ();
-      cmt_loadpath = !Config.load_path;
-      cmt_source_digest = source_digest;
-      cmt_initial_env = if need_to_clear_env then
-          keep_only_summary initial_env else initial_env;
-      cmt_imports = List.sort compare (Env.imports ());
-      cmt_interface_digest = this_crc;
-      cmt_use_summaries = need_to_clear_env;
-    } in
-    output_cmt oc cmt;
-    close_out oc;
+    Misc.output_to_file_via_temporary
+       ~mode:[Open_binary] filename
+       (fun temp_file_name oc ->
+         let this_crc =
+           match cmi with
+           | None -> None
+           | Some cmi -> Some (output_cmi temp_file_name oc cmi)
+         in
+         let source_digest = Misc.may_map Digest.file sourcefile in
+         let cmt = {
+           cmt_modname = modname;
+           cmt_annots = clear_env binary_annots;
+           cmt_value_dependencies = !value_deps;
+           cmt_comments = Lexer.comments ();
+           cmt_args = Sys.argv;
+           cmt_sourcefile = sourcefile;
+           cmt_builddir =  Sys.getcwd ();
+           cmt_loadpath = !Config.load_path;
+           cmt_source_digest = source_digest;
+           cmt_initial_env = if need_to_clear_env then
+               keep_only_summary initial_env else initial_env;
+           cmt_imports = List.sort compare (Env.imports ());
+           cmt_interface_digest = this_crc;
+           cmt_use_summaries = need_to_clear_env;
+         } in
+         output_cmt oc cmt)
   end;
   clear ()

typing/env.ml

@@ -2159,16 +2159,17 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
       (match deprecated with Some s -> [Deprecated s] | None -> []);
     ]
   in
-  let oc = open_out_bin filename in
   try
     let cmi = {
       cmi_name = modname;
       cmi_sign = sg;
       cmi_crcs = imports;
       cmi_flags = flags;
     } in
-    let crc = output_cmi filename oc cmi in
-    close_out oc;
+    let crc =
+      output_to_file_via_temporary (* see MPR#7472, MPR#4991 *)
+         ~mode: [Open_binary] filename
+         (fun temp_filename oc -> output_cmi temp_filename oc cmi) in
     (* Enter signature in persistent table so that imported_unit()
        will also return its crc *)
     let comps =
@@ -2186,7 +2187,6 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
     save_pers_struct crc ps;
     cmi
   with exn ->
-    close_out oc;
     remove_file filename;
     raise exn
 

typing/stypes.ml

@@ -194,16 +194,14 @@ let get_info () =
 
 let dump filename =
   if !Clflags.annotations then begin
-    let info = get_info () in
-    let pp =
-      match filename with
-          None -> stdout
-        | Some filename -> open_out filename in
-    sort_filter_phrases ();
-    ignore (List.fold_left (print_info pp) Location.none info);
+    let do_dump _temp_filename pp =
+      let info = get_info () in
+      sort_filter_phrases ();
+      ignore (List.fold_left (print_info pp) Location.none info) in
     begin match filename with
-    | None -> ()
-    | Some _ -> close_out pp
+    | None -> do_dump "" stdout
+    | Some filename ->
+        Misc.output_to_file_via_temporary ~mode:[Open_text] filename do_dump
     end;
     phrases := [];
   end else begin

utils/misc.ml

@@ -271,6 +271,31 @@ let string_of_file ic =
       (Buffer.add_subbytes b buff 0 n; copy())
   in copy()
 
+let output_to_file_via_temporary ?(mode = [Open_text]) filename fn =
+  let (temp_filename, oc) =
+    Filename.open_temp_file
+       ~mode ~perms:0o666 ~temp_dir:(Filename.dirname filename)
+       (Filename.basename filename) ".tmp" in
+    (* The 0o666 permissions will be modified by the umask.  It's just
+       like what [open_out] and [open_out_bin] do.
+       With temp_dir = dirname filename, we ensure that the returned
+       temp file is in the same directory as filename itself, making
+       it safe to rename temp_filename to filename later.
+       With prefix = basename filename, we are almost certain that
+       the first generated name will be unique.  A fixed prefix
+       would work too but might generate more collisions if many
+       files are being produced simultaneously in the same directory. *)
+  match fn temp_filename oc with
+  | res ->
+      close_out oc;
+      begin try
+        Sys.rename temp_filename filename; res
+      with exn ->
+        remove_file temp_filename; raise exn
+      end
+  | exception exn ->
+      close_out oc; remove_file temp_filename; raise exn
+
 (* Integer operations *)
 
 let rec log2 n =

utils/misc.mli

@@ -127,6 +127,15 @@ val copy_file_chunk: in_channel -> out_channel -> int -> unit
 val string_of_file: in_channel -> string
         (* [string_of_file ic] reads the contents of file [ic] and copies
            them to a string. It stops when encountering EOF on [ic]. *)
+val output_to_file_via_temporary:
+      ?mode:open_flag list -> string -> (string -> out_channel -> 'a) -> 'a
+        (* Produce output in temporary file, then rename it
+           (as atomically as possible) to the desired output file name.
+           [output_to_file_via_temporary filename fn] opens a temporary file
+           which is passed to [fn] (name + output channel).  When [fn] returns,
+           the channel is closed and the temporary file is renamed to
+           [filename]. *)
+
 val log2: int -> int
         (* [log2 n] returns [s] such that [n = 1 lsl s]
            if [n] is a power of 2*)