Skip to content

Commit

Permalink
flambda-backend: Use hooks for type tree and parse tree (ocaml#363)
Browse files Browse the repository at this point in the history
Co-authored-by: Mark Shinwell <mshinwell@gmail.com>
Co-authored-by: Xavier Clerc <xclerc@janestreet.com>
  • Loading branch information
3 people authored Nov 8, 2021
1 parent 33bbc93 commit 82c8086
Show file tree
Hide file tree
Showing 4 changed files with 31 additions and 8 deletions.
11 changes: 9 additions & 2 deletions driver/compile.ml
Original file line number Diff line number Diff line change
Expand Up @@ -23,7 +23,10 @@ let with_info =

let interface ~source_file ~output_prefix =
with_info ~source_file ~output_prefix ~dump_ext:"cmi" @@ fun info ->
Compile_common.interface info
Compile_common.interface
~hook_parse_tree:(fun _ -> ())
~hook_typed_tree:(fun _ -> ())
info

(** Bytecode compilation backend for .ml files. *)

Expand Down Expand Up @@ -61,6 +64,10 @@ let implementation ~start_from ~source_file ~output_prefix =
in
with_info ~source_file ~output_prefix ~dump_ext:"cmo" @@ fun info ->
match (start_from : Clflags.Compiler_pass.t) with
| Parsing -> Compile_common.implementation info ~backend
| Parsing ->
Compile_common.implementation
~hook_parse_tree:(fun _ -> ())
~hook_typed_tree:(fun _ -> ())
info ~backend
| _ -> Misc.fatal_errorf "Cannot start from %s"
(Clflags.Compiler_pass.to_string start_from)
8 changes: 6 additions & 2 deletions driver/compile_common.ml
Original file line number Diff line number Diff line change
Expand Up @@ -81,11 +81,13 @@ let emit_signature info ast tsg =
Typemod.save_signature info.module_name tsg
info.output_prefix info.source_file info.env sg

let interface info =
let interface ~hook_parse_tree ~hook_typed_tree info =
Profile.record_call info.source_file @@ fun () ->
let ast = parse_intf info in
hook_parse_tree ast;
if Clflags.(should_stop_after Compiler_pass.Parsing) then () else begin
let tsg = typecheck_intf info ast in
hook_typed_tree tsg;
if not !Clflags.print_types then begin
emit_signature info ast tsg
end
Expand All @@ -107,16 +109,18 @@ let typecheck_impl i parsetree =
|> print_if i.ppf_dump Clflags.dump_typedtree
Printtyped.implementation_with_coercion

let implementation info ~backend =
let implementation ~hook_parse_tree ~hook_typed_tree info ~backend =
Profile.record_call info.source_file @@ fun () ->
let exceptionally () =
let sufs = if info.native then [ cmx; obj ] else [ cmo ] in
List.iter (fun suf -> remove_file (suf info)) sufs;
in
Misc.try_finally ?always:None ~exceptionally (fun () ->
let parsed = parse_impl info in
hook_parse_tree parsed;
if Clflags.(should_stop_after Compiler_pass.Parsing) then () else begin
let typed = typecheck_impl info parsed in
hook_typed_tree typed;
if Clflags.(should_stop_after Compiler_pass.Typing) then () else begin
backend info typed
end;
Expand Down
9 changes: 7 additions & 2 deletions driver/compile_common.mli
Original file line number Diff line number Diff line change
Expand Up @@ -60,7 +60,10 @@ val emit_signature : info -> Parsetree.signature -> Typedtree.signature -> unit
containing the given signature.
*)

val interface : info -> unit
val interface :
hook_parse_tree:(Parsetree.signature -> unit)
-> hook_typed_tree:(Typedtree.signature -> unit)
-> info -> unit
(** The complete compilation pipeline for interfaces. *)

(** {2 Implementations} *)
Expand All @@ -76,7 +79,9 @@ val typecheck_impl :
*)

val implementation :
info ->
hook_parse_tree:(Parsetree.structure -> unit)
-> hook_typed_tree:(Typedtree.structure * Typedtree.module_coercion -> unit)
-> info ->
backend:(info -> Typedtree.structure * Typedtree.module_coercion -> unit) ->
unit
(** The complete compilation pipeline for implementations. *)
Expand Down
11 changes: 9 additions & 2 deletions driver/optcompile.ml
Original file line number Diff line number Diff line change
Expand Up @@ -25,7 +25,10 @@ let with_info =

let interface ~source_file ~output_prefix =
with_info ~source_file ~output_prefix ~dump_ext:"cmi" @@ fun info ->
Compile_common.interface info
Compile_common.interface
~hook_parse_tree:(fun _ -> ())
~hook_typed_tree:(fun _ -> ())
info

let (|>>) (x, y) f = (x, f y)

Expand Down Expand Up @@ -93,7 +96,11 @@ let implementation ~backend ~start_from ~source_file ~output_prefix =
in
with_info ~source_file ~output_prefix ~dump_ext:"cmx" @@ fun info ->
match (start_from:Clflags.Compiler_pass.t) with
| Parsing -> Compile_common.implementation info ~backend
| Parsing ->
Compile_common.implementation
~hook_parse_tree:(fun _ -> ())
~hook_typed_tree:(fun _ -> ())
info ~backend
| Emit -> emit info
| _ -> Misc.fatal_errorf "Cannot start from %s"
(Clflags.Compiler_pass.to_string start_from)

0 comments on commit 82c8086

Please sign in to comment.