Fix hash collision once and for all

CHANGES.md

@@ -1,3 +1,9 @@
+next
+----
+
+- Fix hash collision for on-demand ppx rewriters once and for all
+  (#1602, fixes #1524, @diml)
+
 1.6.0 (29/11/2018)
 ------------------
 

src/preprocessing.ml

@@ -5,33 +5,43 @@ open Dune_file
 
 module SC = Super_context
 
-(* Encoded representation of a set of library names *)
+(* Encoded representation of a set of library names + scope *)
 module Key : sig
-  val encode
-    :  Context.t
-    -> dir_kind:Dune_lang.Syntax.t
-    -> Lib.t list
-    -> Digest.t
-
-  (* [decode s] fails if there hasn't been a previous call to [encode]
-     such that [encode ~dir_kind l = s]. *)
-  val decode : Context.t -> Digest.t -> Lib.t list
+  (* This module implements a bi-directional function between
+     [encoded] and [decoded] *)
+  type encoded = Digest.t
+  type decoded =
+    { pps   : Lib_name.t list
+    ; scope : Dune_project.Name.t option
+    }
+
+  val of_libs : dir_kind:Dune_lang.Syntax.t -> Lib.t list -> decoded
+
+  (* [decode y] fails if there hasn't been a previous call to [encode]
+     such that [encode x = y]. *)
+  val encode : decoded -> encoded
+  val decode : encoded -> decoded
 end = struct
-
-  let reverse_table = Hashtbl.create 128
-  let () = Hooks.End_of_build.always (fun () -> Hashtbl.reset reverse_table)
-
-  let encode (ctx : Context.t) ~dir_kind libs =
-    let libs =
-      let compare a b = Lib_name.compare (Lib.name a) (Lib.name b) in
-      match (dir_kind : Dune_lang.Syntax.t) with
-      | Dune -> List.sort libs ~compare
-      | Jbuild ->
-        match List.rev libs with
-        | last :: others -> List.sort others ~compare @ [last]
-        | [] -> []
+  type encoded = Digest.t
+  type decoded =
+    { pps   : Lib_name.t list
+    ; scope : Dune_project.Name.t option
+    }
+
+  let reverse_table : (encoded, decoded) Hashtbl.t = Hashtbl.create 128
+
+  let of_libs ~dir_kind libs =
+    let pps =
+      (let compare a b = Lib_name.compare (Lib.name a) (Lib.name b) in
+       match (dir_kind : Dune_lang.Syntax.t) with
+       | Dune -> List.sort libs ~compare
+       | Jbuild ->
+         match List.rev libs with
+         | last :: others -> List.sort others ~compare @ [last]
+         | [] -> [])
+      |> List.map ~f:Lib.name
     in
-    let scope_for_key =
+    let scope =
       List.fold_left libs ~init:None ~f:(fun acc lib ->
         let scope_for_key =
           match Lib.status lib with
@@ -45,52 +55,39 @@ end = struct
         | None  , Some _ -> scope_for_key
         | None  , None   -> None)
     in
-    let scope_key =
-      match scope_for_key with
-      | None -> ""
-      | Some name ->
-        match Dune_project.Name.to_encoded_string name with
-        | "" -> assert false
-        | s -> s
-    in
-    let key =
-      (scope_key
-       :: List.map libs ~f:(fun lib -> Lib.name lib |> Lib_name.to_string))
-      |> String.concat ~sep:"\000"
-      |> Digest.string
-    in
-    let full_key = (ctx.name, key) in
-    begin
-      match Hashtbl.find reverse_table full_key with
-      | None ->
-        Hashtbl.add reverse_table full_key libs
-      | Some libs' ->
-        match List.compare libs libs' ~compare:(fun a b ->
-          Int.compare (Lib.unique_id a) (Lib.unique_id b)) with
-        | Eq -> ()
-        | _ ->
-          let string_of_libs libs =
-            String.concat ~sep:", " (List.map libs ~f:(fun lib ->
-              sprintf "%s (in %s)"
-                (Lib_name.to_string (Lib.name lib))
-                (Path.to_string_maybe_quoted (Lib.src_dir lib))))
-          in
-          die "Hash collision between set of ppx drivers:\n\
-               - cache : %s\n\
-               - fetch : %s\n\
-               context: %s"
-            (string_of_libs libs)
-            (string_of_libs libs')
-            ctx.name
-    end;
-    key
-
-  let decode (ctx : Context.t) key =
-    match Hashtbl.find reverse_table (ctx.name, key) with
-    | Some libs -> libs
+    { pps; scope }
+
+  let encode x =
+    let y = Digest.string (Marshal.to_string x []) in
+    match Hashtbl.find reverse_table y with
+    | None ->
+      Hashtbl.add reverse_table y x;
+      y
+    | Some x' ->
+      if x = x' then
+        y
+      else begin
+        let to_string { pps; scope } =
+          let s = String.enumerate_and (List.map pps ~f:Lib_name.to_string) in
+          match scope with
+          | None -> s
+          | Some scope ->
+            sprintf "%s (in project: %s)" s
+              (Dune_project.Name.to_string_hum scope)
+        in
+        die "Hash collision between set of ppx drivers:\n\
+             - cache : %s\n\
+             - fetch : %s"
+          (to_string x')
+          (to_string x)
+      end
+
+  let decode y =
+    match Hashtbl.find reverse_table y with
+    | Some x -> x
     | None ->
       die "I don't know what ppx rewriters set %s correspond to."
-        (Digest.to_hex key)
+        (Digest.to_hex y)
 end
 
 let pped_path path ~suffix =
@@ -420,28 +417,36 @@ let build_ppx_driver sctx ~dep_kind ~target ~dir_kind ~pps ~pp_names =
 let get_rules sctx key ~dir_kind =
   let exe = ppx_exe sctx ~key ~dir_kind in
   let pps, pp_names =
-    match Digest.from_hex key with
-    | key ->
-      let pps = Key.decode (SC.context sctx) key in
-      (Ok pps, List.map pps ~f:Lib.name)
-    | exception _ ->
-      (* Still support the old scheme for backward compatibility *)
-      let (key, lib_db) = SC.Scope_key.of_string sctx key in
-      let names =
-        match key with
-        | "+none+" -> []
-        | _ -> String.split key ~on:'+'
-      in
-      let names =
-        match List.rev names with
-        | [] -> []
-        | driver :: rest -> List.sort rest ~compare:String.compare @ [driver]
-      in
-      let names = List.map names ~f:(Lib_name.of_string_exn ~loc:None) in
-      let pps =
-        Lib.DB.resolve_pps lib_db (List.map names ~f:(fun x -> (Loc.none, x)))
-      in
-      (pps, names)
+    let names, lib_db =
+      match Digest.from_hex key with
+      | key ->
+        let { Key.pps; scope } = Key.decode key in
+        let lib_db =
+          match scope with
+          | None -> SC.public_libs sctx
+          | Some name -> Scope.libs (SC.find_scope_by_name sctx name)
+        in
+        (pps, lib_db)
+      | exception _ ->
+        (* Still support the old scheme for backward compatibility *)
+        let (key, lib_db) = SC.Scope_key.of_string sctx key in
+        let names =
+          match key with
+          | "+none+" -> []
+          | _ -> String.split key ~on:'+'
+        in
+        let names =
+          match List.rev names with
+          | [] -> []
+          | driver :: rest -> List.sort rest ~compare:String.compare @ [driver]
+        in
+        let names = List.map names ~f:(Lib_name.of_string_exn ~loc:None) in
+        (names, lib_db)
+    in
+    let pps =
+      Lib.DB.resolve_pps lib_db (List.map names ~f:(fun x -> (Loc.none, x)))
+    in
+    (pps, names)
   in
   build_ppx_driver sctx ~pps ~pp_names ~dep_kind:Required ~target:exe ~dir_kind
 
@@ -452,7 +457,7 @@ let gen_rules sctx components =
   | _ -> ()
 
 let ppx_driver_exe sctx libs ~dir_kind =
-  let key = Digest.to_hex (Key.encode (SC.context sctx) ~dir_kind libs) in
+  let key = Digest.to_hex (Key.of_libs ~dir_kind libs |> Key.encode) in
   ppx_exe sctx ~key ~dir_kind
 
 module Compat_ppx_exe_kind = struct

test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t

@@ -48,7 +48,7 @@ Test the argument syntax
 
   $ dune build test_ppx_args.cma
            ppx test_ppx_args.pp.ml
-  .ppx/69cada8dd199103fc89e225db10f626e/ppx.exe
+  .ppx/eb9468425030036114a3b9ffa4c89e4d/ppx.exe
   -arg1
   -arg2
   -foo

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

@@ -1,7 +1,7 @@
   $ dune build --display short bin/technologic.bc.js @install
         ocamlc lib/stubs$ext_obj
     ocamlmklib lib/dllx_stubs$ext_dll,lib/libx_stubs$ext_lib
-      ocamlopt .ppx/a8f6e02cd408c15255989a8e8e17529e/ppx.exe
+      ocamlopt .ppx/3edf09989a28fce237f8b735bd39446a/ppx.exe
            ppx lib/x.pp.ml
       ocamldep lib/.x.objs/x.pp.ml.d
         ocamlc lib/.x.objs/x__.{cmi,cmo,cmt}

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

@@ -30,7 +30,7 @@
   S $LIB_PREFIX/lib/ocaml
   S .
   S subdir
-  FLG -ppx '$PPX/2bf184f0d30fb809b587a965d82ab3a5/ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
+  FLG -ppx '$PPX/828e4b66a2fd80eb3721c549ea6f718d/ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
   FLG -open Foo -w -40 -open Bar -w -40
 
 Make sure a ppx directive is generated

test/blackbox-tests/test-cases/ppx-rewriter/run.t

@@ -3,7 +3,7 @@
         ocamlc ppx/.fooppx.objs/fooppx.{cmi,cmo,cmt}
       ocamlopt ppx/.fooppx.objs/fooppx.{cmx,o}
       ocamlopt ppx/fooppx.{a,cmxa}
-      ocamlopt .ppx/jbuild/f659d13f55bdcc8a6ad052ed2f063a39/ppx.exe
+      ocamlopt .ppx/jbuild/a0597253d899c1b15660d5431f244d21/ppx.exe
            ppx w_omp_driver.pp.ml
       ocamldep .w_omp_driver.eobjs/w_omp_driver.pp.ml.d
         ocamlc .w_omp_driver.eobjs/w_omp_driver.{cmi,cmo,cmt}

test/blackbox-tests/test-cases/private-public-overlap/run.t

@@ -16,7 +16,7 @@ On the other hand, public libraries may have private preprocessors
         ocamlc .ppx_internal.objs/ppx_internal.{cmi,cmo,cmt}
       ocamlopt .ppx_internal.objs/ppx_internal.{cmx,o}
       ocamlopt ppx_internal.{a,cmxa}
-      ocamlopt .ppx/jbuild/921712b1732a132ab3f4b45ec1cfe88f/ppx.exe
+      ocamlopt .ppx/jbuild/a55edf08f347158c59e28648f66f5be3/ppx.exe
            ppx mylib.pp.ml
       ocamldep .mylib.objs/mylib.pp.ml.d
         ocamlc .mylib.objs/mylib.{cmi,cmo,cmt}
@@ -36,7 +36,7 @@ Unless they introduce private runtime dependencies:
         ocamlc .private_ppx.objs/private_ppx.{cmi,cmo,cmt}
       ocamlopt .private_ppx.objs/private_ppx.{cmx,o}
       ocamlopt private_ppx.{a,cmxa}
-      ocamlopt .ppx/jbuild/0b390523eab319d07b4852b0a6a66bed/ppx.exe
+      ocamlopt .ppx/jbuild/3e9c40969655ac7a27e8982841adf043/ppx.exe
            ppx mylib.pp.ml
       ocamldep .mylib.objs/mylib.pp.ml.d
   [1]

test/blackbox-tests/test-cases/scope-ppx-bug/run.t

@@ -11,7 +11,7 @@
         ocamlc a/kernel/a_kernel.cma
       ocamlopt .ppx/jbuild/a.kernel/ppx.exe
       ocamlopt .ppx/jbuild/a/ppx.exe
-      ocamlopt .ppx/jbuild/760f753576f2955b0074758acb4d5fa6/ppx.exe
+      ocamlopt .ppx/jbuild/631b31a68eb10e1850cf7721d41e5b84/ppx.exe
            ppx b/b.pp.ml
       ocamldep b/.b.objs/b.pp.ml.d
         ocamlc b/.b.objs/b.{cmi,cmo,cmt}