package / ocaml-base-compiler.4.10.0 / driver / compile_common.ml
1 (**************************************************************************)
2 (* *)
3 (* OCaml *)
4 (* *)
5 (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *)
6 (* *)
7 (* Copyright 1996 Institut National de Recherche en Informatique et *)
8 (* en Automatique. *)
9 (* *)
10 (* All rights reserved. This file is distributed under the terms of *)
11 (* the GNU Lesser General Public License version 2.1, with the *)
12 (* special exception on linking described in the file LICENSE. *)
13 (* *)
14 (**************************************************************************)
15
16 open Misc
17 open Compenv
18
19 type info = {
20 source_file : string;
21 module_name : string;
22 output_prefix : string;
23 env : Env.t;
24 ppf_dump : Format.formatter;
25 tool_name : string;
26 native : bool;
27 }
28
29 let cmx i = i.output_prefix ^ ".cmx"
30 let obj i = i.output_prefix ^ Config.ext_obj
31 let cmo i = i.output_prefix ^ ".cmo"
32 let annot i = i.output_prefix ^ ".annot"
33
34 let with_info ~native ~tool_name ~source_file ~output_prefix ~dump_ext k =
35 Compmisc.init_path ();
36 let module_name = module_of_filename source_file output_prefix in
37 Env.set_unit_name module_name;
38 let env = Compmisc.initial_env() in
39 let dump_file = String.concat "." [output_prefix; dump_ext] in
40 Compmisc.with_ppf_dump ~file_prefix:dump_file @@ fun ppf_dump ->
41 k {
42 module_name;
43 output_prefix;
44 env;
45 source_file;
46 ppf_dump;
47 tool_name;
48 native;
49 }
50
51 (** Compile a .mli file *)
52
53 let parse_intf i =
54 Pparse.parse_interface ~tool_name:i.tool_name i.source_file
55 |> print_if i.ppf_dump Clflags.dump_parsetree Printast.interface
56 |> print_if i.ppf_dump Clflags.dump_source Pprintast.signature
57
58 let typecheck_intf info ast =
59 Profile.(record_call typing) @@ fun () ->
60 let tsg =
61 ast
62 |> Typemod.type_interface info.env
63 |> print_if info.ppf_dump Clflags.dump_typedtree Printtyped.interface
64 in
65 let sg = tsg.Typedtree.sig_type in
66 if !Clflags.print_types then
67 Printtyp.wrap_printing_env ~error:false info.env (fun () ->
68 Format.(fprintf std_formatter) "%a@."
69 (Printtyp.printed_signature info.source_file)
70 sg);
71 ignore (Includemod.signatures info.env sg sg);
72 Typecore.force_delayed_checks ();
73 Warnings.check_fatal ();
74 tsg
75
76 let emit_signature info ast tsg =
77 let sg =
78 let alerts = Builtin_attributes.alerts_of_sig ast in
79 Env.save_signature ~alerts tsg.Typedtree.sig_type
80 info.module_name (info.output_prefix ^ ".cmi")
81 in
82 Typemod.save_signature info.module_name tsg
83 info.output_prefix info.source_file info.env sg
84
85 let interface info =
86 Profile.record_call info.source_file @@ fun () ->
87 let ast = parse_intf info in
88 if Clflags.(should_stop_after Compiler_pass.Parsing) then () else begin
89 let tsg = typecheck_intf info ast in
90 if not !Clflags.print_types then begin
91 emit_signature info ast tsg
92 end
93 end
94
95
96 (** Frontend for a .ml file *)
97
98 let parse_impl i =
99 Pparse.parse_implementation ~tool_name:i.tool_name i.source_file
100 |> print_if i.ppf_dump Clflags.dump_parsetree Printast.implementation
101 |> print_if i.ppf_dump Clflags.dump_source Pprintast.structure
102
103 let typecheck_impl i parsetree =
104 let always () = Stypes.dump (Some (annot i)) in
105 Misc.try_finally ~always (fun () ->
106 parsetree
107 |> Profile.(record typing)
108 (Typemod.type_implementation
109 i.source_file i.output_prefix i.module_name i.env)
110 |> print_if i.ppf_dump Clflags.dump_typedtree
111 Printtyped.implementation_with_coercion
112 )
113
114 let implementation info ~backend =
115 Profile.record_call info.source_file @@ fun () ->
116 let exceptionally () =
117 let sufs = if info.native then [ cmx; obj ] else [ cmo ] in
118 List.iter (fun suf -> remove_file (suf info)) sufs;
119 in
120 Misc.try_finally ?always:None ~exceptionally (fun () ->
121 let parsed = parse_impl info in
122 if Clflags.(should_stop_after Compiler_pass.Parsing) then () else begin
123 let typed = typecheck_impl info parsed in
124 if Clflags.(should_stop_after Compiler_pass.Typing) then () else begin
125 backend info typed
126 end;
127 end;
128 Warnings.check_fatal ();
129 )
130