Speed up merlin generation (#805)

Improve merlin generation by minimizing intermediate strings and reusing a buffer.

src/merlin.ml

@@ -31,6 +31,37 @@ module Preprocess = struct
       | _  -> Other
 end
 
+module Dot_file = struct
+  let b = Buffer.create 256
+
+  let printf = Printf.bprintf b
+  let print = Buffer.add_string b
+
+  let to_string ~obj_dirs ~src_dirs ~flags ~ppx ~remaindir =
+    let serialize_path = Path.reach ~from:remaindir in
+    Buffer.clear b;
+    Path.Set.iter obj_dirs ~f:(fun p ->
+      printf "B %s\n" (serialize_path p));
+    Path.Set.iter src_dirs ~f:(fun p ->
+      printf "S %s\n" (serialize_path p));
+    begin match ppx with
+    | [] -> ()
+    | ppx ->
+      printf "FLG -ppx %s\n"
+        (List.map ppx ~f:quote_for_shell
+         |> String.concat ~sep:" "
+         |> Filename.quote)
+    end;
+    begin match flags with
+    | [] -> ()
+    | flags ->
+      print "FLG";
+      List.iter flags ~f:(fun f -> printf " %s" (quote_for_shell f));
+      print "\n"
+    end;
+    Buffer.contents b
+end
+
 type t =
   { requires   : Lib.Set.t
   ; flags      : (unit, string list) Build.t
@@ -69,19 +100,15 @@ let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } =
   match preprocess with
   | Pps { pps; flags } ->
     let exe = Preprocessing.get_ppx_driver sctx ~scope pps in
-    let command =
+    (Path.to_absolute_filename exe ~root:!Clflags.workspace_root
-      List.map (Path.to_absolute_filename exe ~root:!Clflags.workspace_root
+     :: "--as-ppx"
-                :: "--as-ppx"
+     :: Preprocessing.cookie_library_name libname
-                :: Preprocessing.cookie_library_name libname
+     @ flags)
-                @ flags)
-        ~f:quote_for_shell
-      |> String.concat ~sep:" "
-    in
-    [sprintf "FLG -ppx %s" (Filename.quote command)]
   | Other -> []
 
 let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) =
   match Path.drop_build_context dir with
+  | None -> ()
   | Some remaindir ->
     let merlin_file = Path.relative dir ".merlin" in
     (* We make the compilation of .ml/.mli files depend on the
@@ -99,57 +126,22 @@ let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) =
     SC.add_rule sctx ~mode:Promote_but_delete_on_clean (
       flags
       >>^ (fun flags ->
-        let ppx_flags = ppx_flags sctx ~dir ~scope ~src_dir:remaindir t in
+        let (src_dirs, obj_dirs) =
-        let libs =
+          Lib.Set.fold requires ~init:(Path.Set.empty, Path.Set.empty)
-          Lib.Set.fold requires ~init:[] ~f:(fun (lib : Lib.t) acc ->
+            ~f:(fun (lib : Lib.t) (src_dirs, build_dirs) ->
-            let serialize_path = Path.reach ~from:remaindir in
+              ( Path.Set.add src_dirs (Lib.src_dir lib)
-            let bpath = serialize_path (Lib.obj_dir lib) in
+              , Path.Set.add build_dirs (
-            let spath =
+                  Lib.obj_dir lib
-              Lib.src_dir lib
+                  |> Path.drop_optional_build_context)))
-              |> Path.drop_optional_build_context
-              |> serialize_path
-            in
-            ("B " ^ bpath) :: ("S " ^ spath) :: acc
-          )
         in
-        let source_dirs =
+        Dot_file.to_string
-          Path.Set.fold t.source_dirs ~init:[] ~f:(fun path acc ->
+          ~remaindir
-            let path = Path.reach path ~from:remaindir in
+          ~ppx:(ppx_flags sctx ~dir ~scope ~src_dir:remaindir t)
-            ("S " ^ path)::acc
+          ~flags
-          )
+          ~src_dirs:(Path.Set.union src_dirs t.source_dirs)
-        in
+          ~obj_dirs:(Path.Set.union obj_dirs t.objs_dirs))
-        let objs_dirs =
-          Path.Set.fold t.objs_dirs ~init:[] ~f:(fun path acc ->
-            let path = Path.reach path ~from:remaindir in
-            ("B " ^ path)::acc
-          )
-        in
-        let flags =
-          match flags with
-          | [] -> []
-          | _  ->
-            let escaped_flags = List.map ~f:quote_for_shell flags in
-            ["FLG " ^ String.concat escaped_flags ~sep:" "]
-        in
-        let dot_merlin =
-          List.concat
-            [ source_dirs
-            ; objs_dirs
-            ; libs
-            ; flags
-            ; ppx_flags
-            ]
-        in
-        dot_merlin
-        |> String.Set.of_list
-        |> String.Set.to_list
-        |> List.map ~f:(Printf.sprintf "%s\n")
-        |> String.concat ~sep:"")
       >>>
-      Build.write_file_dyn merlin_file
+      Build.write_file_dyn merlin_file)
-    )
-  | _ ->
-    ()
 
 let merge_two a b =
   { requires = Lib.Set.union a.requires b.requires

test/blackbox-tests/test-cases/github759/run.t

@@ -1,17 +1,17 @@
   $ jbuilder build foo.cma
   $ cat .merlin
   B _build/default/.foo.objs
-  FLG -open Foo -w -40
   S .
+  FLG -open Foo -w -40
   $ rm -f .merlin
   $ jbuilder build foo.cma
   $ cat .merlin
   B _build/default/.foo.objs
-  FLG -open Foo -w -40
   S .
+  FLG -open Foo -w -40
   $ echo toto > .merlin
   $ jbuilder build foo.cma
   $ cat .merlin
   B _build/default/.foo.objs
-  FLG -open Foo -w -40
   S .
+  FLG -open Foo -w -40

test/blackbox-tests/test-cases/merlin-tests/run.t

@@ -5,29 +5,29 @@
       ocamlopt sanitize-dot-merlin/sanitize_dot_merlin.exe
   sanitize_dot_merlin alias print-merlins
   # Processing exe/.merlin
-  B ../_build/default/exe/.x.eobjs
-  B ../_build/default/lib/.foo.objs
   B $LIB_PREFIX/lib/bytes
   B $LIB_PREFIX/lib/findlib
   B $LIB_PREFIX/lib/ocaml
-  FLG -w -40
+  B ../_build/default/exe/.x.eobjs
-  S .
+  B ../lib/.foo.objs
-  S ../lib
   S $LIB_PREFIX/lib/bytes
   S $LIB_PREFIX/lib/findlib
   S $LIB_PREFIX/lib/ocaml
+  S ../_build/default/lib
+  S .
+  FLG -w -40
   # Processing lib/.merlin
+  B $LIB_PREFIX/lib/bytes
+  B $LIB_PREFIX/lib/findlib
+  B $LIB_PREFIX/lib/ocaml
   B ../_build/default/lib/.bar.objs
   B ../_build/default/lib/.foo.objs
-  B $LIB_PREFIX/lib/bytes
-  B $LIB_PREFIX/lib/findlib
-  B $LIB_PREFIX/lib/ocaml
-  FLG -open Foo -w -40 -open Bar -w -40
-  FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
-  S .
   S $LIB_PREFIX/lib/bytes
   S $LIB_PREFIX/lib/findlib
   S $LIB_PREFIX/lib/ocaml
+  S .
+  FLG -ppx '$PPX/fooppx@./ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
+  FLG -open Foo -w -40 -open Bar -w -40
 
 Make sure a ppx directive is generated