Implement reviewer suggestions

asmcomp/asmgen.ml

@@ -148,7 +148,9 @@ let compile_unit _output_prefix asm_filename keep_asm
       obj_filename gen =
   let create_asm = keep_asm || not !Emitaux.binary_backend_available in
   Emitaux.create_asm_file := create_asm;
-  Misc.try_finally (fun () ->
+  Misc.try_finally
+    ~exceptionally:(fun () -> remove_file obj_filename)
+    (fun () ->
        if create_asm then Emitaux.output_channel := open_out asm_filename;
        Misc.try_finally gen
          ~always:(fun () ->
@@ -163,7 +165,6 @@ let compile_unit _output_prefix asm_filename keep_asm
        then raise(Error(Assembler_error asm_filename));
        if create_asm && not keep_asm then remove_file asm_filename
     )
-    ~exceptionally:(fun () -> remove_file obj_filename)
 
 let set_export_info (ulambda, prealloc, structured_constants, export) =
   Compilenv.set_export_info export;

asmcomp/asmlibrarian.ml

@@ -49,7 +49,10 @@ let read_info name =
 let create_archive file_list lib_name =
   let archive_name = Filename.remove_extension lib_name ^ ext_lib in
   let outchan = open_out_bin lib_name in
-  Misc.try_finally (fun () ->
+  Misc.try_finally
+    ~always:(fun () -> close_out outchan)
+    ~exceptionally:(fun () -> remove_file lib_name; remove_file archive_name)
+    (fun () ->
        output_string outchan cmxa_magic_number;
        let (objfile_list, descr_list) =
          List.split (List.map read_info file_list) in
@@ -65,10 +68,6 @@ let create_archive file_list lib_name =
        if Ccomp.create_archive archive_name objfile_list <> 0
        then raise(Error(Archiver_error archive_name));
     )
-    ~always:(fun () -> close_out outchan)
-    ~exceptionally:(fun () ->
-        remove_file lib_name;
-        remove_file archive_name)
 
 open Format
 

bytecomp/bytelibrarian.ml

@@ -90,7 +90,10 @@ let copy_object_file oc name =
 
 let create_archive file_list lib_name =
   let outchan = open_out_bin lib_name in
-  Misc.try_finally (fun () ->
+  Misc.try_finally
+    ~always:(fun () -> close_out outchan)
+    ~exceptionally:(fun () -> remove_file lib_name)
+    (fun () ->
        output_string outchan cma_magic_number;
        let ofs_pos_toc = pos_out outchan in
        output_binary_int outchan 0;
@@ -109,8 +112,6 @@ let create_archive file_list lib_name =
        seek_out outchan ofs_pos_toc;
        output_binary_int outchan pos_toc;
     )
-    ~always:(fun () -> close_out outchan)
-    ~exceptionally:(fun () -> remove_file lib_name)
 
 open Format
 

bytecomp/bytelink.ml

@@ -309,13 +309,17 @@ let link_bytecode tolink exec_name standalone =
   let outchan =
     open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
                  0o777 exec_name in
-  Misc.try_finally (fun () ->
+  Misc.try_finally
+    ~always:(fun () -> close_out outchan)
+    ~exceptionally:(fun () -> remove_file exec_name)
+    (fun () ->
        if standalone then begin
          (* Copy the header *)
          try
            let header =
              if String.length !Clflags.use_runtime > 0
-            then "camlheader_ur" else "camlheader" ^ !Clflags.runtime_variant in
+             then "camlheader_ur" else "camlheader" ^ !Clflags.runtime_variant
+           in
            let inchan = open_in_bin (find_in_path !load_path header) in
            copy_file inchan outchan;
            close_in inchan
@@ -380,8 +384,6 @@ let link_bytecode tolink exec_name standalone =
        (* The table of contents and the trailer *)
        Bytesections.write_toc_and_trailer outchan;
     )
-    ~always:(fun () -> close_out outchan)
-    ~exceptionally:(fun () -> remove_file exec_name)
 
 (* Output a string as a C array of unsigned ints *)
 
@@ -424,7 +426,10 @@ let output_cds_file outfile =
   let outchan =
     open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
       0o777 outfile in
-  Misc.try_finally (fun () ->
+  Misc.try_finally
+    ~always:(fun () -> close_out outchan)
+    ~exceptionally:(fun () -> remove_file outfile)
+    (fun () ->
        Bytesections.init_record outchan;
        (* The map of global identifiers *)
        Symtable.output_global_map outchan;
@@ -435,14 +440,15 @@ let output_cds_file outfile =
        (* The table of contents and the trailer *)
        Bytesections.write_toc_and_trailer outchan;
     )
-    ~always:(fun () -> close_out outchan)
-    ~exceptionally:(fun () -> remove_file outfile)
 
 (* Output a bytecode executable as a C file *)
 
 let link_bytecode_as_c tolink outfile =
   let outchan = open_out outfile in
-  Misc.try_finally (fun () ->
+  Misc.try_finally
+    ~always:(fun () -> close_out outchan)
+    ~exceptionally:(fun () -> remove_file outfile)
+    (fun () ->
        (* The bytecode *)
        output_string outchan "\
 #define CAML_INTERNALS\
@@ -519,9 +525,7 @@ let link_bytecode_as_c tolink outfile =
 \n#ifdef __cplusplus\
 \n}\
 \n#endif\n";
-    )
-    ~always:(fun () -> close_out outchan)
-    ~exceptionally:(fun () -> remove_file outfile);
+    );
   if !Clflags.debug then
     output_cds_file ((Filename.chop_extension outfile) ^ ".cds")
 
@@ -538,14 +542,12 @@ let build_custom_runtime prim_name exec_name =
     (debug_prefix_map @ [prim_name] @ List.rev !Clflags.ccobjs @ [runtime_lib])
     (Clflags.std_include_flag "-I" ^ " " ^ Config.bytecomp_c_libraries)
 
-let append_bytecode_and_cleanup bytecode_name exec_name prim_name =
+let append_bytecode bytecode_name exec_name =
   let oc = open_out_gen [Open_wronly; Open_append; Open_binary] 0 exec_name in
   let ic = open_in_bin bytecode_name in
   copy_file ic oc;
   close_in ic;
-  close_out oc;
-  remove_file bytecode_name;
-  if not !Clflags.keep_camlprimc_file then remove_file prim_name
+  close_out oc
 
 (* Fix the name of the output file, if the C compiler changes it behind
    our back. *)
@@ -585,7 +587,11 @@ let link objfiles output_name =
         output_name ^ ".camlprim.c"
       else
         Filename.temp_file "camlprim" ".c" in
-    Misc.try_finally (fun () ->
+    Misc.try_finally
+      ~always:(fun () ->
+          remove_file bytecode_name;
+          if not !Clflags.keep_camlprimc_file then remove_file prim_name)
+      (fun () ->
          link_bytecode tolink bytecode_name false;
          let poc = open_out prim_name in
          (* note: builds will not be reproducible if the C code contains macros
@@ -612,17 +618,11 @@ let link objfiles output_name =
          let exec_name = fix_exec_name output_name in
          if not (build_custom_runtime prim_name exec_name)
          then raise(Error Custom_runtime);
-        if !Clflags.make_runtime then begin
-          remove_file bytecode_name;
-          if not !Clflags.keep_camlprimc_file then remove_file prim_name
-        end else append_bytecode_and_cleanup bytecode_name exec_name prim_name
+         if not !Clflags.make_runtime then
+           append_bytecode bytecode_name exec_name
       )
-      ~exceptionally:(fun () ->
-          remove_file bytecode_name;
-          if not !Clflags.keep_camlprimc_file then remove_file prim_name)
   end else begin
     let basename = Filename.chop_extension output_name in
-    let temps = ref [] in
     let c_file, stable_name =
       if !Clflags.output_complete_object
          && not (Filename.check_suffix output_name ".c")
@@ -638,7 +638,10 @@ let link objfiles output_name =
       then (Filename.chop_extension c_file) ^ Config.ext_obj
       else basename ^ Config.ext_obj
     in
-    Misc.try_finally (fun () ->
+    let temps = ref [] in
+    Misc.try_finally
+      ~always:(fun () -> List.iter remove_file !temps)
+      (fun () ->
          link_bytecode_as_c tolink c_file;
          if not (Filename.check_suffix output_name ".c") then begin
            temps := c_file :: !temps;
@@ -661,7 +664,6 @@ let link objfiles output_name =
            end
          end;
       )
-      ~always:(fun () -> List.iter remove_file !temps)
   end
 
 (* Error report *)

bytecomp/symtable.ml

@@ -164,26 +164,28 @@ let init () =
   (* Initialize the known C primitives *)
   let set_prim_table_from_file primfile =
     let ic = open_in primfile in
-    Misc.try_finally (fun () ->
+    Misc.try_finally
+      ~always:(fun () -> close_in ic)
+      (fun () ->
          try
            while true do
              set_prim_table (input_line ic)
            done
          with End_of_file -> ()
       )
-      ~always:(fun () -> close_in ic)
   in
   if String.length !Clflags.use_prims > 0 then
     set_prim_table_from_file !Clflags.use_prims
   else if String.length !Clflags.use_runtime > 0 then begin
     let primfile = Filename.temp_file "camlprims" "" in
-    Misc.try_finally (fun () ->
+    Misc.try_finally
+      ~always:(fun () -> remove_file primfile)
+      (fun () ->
          if Sys.command(Printf.sprintf "%s -p > %s"
                           !Clflags.use_runtime primfile) <> 0
          then raise(Error(Wrong_vm !Clflags.use_runtime));
          set_prim_table_from_file primfile
       )
-      ~always:(fun () -> remove_file primfile)
   end else begin
     Array.iter set_prim_table Runtimedef.builtin_primitives
   end

bytecomp/translcore.ml

@@ -838,7 +838,8 @@ and transl_match e arg pat_expr_list partial =
         let rhs =
           Misc.try_finally
             (fun () -> event_before c_rhs (transl_exp c_rhs))
-            ~always:(fun () -> iter_exn_names Translprim.remove_exception_ident pe)
+            ~always:(fun () ->
+                iter_exn_names Translprim.remove_exception_ident pe)
         in
         (pv, static_raise vids) :: val_cases,
         (pe, static_raise ids) :: exn_cases,

bytecomp/translobj.ml

@@ -171,16 +171,13 @@ let oo_add_class id =
 let oo_wrap env req f x =
   if !wrapping then
     if !cache_required then f x else
-      Misc.try_finally (fun () ->
-          cache_required := true;
+      Misc.protect_refs [Misc.R (cache_required, true)] (fun () ->
           f x
         )
-        ~always:(fun () -> cache_required := false)
   else
-    Misc.try_finally (fun () ->
-        wrapping := true;
+    Misc.protect_refs [Misc.R (wrapping, true); Misc.R (top_env, env)]
+      (fun () ->
          cache_required := req;
-        top_env := env;
          classes := [];
          method_ids := Ident.Set.empty;
          let lambda = f x in
@@ -196,9 +193,6 @@ let oo_wrap env req f x =
          in
          lambda
       )
-      ~always:(fun () ->
-          wrapping := false;
-          top_env := Env.empty)
 
 let reset () =
   Hashtbl.clear consts;

driver/compile.ml

@@ -103,14 +103,15 @@ let implementation ppf sourcefile outputprefix =
           in
           let objfile = outputprefix ^ ".cmo" in
           let oc = open_out_bin objfile in
-          Misc.try_finally (fun () ->
+          Misc.try_finally
+            ~always:(fun () -> close_out oc)
+            ~exceptionally:(fun () -> remove_file objfile)
+            (fun () ->
                bytecode
                ++ Profile.(record ~accumulate:true generate)
                  (Emitcode.to_file oc modulename objfile ~required_globals);
                Warnings.check_fatal ()
             )
-            ~always:(fun () -> close_out oc)
-            ~exceptionally:(fun () -> remove_file objfile)
         end
       )
       ~always:(fun () -> Stypes.dump (Some (outputprefix ^ ".annot")))

driver/optcompile.ml

@@ -78,13 +78,16 @@ let implementation ~backend ppf sourcefile outputprefix =
     Compilenv.reset ?packname:!Clflags.for_package modulename;
     let cmxfile = outputprefix ^ ".cmx" in
     let objfile = outputprefix ^ ext_obj in
-    let comp ast =
+    Misc.try_finally
+      ~exceptionally:(fun () -> remove_file objfile; remove_file cmxfile)
+      (fun () ->
          let (typedtree, coercion) =
-        ast
+           Pparse.parse_implementation ~tool_name sourcefile
            ++ print_if ppf Clflags.dump_parsetree Printast.implementation
            ++ print_if ppf Clflags.dump_source Pprintast.structure
            ++ Profile.(record typing)
-            (Typemod.type_implementation sourcefile outputprefix modulename env)
+             (Typemod.type_implementation sourcefile outputprefix
+                modulename env)
            ++ print_if ppf Clflags.dump_typedtree
              Printtyped.implementation_with_coercion
          in
@@ -136,10 +139,6 @@ let implementation ~backend ppf sourcefile outputprefix =
            end
          end;
          Warnings.check_fatal ()
-    in
-    Misc.try_finally (fun () ->
-        comp (Pparse.parse_implementation ~tool_name sourcefile)
       )
       ~always:(fun () -> Stypes.dump (Some (outputprefix ^ ".annot")))
-      ~exceptionally:(fun () -> remove_file objfile; remove_file cmxfile)
   )

driver/pparse.ml

@@ -92,14 +92,15 @@ let apply_rewriter kind fn_in ppx =
 
 let read_ast (type a) (kind : a ast_kind) fn : a =
   let ic = open_in_bin fn in
-  Misc.try_finally (fun () ->
+  Misc.try_finally
+    ~always:(fun () -> close_in ic; Misc.remove_file fn)
+    (fun () ->
        let magic = magic_of_kind kind in
        let buffer = really_input_string ic (String.length magic) in
        assert(buffer = magic); (* already checked by apply_rewriter *)
        Location.input_name := (input_value ic : string);
        (input_value ic : a)
     )
-    ~always:(fun () -> close_in ic; Misc.remove_file fn)
 
 let rewrite kind ppxs ast =
   let fn = Filename.temp_file "camlppx" "" in

parsing/ast_helper.ml

@@ -27,10 +27,7 @@ type attrs = attribute list
 let default_loc = ref Location.none
 
 let with_default_loc l f =
-  let old = !default_loc in
-  default_loc := l;
-  Misc.try_finally f
-    ~always:(fun () -> default_loc := old)
+  Misc.protect_refs [Misc.R (default_loc, l)] f
 
 module Const = struct
   let integer ?suffix i = Pconst_integer (i, suffix)

tools/objinfo.ml

@@ -242,10 +242,11 @@ let dump_byte ic =
     toc
 
 let read_dyn_header filename ic =
-  let tempfile = Filename.temp_file "objinfo" ".out" in
   let helper = Filename.concat Config.standard_library "objinfo_helper" in
+  let tempfile = Filename.temp_file "objinfo" ".out" in
   try
     try_finally
+      ~always:(fun () -> remove_file tempfile)
       (fun () ->
          let rc = Sys.command (sprintf "%s %s > %s"
                                  (Filename.quote helper)
@@ -254,12 +255,11 @@ let read_dyn_header filename ic =
          if rc <> 0 then failwith "cannot read";
          let tc = Scanf.Scanning.from_file tempfile in
          try_finally
+           ~always:(fun () -> Scanf.Scanning.close_in tc)
            (fun () ->
               let ofs = Scanf.bscanf tc "%Ld" (fun x -> x) in
               LargeFile.seek_in ic ofs;
-              Some(input_value ic : dynheader))
-           ~always:(fun () -> Scanf.Scanning.close_in tc))
-      ~always:(fun () -> remove_file tempfile)
+              Some(input_value ic : dynheader)))
   with Failure _ | Sys_error _ -> None
 
 let dump_obj filename =

toplevel/topdirs.ml

@@ -159,10 +159,9 @@ let rec load_file recursive ppf name =
   | None -> fprintf ppf "Cannot find file %s.@." name; false
   | Some filename ->
       let ic = open_in_bin filename in
-      Misc.try_finally (fun () ->
-          really_load_file recursive ppf name filename ic
-        )
+      Misc.try_finally
         ~always:(fun () -> close_in ic)
+        (fun () -> really_load_file recursive ppf name filename ic)
 
 and really_load_file recursive ppf name filename ic =
   let buffer = really_input_string ic (String.length Config.cmo_magic_number) in

typing/cmt_format.ml

@@ -112,7 +112,9 @@ let output_cmt oc cmt =
 let read filename =
 (*  Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)
   let ic = open_in_bin filename in
-  Misc.try_finally (fun () ->
+  Misc.try_finally
+    ~always:(fun () -> close_in ic)
+    (fun () ->
        let magic_number = read_magic_number ic in
        let cmi, cmt =
          if magic_number = Config.cmt_magic_number then
@@ -133,7 +135,6 @@ let read filename =
        in
        cmi, cmt
     )
-    ~always:(fun () -> close_in ic)
 
 let read_cmt filename =
   match read filename with

typing/ctype.ml

@@ -202,20 +202,10 @@ let generate_equations = ref false
 let assume_injective = ref false
 
 let set_mode_pattern ~generate ~injective f =
-  let old_unification_mode = !umode
-  and old_gen = !generate_equations
-  and old_inj = !assume_injective in
-  Misc.try_finally (fun () ->
-      umode := Pattern;
-      generate_equations := generate;
-      assume_injective := injective;
-      f ()
-    )
-    ~always:(fun () ->
-        umode := old_unification_mode;
-        generate_equations := old_gen;
-        assume_injective := old_inj
-      )
+  Misc.protect_refs
+    [Misc.R (umode, Pattern);
+     Misc.R (generate_equations, generate);
+     Misc.R (assume_injective, injective)] f
 
 (*** Checks for type definitions ***)
 
@@ -3418,10 +3408,9 @@ and eqtype_row rename type_pairs subst env row1 row2 =
 let eqtype_list rename type_pairs subst env tl1 tl2 =
   univar_pairs := [];
   let snap = Btype.snapshot () in
-  Misc.try_finally (fun () ->
-      eqtype_list rename type_pairs subst env tl1 tl2
-    )
+  Misc.try_finally
     ~always:(fun () -> backtrack snap)
+    (fun () -> eqtype_list rename type_pairs subst env tl1 tl2)
 
 let eqtype rename type_pairs subst env t1 t2 =
   eqtype_list rename type_pairs subst env [t1] [t2]

typing/typecore.ml

@@ -1493,18 +1493,14 @@ and type_pat_aux ~exception_allowed ~constrs ~labels ~no_existentials ~mode
 
 let type_pat ?exception_allowed ?no_existentials ?constrs ?labels ?(mode=Normal)
     ?(explode=0) ?(lev=get_current_level()) env sp expected_ty =
-  gadt_equations_level := Some lev;
-  Misc.try_finally (fun () ->
+  Misc.protect_refs [Misc.R (gadt_equations_level, Some lev)] (fun () ->
       let r =
         type_pat ?exception_allowed ~no_existentials ~constrs ~labels ~mode
           ~explode ~env sp expected_ty (fun x -> x)
       in
       iter_pattern (fun p -> p.pat_env <- !env) r;
-      gadt_equations_level := None;
       r
     )
-    ~always:(fun () -> gadt_equations_level := None)
-
 
 (* this function is passed to Partial.parmatch
    to type check gadt nonexhaustiveness *)

typing/typemod.ml

@@ -2090,8 +2090,8 @@ let type_implementation sourcefile outputprefix modulename initial_env ast =
           in
           Typecore.force_delayed_checks ();
           (* It is important to run these checks after the inclusion test above,
-             so that value declarations which are not used internally but exported
-             are not reported as being unused. *)
+             so that value declarations which are not used internally but
+             exported are not reported as being unused. *)
           Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
             (Cmt_format.Implementation str) (Some sourcefile) initial_env None;
           (str, coercion)