diff --git a/CHANGES.md b/CHANGES.md index b2aa08bb1cc..eb2b339e870 100644 --- a/CHANGES.md +++ b/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) ------------------ diff --git a/src/preprocessing.ml b/src/preprocessing.ml index 6c1bb1d91f9..446157f8f64 100644 --- a/src/preprocessing.ml +++ b/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 diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t b/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t index 5c0ec1cd810..77710aec653 100644 --- a/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t +++ b/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 diff --git a/test/blackbox-tests/test-cases/js_of_ocaml/run.t b/test/blackbox-tests/test-cases/js_of_ocaml/run.t index 09e8590a847..0846bfdf2a0 100644 --- a/test/blackbox-tests/test-cases/js_of_ocaml/run.t +++ b/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} diff --git a/test/blackbox-tests/test-cases/merlin-tests/run.t b/test/blackbox-tests/test-cases/merlin-tests/run.t index ad36fc2cc20..3827c995f2b 100644 --- a/test/blackbox-tests/test-cases/merlin-tests/run.t +++ b/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 diff --git a/test/blackbox-tests/test-cases/ppx-rewriter/run.t b/test/blackbox-tests/test-cases/ppx-rewriter/run.t index d0a83b0af4c..94b8adc86ba 100644 --- a/test/blackbox-tests/test-cases/ppx-rewriter/run.t +++ b/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} diff --git a/test/blackbox-tests/test-cases/private-public-overlap/run.t b/test/blackbox-tests/test-cases/private-public-overlap/run.t index 0d2c6a08c2f..1034958c3b2 100644 --- a/test/blackbox-tests/test-cases/private-public-overlap/run.t +++ b/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] diff --git a/test/blackbox-tests/test-cases/scope-ppx-bug/run.t b/test/blackbox-tests/test-cases/scope-ppx-bug/run.t index baa9a810ae7..45b57e12585 100644 --- a/test/blackbox-tests/test-cases/scope-ppx-bug/run.t +++ b/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}