flambda-backend: Use hooks for type tree and parse tree (#363)

Co-authored-by: Mark Shinwell <[email protected]>
Co-authored-by: Xavier Clerc <[email protected]>

Author: 3 people

driver/compile.ml

@@ -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. *)
 
@@ -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)

driver/compile_common.ml

@@ -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
@@ -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;

driver/compile_common.mli

@@ -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} *)
@@ -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. *)

driver/optcompile.ml

@@ -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)
 
@@ -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)