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

Implement reviewer suggestions

master
Nicolás Ojeda Bär 2018-07-25 16:23:07 +02:00
parent d6ad7c2fb2
commit 40bab2d768
17 changed files with 383 additions and 400 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
asmcomp/asmgen.ml
View File

@ -148,22 +148,23 @@ 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 () ->
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
)
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 () ->
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
)
let set_export_info (ulambda, prealloc, structured_constants, export) =
Compilenv.set_export_info export;

37
asmcomp/asmlibrarian.ml
View File

@ -49,26 +49,25 @@ 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 () ->
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));
)
Misc.try_finally
~always:(fun () -> close_out outchan)
~exceptionally:(fun () ->
remove_file lib_name;
remove_file archive_name)
~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
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));
)
open Format

39
bytecomp/bytelibrarian.ml
View File

@ -90,27 +90,28 @@ 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 () ->
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;
)
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;
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;
)
open Format

358
bytecomp/bytelink.ml
View File

@ -309,79 +309,81 @@ 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 () ->
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;
)
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
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;
)
(* Output a string as a C array of unsigned ints *)
@ -424,27 +426,31 @@ 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 () ->
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;
)
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;
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;
)
(* 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 () ->
(* The bytecode *)
output_string outchan "\
Misc.try_finally
~always:(fun () -> close_out outchan)
~exceptionally:(fun () -> remove_file outfile)
(fun () ->
(* The bytecode *)
output_string outchan "\
#define CAML_INTERNALS\
\n\
\n#ifdef __cplusplus\
@ -452,35 +458,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),\
@ -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,44 +587,42 @@ let link objfiles output_name =
output_name ^ ".camlprim.c"
else
Filename.temp_file "camlprim" ".c" in
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\
#ifdef _WIN64\n\
#ifdef __MINGW32__\n\
typedef long long value;\n\
#else\n\
typedef __int64 value;\n\
#endif\n\
#else\n\
typedef long value;\n\
#endif\n";
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
)
~exceptionally:(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
such as __FILE__. *)
output_string poc "\
#ifdef __cplusplus\n\
extern \"C\" {\n\
#endif\n\
#ifdef _WIN64\n\
#ifdef __MINGW32__\n\
typedef long long value;\n\
#else\n\
typedef __int64 value;\n\
#endif\n\
#else\n\
typedef long value;\n\
#endif\n";
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 not !Clflags.make_runtime then
append_bytecode bytecode_name exec_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,30 +638,32 @@ let link objfiles output_name =
then (Filename.chop_extension c_file) ^ Config.ext_obj
else basename ^ Config.ext_obj
in
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;
)
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;
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
(* Error report *)

28
bytecomp/symtable.ml
View File

@ -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 () ->
try
while true do
set_prim_table (input_line ic)
done
with End_of_file -> ()
)
Misc.try_finally
~always:(fun () -> close_in ic)
(fun () ->
try
while true do
set_prim_table (input_line ic)
done
with End_of_file -> ()
)
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 () ->
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
)
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
)
end else begin
Array.iter set_prim_table Runtimedef.builtin_primitives
end

3
bytecomp/translcore.ml
View File

@ -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,

42
bytecomp/translobj.ml
View File

@ -171,34 +171,28 @@ 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;
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
Misc.protect_refs [Misc.R (wrapping, true); Misc.R (top_env, env)]
(fun () ->
cache_required := req;
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;

13
driver/compile.ml
View File

@ -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 () ->
bytecode
++ Profile.(record ~accumulate:true generate)
(Emitcode.to_file oc modulename objfile ~required_globals);
Warnings.check_fatal ()
)
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 ()
)
end
)
~always:(fun () -> Stypes.dump (Some (outputprefix ^ ".annot")))

123
driver/optcompile.ml
View File

@ -78,68 +78,67 @@ 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 =
let (typedtree, coercion) =
ast
++ 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 not !Clflags.print_types then begin
if Config.flambda then begin
if !Clflags.classic_inlining then begin
Clflags.default_simplify_rounds := 1;
Clflags.use_inlining_arguments_set Clflags.classic_arguments;
Clflags.unbox_free_vars_of_closures := false;
Clflags.unbox_specialised_args := false
end;
(typedtree, coercion)
++ Profile.(record transl)
(Translmod.transl_implementation_flambda modulename)
++ Profile.(record generate)
(fun { Lambda.module_ident; main_module_block_size;
required_globals; code } ->
((module_ident, main_module_block_size), code)
+++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+++ Simplif.simplify_lambda sourcefile
+++ print_if ppf Clflags.dump_lambda Printlambda.lambda
++ (fun ((module_ident, size), lam) ->
Middle_end.middle_end ppf
~prefixname:outputprefix
~size
~filename:sourcefile
~module_ident
~backend
~module_initializer:lam)
++ Asmgen.compile_implementation_flambda
outputprefix ~required_globals ~backend ppf;
Compilenv.save_unit_info cmxfile)
end
else begin
Clflags.use_inlining_arguments_set Clflags.classic_arguments;
(typedtree, coercion)
++ Profile.(record transl)
(Translmod.transl_store_implementation modulename)
++ print_if ppf Clflags.dump_rawlambda Printlambda.program
++ Profile.(record generate)
(fun program ->
{ program with
Lambda.code = Simplif.simplify_lambda sourcefile
program.Lambda.code }
++ print_if ppf Clflags.dump_lambda Printlambda.program
++ Asmgen.compile_implementation_clambda
outputprefix ppf;
Compilenv.save_unit_info cmxfile)
end
end;
Warnings.check_fatal ()
in
Misc.try_finally (fun () ->
comp (Pparse.parse_implementation ~tool_name sourcefile)
Misc.try_finally
~exceptionally:(fun () -> remove_file objfile; remove_file cmxfile)
(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 not !Clflags.print_types then begin
if Config.flambda then begin
if !Clflags.classic_inlining then begin
Clflags.default_simplify_rounds := 1;
Clflags.use_inlining_arguments_set Clflags.classic_arguments;
Clflags.unbox_free_vars_of_closures := false;
Clflags.unbox_specialised_args := false
end;
(typedtree, coercion)
++ Profile.(record transl)
(Translmod.transl_implementation_flambda modulename)
++ Profile.(record generate)
(fun { Lambda.module_ident; main_module_block_size;
required_globals; code } ->
((module_ident, main_module_block_size), code)
+++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
+++ Simplif.simplify_lambda sourcefile
+++ print_if ppf Clflags.dump_lambda Printlambda.lambda
++ (fun ((module_ident, size), lam) ->
Middle_end.middle_end ppf
~prefixname:outputprefix
~size
~filename:sourcefile
~module_ident
~backend
~module_initializer:lam)
++ Asmgen.compile_implementation_flambda
outputprefix ~required_globals ~backend ppf;
Compilenv.save_unit_info cmxfile)
end
else begin
Clflags.use_inlining_arguments_set Clflags.classic_arguments;
(typedtree, coercion)
++ Profile.(record transl)
(Translmod.transl_store_implementation modulename)
++ print_if ppf Clflags.dump_rawlambda Printlambda.program
++ Profile.(record generate)
(fun program ->
{ program with
Lambda.code = Simplif.simplify_lambda sourcefile
program.Lambda.code }
++ print_if ppf Clflags.dump_lambda Printlambda.program
++ Asmgen.compile_implementation_clambda
outputprefix ppf;
Compilenv.save_unit_info cmxfile)
end
end;
Warnings.check_fatal ()
)
~always:(fun () -> Stypes.dump (Some (outputprefix ^ ".annot")))
~exceptionally:(fun () -> remove_file objfile; remove_file cmxfile)
)

15
driver/pparse.ml
View File

@ -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 () ->
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)
)
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)
)
let rewrite kind ppxs ast =
let fn = Filename.temp_file "camlppx" "" in

5
parsing/ast_helper.ml
View File

@ -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)

8
tools/objinfo.ml
View File

@ -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 =

5
toplevel/topdirs.ml
View File

@ -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

43
typing/cmt_format.ml
View File

@ -112,28 +112,29 @@ 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 () ->
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
)
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
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
)
let read_cmt filename =
match read filename with

23
typing/ctype.ml
View File

@ -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]

6
typing/typecore.ml
View File

@ -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 *)

4
typing/typemod.ml
View File

@ -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)