Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Use reraise_raw_backtrace in Misc.try_finally 

And add labels ~always for previous cleanup function and
    ~exceptionally for new cleanup function in exceptional case
master
François Bobot 2015-12-23 22:40:21 +01:00 committed by Nicolás Ojeda Bär
parent 429f42d64b
commit da3f9f34f5
27 changed files with 583 additions and 570 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

36
asmcomp/asmgen.ml
View File

@ -148,26 +148,22 @@ 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;
try
if create_asm then Emitaux.output_channel := open_out asm_filename;
begin try
gen ();
if create_asm then close_out !Emitaux.output_channel;
with exn when create_asm ->
close_out !Emitaux.output_channel;
if not keep_asm then remove_file asm_filename;
raise exn
end;
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
with exn ->
remove_file obj_filename;
raise exn
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) =
Compilenv.set_export_info export;

41
asmcomp/asmlibrarian.ml
View File

@ -49,27 +49,26 @@ 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
try
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));
close_out outchan
with x ->
close_out outchan;
remove_file lib_name;
remove_file archive_name;
raise x
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;
remove_file archive_name)
open Format

6
asmcomp/asmlink.ml
View File

@ -353,9 +353,9 @@ 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)
(fun () -> remove_file startup_obj)
call_linker (List.map object_file_name objfiles)
startup_obj output_name)
~always:(fun () -> remove_file startup_obj)
)
(* Error report *)

15
asmcomp/asmpackager.ml
View File

@ -248,14 +248,13 @@ 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;
try
let coercion =
Typemod.package_units initial_env files targetcmi targetname in
package_object_files ppf files targetcmx targetobj targetname coercion
~backend
with x ->
remove_file targetcmx; remove_file targetobj;
raise x
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 *)

44
bytecomp/bytelibrarian.ml
View File

@ -90,29 +90,27 @@ let copy_object_file oc name =
let create_archive file_list lib_name =
let outchan = open_out_bin lib_name in
try
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;
close_out outchan
with x ->
close_out outchan;
remove_file lib_name;
raise x
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)
open Format

339
bytecomp/bytelink.ml
View File

@ -309,81 +309,79 @@ let link_bytecode tolink exec_name standalone =
let outchan =
open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
0o777 exec_name in
try
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;
close_out outchan
with x ->
close_out outchan;
remove_file exec_name;
raise x
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)
(* Output a string as a C array of unsigned ints *)
@ -426,29 +424,27 @@ let output_cds_file outfile =
let outchan =
open_out_gen [Open_wronly; Open_trunc; Open_creat; Open_binary]
0o777 outfile in
try
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;
close_out outchan
with x ->
close_out outchan;
remove_file outfile;
raise x
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)
(* Output a bytecode executable as a C file *)
let link_bytecode_as_c tolink outfile =
let outchan = open_out outfile in
begin try
(* The bytecode *)
output_string outchan "\
Misc.try_finally (fun () ->
(* The bytecode *)
output_string outchan "\
#define CAML_INTERNALS\
\n\
\n#ifdef __cplusplus\
@ -456,35 +452,35 @@ let link_bytecode_as_c tolink outfile =
\n#endif\
\n#include <caml/mlvalues.h>\
\n#include <caml/startup.h>\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),\
@ -523,12 +519,9 @@ let link_bytecode_as_c tolink outfile =
\n#ifdef __cplusplus\
\n}\
\n#endif\n";
close_out outchan
with x ->
close_out outchan;
remove_file outfile;
raise x
end;
)
~always:(fun () -> close_out outchan)
~exceptionally:(fun () -> remove_file outfile);
if !Clflags.debug then
output_cds_file ((Filename.chop_extension outfile) ^ ".cds")
@ -592,12 +585,12 @@ let link objfiles output_name =
output_name ^ ".camlprim.c"
else
Filename.temp_file "camlprim" ".c" in
try
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\
@ -610,23 +603,23 @@ 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
with x ->
remove_file bytecode_name;
if not !Clflags.keep_camlprimc_file then remove_file prim_name;
raise x
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)
end else begin
let basename = Filename.chop_extension output_name in
let temps = ref [] in
@ -645,32 +638,30 @@ let link objfiles output_name =
then (Filename.chop_extension c_file) ^ Config.ext_obj
else basename ^ Config.ext_obj
in
try
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;
List.iter remove_file !temps
with x ->
List.iter remove_file !temps;
raise x
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
(* Error report *)

12
bytecomp/bytepackager.ml
View File

@ -287,12 +287,12 @@ 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
try
let coercion =
Typemod.package_units initial_env files targetcmi targetname in
package_object_files files targetfile targetname coercion
with x ->
remove_file targetfile; raise x
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 *)

42
bytecomp/symtable.ml
View File

@ -162,28 +162,28 @@ let init () =
literal_table := (c, cst) :: !literal_table)
Runtimedef.builtin_exceptions;
(* Initialize the known C primitives *)
if String.length !Clflags.use_prims > 0 then begin
let ic = open_in !Clflags.use_prims in
try
while true do
set_prim_table (input_line ic)
done
with End_of_file -> close_in ic
| x -> close_in ic; raise x
end else if String.length !Clflags.use_runtime > 0 then begin
let set_prim_table_from_file primfile =
let ic = open_in primfile in
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
try
if Sys.command(Printf.sprintf "%s -p > %s"
!Clflags.use_runtime primfile) <> 0
then raise(Error(Wrong_vm !Clflags.use_runtime));
let ic = open_in primfile in
try
while true do
set_prim_table (input_line ic)
done
with End_of_file -> close_in ic; remove_file primfile
| x -> close_in ic; raise x
with x -> remove_file primfile; raise x
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
end

6
bytecomp/translcore.ml
View File

@ -550,8 +550,8 @@ and transl_case_try {c_lhs; c_guard; c_rhs} =
iter_exn_names Translprim.add_exception_ident c_lhs;
Misc.try_finally
(fun () -> c_lhs, transl_guard c_guard c_rhs)
(fun () ->
iter_exn_names Translprim.remove_exception_ident c_lhs)
~always:(fun () ->
iter_exn_names Translprim.remove_exception_ident c_lhs)
and transl_cases_try cases =
let cases =
@ -838,7 +838,7 @@ and transl_match e arg pat_expr_list partial =
let rhs =
Misc.try_finally
(fun () -> event_before c_rhs (transl_exp c_rhs))
(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,

54
bytecomp/translobj.ml
View File

@ -171,32 +171,34 @@ let oo_add_class id =
let oo_wrap env req f x =
if !wrapping then
if !cache_required then f x else
try cache_required := true; let lam = f x in cache_required := false; lam
with exn -> cache_required := false; raise exn
else try
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
wrapping := false;
top_env := Env.empty;
lambda
with exn ->
wrapping := false;
top_env := Env.empty;
raise exn
Misc.try_finally (fun () ->
cache_required := true;
f x
)
~always:(fun () -> cache_required := false)
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)
let reset () =
Hashtbl.clear consts;

14
debugger/loadprinter.ml
View File

@ -47,14 +47,12 @@ let use_debugger_symtable fn arg =
| Some st ->
Symtable.restore_state st
end;
try
let result = fn arg in
debugger_symtable := Some(Symtable.current_state());
Symtable.restore_state old_symtable;
result
with exn ->
Symtable.restore_state old_symtable;
raise exn
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 *)

78
driver/compile.ml
View File

@ -74,48 +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
try
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)
(Translmod.transl_implementation modulename)
++ 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)
++ print_if ppf Clflags.dump_typedtree
Printtyped.implementation_with_coercion
in
let objfile = outputprefix ^ ".cmo" in
let oc = open_out_bin objfile in
try
bytecode
++ Profile.(record ~accumulate:true generate)
(Emitcode.to_file oc modulename objfile ~required_globals);
if !Clflags.print_types then begin
Warnings.check_fatal ();
close_out oc;
Stypes.dump (Some (outputprefix ^ ".annot"))
with x ->
close_out oc;
remove_file objfile;
raise x
end
with x ->
Stypes.dump (Some (outputprefix ^ ".annot"));
raise x
)
end else begin
let bytecode, required_globals =
(typedtree, coercion)
++ Profile.(record transl)
(Translmod.transl_implementation modulename)
++ 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 (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")))
)

14
driver/optcompile.ml
View File

@ -135,13 +135,11 @@ let implementation ~backend ppf sourcefile outputprefix =
Compilenv.save_unit_info cmxfile)
end
end;
Warnings.check_fatal ();
Stypes.dump (Some (outputprefix ^ ".annot"))
Warnings.check_fatal ()
in
try comp (Pparse.parse_implementation ~tool_name sourcefile)
with x ->
Stypes.dump (Some (outputprefix ^ ".annot"));
remove_file objfile;
remove_file cmxfile;
raise x
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)
)

30
driver/pparse.ml
View File

@ -92,19 +92,14 @@ 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
try
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);
let ast = (input_value ic : a) in
close_in ic;
Misc.remove_file fn;
ast
with exn ->
close_in ic;
Misc.remove_file fn;
raise exn
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 =
let fn = Filename.temp_file "camlppx" "" in
@ -212,12 +207,11 @@ let parse_file ~tool_name invariant_fun apply_hooks kind sourcefile =
Location.input_name := sourcefile;
let inputfile = preprocess sourcefile in
let ast =
try file_aux ~tool_name inputfile (parse kind) invariant_fun kind
with exn ->
remove_preprocessed inputfile;
raise exn
Misc.try_finally (fun () ->
file_aux ~tool_name inputfile (parse kind) invariant_fun kind
)
~always:(fun () -> remove_preprocessed inputfile)
in
remove_preprocessed inputfile;
let ast = apply_hooks { Misc.sourcefile } ast in
ast

3
lex/main.ml
View File

@ -88,6 +88,7 @@ let main () =
close_out oc;
Common.close_tracker tr;
with exn ->
let bt = Printexc.get_raw_backtrace () in
close_in ic;
close_out oc;
Common.close_tracker tr;
@ -118,7 +119,7 @@ let main () =
"File \"%s\":\ntransition table overflow, automaton is too big\n"
source_name
| _ ->
raise exn
Printexc.raise_with_backtrace exn bt
end;
exit 3

4
parsing/ast_helper.ml
View File

@ -29,8 +29,8 @@ let default_loc = ref Location.none
let with_default_loc l f =
let old = !default_loc in
default_loc := l;
try let r = f () in default_loc := old; r
with exn -> default_loc := old; raise exn
Misc.try_finally f
~always:(fun () -> default_loc := old)
module Const = struct
let integer ?suffix i = Pconst_integer (i, suffix)

26
tools/objinfo.ml
View File

@ -247,19 +247,19 @@ 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))
(fun () -> Scanf.Scanning.close_in tc))
(fun () -> remove_file tempfile)
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
let dump_obj filename =

11
toplevel/topdirs.ml
View File

@ -159,13 +159,10 @@ 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
try
let success = really_load_file recursive ppf name filename ic in
close_in ic;
success
with exn ->
close_in ic;
raise exn
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 =
let buffer = really_input_string ic (String.length Config.cmo_magic_number) in

47
typing/cmt_format.ml
View File

@ -112,31 +112,28 @@ let output_cmt oc cmt =
let read filename =
(* Printf.fprintf stderr "Cmt_format.read %s\n%!" filename; *)
let ic = open_in_bin filename in
try
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
close_in ic;
(* Printf.fprintf stderr "Cmt_format.read done\n%!"; *)
cmi, cmt
with e ->
close_in ic;
raise e
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 =
match read filename with

43
typing/ctype.ml
View File

@ -205,20 +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
try
umode := Pattern;
generate_equations := generate;
assume_injective := injective;
let ret = f () in
umode := old_unification_mode;
generate_equations := old_gen;
assume_injective := old_inj;
ret
with e ->
umode := old_unification_mode;
generate_equations := old_gen;
assume_injective := old_inj;
raise e
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 ***)
@ -1764,10 +1761,10 @@ let occur_univar env ty =
end
| _ -> iter_type_expr (occur_rec bound) ty
in
try
occur_rec TypeSet.empty ty; unmark_type ty
with exn ->
unmark_type ty; raise exn
Misc.try_finally (fun () ->
occur_rec TypeSet.empty ty
)
~always:(fun () -> unmark_type ty)
(* Grouping univars by families according to their binders *)
let add_univars =
@ -1832,8 +1829,8 @@ let enter_poly env univar_pairs t1 tl1 t2 tl2 f =
let cl1 = List.map (fun t -> t, ref None) tl1
and cl2 = List.map (fun t -> t, ref None) tl2 in
univar_pairs := (cl1,cl2) :: (cl2,cl1) :: old_univars;
try let res = f t1 t2 in univar_pairs := old_univars; res
with exn -> univar_pairs := old_univars; raise exn
Misc.try_finally (fun () -> f t1 t2)
~always:(fun () -> univar_pairs := old_univars)
let univar_pairs = ref []
@ -3421,8 +3418,10 @@ 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
try eqtype_list rename type_pairs subst env tl1 tl2; backtrack snap
with exn -> backtrack snap; raise exn
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 =
eqtype_list rename type_pairs subst env [t1] [t2]

57
typing/env.ml
View File

@ -2183,36 +2183,35 @@ let save_signature_with_imports ~deprecated sg modname filename imports =
(match deprecated with Some s -> [Deprecated s] | None -> []);
]
in
try
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
with exn ->
remove_file filename;
raise exn
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 =
save_signature_with_imports ~deprecated sg modname filename (imports())

2
typing/printtyp.ml
View File

@ -655,7 +655,7 @@ let set_printing_env env =
let wrap_printing_env env f =
set_printing_env env; reset_naming_context ();
try_finally f (fun () -> set_printing_env Env.empty)
try_finally f ~always:(fun () -> set_printing_env Env.empty)
let wrap_printing_env ~error env f =
if error then Env.without_cmis (wrap_printing_env env) f

21
typing/typecore.ml
View File

@ -1494,17 +1494,16 @@ 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;
try
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
with e ->
gadt_equations_level := None;
raise e
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)
(* this function is passed to Partial.parmatch

134
typing/typemod.ml
View File

@ -2058,74 +2058,74 @@ let () =
let type_implementation sourcefile outputprefix modulename initial_env ast =
Cmt_format.clear ();
try
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, to_remove_from_sg, finalenv) =
type_structure initial_env ast (Location.in_file sourcefile) in
let simple_sg = simplify_signature finalenv to_remove_from_sg 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
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, to_remove_from_sg, finalenv) =
type_structure initial_env ast (Location.in_file sourcefile) in
let simple_sg = simplify_signature finalenv to_remove_from_sg 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.Implementation str)
(Some sourcefile) initial_env (Some cmi);
end;
(str, coercion)
end
end
with e ->
Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename
(Cmt_format.Partial_implementation
(Array.of_list (Cmt_format.get_saved_types ())))
(Some sourcefile) initial_env None;
raise e
(Cmt_format.Partial_implementation
(Array.of_list (Cmt_format.get_saved_types ())))
(Some sourcefile) initial_env None)
let type_implementation sourcefile outputprefix modulename initial_env ast =
ImplementationHooks.apply_hooks { Misc.sourcefile }

26
utils/misc.ml
View File

@ -24,11 +24,27 @@ let fatal_errorf fmt = Format.kasprintf fatal_error fmt
(* Exceptions *)
let try_finally work cleanup =
let result = (try work () with e -> cleanup (); raise e) in
cleanup ();
result
;;
let try_finally ?(always=(fun () -> ())) ?(exceptionally=(fun () -> ())) work =
match work () with
| result ->
begin match always () with
| () -> result
| exception always_exn ->
let always_bt = Printexc.get_raw_backtrace () in
exceptionally ();
Printexc.raise_with_backtrace always_exn always_bt
end
| exception work_exn ->
let work_bt = Printexc.get_raw_backtrace () in
begin match always () with
| () ->
exceptionally ();
Printexc.raise_with_backtrace work_exn work_bt
| exception always_exn ->
let always_bt = Printexc.get_raw_backtrace () in
exceptionally ();
Printexc.raise_with_backtrace always_exn always_bt
end
type ref_and_value = R : 'a ref * 'a -> ref_and_value

36
utils/misc.mli
View File

@ -19,7 +19,41 @@ val fatal_error: string -> 'a
val fatal_errorf: ('a, Format.formatter, unit, 'b) format4 -> 'a
exception Fatal_error
val try_finally : (unit -> 'a) -> (unit -> unit) -> 'a;;
val try_finally :
?always:(unit -> unit) ->
?exceptionally:(unit -> unit) ->
(unit -> 'a) -> 'a
(** [try_finally work ~always ~exceptionally] is designed to run code
in [work] that may fail with an exception, and has two kind of
cleanup routines: [always], that must be run after any execution
of the function (typically, freeing system resources), and
[exceptionally], that should be run only if [work] or [always]
failed with an exception (typically, undoing user-visible state
changes that would only make sense if the function completes
correctly). For example:
{[
let objfile = outputprefix ^ ".cmo" in
let oc = open_out_bin objfile in
Misc.try_finally
(fun () ->
bytecode
++ Timings.(accumulate_time (Generate sourcefile))
(Emitcode.to_file oc modulename objfile);
Warnings.check_fatal ())
~always:(fun () -> close_out oc)
~exceptionally:(fun _exn -> remove_file objfile);
]}
If [exceptionally] fail with an exception, it is propagated as
usual.
If [always] or [exceptionally] use exceptions internally for
control-flow but do not raise, then [try_finally] is careful to
preserve any exception backtrace coming from [work] or [always]
for easier debugging.
*)
val map_end: ('a -> 'b) -> 'a list -> 'b list -> 'b list
(* [map_end f l t] is [map f l @ t], just more efficient. *)

12
utils/profile.ml
View File

@ -90,12 +90,12 @@ let record_call ?(accumulate = false) name f =
in
hierarchy := E this_table;
Misc.try_finally f
(fun () ->
hierarchy := E prev_hierarchy;
let end_measure = Measure.create () in
let measure_diff =
Measure_diff.accumulate this_measure_diff start_measure end_measure in
Hashtbl.add prev_hierarchy name (measure_diff, E this_table))
~always:(fun () ->
hierarchy := E prev_hierarchy;
let end_measure = Measure.create () in
let measure_diff =
Measure_diff.accumulate this_measure_diff start_measure end_measure in
Hashtbl.add prev_hierarchy name (measure_diff, E this_table))
let record ?accumulate pass f x = record_call ?accumulate pass (fun () -> f x)