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

Merge pull request #1906 from sliquister/doutput-prepare 

Minor cleanup around printing in the compiler (warnings, errors, etc)
master
Gabriel Scherer 2018-07-17 11:44:47 +02:00 committed by GitHub
parent ce971f5d63 68e54ea9bf
commit dca053d6e7
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
35 changed files with 120 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
Changes
View File

@ -97,6 +97,10 @@ Working version
`__FILE__` or `__LOC__`
(Xavier Clerc, review by Gabriel Scherer and Sébastien Hinderer)
- GPR#1906: created warning 64 when using -unsafe and a -pp argument that
returns a syntax tree, to replace the print that was there already
(Valentin Gatien-Baron)
### Code generation and optimizations:
- MPR#7725, GPR#1754: improve AFL instrumentation for objects and lazy values.

11
asmcomp/asmgen.ml
View File

@ -27,8 +27,7 @@ type error = Assembler_error of string
exception Error of error
let liveness ppf phrase =
Liveness.fundecl ppf phrase; phrase
let liveness phrase = Liveness.fundecl phrase; phrase
let dump_if ppf flag message phrase =
if !flag then Printmach.phase message ppf phrase
@ -96,7 +95,7 @@ let rec regalloc ppf round fd =
let (newfd, redo_regalloc) = Reload.fundecl fd in
dump_if ppf dump_reload "After insertion of reloading code" newfd;
if redo_regalloc then begin
Reg.reinit(); Liveness.fundecl ppf newfd; regalloc ppf (round + 1) newfd
Reg.reinit(); Liveness.fundecl newfd; regalloc ppf (round + 1) newfd
end else newfd
let (++) x f = f x
@ -111,15 +110,15 @@ let compile_fundecl (ppf : formatter) fd_cmm =
++ pass_dump_if ppf dump_combine "After allocation combining"
++ Profile.record ~accumulate:true "cse" CSE.fundecl
++ pass_dump_if ppf dump_cse "After CSE"
++ Profile.record ~accumulate:true "liveness" (liveness ppf)
++ Profile.record ~accumulate:true "liveness" liveness
++ Profile.record ~accumulate:true "deadcode" Deadcode.fundecl
++ pass_dump_if ppf dump_live "Liveness analysis"
++ Profile.record ~accumulate:true "spill" Spill.fundecl
++ Profile.record ~accumulate:true "liveness" (liveness ppf)
++ Profile.record ~accumulate:true "liveness" liveness
++ pass_dump_if ppf dump_spill "After spilling"
++ Profile.record ~accumulate:true "split" Split.fundecl
++ pass_dump_if ppf dump_split "After live range splitting"
++ Profile.record ~accumulate:true "liveness" (liveness ppf)
++ Profile.record ~accumulate:true "liveness" liveness
++ Profile.record ~accumulate:true "regalloc" (regalloc ppf 1)
++ Profile.record ~accumulate:true "available_regs" Available_regs.fundecl
++ Profile.record ~accumulate:true "linearize" Linearize.fundecl

4
asmcomp/cmmgen.ml
View File

@ -444,7 +444,7 @@ let rec div_int c1 c2 is_safe dbg =
let t = if p > 0 then Cop(Casr, [t; Cconst_int p], dbg) else t in
add_int t (lsr_int c1 (Cconst_int (Nativeint.size - 1)) dbg) dbg)
end
| (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe ->
| (c1, c2) when !Clflags.unsafe || is_safe = Lambda.Unsafe ->
Cop(Cdivi, [c1; c2], dbg)
| (c1, c2) ->
bind "divisor" c2 (fun c2 ->
@ -480,7 +480,7 @@ let mod_int c1 c2 is_safe dbg =
else
bind "dividend" c1 (fun c1 ->
sub_int c1 (mul_int (div_int c1 c2 is_safe dbg) c2 dbg) dbg)
| (c1, c2) when !Clflags.fast || is_safe = Lambda.Unsafe ->
| (c1, c2) when !Clflags.unsafe || is_safe = Lambda.Unsafe ->
(* Flambda already generates that test *)
Cop(Cmodi, [c1; c2], dbg)
| (c1, c2) ->

6
asmcomp/liveness.ml
View File

@ -160,7 +160,7 @@ let reset () =
live_at_raise := Reg.Set.empty;
live_at_exit := []
let fundecl ppf f =
let fundecl f =
let initially_live = live f.fun_body Reg.Set.empty in
(* Sanity check: only function parameters (and the Spacetime node hole
register, if profiling) can be live at entrypoint *)
@ -170,6 +170,6 @@ let fundecl ppf f =
else Reg.Set.remove Proc.loc_spacetime_node_hole wrong_live
in
if not (Reg.Set.is_empty wrong_live) then begin
Format.fprintf ppf "%a@." Printmach.regset wrong_live;
Misc.fatal_error "Liveness.fundecl"
Misc.fatal_errorf "@[Liveness.fundecl:@\n%a@]"
Printmach.regset wrong_live
end

4
asmcomp/liveness.mli
View File

@ -16,7 +16,5 @@
(* Liveness analysis.
Annotate mach code with the set of regs live at each point. *)
open Format
val reset : unit -> unit
val fundecl: formatter -> Mach.fundecl -> unit
val fundecl: Mach.fundecl -> unit

10
bytecomp/bytelibrarian.ml
View File

@ -55,7 +55,7 @@ let add_ccobjs l =
lib_dllibs := !lib_dllibs @ l.lib_dllibs
end
let copy_object_file ppf oc name =
let copy_object_file oc name =
let file_name =
try
find_in_path !load_path name
@ -68,7 +68,7 @@ let copy_object_file ppf oc name =
let compunit_pos = input_binary_int ic in
seek_in ic compunit_pos;
let compunit = (input_value ic : compilation_unit) in
Bytelink.check_consistency ppf file_name compunit;
Bytelink.check_consistency file_name compunit;
copy_compunit ic oc compunit;
close_in ic;
[compunit]
@ -77,7 +77,7 @@ let copy_object_file ppf oc name =
let toc_pos = input_binary_int ic in
seek_in ic toc_pos;
let toc = (input_value ic : library) in
List.iter (Bytelink.check_consistency ppf file_name) toc.lib_units;
List.iter (Bytelink.check_consistency file_name) toc.lib_units;
add_ccobjs toc;
List.iter (copy_compunit ic oc) toc.lib_units;
close_in ic;
@ -88,14 +88,14 @@ let copy_object_file ppf oc name =
End_of_file -> close_in ic; raise(Error(Not_an_object_file file_name))
| x -> close_in ic; raise x
let create_archive ppf file_list lib_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 ppf outchan) file_list) in
List.flatten(List.map (copy_object_file outchan) file_list) in
let toc =
{ lib_units = units;
lib_custom = !Clflags.custom_runtime;

2
bytecomp/bytelibrarian.mli
View File

@ -22,7 +22,7 @@
content table = list of compilation units
*)
val create_archive: Format.formatter -> string list -> string -> unit
val create_archive: string list -> string -> unit
type error =
File_not_found of string

38
bytecomp/bytelink.ml
View File

@ -169,7 +169,7 @@ let crc_interfaces = Consistbl.create ()
let interfaces = ref ([] : string list)
let implementations_defined = ref ([] : (string * string) list)
let check_consistency ppf file_name cu =
let check_consistency file_name cu =
begin try
List.iter
(fun (name, crco) ->
@ -186,7 +186,7 @@ let check_consistency ppf file_name cu =
end;
begin try
let source = List.assoc cu.cu_name !implementations_defined in
Location.print_warning (Location.in_file file_name) ppf
Location.prerr_warning (Location.in_file file_name)
(Warnings.Multiple_definition(cu.cu_name,
Location.show_filename file_name,
Location.show_filename source))
@ -208,8 +208,8 @@ let debug_info = ref ([] : (int * Instruct.debug_event list * string list) list)
(* Link in a compilation unit *)
let link_compunit ppf output_fun currpos_fun inchan file_name compunit =
check_consistency ppf file_name compunit;
let link_compunit output_fun currpos_fun inchan file_name compunit =
check_consistency file_name compunit;
seek_in inchan compunit.cu_pos;
let code_block = LongString.input_bytes inchan compunit.cu_codesize in
Symtable.patch_object code_block compunit.cu_reloc;
@ -230,10 +230,10 @@ let link_compunit ppf output_fun currpos_fun inchan file_name compunit =
(* Link in a .cmo file *)
let link_object ppf output_fun currpos_fun file_name compunit =
let link_object output_fun currpos_fun file_name compunit =
let inchan = open_in_bin file_name in
try
link_compunit ppf output_fun currpos_fun inchan file_name compunit;
link_compunit output_fun currpos_fun inchan file_name compunit;
close_in inchan
with
Symtable.Error msg ->
@ -243,14 +243,14 @@ let link_object ppf output_fun currpos_fun file_name compunit =
(* Link in a .cma file *)
let link_archive ppf output_fun currpos_fun file_name units_required =
let link_archive output_fun currpos_fun file_name units_required =
let inchan = open_in_bin file_name in
try
List.iter
(fun cu ->
let name = file_name ^ "(" ^ cu.cu_name ^ ")" in
try
link_compunit ppf output_fun currpos_fun inchan name cu
link_compunit output_fun currpos_fun inchan name cu
with Symtable.Error msg ->
raise(Error(Symbol_error(name, msg))))
units_required;
@ -259,11 +259,11 @@ let link_archive ppf output_fun currpos_fun file_name units_required =
(* Link in a .cmo or .cma file *)
let link_file ppf output_fun currpos_fun = function
let link_file output_fun currpos_fun = function
Link_object(file_name, unit) ->
link_object ppf output_fun currpos_fun file_name unit
link_object output_fun currpos_fun file_name unit
| Link_archive(file_name, units) ->
link_archive ppf output_fun currpos_fun file_name units
link_archive output_fun currpos_fun file_name units
(* Output the debugging information *)
(* Format is:
@ -298,7 +298,7 @@ let make_absolute file =
(* Create a bytecode executable file *)
let link_bytecode ppf tolink exec_name standalone =
let link_bytecode tolink exec_name standalone =
(* Avoid the case where the specified exec output file is the same as
one of the objects to be linked *)
List.iter (function
@ -343,7 +343,7 @@ let link_bytecode ppf tolink exec_name standalone =
end;
let output_fun = output_bytes outchan
and currpos_fun () = pos_out outchan - start_code in
List.iter (link_file ppf output_fun currpos_fun) tolink;
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;
@ -444,7 +444,7 @@ let output_cds_file outfile =
(* Output a bytecode executable as a C file *)
let link_bytecode_as_c ppf tolink outfile =
let link_bytecode_as_c tolink outfile =
let outchan = open_out outfile in
begin try
(* The bytecode *)
@ -464,7 +464,7 @@ let link_bytecode_as_c ppf tolink outfile =
output_code_string outchan code;
currpos := !currpos + Bytes.length code
and currpos_fun () = !currpos in
List.iter (link_file ppf output_fun currpos_fun) tolink;
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 *)
@ -565,7 +565,7 @@ let fix_exec_name name =
(* Main entry point (build a custom runtime if needed) *)
let link ppf objfiles output_name =
let link objfiles output_name =
let objfiles =
if !Clflags.nopervasives then objfiles
else if !Clflags.output_c_object then "stdlib.cma" :: objfiles
@ -584,7 +584,7 @@ let link ppf objfiles output_name =
(* put user's opts first *)
Clflags.dllibs := !lib_dllibs @ !Clflags.dllibs; (* put user's DLLs first *)
if not !Clflags.custom_runtime then
link_bytecode ppf tolink output_name true
link_bytecode tolink output_name true
else if not !Clflags.output_c_object then begin
let bytecode_name = Filename.temp_file "camlcode" "" in
let prim_name =
@ -593,7 +593,7 @@ let link ppf objfiles output_name =
else
Filename.temp_file "camlprim" ".c" in
try
link_bytecode ppf tolink bytecode_name false;
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__. *)
@ -646,7 +646,7 @@ let link ppf objfiles output_name =
else basename ^ Config.ext_obj
in
try
link_bytecode_as_c ppf tolink c_file;
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

5
bytecomp/bytelink.mli
View File

@ -15,11 +15,10 @@
(* Link .cmo files and produce a bytecode executable. *)
val link : Format.formatter -> string list -> string -> unit
val link : string list -> string -> unit
val reset : unit -> unit
val check_consistency:
Format.formatter -> string -> Cmo_format.compilation_unit -> unit
val check_consistency: string -> Cmo_format.compilation_unit -> unit
val extract_crc_interfaces: unit -> (string * Digest.t option) list

20
bytecomp/bytepackager.ml
View File

@ -132,11 +132,11 @@ let read_member_info file = (
Accumulate relocs, debug info, etc.
Return size of bytecode. *)
let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst
let rename_append_bytecode packagename oc mapping defined ofs prefix subst
objfile compunit =
let ic = open_in_bin objfile in
try
Bytelink.check_consistency ppf objfile compunit;
Bytelink.check_consistency objfile compunit;
List.iter
(rename_relocation packagename objfile mapping defined ofs)
compunit.cu_reloc;
@ -161,7 +161,7 @@ let rename_append_bytecode ppf packagename oc mapping defined ofs prefix subst
(* Same, for a list of .cmo and .cmi files.
Return total size of bytecode. *)
let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs
let rec rename_append_bytecode_list packagename oc mapping defined ofs
prefix subst =
function
[] ->
@ -169,15 +169,15 @@ let rec rename_append_bytecode_list ppf packagename oc mapping defined ofs
| m :: rem ->
match m.pm_kind with
| PM_intf ->
rename_append_bytecode_list ppf packagename oc mapping defined ofs
rename_append_bytecode_list packagename oc mapping defined ofs
prefix subst rem
| PM_impl compunit ->
let size =
rename_append_bytecode ppf packagename oc mapping defined ofs
rename_append_bytecode packagename oc mapping defined ofs
prefix subst m.pm_file compunit in
let id = Ident.create_persistent m.pm_name in
let root = Path.Pident (Ident.create_persistent prefix) in
rename_append_bytecode_list ppf packagename oc mapping (id :: defined)
rename_append_bytecode_list packagename oc mapping (id :: defined)
(ofs + size) prefix
(Subst.add_module id (Path.Pdot (root, Ident.name id, Path.nopos))
subst)
@ -206,7 +206,7 @@ let build_global_target oc target_name members mapping pos coercion =
(* Build the .cmo file obtained by packaging the given .cmo files. *)
let package_object_files ppf files targetfile targetname coercion =
let package_object_files files targetfile targetname coercion =
let members =
map_left_right read_member_info files in
let required_globals =
@ -241,7 +241,7 @@ let package_object_files ppf files targetfile targetname coercion =
let pos_depl = pos_out oc in
output_binary_int oc 0;
let pos_code = pos_out oc in
let ofs = rename_append_bytecode_list ppf targetname oc mapping [] 0
let ofs = rename_append_bytecode_list targetname oc mapping [] 0
targetname Subst.identity members in
build_global_target oc targetname members mapping ofs coercion;
let pos_debug = pos_out oc in
@ -278,7 +278,7 @@ let package_object_files ppf files targetfile targetname coercion =
(* The entry point *)
let package_files ppf initial_env files targetfile =
let package_files initial_env files targetfile =
let files =
List.map
(fun f ->
@ -291,7 +291,7 @@ let package_files ppf initial_env files targetfile =
try
let coercion =
Typemod.package_units initial_env files targetcmi targetname in
package_object_files ppf files targetfile targetname coercion
package_object_files files targetfile targetname coercion
with x ->
remove_file targetfile; raise x

2
bytecomp/bytepackager.mli
View File

@ -16,7 +16,7 @@
(* "Package" a set of .cmo files into one .cmo file having the
original compilation units as sub-modules. *)
val package_files: Format.formatter -> Env.t -> string list -> string -> unit
val package_files: Env.t -> string list -> string -> unit
type error =
Forward_reference of string * Ident.t

2
driver/compenv.ml
View File

@ -219,7 +219,7 @@ let read_one_param ppf position name v =
| "strict-formats" -> set "strict-formats" [ strict_formats ] v
| "thread" -> set "thread" [ use_threads ] v
| "unboxed-types" -> set "unboxed-types" [ unboxed_types ] v
| "unsafe" -> set "unsafe" [ fast ] v
| "unsafe" -> set "unsafe" [ unsafe ] v
| "verbose" -> set "verbose" [ verbose ] v
| "nopervasives" -> set "nopervasives" [ nopervasives ] v
| "slash" -> set "slash" [ force_slash ] v (* for ocamldep *)

4
driver/compile.ml
View File

@ -32,7 +32,7 @@ let interface ppf sourcefile outputprefix =
let modulename = module_of_filename ppf sourcefile outputprefix in
Env.set_unit_name modulename;
let initial_env = Compmisc.initial_env () in
let ast = Pparse.parse_interface ~tool_name ppf sourcefile in
let ast = Pparse.parse_interface ~tool_name sourcefile in
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
@ -76,7 +76,7 @@ let implementation ppf sourcefile outputprefix =
let env = Compmisc.initial_env() in
try
let (typedtree, coercion) =
Pparse.parse_implementation ~tool_name ppf sourcefile
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)

4
driver/compmisc.ml
View File

@ -57,11 +57,11 @@ let initial_env () =
~initially_opened_module
~open_implicit_modules:(List.rev !Clflags.open_modules)
let read_color_env ppf =
let read_color_env () =
try
match Clflags.parse_color_setting (Sys.getenv "OCAML_COLOR") with
| None ->
Location.print_warning Location.none ppf
Location.prerr_warning Location.none
(Warnings.Bad_env_variable
("OCAML_COLOR",
"expected \"auto\", \"always\" or \"never\""));

2
driver/compmisc.mli
View File

@ -16,4 +16,4 @@
val init_path : ?dir:string -> bool -> unit
val initial_env : unit -> Env.t
val read_color_env : Format.formatter -> unit
val read_color_env : unit -> unit

11
driver/main.ml
View File

@ -89,7 +89,7 @@ module Options = Main_args.Make_bytecomp_options (struct
let _vmthread = set use_vmthreads
let _unboxed_types = set unboxed_types
let _no_unboxed_types = unset unboxed_types
let _unsafe = set fast
let _unsafe = set unsafe
let _unsafe_string = set unsafe_string
let _use_prims s = use_prims := s
let _use_runtime s = use_runtime := s
@ -134,7 +134,7 @@ let main () =
try
readenv ppf Before_args;
Clflags.parse_arguments anonymous usage;
Compmisc.read_color_env ppf;
Compmisc.read_color_env ();
begin try
Compenv.process_deferred_actions
(ppf,
@ -162,8 +162,7 @@ let main () =
if !make_archive then begin
Compmisc.init_path false;
Bytelibrarian.create_archive ppf
(Compenv.get_objfiles ~with_ocamlparam:false)
Bytelibrarian.create_archive (Compenv.get_objfiles ~with_ocamlparam:false)
(extract_output !output_name);
Warnings.check_fatal ();
end
@ -171,7 +170,7 @@ let main () =
Compmisc.init_path false;
let extracted_output = extract_output !output_name in
let revd = get_objfiles ~with_ocamlparam:false in
Bytepackager.package_files ppf (Compmisc.initial_env ())
Bytepackager.package_files (Compmisc.initial_env ())
revd (extracted_output);
Warnings.check_fatal ();
end
@ -193,7 +192,7 @@ let main () =
default_output !output_name
in
Compmisc.init_path false;
Bytelink.link ppf (get_objfiles ~with_ocamlparam:true) target;
Bytelink.link (get_objfiles ~with_ocamlparam:true) target;
Warnings.check_fatal ();
end;
with x ->

5
driver/makedepend.ml
View File

@ -281,10 +281,7 @@ let read_parse_and_extract parse_function extract_function def ast_kind
try
let input_file = Pparse.preprocess source_file in
begin try
let ast =
Pparse.file ~tool_name Format.err_formatter
input_file parse_function ast_kind
in
let ast = Pparse.file ~tool_name input_file parse_function ast_kind in
let bound_vars =
List.fold_left
(fun bv modname ->

4
driver/optcompile.ml
View File

@ -33,7 +33,7 @@ let interface ppf sourcefile outputprefix =
let modulename = module_of_filename ppf sourcefile outputprefix in
Env.set_unit_name modulename;
let initial_env = Compmisc.initial_env () in
let ast = Pparse.parse_interface ~tool_name ppf sourcefile in
let ast = Pparse.parse_interface ~tool_name sourcefile in
if !Clflags.dump_parsetree then fprintf ppf "%a@." Printast.interface ast;
if !Clflags.dump_source then fprintf ppf "%a@." Pprintast.signature ast;
Profile.(record_call typing) (fun () ->
@ -138,7 +138,7 @@ let implementation ~backend ppf sourcefile outputprefix =
Warnings.check_fatal ();
Stypes.dump (Some (outputprefix ^ ".annot"))
in
try comp (Pparse.parse_implementation ~tool_name ppf sourcefile)
try comp (Pparse.parse_implementation ~tool_name sourcefile)
with x ->
Stypes.dump (Some (outputprefix ^ ".annot"));
remove_file objfile;

4
driver/optmain.ml
View File

@ -174,7 +174,7 @@ module Options = Main_args.Make_optcomp_options (struct
let _unbox_closures_factor f = unbox_closures_factor := f
let _unboxed_types = set unboxed_types
let _no_unboxed_types = clear unboxed_types
let _unsafe = set fast
let _unsafe = set unsafe
let _unsafe_string = set unsafe_string
let _v () = print_version_and_library "native-code compiler"
let _version () = print_version_string ()
@ -247,7 +247,7 @@ let main () =
"<options> Compute dependencies \
(use 'ocamlopt -depend -help' for details)"];
Clflags.parse_arguments anonymous usage;
Compmisc.read_color_env ppf;
Compmisc.read_color_env ();
if !gprofile && not Config.profiling then
fatal "Profiling with \"gprof\" is not supported on this platform.";
begin try

25
driver/pparse.ml
View File

@ -163,18 +163,17 @@ let parse (type a) (kind : a ast_kind) lexbuf : a =
| Structure -> Parse.implementation lexbuf
| Signature -> Parse.interface lexbuf
let file_aux ppf ~tool_name inputfile (type a) parse_fun invariant_fun
let file_aux ~tool_name inputfile (type a) parse_fun invariant_fun
(kind : a ast_kind) =
let ast_magic = magic_of_kind kind in
let (ic, is_ast_file) = open_and_check_magic inputfile ast_magic in
let ast =
try
if is_ast_file then begin
if !Clflags.fast then
(* FIXME make this a proper warning *)
fprintf ppf "@[Warning: %s@]@."
"option -unsafe used with a preprocessor returning a syntax tree";
Location.input_name := (input_value ic : string);
if !Clflags.unsafe then
Location.prerr_warning (Location.in_file !Location.input_name)
Warnings.Unsafe_without_parsing;
(input_value ic : a)
end else begin
seek_in ic 0;
@ -191,8 +190,8 @@ let file_aux ppf ~tool_name inputfile (type a) parse_fun invariant_fun
if is_ast_file || !Clflags.all_ppx <> [] then invariant_fun ast;
ast
let file ppf ~tool_name inputfile parse_fun ast_kind =
file_aux ppf ~tool_name inputfile parse_fun ignore ast_kind
let file ~tool_name inputfile parse_fun ast_kind =
file_aux ~tool_name inputfile parse_fun ignore ast_kind
let report_error ppf = function
| CannotRun cmd ->
@ -209,11 +208,11 @@ let () =
| _ -> None
)
let parse_file ~tool_name invariant_fun apply_hooks kind ppf sourcefile =
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 ppf ~tool_name inputfile (parse kind) invariant_fun kind
try file_aux ~tool_name inputfile (parse kind) invariant_fun kind
with exn ->
remove_preprocessed inputfile;
raise exn
@ -229,11 +228,11 @@ module InterfaceHooks = Misc.MakeHooks(struct
type t = Parsetree.signature
end)
let parse_implementation ppf ~tool_name sourcefile =
let parse_implementation ~tool_name sourcefile =
Profile.record_call "parsing" (fun () ->
parse_file ~tool_name Ast_invariants.structure
ImplementationHooks.apply_hooks Structure ppf sourcefile)
let parse_interface ppf ~tool_name sourcefile =
ImplementationHooks.apply_hooks Structure sourcefile)
let parse_interface ~tool_name sourcefile =
Profile.record_call "parsing" (fun () ->
parse_file ~tool_name Ast_invariants.signature
InterfaceHooks.apply_hooks Signature ppf sourcefile)
InterfaceHooks.apply_hooks Signature sourcefile)

6
driver/pparse.mli
View File

@ -33,7 +33,7 @@ type 'a ast_kind =
val read_ast : 'a ast_kind -> string -> 'a
val write_ast : 'a ast_kind -> string -> 'a -> unit
val file : formatter -> tool_name:string -> string ->
val file : tool_name:string -> string ->
(Lexing.lexbuf -> 'a) -> 'a ast_kind -> 'a
val apply_rewriters: ?restore:bool -> tool_name:string ->
@ -52,9 +52,9 @@ val report_error : formatter -> error -> unit
val parse_implementation:
formatter -> tool_name:string -> string -> Parsetree.structure
tool_name:string -> string -> Parsetree.structure
val parse_interface:
formatter -> tool_name:string -> string -> Parsetree.signature
tool_name:string -> string -> Parsetree.signature
(* [call_external_preprocessor sourcefile pp] *)
val call_external_preprocessor : string -> string -> string

9
man/ocamlc.m
View File

@ -939,6 +939,15 @@ mutually recursive types.
61
\ \ Unannotated unboxable type in primitive declaration.
62
\ \ Type constraint on GADT type declaration
63
\ \ Erroneous printed signature
64
\ \ -unsafe used with a preprocessor returning a syntax tree
The letters stand for the following sets of warnings. Any letter not
mentioned here corresponds to the empty set.

6
manual/tests/cross_reference_checker.ml
View File

@ -130,8 +130,8 @@ end
(** {1 Extract references from Ocaml source files} *)
module OCaml_refs = struct
let parse ppf sourcefile =
Pparse.parse_implementation ppf ~tool_name:"manual_cross_reference_check"
let parse sourcefile =
Pparse.parse_implementation ~tool_name:"manual_cross_reference_check"
sourcefile
(** search for an attribute [[@manual.ref "tex_label_name"]] *)
@ -213,7 +213,7 @@ module OCaml_refs = struct
iterator.structure iterator ast
let from_file m f =
from_ast m @@ parse Format.std_formatter f
from_ast m @@ parse f
end

4
middle_end/closure_conversion.ml
View File

@ -315,7 +315,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
| Lprim ((Pdivint Safe | Pmodint Safe
| Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }) as prim,
[arg1; arg2], loc)
when not !Clflags.fast -> (* not -unsafe *)
when not !Clflags.unsafe ->
let arg2 = close t env arg2 in
let arg1 = close t env arg1 in
let numerator = Variable.create Names.numerator in
@ -374,7 +374,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t =
(Prim (prim, [numerator; denominator], dbg))))))))
| Lprim ((Pdivint Safe | Pmodint Safe
| Pdivbint { is_safe = Safe } | Pmodbint { is_safe = Safe }), _, _)
when not !Clflags.fast ->
when not !Clflags.unsafe ->
Misc.fatal_error "Pdivint / Pmodint must have exactly two arguments"
| Lprim (Psequor, [arg1; arg2], _) ->
let arg1 = close t env arg1 in

4
middle_end/middle_end.ml
View File

@ -45,11 +45,11 @@ let middle_end ppf ~prefixname ~backend
end)
in
let warning_set = ref WarningSet.empty in
let flambda_warning_printer loc _fmt w =
let flambda_warning_printer loc ppf w =
let elt = loc, w in
if not (WarningSet.mem elt !warning_set) then begin
warning_set := WarningSet.add elt !warning_set;
previous_warning_printer loc !Location.formatter_for_warnings w
previous_warning_printer loc ppf w
end;
in
Misc.protect_refs

4
ocamldoc/odoc_analyse.ml
View File

@ -73,7 +73,7 @@ let process_implementation_file sourcefile =
let env = initial_env () in
try
let parsetree =
Pparse.file ~tool_name Format.err_formatter inputfile
Pparse.file ~tool_name inputfile
(no_docstring Parse.implementation) Pparse.Structure
in
let typedtree =
@ -104,7 +104,7 @@ let process_interface_file sourcefile =
Env.set_unit_name modulename;
let inputfile = preprocess sourcefile in
let ast =
Pparse.file ~tool_name Format.err_formatter inputfile
Pparse.file ~tool_name inputfile
(no_docstring Parse.interface) Pparse.Signature
in
let sg = Typemod.type_interface sourcefile (initial_env()) ast in

6
parsing/parser.mly
View File

@ -161,7 +161,7 @@ let mkpat_opt_constraint p = function
| Some typ -> mkpat (Ppat_constraint(p, typ))
let array_function str name =
ghloc (Ldot(Lident str, (if !Clflags.fast then "unsafe_" ^ name else name)))
ghloc (Ldot(Lident str, (if !Clflags.unsafe then "unsafe_" ^ name else name)))
let syntax_error () =
raise Syntaxerr.Escape_error
@ -184,7 +184,7 @@ let bigarray_untuplify = function
| exp -> [exp]
let bigarray_get arr arg =
let get = if !Clflags.fast then "unsafe_get" else "get" in
let get = if !Clflags.unsafe then "unsafe_get" else "get" in
match bigarray_untuplify arg with
[c1] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" get)),
@ -200,7 +200,7 @@ let bigarray_get arr arg =
[Nolabel, arr; Nolabel, ghexp(Pexp_array coords)]))
let bigarray_set arr arg newval =
let set = if !Clflags.fast then "unsafe_set" else "set" in
let set = if !Clflags.unsafe then "unsafe_set" else "set" in
match bigarray_untuplify arg with
[c1] ->
mkexp(Pexp_apply(ghexp(Pexp_ident(bigarray_function "Array1" set)),

2
testsuite/tools/expect_test.ml
View File

@ -389,7 +389,7 @@ module Options = Main_args.Make_bytetop_options (struct
let _no_strict_formats = clear strict_formats
let _unboxed_types = set unboxed_types
let _no_unboxed_types = clear unboxed_types
let _unsafe = set fast
let _unsafe = set unsafe
let _unsafe_string = set unsafe_string
let _version () = (* disabled *) ()
let _vnum () = (* disabled *) ()

2
tools/lintapidiff.ml
View File

@ -174,7 +174,7 @@ module Ast = struct
let id =
orig |> Filename.chop_extension |> Filename.basename |>
String.capitalize_ascii |> Ident.create in
let ast = Pparse.file ~tool_name:"lintapidiff" Format.err_formatter input
let ast = Pparse.file ~tool_name:"lintapidiff" input
Parse.interface Pparse.Signature in
Location.input_name := orig;
add_items ~f (Path.Pident id) (init,IdMap.empty) ast

2
toplevel/opttopmain.ml
View File

@ -202,7 +202,7 @@ module Options = Main_args.Make_opttop_options (struct
let _stdin () = file_argument ""
let _unboxed_types = set unboxed_types
let _no_unboxed_types = clear unboxed_types
let _unsafe = set fast
let _unsafe = set unsafe
let _verbose = set verbose
let _version () = print_version ()
let _vnum () = print_version_num ()

2
toplevel/topmain.ml
View File

@ -129,7 +129,7 @@ module Options = Main_args.Make_bytetop_options (struct
let _no_strict_formats = clear strict_formats
let _unboxed_types = set unboxed_types
let _no_unboxed_types = clear unboxed_types
let _unsafe = set fast
let _unsafe = set unsafe
let _unsafe_string = set unsafe_string
let _version () = print_version ()
let _vnum () = print_version_num ()

2
utils/clflags.ml
View File

@ -49,7 +49,7 @@ and no_std_include = ref false (* -nostdlib *)
and print_types = ref false (* -i *)
and make_archive = ref false (* -a *)
and debug = ref false (* -g *)
and fast = ref false (* -unsafe *)
and unsafe = ref false (* -unsafe *)
and use_linscan = ref false (* -linscan *)
and link_everything = ref false (* -linkall *)
and custom_runtime = ref false (* -custom *)

2
utils/clflags.mli
View File

@ -76,7 +76,7 @@ val no_std_include : bool ref
val print_types : bool ref
val make_archive : bool ref
val debug : bool ref
val fast : bool ref
val unsafe : bool ref
val use_linscan : bool ref
val link_everything : bool ref
val custom_runtime : bool ref

12
utils/warnings.ml
View File

@ -89,7 +89,8 @@ type t =
| Unused_module of string (* 60 *)
| Unboxable_type_in_prim_decl of string (* 61 *)
| Constraint_on_gadt (* 62 *)
| Erroneous_printed_signature of string (* 63 *)
| Erroneous_printed_signature of string (* 63 *)
| Unsafe_without_parsing (* 64 *)
;;
(* If you remove a warning, leave a hole in the numbering. NEVER change
@ -162,9 +163,10 @@ let number = function
| Unboxable_type_in_prim_decl _ -> 61
| Constraint_on_gadt -> 62
| Erroneous_printed_signature _ -> 63
| Unsafe_without_parsing -> 64
;;
let last_warning_number = 63
let last_warning_number = 64
;;
(* Must be the max number returned by the [number] function. *)
@ -532,7 +534,8 @@ let message = function
^ s
^ "\nBeware that this warning is purely informational and will not catch\n\
all instances of erroneous printed interface."
| Unsafe_without_parsing ->
"option -unsafe used with a preprocessor returning a syntax tree"
;;
let sub_locs = function
@ -649,7 +652,8 @@ let descriptions =
60, "Unused module declaration";
61, "Unboxable type in primitive declaration";
62, "Type constraint on GADT type declaration";
63, "Erroneous printed signature"
63, "Erroneous printed signature";
64, "-unsafe used with a preprocessor returning a syntax tree";
]
;;

1
utils/warnings.mli
View File

@ -83,6 +83,7 @@ type t =
| Unboxable_type_in_prim_decl of string (* 61 *)
| Constraint_on_gadt (* 62 *)
| Erroneous_printed_signature of string (* 63 *)
| Unsafe_without_parsing (* 64 *)
;;
val parse_options : bool -> string -> unit;;