Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- commit ab6554328b00bc8a844ed4c09f7a0a8af66bad82
- Author: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
- Date: Tue Jul 30 21:19:37 2013 +0100
- Add the quit_after command line switches (PR#6102)
- diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml
- index 40f7daf..9bfa9ac 100644
- --- a/asmcomp/asmgen.ml
- +++ b/asmcomp/asmgen.ml
- @@ -38,6 +38,9 @@ let pass_dump_linear_if ppf flag message phrase =
- let clambda_dump_if ppf ulambda =
- if !dump_clambda then Printclambda.clambda ppf ulambda; ulambda
- +let quit_if flag cmm =
- + if !flag then exit 0 else cmm
- +
- let rec regalloc ppf round fd =
- if round > 50 then
- fatal_error(fd.Mach.fun_name ^
- @@ -108,6 +111,7 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) =
- Closure.intro size lam
- ++ clambda_dump_if ppf
- ++ Cmmgen.compunit size
- + ++ quit_if Clflags.quit_after_cmm
- ++ List.iter (compile_phrase ppf) ++ (fun () -> ());
- (match toplevel with None -> () | Some f -> compile_genfuns ppf f);
- diff --git a/driver/compile.ml b/driver/compile.ml
- index 2e5b405..66d3d52 100644
- --- a/driver/compile.ml
- +++ b/driver/compile.ml
- @@ -60,6 +60,9 @@ let print_if ppf flag printer arg =
- if !flag then fprintf ppf "%a@." printer arg;
- arg
- +let quit_if flag arg =
- + if !flag then (Warnings.check_fatal (); exit 0) else arg
- +
- let (++) x f = f x
- let implementation ppf sourcefile outputprefix =
- @@ -76,9 +79,11 @@ let implementation ppf sourcefile outputprefix =
- Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
- ++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ print_if ppf Clflags.dump_source Pprintast.structure
- + ++ quit_if Clflags.quit_after_parse
- ++ Typemod.type_implementation sourcefile outputprefix modulename env
- ++ print_if ppf Clflags.dump_typedtree
- - Printtyped.implementation_with_coercion);
- + Printtyped.implementation_with_coercion
- + ++ quit_if Clflags.quit_after_typing);
- Warnings.check_fatal ();
- Pparse.remove_preprocessed inputfile;
- Stypes.dump (Some (outputprefix ^ ".annot"));
- @@ -93,15 +98,20 @@ let implementation ppf sourcefile outputprefix =
- Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
- ++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ print_if ppf Clflags.dump_source Pprintast.structure
- + ++ quit_if Clflags.quit_after_parse
- ++ Typemod.type_implementation sourcefile outputprefix modulename env
- ++ print_if ppf Clflags.dump_typedtree
- Printtyped.implementation_with_coercion
- + ++ quit_if Clflags.quit_after_typing
- ++ Translmod.transl_implementation modulename
- ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
- + ++ quit_if Clflags.quit_after_rawlambda
- ++ Simplif.simplify_lambda
- ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
- + ++ quit_if Clflags.quit_after_lambda
- ++ Bytegen.compile_implementation modulename
- ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
- + ++ quit_if Clflags.quit_after_instr
- ++ Emitcode.to_file oc modulename;
- Warnings.check_fatal ();
- close_out oc;
- diff --git a/driver/main.ml b/driver/main.ml
- index 8deb883..203d0e2 100644
- --- a/driver/main.ml
- +++ b/driver/main.ml
- @@ -130,6 +130,13 @@ module Options = Main_args.Make_bytecomp_options (struct
- let _drawlambda = set dump_rawlambda
- let _dlambda = set dump_lambda
- let _dinstr = set dump_instr
- +
- + let _qparse = set quit_after_parse
- + let _qtyping = set quit_after_typing
- + let _qrawlambda = set quit_after_rawlambda
- + let _qlambda = set quit_after_lambda
- + let _qinstr = set quit_after_instr
- +
- let anonymous = anonymous
- end)
- diff --git a/driver/main_args.ml b/driver/main_args.ml
- index 487a929..ee5da2b 100644
- --- a/driver/main_args.ml
- +++ b/driver/main_args.ml
- @@ -360,6 +360,30 @@ let mk_dinstr f =
- "-dinstr", Arg.Unit f, " (undocumented)"
- ;;
- +let mk_qparse f =
- + "-qparse", Arg.Unit f, " (undocumented)"
- +;;
- +
- +let mk_qtyping f =
- + "-qtyping", Arg.Unit f, " (undocumented)"
- +;;
- +
- +let mk_qrawlambda f =
- + "-qrawlambda", Arg.Unit f, " (undocumented)"
- +;;
- +
- +let mk_qlambda f =
- + "-qlambda", Arg.Unit f, " (undocumented)"
- +;;
- +
- +let mk_qinstr f =
- + "-qinstr", Arg.Unit f, " (undocumented)"
- +;;
- +
- +let mk_qcmm f =
- + "-qcmm", Arg.Unit f, " (undocumented)"
- +;;
- +
- let mk_dcmm f =
- "-dcmm", Arg.Unit f, " (undocumented)"
- ;;
- @@ -477,6 +501,12 @@ module type Bytecomp_options = sig
- val _dlambda : unit -> unit
- val _dinstr : unit -> unit
- + val _qparse : unit -> unit
- + val _qtyping : unit -> unit
- + val _qrawlambda : unit -> unit
- + val _qlambda : unit -> unit
- + val _qinstr : unit -> unit
- +
- val anonymous : string -> unit
- end;;
- @@ -511,6 +541,12 @@ module type Bytetop_options = sig
- val _dlambda : unit -> unit
- val _dinstr : unit -> unit
- + val _qparse : unit -> unit
- + val _qtyping : unit -> unit
- + val _qrawlambda : unit -> unit
- + val _qlambda : unit -> unit
- + val _qinstr : unit -> unit
- +
- val anonymous : string -> unit
- end;;
- @@ -586,6 +622,12 @@ module type Optcomp_options = sig
- val _dlinear : unit -> unit
- val _dstartup : unit -> unit
- + val _qparse : unit -> unit
- + val _qtyping : unit -> unit
- + val _qrawlambda : unit -> unit
- + val _qlambda : unit -> unit
- + val _qcmm : unit -> unit
- +
- val anonymous : string -> unit
- end;;
- @@ -636,6 +678,12 @@ module type Opttop_options = sig
- val _dlinear : unit -> unit
- val _dstartup : unit -> unit
- + val _qparse : unit -> unit
- + val _qtyping : unit -> unit
- + val _qrawlambda : unit -> unit
- + val _qlambda : unit -> unit
- + val _qcmm : unit -> unit
- +
- val anonymous : string -> unit
- end;;
- @@ -711,6 +759,12 @@ struct
- mk_dlambda F._dlambda;
- mk_dinstr F._dinstr;
- + mk_qparse F._qparse;
- + mk_qtyping F._qtyping;
- + mk_qrawlambda F._qrawlambda;
- + mk_qlambda F._qlambda;
- + mk_qinstr F._qinstr;
- +
- mk__ F.anonymous;
- ]
- end;;
- @@ -748,6 +802,12 @@ struct
- mk_dlambda F._dlambda;
- mk_dinstr F._dinstr;
- + mk_qparse F._qparse;
- + mk_qtyping F._qtyping;
- + mk_qrawlambda F._qrawlambda;
- + mk_qlambda F._qlambda;
- + mk_qinstr F._qinstr;
- +
- mk__ F.anonymous;
- ]
- end;;
- @@ -827,6 +887,12 @@ struct
- mk_dlinear F._dlinear;
- mk_dstartup F._dstartup;
- + mk_qparse F._qparse;
- + mk_qtyping F._qtyping;
- + mk_qrawlambda F._qrawlambda;
- + mk_qlambda F._qlambda;
- + mk_qcmm F._qcmm;
- +
- mk__ F.anonymous;
- ]
- end;;
- @@ -878,6 +944,12 @@ module Make_opttop_options (F : Opttop_options) = struct
- mk_dlinear F._dlinear;
- mk_dstartup F._dstartup;
- + mk_qparse F._qparse;
- + mk_qtyping F._qtyping;
- + mk_qrawlambda F._qrawlambda;
- + mk_qlambda F._qlambda;
- + mk_qcmm F._qcmm;
- +
- mk__ F.anonymous;
- ]
- end;;
- diff --git a/driver/main_args.mli b/driver/main_args.mli
- index 6d431e7..73080d2 100644
- --- a/driver/main_args.mli
- +++ b/driver/main_args.mli
- @@ -71,6 +71,12 @@ module type Bytecomp_options =
- val _dlambda : unit -> unit
- val _dinstr : unit -> unit
- + val _qparse : unit -> unit
- + val _qtyping : unit -> unit
- + val _qrawlambda : unit -> unit
- + val _qlambda : unit -> unit
- + val _qinstr : unit -> unit
- +
- val anonymous : string -> unit
- end
- ;;
- @@ -106,6 +112,12 @@ module type Bytetop_options = sig
- val _dlambda : unit -> unit
- val _dinstr : unit -> unit
- + val _qparse : unit -> unit
- + val _qtyping : unit -> unit
- + val _qrawlambda : unit -> unit
- + val _qlambda : unit -> unit
- + val _qinstr : unit -> unit
- +
- val anonymous : string -> unit
- end;;
- @@ -181,6 +193,12 @@ module type Optcomp_options = sig
- val _dlinear : unit -> unit
- val _dstartup : unit -> unit
- + val _qparse : unit -> unit
- + val _qtyping : unit -> unit
- + val _qrawlambda : unit -> unit
- + val _qlambda : unit -> unit
- + val _qcmm : unit -> unit
- +
- val anonymous : string -> unit
- end;;
- @@ -231,6 +249,12 @@ module type Opttop_options = sig
- val _dlinear : unit -> unit
- val _dstartup : unit -> unit
- + val _qparse : unit -> unit
- + val _qtyping : unit -> unit
- + val _qrawlambda : unit -> unit
- + val _qlambda : unit -> unit
- + val _qcmm : unit -> unit
- +
- val anonymous : string -> unit
- end;;
- diff --git a/driver/optcompile.ml b/driver/optcompile.ml
- index ebe2457..d07359a 100644
- --- a/driver/optcompile.ml
- +++ b/driver/optcompile.ml
- @@ -61,6 +61,9 @@ let print_if ppf flag printer arg =
- if !flag then fprintf ppf "%a@." printer arg;
- arg
- +let quit_if flag arg =
- + if !flag then (Warnings.check_fatal (); exit 0) else arg
- +
- let (++) x f = f x
- let (+++) (x, y) f = (x, f y)
- @@ -81,20 +84,26 @@ let implementation ppf sourcefile outputprefix =
- Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
- ++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ print_if ppf Clflags.dump_source Pprintast.structure
- + ++ quit_if Clflags.quit_after_parse
- ++ Typemod.type_implementation sourcefile outputprefix modulename env
- ++ print_if ppf Clflags.dump_typedtree
- Printtyped.implementation_with_coercion
- + ++ quit_if Clflags.quit_after_typing
- end else begin
- Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
- ++ print_if ppf Clflags.dump_parsetree Printast.implementation
- ++ print_if ppf Clflags.dump_source Pprintast.structure
- + ++ quit_if Clflags.quit_after_parse
- ++ Typemod.type_implementation sourcefile outputprefix modulename env
- ++ print_if ppf Clflags.dump_typedtree
- Printtyped.implementation_with_coercion
- + ++ quit_if Clflags.quit_after_typing
- ++ Translmod.transl_store_implementation modulename
- +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
- + +++ quit_if Clflags.quit_after_rawlambda
- +++ Simplif.simplify_lambda
- +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
- + +++ quit_if Clflags.quit_after_lambda
- ++ Asmgen.compile_implementation outputprefix ppf;
- Compilenv.save_unit_info cmxfile;
- end;
- diff --git a/driver/optmain.ml b/driver/optmain.ml
- index 7571fca..ddfb9d0 100644
- --- a/driver/optmain.ml
- +++ b/driver/optmain.ml
- @@ -143,6 +143,12 @@ module Options = Main_args.Make_optcomp_options (struct
- let _dlinear = set dump_linear
- let _dstartup = set keep_startup_file
- + let _qparse = set quit_after_parse
- + let _qtyping = set quit_after_typing
- + let _qrawlambda = set quit_after_rawlambda
- + let _qlambda = set quit_after_lambda
- + let _qcmm = set quit_after_cmm
- +
- let anonymous = anonymous
- end);;
- diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
- index 67a2bae..9da3f46 100644
- --- a/tools/ocamlcp.ml
- +++ b/tools/ocamlcp.ml
- @@ -98,6 +98,13 @@ module Options = Main_args.Make_bytecomp_options (struct
- let _drawlambda = option "-drawlambda"
- let _dlambda = option "-dlambda"
- let _dinstr = option "-dinstr"
- +
- + let _qparse = option "-qparse"
- + let _qtyping = option "-qtyping"
- + let _qrawlambda = option "-qrawlambda"
- + let _qlambda = option "-qlambda"
- + let _qinstr = option "-qinstr"
- +
- let anonymous = process_file
- end);;
- diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
- index 74d1314..c67bf40 100644
- --- a/tools/ocamloptp.ml
- +++ b/tools/ocamloptp.ml
- @@ -114,6 +114,12 @@ module Options = Main_args.Make_optcomp_options (struct
- let _dlinear = option "-dlinear"
- let _dstartup = option "-dstartup"
- + let _qparse = option "-qparse"
- + let _qtyping = option "-qtyping"
- + let _qrawlambda = option "-qrawlambda"
- + let _qlambda = option "-qlambda"
- + let _qcmm = option "-qcmm"
- +
- let anonymous = process_file
- end);;
- diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
- index 87c36d1..0812c52 100644
- --- a/toplevel/topmain.ml
- +++ b/toplevel/topmain.ml
- @@ -91,6 +91,12 @@ module Options = Main_args.Make_bytetop_options (struct
- let _dlambda = set dump_lambda
- let _dinstr = set dump_instr
- + let _qparse = set quit_after_parse
- + let _qtyping = set quit_after_typing
- + let _qrawlambda = set quit_after_rawlambda
- + let _qlambda = set quit_after_lambda
- + let _qinstr = set quit_after_instr
- +
- let anonymous s = file_argument s
- end);;
- diff --git a/utils/clflags.ml b/utils/clflags.ml
- index 4ff808f..564d3a7 100644
- --- a/utils/clflags.ml
- +++ b/utils/clflags.ml
- @@ -82,6 +82,13 @@ let dump_linear = ref false (* -dlinear *)
- let keep_startup_file = ref false (* -dstartup *)
- let dump_combine = ref false (* -dcombine *)
- +let quit_after_parse = ref false
- +let quit_after_typing = ref false
- +let quit_after_rawlambda = ref false
- +let quit_after_lambda = ref false
- +let quit_after_instr = ref false
- +let quit_after_cmm = ref false
- +
- let native_code = ref false (* set to true under ocamlopt *)
- let inline_threshold = ref 10
- let force_slash = ref false (* for ocamldep *)
- diff --git a/utils/clflags.mli b/utils/clflags.mli
- index e671133..2866682 100644
- --- a/utils/clflags.mli
- +++ b/utils/clflags.mli
- @@ -76,6 +76,12 @@ val dump_scheduling : bool ref
- val dump_linear : bool ref
- val keep_startup_file : bool ref
- val dump_combine : bool ref
- +val quit_after_parse : bool ref
- +val quit_after_typing : bool ref
- +val quit_after_rawlambda : bool ref
- +val quit_after_lambda : bool ref
- +val quit_after_instr : bool ref
- +val quit_after_cmm : bool ref
- val native_code : bool ref
- val inline_threshold : int ref
- val dont_write_files : bool ref
Add Comment
Please, Sign In to add comment