From 0defbbe429ebcbc817905d5bf323261bb0db51b1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Nicol=C3=A1s=20Ojeda=20B=C3=A4r?= Date: Wed, 25 Jul 2018 11:10:22 +0200 Subject: [PATCH] Cosmetics --- asmcomp/asmgen.ml | 30 ++-- asmcomp/asmlibrarian.ml | 32 ++-- asmcomp/asmlink.ml | 4 +- asmcomp/asmpackager.ml | 12 +- bytecomp/bytelibrarian.ml | 38 ++--- bytecomp/bytelink.ml | 310 +++++++++++++++++++------------------- bytecomp/bytepackager.ml | 10 +- bytecomp/symtable.ml | 26 ++-- bytecomp/translobj.ml | 47 +++--- debugger/loadprinter.ml | 10 +- driver/compile.ml | 72 ++++----- driver/optcompile.ml | 6 +- driver/pparse.ml | 20 +-- tools/objinfo.ml | 24 +-- toplevel/topdirs.ml | 6 +- typing/cmt_format.ml | 42 +++--- typing/ctype.ml | 34 ++--- typing/env.ml | 54 +++---- typing/typecore.ml | 18 +-- typing/typemod.ml | 126 ++++++++-------- 20 files changed, 461 insertions(+), 460 deletions(-) diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml index 5d23b6b08358..b5692e0c9fbe 100644 --- a/asmcomp/asmgen.ml +++ b/asmcomp/asmgen.ml @@ -148,21 +148,21 @@ 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 begin fun () -> - if create_asm then Emitaux.output_channel := open_out asm_filename; - Misc.try_finally gen - ~always:(fun () -> - if create_asm then close_out !Emitaux.output_channel) - ~exceptionally:(fun () -> - if create_asm && not keep_asm then remove_file asm_filename); - let assemble_result = - Profile.record "assemble" - (Proc.assemble_file asm_filename) obj_filename - in - if assemble_result <> 0 - then raise(Error(Assembler_error asm_filename)); - if create_asm && not keep_asm then remove_file asm_filename - end + Misc.try_finally (fun () -> + if create_asm then Emitaux.output_channel := open_out asm_filename; + Misc.try_finally gen + ~always:(fun () -> + if create_asm then close_out !Emitaux.output_channel) + ~exceptionally:(fun () -> + if create_asm && not keep_asm then remove_file asm_filename); + let assemble_result = + Profile.record "assemble" + (Proc.assemble_file asm_filename) obj_filename + in + if assemble_result <> 0 + 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) = diff --git a/asmcomp/asmlibrarian.ml b/asmcomp/asmlibrarian.ml index 56725d85c8c9..38ea3dab2446 100644 --- a/asmcomp/asmlibrarian.ml +++ b/asmcomp/asmlibrarian.ml @@ -49,22 +49,22 @@ 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 begin fun () -> - output_string outchan cmxa_magic_number; - let (objfile_list, descr_list) = - List.split (List.map read_info file_list) in - List.iter2 - (fun file_name (unit, crc) -> - Asmlink.check_consistency file_name unit crc) - file_list descr_list; - let infos = - { lib_units = descr_list; - lib_ccobjs = !Clflags.ccobjs; - lib_ccopts = !Clflags.all_ccopts } in - output_value outchan infos; - if Ccomp.create_archive archive_name objfile_list <> 0 - then raise(Error(Archiver_error archive_name)); - end + Misc.try_finally (fun () -> + output_string outchan cmxa_magic_number; + let (objfile_list, descr_list) = + List.split (List.map read_info file_list) in + List.iter2 + (fun file_name (unit, crc) -> + Asmlink.check_consistency file_name unit crc) + file_list descr_list; + let infos = + { lib_units = descr_list; + lib_ccobjs = !Clflags.ccobjs; + lib_ccopts = !Clflags.all_ccopts } in + output_value outchan infos; + 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; diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index ff151ea06a02..5b5620ce6426 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -353,8 +353,8 @@ let link ppf objfiles output_name = (fun () -> make_startup_file ppf units_tolink); Misc.try_finally (fun () -> - call_linker (List.map object_file_name objfiles) - startup_obj output_name) + call_linker (List.map object_file_name objfiles) + startup_obj output_name) ~always:(fun () -> remove_file startup_obj) ) diff --git a/asmcomp/asmpackager.ml b/asmcomp/asmpackager.ml index 72fe422055ae..ce3344103277 100644 --- a/asmcomp/asmpackager.ml +++ b/asmcomp/asmpackager.ml @@ -248,12 +248,12 @@ let package_files ppf initial_env files targetcmx ~backend = Location.input_name := targetcmx; (* Set the name of the current compunit *) Compilenv.reset ?packname:!Clflags.for_package targetname; - Misc.try_finally begin fun () -> - let coercion = - Typemod.package_units initial_env files targetcmi targetname in - package_object_files ppf files targetcmx targetobj targetname coercion - ~backend - end + Misc.try_finally (fun () -> + let coercion = + Typemod.package_units initial_env files targetcmi targetname in + package_object_files ppf files targetcmx targetobj targetname coercion + ~backend + ) ~exceptionally:(fun () -> remove_file targetcmx; remove_file targetobj) (* Error report *) diff --git a/bytecomp/bytelibrarian.ml b/bytecomp/bytelibrarian.ml index 0bdd9c106bac..d663bfc64abb 100644 --- a/bytecomp/bytelibrarian.ml +++ b/bytecomp/bytelibrarian.ml @@ -90,25 +90,25 @@ let copy_object_file oc name = let create_archive file_list lib_name = let outchan = open_out_bin lib_name in - Misc.try_finally begin fun () -> - output_string outchan cma_magic_number; - let ofs_pos_toc = pos_out outchan in - output_binary_int outchan 0; - let units = - List.flatten(List.map (copy_object_file outchan) file_list) in - let toc = - { lib_units = units; - lib_custom = !Clflags.custom_runtime; - lib_ccobjs = !Clflags.ccobjs @ !lib_ccobjs; - lib_ccopts = !Clflags.all_ccopts @ !lib_ccopts; - lib_dllibs = !Clflags.dllibs @ !lib_dllibs } in - let pos_toc = pos_out outchan in - Emitcode.marshal_to_channel_with_possibly_32bit_compat - ~filename:lib_name ~kind:"bytecode library" - outchan toc; - seek_out outchan ofs_pos_toc; - output_binary_int outchan pos_toc; - end + Misc.try_finally (fun () -> + output_string outchan cma_magic_number; + let ofs_pos_toc = pos_out outchan in + output_binary_int outchan 0; + let units = + List.flatten(List.map (copy_object_file outchan) file_list) in + let toc = + { lib_units = units; + lib_custom = !Clflags.custom_runtime; + lib_ccobjs = !Clflags.ccobjs @ !lib_ccobjs; + lib_ccopts = !Clflags.all_ccopts @ !lib_ccopts; + lib_dllibs = !Clflags.dllibs @ !lib_dllibs } in + let pos_toc = pos_out outchan in + Emitcode.marshal_to_channel_with_possibly_32bit_compat + ~filename:lib_name ~kind:"bytecode library" + outchan toc; + seek_out outchan ofs_pos_toc; + output_binary_int outchan pos_toc; + ) ~always:(fun () -> close_out outchan) ~exceptionally:(fun () -> remove_file lib_name) diff --git a/bytecomp/bytelink.ml b/bytecomp/bytelink.ml index e7d0318ce6e7..1f16f6cff6df 100644 --- a/bytecomp/bytelink.ml +++ b/bytecomp/bytelink.ml @@ -309,77 +309,77 @@ 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 begin 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 - let inchan = open_in_bin (find_in_path !load_path header) in - copy_file inchan outchan; - close_in inchan - with Not_found | Sys_error _ -> () - end; - Bytesections.init_record outchan; - (* The path to the bytecode interpreter (in use_runtime mode) *) - if String.length !Clflags.use_runtime > 0 then begin - output_string outchan (make_absolute !Clflags.use_runtime); - output_char outchan '\n'; - Bytesections.record outchan "RNTM" - end; - (* The bytecode *) - let start_code = pos_out outchan in - Symtable.init(); - clear_crc_interfaces (); - let sharedobjs = List.map Dll.extract_dll_name !Clflags.dllibs in - let check_dlls = standalone && Config.target = Config.host in - if check_dlls then begin - (* Initialize the DLL machinery *) - Dll.init_compile !Clflags.no_std_include; - Dll.add_path !load_path; - try Dll.open_dlls Dll.For_checking sharedobjs - with Failure reason -> raise(Error(Cannot_open_dll reason)) - end; - let output_fun = output_bytes outchan - and currpos_fun () = pos_out outchan - start_code in - List.iter (link_file output_fun currpos_fun) tolink; - if check_dlls then Dll.close_all_dlls(); - (* The final STOP instruction *) - output_byte outchan Opcodes.opSTOP; - output_byte outchan 0; output_byte outchan 0; output_byte outchan 0; - Bytesections.record outchan "CODE"; - (* DLL stuff *) - if standalone then begin - (* The extra search path for DLLs *) - output_stringlist outchan !Clflags.dllpaths; - Bytesections.record outchan "DLPT"; - (* The names of the DLLs *) - output_stringlist outchan sharedobjs; - Bytesections.record outchan "DLLS" - end; - (* The names of all primitives *) - Symtable.output_primitive_names outchan; - Bytesections.record outchan "PRIM"; - (* The table of global data *) - Emitcode.marshal_to_channel_with_possibly_32bit_compat - ~filename:exec_name ~kind:"bytecode executable" - outchan (Symtable.initial_global_table()); - Bytesections.record outchan "DATA"; - (* The map of global identifiers *) - Symtable.output_global_map outchan; - Bytesections.record outchan "SYMB"; - (* CRCs for modules *) - output_value outchan (extract_crc_interfaces()); - Bytesections.record outchan "CRCS"; - (* Debug info *) - if !Clflags.debug then begin - output_debug_info outchan; - Bytesections.record outchan "DBUG" - end; - (* The table of contents and the trailer *) - Bytesections.write_toc_and_trailer outchan; - end + Misc.try_finally (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 + let inchan = open_in_bin (find_in_path !load_path header) in + copy_file inchan outchan; + close_in inchan + with Not_found | Sys_error _ -> () + end; + Bytesections.init_record outchan; + (* The path to the bytecode interpreter (in use_runtime mode) *) + if String.length !Clflags.use_runtime > 0 then begin + output_string outchan (make_absolute !Clflags.use_runtime); + output_char outchan '\n'; + Bytesections.record outchan "RNTM" + end; + (* The bytecode *) + let start_code = pos_out outchan in + Symtable.init(); + clear_crc_interfaces (); + let sharedobjs = List.map Dll.extract_dll_name !Clflags.dllibs in + let check_dlls = standalone && Config.target = Config.host in + if check_dlls then begin + (* Initialize the DLL machinery *) + Dll.init_compile !Clflags.no_std_include; + Dll.add_path !load_path; + try Dll.open_dlls Dll.For_checking sharedobjs + with Failure reason -> raise(Error(Cannot_open_dll reason)) + end; + let output_fun = output_bytes outchan + and currpos_fun () = pos_out outchan - start_code in + List.iter (link_file output_fun currpos_fun) tolink; + if check_dlls then Dll.close_all_dlls(); + (* The final STOP instruction *) + output_byte outchan Opcodes.opSTOP; + output_byte outchan 0; output_byte outchan 0; output_byte outchan 0; + Bytesections.record outchan "CODE"; + (* DLL stuff *) + if standalone then begin + (* The extra search path for DLLs *) + output_stringlist outchan !Clflags.dllpaths; + Bytesections.record outchan "DLPT"; + (* The names of the DLLs *) + output_stringlist outchan sharedobjs; + Bytesections.record outchan "DLLS" + end; + (* The names of all primitives *) + Symtable.output_primitive_names outchan; + Bytesections.record outchan "PRIM"; + (* The table of global data *) + Emitcode.marshal_to_channel_with_possibly_32bit_compat + ~filename:exec_name ~kind:"bytecode executable" + outchan (Symtable.initial_global_table()); + Bytesections.record outchan "DATA"; + (* The map of global identifiers *) + Symtable.output_global_map outchan; + Bytesections.record outchan "SYMB"; + (* CRCs for modules *) + output_value outchan (extract_crc_interfaces()); + Bytesections.record outchan "CRCS"; + (* Debug info *) + if !Clflags.debug then begin + output_debug_info outchan; + Bytesections.record outchan "DBUG" + end; + (* The table of contents and the trailer *) + Bytesections.write_toc_and_trailer outchan; + ) ~always:(fun () -> close_out outchan) ~exceptionally:(fun () -> remove_file exec_name) @@ -424,17 +424,17 @@ let output_cds_file outfile = let outchan = open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary] 0o777 outfile in - Misc.try_finally begin fun () -> - Bytesections.init_record outchan; - (* The map of global identifiers *) - Symtable.output_global_map outchan; - Bytesections.record outchan "SYMB"; - (* Debug info *) - output_debug_info outchan; - Bytesections.record outchan "DBUG"; - (* The table of contents and the trailer *) - Bytesections.write_toc_and_trailer outchan; - end + Misc.try_finally (fun () -> + Bytesections.init_record outchan; + (* The map of global identifiers *) + Symtable.output_global_map outchan; + Bytesections.record outchan "SYMB"; + (* Debug info *) + output_debug_info outchan; + Bytesections.record outchan "DBUG"; + (* The table of contents and the trailer *) + Bytesections.write_toc_and_trailer outchan; + ) ~always:(fun () -> close_out outchan) ~exceptionally:(fun () -> remove_file outfile) @@ -442,9 +442,9 @@ let output_cds_file outfile = let link_bytecode_as_c tolink outfile = let outchan = open_out outfile in - Misc.try_finally begin fun () -> - (* The bytecode *) - output_string outchan "\ + Misc.try_finally (fun () -> + (* The bytecode *) + output_string outchan "\ #define CAML_INTERNALS\ \n\ \n#ifdef __cplusplus\ @@ -452,35 +452,35 @@ let link_bytecode_as_c tolink outfile = \n#endif\ \n#include \ \n#include \n"; - output_string outchan "static int caml_code[] = {\n"; - Symtable.init(); - clear_crc_interfaces (); - let currpos = ref 0 in - let output_fun code = - output_code_string outchan code; - currpos := !currpos + Bytes.length code - and currpos_fun () = !currpos in - List.iter (link_file output_fun currpos_fun) tolink; - (* The final STOP instruction *) - Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP; - (* The table of global data *) - output_string outchan "static char caml_data[] = {\n"; - output_data_string outchan - (Marshal.to_string (Symtable.initial_global_table()) []); - output_string outchan "\n};\n\n"; - (* The sections *) - let sections = - [ "SYMB", Symtable.data_global_map(); - "PRIM", Obj.repr(Symtable.data_primitive_names()); - "CRCS", Obj.repr(extract_crc_interfaces()) ] in - output_string outchan "static char caml_sections[] = {\n"; - output_data_string outchan - (Marshal.to_string sections []); - output_string outchan "\n};\n\n"; - (* The table of primitives *) - Symtable.output_primitive_table outchan; - (* The entry point *) - output_string outchan "\ + output_string outchan "static int caml_code[] = {\n"; + Symtable.init(); + clear_crc_interfaces (); + let currpos = ref 0 in + let output_fun code = + output_code_string outchan code; + currpos := !currpos + Bytes.length code + and currpos_fun () = !currpos in + List.iter (link_file output_fun currpos_fun) tolink; + (* The final STOP instruction *) + Printf.fprintf outchan "\n0x%x};\n\n" Opcodes.opSTOP; + (* The table of global data *) + output_string outchan "static char caml_data[] = {\n"; + output_data_string outchan + (Marshal.to_string (Symtable.initial_global_table()) []); + output_string outchan "\n};\n\n"; + (* The sections *) + let sections = + [ "SYMB", Symtable.data_global_map(); + "PRIM", Obj.repr(Symtable.data_primitive_names()); + "CRCS", Obj.repr(extract_crc_interfaces()) ] in + output_string outchan "static char caml_sections[] = {\n"; + output_data_string outchan + (Marshal.to_string sections []); + output_string outchan "\n};\n\n"; + (* The table of primitives *) + Symtable.output_primitive_table outchan; + (* The entry point *) + output_string outchan "\ \nvoid caml_startup(char_os ** argv)\ \n{\ \n caml_startup_code(caml_code, sizeof(caml_code),\ @@ -519,7 +519,7 @@ let link_bytecode_as_c tolink outfile = \n#ifdef __cplusplus\ \n}\ \n#endif\n"; - end + ) ~always:(fun () -> close_out outchan) ~exceptionally:(fun () -> remove_file outfile); if !Clflags.debug then @@ -585,12 +585,12 @@ let link objfiles output_name = output_name ^ ".camlprim.c" else Filename.temp_file "camlprim" ".c" in - Misc.try_finally begin 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 - such as __FILE__. *) - output_string poc "\ + Misc.try_finally (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 + such as __FILE__. *) + output_string poc "\ #ifdef __cplusplus\n\ extern \"C\" {\n\ #endif\n\ @@ -603,20 +603,20 @@ let link objfiles output_name = #else\n\ typedef long value;\n\ #endif\n"; - Symtable.output_primitive_table poc; - output_string poc "\ + Symtable.output_primitive_table poc; + output_string poc "\ #ifdef __cplusplus\n\ }\n\ #endif\n"; - close_out poc; - 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 - end + close_out poc; + 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 + ) ~exceptionally:(fun () -> remove_file bytecode_name; if not !Clflags.keep_camlprimc_file then remove_file prim_name) @@ -638,29 +638,29 @@ let link objfiles output_name = then (Filename.chop_extension c_file) ^ Config.ext_obj else basename ^ Config.ext_obj in - Misc.try_finally begin fun () -> - link_bytecode_as_c tolink c_file; - if not (Filename.check_suffix output_name ".c") then begin - temps := c_file :: !temps; - if Ccomp.compile_file ~output:obj_file ?stable_name c_file <> 0 then - raise(Error Custom_runtime); - if not (Filename.check_suffix output_name Config.ext_obj) || - !Clflags.output_complete_object then begin - temps := obj_file :: !temps; - let mode, c_libs = - if Filename.check_suffix output_name Config.ext_obj - then Ccomp.Partial, "" - else Ccomp.MainDll, Config.bytecomp_c_libraries - in - if not ( - let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in - Ccomp.call_linker mode output_name - ([obj_file] @ List.rev !Clflags.ccobjs @ [runtime_lib]) - c_libs - ) then raise (Error Custom_runtime); - end - end; - end + Misc.try_finally (fun () -> + link_bytecode_as_c tolink c_file; + if not (Filename.check_suffix output_name ".c") then begin + temps := c_file :: !temps; + if Ccomp.compile_file ~output:obj_file ?stable_name c_file <> 0 then + raise(Error Custom_runtime); + if not (Filename.check_suffix output_name Config.ext_obj) || + !Clflags.output_complete_object then begin + temps := obj_file :: !temps; + let mode, c_libs = + if Filename.check_suffix output_name Config.ext_obj + then Ccomp.Partial, "" + else Ccomp.MainDll, Config.bytecomp_c_libraries + in + if not ( + let runtime_lib = "-lcamlrun" ^ !Clflags.runtime_variant in + Ccomp.call_linker mode output_name + ([obj_file] @ List.rev !Clflags.ccobjs @ [runtime_lib]) + c_libs + ) then raise (Error Custom_runtime); + end + end; + ) ~always:(fun () -> List.iter remove_file !temps) end diff --git a/bytecomp/bytepackager.ml b/bytecomp/bytepackager.ml index 696af4a5e1b8..cd989bdc2f12 100644 --- a/bytecomp/bytepackager.ml +++ b/bytecomp/bytepackager.ml @@ -287,11 +287,11 @@ let package_files initial_env files targetfile = let prefix = chop_extensions targetfile in let targetcmi = prefix ^ ".cmi" in let targetname = String.capitalize_ascii(Filename.basename prefix) in - Misc.try_finally begin fun () -> - let coercion = - Typemod.package_units initial_env files targetcmi targetname in - package_object_files files targetfile targetname coercion - end + Misc.try_finally (fun () -> + let coercion = + Typemod.package_units initial_env files targetcmi targetname in + package_object_files files targetfile targetname coercion + ) ~exceptionally:(fun () -> remove_file targetfile) (* Error report *) diff --git a/bytecomp/symtable.ml b/bytecomp/symtable.ml index 40458ea44b5e..cc5b7b4a4ab3 100644 --- a/bytecomp/symtable.ml +++ b/bytecomp/symtable.ml @@ -164,25 +164,25 @@ let init () = (* Initialize the known C primitives *) let set_prim_table_from_file primfile = let ic = open_in primfile in - Misc.try_finally begin fun () -> - try - while true do - set_prim_table (input_line ic) - done - with End_of_file -> () - end + Misc.try_finally (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 begin 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 - end + Misc.try_finally (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 diff --git a/bytecomp/translobj.ml b/bytecomp/translobj.ml index 08129e757237..ab53a5ee08dc 100644 --- a/bytecomp/translobj.ml +++ b/bytecomp/translobj.ml @@ -171,30 +171,31 @@ 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 begin fun () -> - cache_required := true; - f x - end + Misc.try_finally (fun () -> + cache_required := true; + f x + ) ~always:(fun () -> cache_required := false) - else Misc.try_finally begin fun () -> - wrapping := true; - cache_required := req; - top_env := env; - classes := []; - method_ids := Ident.Set.empty; - let lambda = f x in - let lambda = - List.fold_left - (fun lambda id -> - Llet(StrictOpt, Pgenval, id, - Lprim(Pmakeblock(0, Mutable, None), - [lambda_unit; lambda_unit; lambda_unit], - Location.none), - lambda)) - lambda !classes - in - lambda - end + else + Misc.try_finally (fun () -> + wrapping := true; + cache_required := req; + top_env := env; + classes := []; + method_ids := Ident.Set.empty; + let lambda = f x in + let lambda = + List.fold_left + (fun lambda id -> + Llet(StrictOpt, Pgenval, id, + Lprim(Pmakeblock(0, Mutable, None), + [lambda_unit; lambda_unit; lambda_unit], + Location.none), + lambda)) + lambda !classes + in + lambda + ) ~always:(fun () -> wrapping := false; top_env := Env.empty) diff --git a/debugger/loadprinter.ml b/debugger/loadprinter.ml index c58c6353f0bb..c0f179775546 100644 --- a/debugger/loadprinter.ml +++ b/debugger/loadprinter.ml @@ -47,11 +47,11 @@ let use_debugger_symtable fn arg = | Some st -> Symtable.restore_state st end; - Misc.try_finally begin fun () -> - let result = fn arg in - debugger_symtable := Some(Symtable.current_state()); - result - end + Misc.try_finally (fun () -> + let result = fn arg in + debugger_symtable := Some(Symtable.current_state()); + result + ) ~always:(fun () -> Symtable.restore_state old_symtable) (* Load a .cmo or .cma file *) diff --git a/driver/compile.ml b/driver/compile.ml index e34e6284b9ba..94483c060912 100644 --- a/driver/compile.ml +++ b/driver/compile.ml @@ -74,44 +74,44 @@ let implementation ppf sourcefile outputprefix = let modulename = module_of_filename ppf sourcefile outputprefix in Env.set_unit_name modulename; let env = Compmisc.initial_env() in - Misc.try_finally begin fun () -> - let (typedtree, coercion) = - 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) + Misc.try_finally (fun () -> + let (typedtree, coercion) = + 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) - ++ print_if ppf Clflags.dump_typedtree - Printtyped.implementation_with_coercion - in - if !Clflags.print_types then begin - Warnings.check_fatal (); - Stypes.dump (Some (outputprefix ^ ".annot")) - end else begin - let bytecode, required_globals = - (typedtree, coercion) - ++ Profile.(record transl) + ++ print_if ppf Clflags.dump_typedtree + Printtyped.implementation_with_coercion + in + if !Clflags.print_types then begin + Warnings.check_fatal (); + Stypes.dump (Some (outputprefix ^ ".annot")) + end else begin + let bytecode, required_globals = + (typedtree, coercion) + ++ Profile.(record transl) (Translmod.transl_implementation modulename) - ++ Profile.(record ~accumulate:true generate) + ++ Profile.(record ~accumulate:true generate) (fun { Lambda.code = lambda; required_globals } -> - print_if ppf Clflags.dump_rawlambda Printlambda.lambda lambda - ++ Simplif.simplify_lambda sourcefile - ++ print_if ppf Clflags.dump_lambda Printlambda.lambda - ++ Bytegen.compile_implementation modulename - ++ print_if ppf Clflags.dump_instr Printinstr.instrlist - ++ fun bytecode -> bytecode, required_globals) - in - let objfile = outputprefix ^ ".cmo" in - let oc = open_out_bin objfile in - Misc.try_finally begin fun () -> - bytecode - ++ Profile.(record ~accumulate:true generate) - (Emitcode.to_file oc modulename objfile ~required_globals); - Warnings.check_fatal () + print_if ppf Clflags.dump_rawlambda Printlambda.lambda lambda + ++ Simplif.simplify_lambda sourcefile + ++ print_if ppf Clflags.dump_lambda Printlambda.lambda + ++ Bytegen.compile_implementation modulename + ++ print_if ppf Clflags.dump_instr Printinstr.instrlist + ++ fun bytecode -> bytecode, required_globals) + in + let objfile = outputprefix ^ ".cmo" in + let oc = open_out_bin objfile in + Misc.try_finally (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 () -> close_out oc) - ~exceptionally:(fun () -> remove_file objfile) - end - end + ) ~always:(fun () -> Stypes.dump (Some (outputprefix ^ ".annot"))) - ) + ) diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 45c6331afd4f..28577782d353 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -137,9 +137,9 @@ let implementation ~backend ppf sourcefile outputprefix = end; Warnings.check_fatal () in - Misc.try_finally begin fun () -> - comp (Pparse.parse_implementation ~tool_name sourcefile) - end + 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) ) diff --git a/driver/pparse.ml b/driver/pparse.ml index 246d5bb23aa3..6a888cd63ef3 100644 --- a/driver/pparse.ml +++ b/driver/pparse.ml @@ -92,13 +92,13 @@ 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 begin 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) - end + Misc.try_finally (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 = @@ -207,9 +207,9 @@ let parse_file ~tool_name invariant_fun apply_hooks kind sourcefile = Location.input_name := sourcefile; let inputfile = preprocess sourcefile in let ast = - Misc.try_finally begin fun () -> - file_aux ~tool_name inputfile (parse kind) invariant_fun kind - end + Misc.try_finally (fun () -> + file_aux ~tool_name inputfile (parse kind) invariant_fun kind + ) ~always:(fun () -> remove_preprocessed inputfile) in let ast = apply_hooks { Misc.sourcefile } ast in diff --git a/tools/objinfo.ml b/tools/objinfo.ml index 178f78a91975..fa0111c5c037 100644 --- a/tools/objinfo.ml +++ b/tools/objinfo.ml @@ -247,18 +247,18 @@ let read_dyn_header filename ic = try try_finally (fun () -> - let rc = Sys.command (sprintf "%s %s > %s" - (Filename.quote helper) - (Filename.quote filename) - tempfile) in - if rc <> 0 then failwith "cannot read"; - let tc = Scanf.Scanning.from_file tempfile in - try_finally - (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)) + let rc = Sys.command (sprintf "%s %s > %s" + (Filename.quote helper) + (Filename.quote filename) + tempfile) in + if rc <> 0 then failwith "cannot read"; + let tc = Scanf.Scanning.from_file tempfile in + try_finally + (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) with Failure _ | Sys_error _ -> None diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 8f20f805aa40..555beff45dac 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -159,9 +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 begin fun () -> - really_load_file recursive ppf name filename ic - end + Misc.try_finally (fun () -> + really_load_file recursive ppf name filename ic + ) ~always:(fun () -> close_in ic) and really_load_file recursive ppf name filename ic = diff --git a/typing/cmt_format.ml b/typing/cmt_format.ml index 72f3862d157e..937e0ddc25c2 100644 --- a/typing/cmt_format.ml +++ b/typing/cmt_format.ml @@ -112,27 +112,27 @@ 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 begin fun () -> - let magic_number = read_magic_number ic in - let cmi, cmt = - if magic_number = Config.cmt_magic_number then - None, Some (input_cmt ic) - else if magic_number = Config.cmi_magic_number then - let cmi = Cmi_format.input_cmi ic in - let cmt = try - let magic_number = read_magic_number ic in - if magic_number = Config.cmt_magic_number then - let cmt = input_cmt ic in - Some cmt - else None - with _ -> None - in - Some cmi, cmt - else - raise(Cmi_format.Error(Cmi_format.Not_an_interface filename)) - in - cmi, cmt - end + Misc.try_finally (fun () -> + let magic_number = read_magic_number ic in + let cmi, cmt = + if magic_number = Config.cmt_magic_number then + None, Some (input_cmt ic) + else if magic_number = Config.cmi_magic_number then + let cmi = Cmi_format.input_cmi ic in + let cmt = try + let magic_number = read_magic_number ic in + if magic_number = Config.cmt_magic_number then + let cmt = input_cmt ic in + Some cmt + else None + with _ -> None + in + Some cmi, cmt + else + raise(Cmi_format.Error(Cmi_format.Not_an_interface filename)) + in + cmi, cmt + ) ~always:(fun () -> close_in ic) let read_cmt filename = diff --git a/typing/ctype.ml b/typing/ctype.ml index 4ba5e3418fb5..b5e0d5ad5d25 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -205,17 +205,17 @@ 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 begin fun () -> - umode := Pattern; - generate_equations := generate; - assume_injective := injective; - f () - end - ~always:begin fun () -> - umode := old_unification_mode; - generate_equations := old_gen; - assume_injective := old_inj - end + 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 + ) (*** Checks for type definitions ***) @@ -1766,9 +1766,9 @@ let occur_univar env ty = end | _ -> iter_type_expr (occur_rec bound) ty in - Misc.try_finally begin fun () -> - occur_rec TypeSet.empty ty - end + Misc.try_finally (fun () -> + occur_rec TypeSet.empty ty + ) ~always:(fun () -> unmark_type ty) (* Grouping univars by families according to their binders *) @@ -3423,9 +3423,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 begin fun () -> - eqtype_list rename type_pairs subst env tl1 tl2 - end + Misc.try_finally (fun () -> + eqtype_list rename type_pairs subst env tl1 tl2 + ) ~always:(fun () -> backtrack snap) let eqtype rename type_pairs subst env t1 t2 = diff --git a/typing/env.ml b/typing/env.ml index 10df76fe3aa4..1bd0ca4b5b52 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -2183,34 +2183,34 @@ let save_signature_with_imports ~deprecated sg modname filename imports = (match deprecated with Some s -> [Deprecated s] | None -> []); ] in - Misc.try_finally begin fun () -> - let cmi = { - cmi_name = modname; - cmi_sign = sg; - cmi_crcs = imports; - cmi_flags = flags; - } in - 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 = - components_of_module ~deprecated ~loc:Location.none - empty Subst.identity - (Pident(Ident.create_persistent modname)) (Mty_signature sg) in - let ps = - { ps_name = modname; - ps_sig = lazy (Subst.signature Subst.identity sg); - ps_comps = comps; - ps_crcs = (cmi.cmi_name, Some crc) :: imports; - ps_filename = filename; - ps_flags = cmi.cmi_flags; + Misc.try_finally (fun () -> + let cmi = { + cmi_name = modname; + cmi_sign = sg; + cmi_crcs = imports; + cmi_flags = flags; } in - save_pers_struct crc ps; - cmi - end + 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 = + components_of_module ~deprecated ~loc:Location.none + empty Subst.identity + (Pident(Ident.create_persistent modname)) (Mty_signature sg) in + let ps = + { ps_name = modname; + ps_sig = lazy (Subst.signature Subst.identity sg); + ps_comps = comps; + ps_crcs = (cmi.cmi_name, Some crc) :: imports; + ps_filename = filename; + ps_flags = cmi.cmi_flags; + } in + save_pers_struct crc ps; + cmi + ) ~exceptionally:(fun () -> remove_file filename) let save_signature ~deprecated sg modname filename = diff --git a/typing/typecore.ml b/typing/typecore.ml index 7affb3d45df2..b3a7b6389d91 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -1494,15 +1494,15 @@ 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 begin 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 - end + Misc.try_finally (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) diff --git a/typing/typemod.ml b/typing/typemod.ml index 8c9d2c712f55..f586f5a731d1 100644 --- a/typing/typemod.ml +++ b/typing/typemod.ml @@ -1906,69 +1906,69 @@ let () = let type_implementation sourcefile outputprefix modulename initial_env ast = Cmt_format.clear (); - Misc.try_finally begin fun () -> - Typecore.reset_delayed_checks (); - Env.reset_required_globals (); - if !Clflags.print_types then (* #7656 *) - Warnings.parse_options false "-32-34-37-38-60"; - let (str, sg, finalenv) = - type_structure initial_env ast (Location.in_file sourcefile) in - let simple_sg = simplify_signature sg in - if !Clflags.print_types then begin - Typecore.force_delayed_checks (); - Printtyp.wrap_printing_env ~error:false initial_env - (fun () -> fprintf std_formatter "%a@." - (Printtyp.printed_signature sourcefile) simple_sg - ); - (str, Tcoerce_none) (* result is ignored by Compile.implementation *) - end else begin - let sourceintf = - Filename.remove_extension sourcefile ^ !Config.interface_suffix in - if Sys.file_exists sourceintf then begin - let intf_file = - try - find_in_path_uncap !Config.load_path (modulename ^ ".cmi") - with Not_found -> - raise(Error(Location.in_file sourcefile, Env.empty, - Interface_not_compiled sourceintf)) in - let dclsig = Env.read_signature modulename intf_file in - let coercion = - Includemod.compunit initial_env ~mark:Includemod.Mark_positive - sourcefile sg intf_file dclsig - 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. *) - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) (Some sourcefile) initial_env None; - (str, coercion) - end else begin - let coercion = - Includemod.compunit initial_env ~mark:Includemod.Mark_positive - sourcefile sg "(inferred signature)" simple_sg - in - check_nongen_schemes finalenv simple_sg; - normalize_signature finalenv simple_sg; - Typecore.force_delayed_checks (); - (* See comment above. Here the target signature contains all - the value being exported. We can still capture unused - declarations like "let x = true;; let x = 1;;", because in this - case, the inferred signature contains only the last declaration. *) - if not !Clflags.dont_write_files then begin - let deprecated = Builtin_attributes.deprecated_of_str ast in - let cmi = - Env.save_signature ~deprecated - simple_sg modulename (outputprefix ^ ".cmi") - in - Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - (Cmt_format.Implementation str) - (Some sourcefile) initial_env (Some cmi); - end; - (str, coercion) - end - end - end + Misc.try_finally (fun () -> + Typecore.reset_delayed_checks (); + Env.reset_required_globals (); + if !Clflags.print_types then (* #7656 *) + Warnings.parse_options false "-32-34-37-38-60"; + let (str, sg, finalenv) = + type_structure initial_env ast (Location.in_file sourcefile) in + let simple_sg = simplify_signature sg in + if !Clflags.print_types then begin + Typecore.force_delayed_checks (); + Printtyp.wrap_printing_env ~error:false initial_env + (fun () -> fprintf std_formatter "%a@." + (Printtyp.printed_signature sourcefile) simple_sg + ); + (str, Tcoerce_none) (* result is ignored by Compile.implementation *) + end else begin + let sourceintf = + Filename.remove_extension sourcefile ^ !Config.interface_suffix in + if Sys.file_exists sourceintf then begin + let intf_file = + try + find_in_path_uncap !Config.load_path (modulename ^ ".cmi") + with Not_found -> + raise(Error(Location.in_file sourcefile, Env.empty, + Interface_not_compiled sourceintf)) in + let dclsig = Env.read_signature modulename intf_file in + let coercion = + Includemod.compunit initial_env ~mark:Includemod.Mark_positive + sourcefile sg intf_file dclsig + 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. *) + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) (Some sourcefile) initial_env None; + (str, coercion) + end else begin + let coercion = + Includemod.compunit initial_env ~mark:Includemod.Mark_positive + sourcefile sg "(inferred signature)" simple_sg + in + check_nongen_schemes finalenv simple_sg; + normalize_signature finalenv simple_sg; + Typecore.force_delayed_checks (); + (* See comment above. Here the target signature contains all + the value being exported. We can still capture unused + declarations like "let x = true;; let x = 1;;", because in this + case, the inferred signature contains only the last declaration. *) + if not !Clflags.dont_write_files then begin + let deprecated = Builtin_attributes.deprecated_of_str ast in + let cmi = + Env.save_signature ~deprecated + simple_sg modulename (outputprefix ^ ".cmi") + in + Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename + (Cmt_format.Implementation str) + (Some sourcefile) initial_env (Some cmi); + end; + (str, coercion) + end + end + ) ~exceptionally:(fun () -> Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename (Cmt_format.Partial_implementation