Guest User

Untitled

a guest
Feb 16th, 2019
94
0
Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
text 13.19 KB | None | 0 0
  1. commit ab6554328b00bc8a844ed4c09f7a0a8af66bad82
  2. Author: Jon Ludlam <jonathan.ludlam@eu.citrix.com>
  3. Date: Tue Jul 30 21:19:37 2013 +0100
  4.  
  5. Add the quit_after command line switches (PR#6102)
  6.  
  7. diff --git a/asmcomp/asmgen.ml b/asmcomp/asmgen.ml
  8. index 40f7daf..9bfa9ac 100644
  9. --- a/asmcomp/asmgen.ml
  10. +++ b/asmcomp/asmgen.ml
  11. @@ -38,6 +38,9 @@ let pass_dump_linear_if ppf flag message phrase =
  12. let clambda_dump_if ppf ulambda =
  13. if !dump_clambda then Printclambda.clambda ppf ulambda; ulambda
  14.  
  15. +let quit_if flag cmm =
  16. + if !flag then exit 0 else cmm
  17. +
  18. let rec regalloc ppf round fd =
  19. if round > 50 then
  20. fatal_error(fd.Mach.fun_name ^
  21. @@ -108,6 +111,7 @@ let compile_implementation ?toplevel prefixname ppf (size, lam) =
  22. Closure.intro size lam
  23. ++ clambda_dump_if ppf
  24. ++ Cmmgen.compunit size
  25. + ++ quit_if Clflags.quit_after_cmm
  26. ++ List.iter (compile_phrase ppf) ++ (fun () -> ());
  27. (match toplevel with None -> () | Some f -> compile_genfuns ppf f);
  28.  
  29. diff --git a/driver/compile.ml b/driver/compile.ml
  30. index 2e5b405..66d3d52 100644
  31. --- a/driver/compile.ml
  32. +++ b/driver/compile.ml
  33. @@ -60,6 +60,9 @@ let print_if ppf flag printer arg =
  34. if !flag then fprintf ppf "%a@." printer arg;
  35. arg
  36.  
  37. +let quit_if flag arg =
  38. + if !flag then (Warnings.check_fatal (); exit 0) else arg
  39. +
  40. let (++) x f = f x
  41.  
  42. let implementation ppf sourcefile outputprefix =
  43. @@ -76,9 +79,11 @@ let implementation ppf sourcefile outputprefix =
  44. Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
  45. ++ print_if ppf Clflags.dump_parsetree Printast.implementation
  46. ++ print_if ppf Clflags.dump_source Pprintast.structure
  47. + ++ quit_if Clflags.quit_after_parse
  48. ++ Typemod.type_implementation sourcefile outputprefix modulename env
  49. ++ print_if ppf Clflags.dump_typedtree
  50. - Printtyped.implementation_with_coercion);
  51. + Printtyped.implementation_with_coercion
  52. + ++ quit_if Clflags.quit_after_typing);
  53. Warnings.check_fatal ();
  54. Pparse.remove_preprocessed inputfile;
  55. Stypes.dump (Some (outputprefix ^ ".annot"));
  56. @@ -93,15 +98,20 @@ let implementation ppf sourcefile outputprefix =
  57. Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
  58. ++ print_if ppf Clflags.dump_parsetree Printast.implementation
  59. ++ print_if ppf Clflags.dump_source Pprintast.structure
  60. + ++ quit_if Clflags.quit_after_parse
  61. ++ Typemod.type_implementation sourcefile outputprefix modulename env
  62. ++ print_if ppf Clflags.dump_typedtree
  63. Printtyped.implementation_with_coercion
  64. + ++ quit_if Clflags.quit_after_typing
  65. ++ Translmod.transl_implementation modulename
  66. ++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
  67. + ++ quit_if Clflags.quit_after_rawlambda
  68. ++ Simplif.simplify_lambda
  69. ++ print_if ppf Clflags.dump_lambda Printlambda.lambda
  70. + ++ quit_if Clflags.quit_after_lambda
  71. ++ Bytegen.compile_implementation modulename
  72. ++ print_if ppf Clflags.dump_instr Printinstr.instrlist
  73. + ++ quit_if Clflags.quit_after_instr
  74. ++ Emitcode.to_file oc modulename;
  75. Warnings.check_fatal ();
  76. close_out oc;
  77. diff --git a/driver/main.ml b/driver/main.ml
  78. index 8deb883..203d0e2 100644
  79. --- a/driver/main.ml
  80. +++ b/driver/main.ml
  81. @@ -130,6 +130,13 @@ module Options = Main_args.Make_bytecomp_options (struct
  82. let _drawlambda = set dump_rawlambda
  83. let _dlambda = set dump_lambda
  84. let _dinstr = set dump_instr
  85. +
  86. + let _qparse = set quit_after_parse
  87. + let _qtyping = set quit_after_typing
  88. + let _qrawlambda = set quit_after_rawlambda
  89. + let _qlambda = set quit_after_lambda
  90. + let _qinstr = set quit_after_instr
  91. +
  92. let anonymous = anonymous
  93. end)
  94.  
  95. diff --git a/driver/main_args.ml b/driver/main_args.ml
  96. index 487a929..ee5da2b 100644
  97. --- a/driver/main_args.ml
  98. +++ b/driver/main_args.ml
  99. @@ -360,6 +360,30 @@ let mk_dinstr f =
  100. "-dinstr", Arg.Unit f, " (undocumented)"
  101. ;;
  102.  
  103. +let mk_qparse f =
  104. + "-qparse", Arg.Unit f, " (undocumented)"
  105. +;;
  106. +
  107. +let mk_qtyping f =
  108. + "-qtyping", Arg.Unit f, " (undocumented)"
  109. +;;
  110. +
  111. +let mk_qrawlambda f =
  112. + "-qrawlambda", Arg.Unit f, " (undocumented)"
  113. +;;
  114. +
  115. +let mk_qlambda f =
  116. + "-qlambda", Arg.Unit f, " (undocumented)"
  117. +;;
  118. +
  119. +let mk_qinstr f =
  120. + "-qinstr", Arg.Unit f, " (undocumented)"
  121. +;;
  122. +
  123. +let mk_qcmm f =
  124. + "-qcmm", Arg.Unit f, " (undocumented)"
  125. +;;
  126. +
  127. let mk_dcmm f =
  128. "-dcmm", Arg.Unit f, " (undocumented)"
  129. ;;
  130. @@ -477,6 +501,12 @@ module type Bytecomp_options = sig
  131. val _dlambda : unit -> unit
  132. val _dinstr : unit -> unit
  133.  
  134. + val _qparse : unit -> unit
  135. + val _qtyping : unit -> unit
  136. + val _qrawlambda : unit -> unit
  137. + val _qlambda : unit -> unit
  138. + val _qinstr : unit -> unit
  139. +
  140. val anonymous : string -> unit
  141. end;;
  142.  
  143. @@ -511,6 +541,12 @@ module type Bytetop_options = sig
  144. val _dlambda : unit -> unit
  145. val _dinstr : unit -> unit
  146.  
  147. + val _qparse : unit -> unit
  148. + val _qtyping : unit -> unit
  149. + val _qrawlambda : unit -> unit
  150. + val _qlambda : unit -> unit
  151. + val _qinstr : unit -> unit
  152. +
  153. val anonymous : string -> unit
  154. end;;
  155.  
  156. @@ -586,6 +622,12 @@ module type Optcomp_options = sig
  157. val _dlinear : unit -> unit
  158. val _dstartup : unit -> unit
  159.  
  160. + val _qparse : unit -> unit
  161. + val _qtyping : unit -> unit
  162. + val _qrawlambda : unit -> unit
  163. + val _qlambda : unit -> unit
  164. + val _qcmm : unit -> unit
  165. +
  166. val anonymous : string -> unit
  167. end;;
  168.  
  169. @@ -636,6 +678,12 @@ module type Opttop_options = sig
  170. val _dlinear : unit -> unit
  171. val _dstartup : unit -> unit
  172.  
  173. + val _qparse : unit -> unit
  174. + val _qtyping : unit -> unit
  175. + val _qrawlambda : unit -> unit
  176. + val _qlambda : unit -> unit
  177. + val _qcmm : unit -> unit
  178. +
  179. val anonymous : string -> unit
  180. end;;
  181.  
  182. @@ -711,6 +759,12 @@ struct
  183. mk_dlambda F._dlambda;
  184. mk_dinstr F._dinstr;
  185.  
  186. + mk_qparse F._qparse;
  187. + mk_qtyping F._qtyping;
  188. + mk_qrawlambda F._qrawlambda;
  189. + mk_qlambda F._qlambda;
  190. + mk_qinstr F._qinstr;
  191. +
  192. mk__ F.anonymous;
  193. ]
  194. end;;
  195. @@ -748,6 +802,12 @@ struct
  196. mk_dlambda F._dlambda;
  197. mk_dinstr F._dinstr;
  198.  
  199. + mk_qparse F._qparse;
  200. + mk_qtyping F._qtyping;
  201. + mk_qrawlambda F._qrawlambda;
  202. + mk_qlambda F._qlambda;
  203. + mk_qinstr F._qinstr;
  204. +
  205. mk__ F.anonymous;
  206. ]
  207. end;;
  208. @@ -827,6 +887,12 @@ struct
  209. mk_dlinear F._dlinear;
  210. mk_dstartup F._dstartup;
  211.  
  212. + mk_qparse F._qparse;
  213. + mk_qtyping F._qtyping;
  214. + mk_qrawlambda F._qrawlambda;
  215. + mk_qlambda F._qlambda;
  216. + mk_qcmm F._qcmm;
  217. +
  218. mk__ F.anonymous;
  219. ]
  220. end;;
  221. @@ -878,6 +944,12 @@ module Make_opttop_options (F : Opttop_options) = struct
  222. mk_dlinear F._dlinear;
  223. mk_dstartup F._dstartup;
  224.  
  225. + mk_qparse F._qparse;
  226. + mk_qtyping F._qtyping;
  227. + mk_qrawlambda F._qrawlambda;
  228. + mk_qlambda F._qlambda;
  229. + mk_qcmm F._qcmm;
  230. +
  231. mk__ F.anonymous;
  232. ]
  233. end;;
  234. diff --git a/driver/main_args.mli b/driver/main_args.mli
  235. index 6d431e7..73080d2 100644
  236. --- a/driver/main_args.mli
  237. +++ b/driver/main_args.mli
  238. @@ -71,6 +71,12 @@ module type Bytecomp_options =
  239. val _dlambda : unit -> unit
  240. val _dinstr : unit -> unit
  241.  
  242. + val _qparse : unit -> unit
  243. + val _qtyping : unit -> unit
  244. + val _qrawlambda : unit -> unit
  245. + val _qlambda : unit -> unit
  246. + val _qinstr : unit -> unit
  247. +
  248. val anonymous : string -> unit
  249. end
  250. ;;
  251. @@ -106,6 +112,12 @@ module type Bytetop_options = sig
  252. val _dlambda : unit -> unit
  253. val _dinstr : unit -> unit
  254.  
  255. + val _qparse : unit -> unit
  256. + val _qtyping : unit -> unit
  257. + val _qrawlambda : unit -> unit
  258. + val _qlambda : unit -> unit
  259. + val _qinstr : unit -> unit
  260. +
  261. val anonymous : string -> unit
  262. end;;
  263.  
  264. @@ -181,6 +193,12 @@ module type Optcomp_options = sig
  265. val _dlinear : unit -> unit
  266. val _dstartup : unit -> unit
  267.  
  268. + val _qparse : unit -> unit
  269. + val _qtyping : unit -> unit
  270. + val _qrawlambda : unit -> unit
  271. + val _qlambda : unit -> unit
  272. + val _qcmm : unit -> unit
  273. +
  274. val anonymous : string -> unit
  275. end;;
  276.  
  277. @@ -231,6 +249,12 @@ module type Opttop_options = sig
  278. val _dlinear : unit -> unit
  279. val _dstartup : unit -> unit
  280.  
  281. + val _qparse : unit -> unit
  282. + val _qtyping : unit -> unit
  283. + val _qrawlambda : unit -> unit
  284. + val _qlambda : unit -> unit
  285. + val _qcmm : unit -> unit
  286. +
  287. val anonymous : string -> unit
  288. end;;
  289.  
  290. diff --git a/driver/optcompile.ml b/driver/optcompile.ml
  291. index ebe2457..d07359a 100644
  292. --- a/driver/optcompile.ml
  293. +++ b/driver/optcompile.ml
  294. @@ -61,6 +61,9 @@ let print_if ppf flag printer arg =
  295. if !flag then fprintf ppf "%a@." printer arg;
  296. arg
  297.  
  298. +let quit_if flag arg =
  299. + if !flag then (Warnings.check_fatal (); exit 0) else arg
  300. +
  301. let (++) x f = f x
  302. let (+++) (x, y) f = (x, f y)
  303.  
  304. @@ -81,20 +84,26 @@ let implementation ppf sourcefile outputprefix =
  305. Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
  306. ++ print_if ppf Clflags.dump_parsetree Printast.implementation
  307. ++ print_if ppf Clflags.dump_source Pprintast.structure
  308. + ++ quit_if Clflags.quit_after_parse
  309. ++ Typemod.type_implementation sourcefile outputprefix modulename env
  310. ++ print_if ppf Clflags.dump_typedtree
  311. Printtyped.implementation_with_coercion
  312. + ++ quit_if Clflags.quit_after_typing
  313. end else begin
  314. Pparse.file ppf inputfile Parse.implementation ast_impl_magic_number
  315. ++ print_if ppf Clflags.dump_parsetree Printast.implementation
  316. ++ print_if ppf Clflags.dump_source Pprintast.structure
  317. + ++ quit_if Clflags.quit_after_parse
  318. ++ Typemod.type_implementation sourcefile outputprefix modulename env
  319. ++ print_if ppf Clflags.dump_typedtree
  320. Printtyped.implementation_with_coercion
  321. + ++ quit_if Clflags.quit_after_typing
  322. ++ Translmod.transl_store_implementation modulename
  323. +++ print_if ppf Clflags.dump_rawlambda Printlambda.lambda
  324. + +++ quit_if Clflags.quit_after_rawlambda
  325. +++ Simplif.simplify_lambda
  326. +++ print_if ppf Clflags.dump_lambda Printlambda.lambda
  327. + +++ quit_if Clflags.quit_after_lambda
  328. ++ Asmgen.compile_implementation outputprefix ppf;
  329. Compilenv.save_unit_info cmxfile;
  330. end;
  331. diff --git a/driver/optmain.ml b/driver/optmain.ml
  332. index 7571fca..ddfb9d0 100644
  333. --- a/driver/optmain.ml
  334. +++ b/driver/optmain.ml
  335. @@ -143,6 +143,12 @@ module Options = Main_args.Make_optcomp_options (struct
  336. let _dlinear = set dump_linear
  337. let _dstartup = set keep_startup_file
  338.  
  339. + let _qparse = set quit_after_parse
  340. + let _qtyping = set quit_after_typing
  341. + let _qrawlambda = set quit_after_rawlambda
  342. + let _qlambda = set quit_after_lambda
  343. + let _qcmm = set quit_after_cmm
  344. +
  345. let anonymous = anonymous
  346. end);;
  347.  
  348. diff --git a/tools/ocamlcp.ml b/tools/ocamlcp.ml
  349. index 67a2bae..9da3f46 100644
  350. --- a/tools/ocamlcp.ml
  351. +++ b/tools/ocamlcp.ml
  352. @@ -98,6 +98,13 @@ module Options = Main_args.Make_bytecomp_options (struct
  353. let _drawlambda = option "-drawlambda"
  354. let _dlambda = option "-dlambda"
  355. let _dinstr = option "-dinstr"
  356. +
  357. + let _qparse = option "-qparse"
  358. + let _qtyping = option "-qtyping"
  359. + let _qrawlambda = option "-qrawlambda"
  360. + let _qlambda = option "-qlambda"
  361. + let _qinstr = option "-qinstr"
  362. +
  363. let anonymous = process_file
  364. end);;
  365.  
  366. diff --git a/tools/ocamloptp.ml b/tools/ocamloptp.ml
  367. index 74d1314..c67bf40 100644
  368. --- a/tools/ocamloptp.ml
  369. +++ b/tools/ocamloptp.ml
  370. @@ -114,6 +114,12 @@ module Options = Main_args.Make_optcomp_options (struct
  371. let _dlinear = option "-dlinear"
  372. let _dstartup = option "-dstartup"
  373.  
  374. + let _qparse = option "-qparse"
  375. + let _qtyping = option "-qtyping"
  376. + let _qrawlambda = option "-qrawlambda"
  377. + let _qlambda = option "-qlambda"
  378. + let _qcmm = option "-qcmm"
  379. +
  380. let anonymous = process_file
  381. end);;
  382.  
  383. diff --git a/toplevel/topmain.ml b/toplevel/topmain.ml
  384. index 87c36d1..0812c52 100644
  385. --- a/toplevel/topmain.ml
  386. +++ b/toplevel/topmain.ml
  387. @@ -91,6 +91,12 @@ module Options = Main_args.Make_bytetop_options (struct
  388. let _dlambda = set dump_lambda
  389. let _dinstr = set dump_instr
  390.  
  391. + let _qparse = set quit_after_parse
  392. + let _qtyping = set quit_after_typing
  393. + let _qrawlambda = set quit_after_rawlambda
  394. + let _qlambda = set quit_after_lambda
  395. + let _qinstr = set quit_after_instr
  396. +
  397. let anonymous s = file_argument s
  398. end);;
  399.  
  400. diff --git a/utils/clflags.ml b/utils/clflags.ml
  401. index 4ff808f..564d3a7 100644
  402. --- a/utils/clflags.ml
  403. +++ b/utils/clflags.ml
  404. @@ -82,6 +82,13 @@ let dump_linear = ref false (* -dlinear *)
  405. let keep_startup_file = ref false (* -dstartup *)
  406. let dump_combine = ref false (* -dcombine *)
  407.  
  408. +let quit_after_parse = ref false
  409. +let quit_after_typing = ref false
  410. +let quit_after_rawlambda = ref false
  411. +let quit_after_lambda = ref false
  412. +let quit_after_instr = ref false
  413. +let quit_after_cmm = ref false
  414. +
  415. let native_code = ref false (* set to true under ocamlopt *)
  416. let inline_threshold = ref 10
  417. let force_slash = ref false (* for ocamldep *)
  418. diff --git a/utils/clflags.mli b/utils/clflags.mli
  419. index e671133..2866682 100644
  420. --- a/utils/clflags.mli
  421. +++ b/utils/clflags.mli
  422. @@ -76,6 +76,12 @@ val dump_scheduling : bool ref
  423. val dump_linear : bool ref
  424. val keep_startup_file : bool ref
  425. val dump_combine : bool ref
  426. +val quit_after_parse : bool ref
  427. +val quit_after_typing : bool ref
  428. +val quit_after_rawlambda : bool ref
  429. +val quit_after_lambda : bool ref
  430. +val quit_after_instr : bool ref
  431. +val quit_after_cmm : bool ref
  432. val native_code : bool ref
  433. val inline_threshold : int ref
  434. val dont_write_files : bool ref
Add Comment
Please, Sign In to add comment