From 48e078cfdb2049e20b5aa387f267e73e507dba72 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Bour?= Date: Fri, 3 Apr 2020 10:57:53 +0200 Subject: [PATCH 1/4] Add failing test of typechecker caching policy --- tests/dune.inc | 15 +++ tests/test-dirs/typer-cache/sub/dep.ml | 0 tests/test-dirs/typer-cache/test.ml | 1 + tests/test-dirs/typer-cache/test.t | 171 +++++++++++++++++++++++++ 4 files changed, 187 insertions(+) create mode 100644 tests/test-dirs/typer-cache/sub/dep.ml create mode 100644 tests/test-dirs/typer-cache/test.ml create mode 100644 tests/test-dirs/typer-cache/test.t diff --git a/tests/dune.inc b/tests/dune.inc index c677ee5da0..d3d9bfdae5 100644 --- a/tests/dune.inc +++ b/tests/dune.inc @@ -1124,6 +1124,21 @@ (diff? %{t} %{t}.corrected))))))) (alias (name runtest) (deps (alias type-expr-test))) +(alias + (name typer-cache-test) + (deps (:t ./test-dirs/typer-cache/test.t) + (source_tree ./test-dirs/typer-cache) + %{bin:ocamlmerlin} + %{bin:ocamlmerlin-server}) + (action + (chdir ./test-dirs/typer-cache + (setenv MERLIN %{exe:merlin-wrapper} + (setenv OCAMLC %{ocamlc} + (progn + (run %{bin:mdx} test --syntax=cram %{t}) + (diff? %{t} %{t}.corrected))))))) +(alias (name runtest) (deps (alias typer-cache-test))) + (alias (name warnings-backtrack) (deps (:t ./test-dirs/warnings/backtrack.t) diff --git a/tests/test-dirs/typer-cache/sub/dep.ml b/tests/test-dirs/typer-cache/sub/dep.ml new file mode 100644 index 0000000000..e69de29bb2 diff --git a/tests/test-dirs/typer-cache/test.ml b/tests/test-dirs/typer-cache/test.ml new file mode 100644 index 0000000000..2c75085cab --- /dev/null +++ b/tests/test-dirs/typer-cache/test.ml @@ -0,0 +1 @@ +open Dep diff --git a/tests/test-dirs/typer-cache/test.t b/tests/test-dirs/typer-cache/test.t new file mode 100644 index 0000000000..0dfe02a59c --- /dev/null +++ b/tests/test-dirs/typer-cache/test.t @@ -0,0 +1,171 @@ +Instances of the typechecker are cached based on configuration +(values of type `Mconfig.t`). + +Older versions of Merlin ignored some components resulting in possible +mismatches between the internal configuration of the typechecker (loadpath, +global modules visible from the environment) and Merlin configuration. + +For instance, `-package` and `-cmi-path` were ignored. + +The server might already be running, we kill it to make sure we start from a +clean slate: + + $ $MERLIN server stop-server + +We build a dep which we will be revealed to Merlin later: + + $ $OCAMLC -c sub/dep.ml + +First try with dep hidden: + + $ $MERLIN server errors -filename test.ml < test.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 5 + }, + "end": { + "line": 1, + "col": 8 + }, + "type": "typer", + "sub": [], + "valid": true, + "message": "Unbound module Dep" + } + ], + "notifications": [] + } + +For reference, the answer in single mode: + + $ $MERLIN single errors -filename test.ml < test.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 5 + }, + "end": { + "line": 1, + "col": 8 + }, + "type": "typer", + "sub": [], + "valid": true, + "message": "Unbound module Dep" + } + ], + "notifications": [] + } + + +We try again after revealing the dependency: + + $ $MERLIN server errors -filename test.ml -cmi-path sub < test.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 5 + }, + "end": { + "line": 1, + "col": 8 + }, + "type": "typer", + "sub": [], + "valid": true, + "message": "Unbound module Dep" + } + ], + "notifications": [] + } + + +Reference: + + $ $MERLIN single errors -filename test.ml -cmi-path sub < test.ml + { + "class": "return", + "value": [], + "notifications": [] + } + + +Well behaving versions of Merlin (>= 3.3.4) of should return the same answer as +reference. + +We should check in the other direction too. Starting from a visible dep and +hidding it. Older versions of the typechecker (before the 4.08 revamp of Env) +would accumulate dependencies and forget to flush the cache when a dependency +disappeared. + + $ $MERLIN server stop-server + + +Visible: + + $ $MERLIN server errors -filename test.ml -cmi-path sub < test.ml + { + "class": "return", + "value": [], + "notifications": [] + } + + +Reference: + + $ $MERLIN single errors -filename test.ml -cmi-path sub < test.ml + { + "class": "return", + "value": [], + "notifications": [] + } + + +Hidden: + + $ $MERLIN server errors -filename test.ml < test.ml + { + "class": "return", + "value": [], + "notifications": [] + } + + +Reference: + + $ $MERLIN single errors -filename test.ml < test.ml + { + "class": "return", + "value": [ + { + "start": { + "line": 1, + "col": 5 + }, + "end": { + "line": 1, + "col": 8 + }, + "type": "typer", + "sub": [], + "valid": true, + "message": "Unbound module Dep" + } + ], + "notifications": [] + } + + +Now some cleanup. + + $ rm sub/dep.cm* From 3fcdefb7ebcbec85d17326a91563b1735155b05d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Bour?= Date: Fri, 3 Apr 2020 10:58:18 +0200 Subject: [PATCH 2/4] Mpipeline: fix typechecker caching policy --- src/kernel/mpipeline.ml | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index 9cd0a32cbd..3d74adaed4 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -24,9 +24,7 @@ module Cache = struct let get config = let title = "pop_cache" in - let key = - Mconfig.(config.query.directory, config.query.filename, config.ocaml) - in + let key = config in match List.assoc key !cache with | state -> cache := (key, state) :: List.remove_assoc key !cache; From fcf86ab94caa46c88093c8c66b6ca5174e5a3071 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Bour?= Date: Fri, 3 Apr 2020 11:10:09 +0200 Subject: [PATCH 3/4] Fix typer-cache test --- tests/test-dirs/typer-cache/test.t | 34 +++++++++++++++--------------- 1 file changed, 17 insertions(+), 17 deletions(-) diff --git a/tests/test-dirs/typer-cache/test.t b/tests/test-dirs/typer-cache/test.t index 0dfe02a59c..02f2649409 100644 --- a/tests/test-dirs/typer-cache/test.t +++ b/tests/test-dirs/typer-cache/test.t @@ -70,22 +70,7 @@ We try again after revealing the dependency: $ $MERLIN server errors -filename test.ml -cmi-path sub < test.ml { "class": "return", - "value": [ - { - "start": { - "line": 1, - "col": 5 - }, - "end": { - "line": 1, - "col": 8 - }, - "type": "typer", - "sub": [], - "valid": true, - "message": "Unbound module Dep" - } - ], + "value": [], "notifications": [] } @@ -136,7 +121,22 @@ Hidden: $ $MERLIN server errors -filename test.ml < test.ml { "class": "return", - "value": [], + "value": [ + { + "start": { + "line": 1, + "col": 5 + }, + "end": { + "line": 1, + "col": 8 + }, + "type": "typer", + "sub": [], + "valid": true, + "message": "Unbound module Dep" + } + ], "notifications": [] } From e3e7193185daa3d18f8bd62fbb3e2018229cc343 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Fr=C3=A9d=C3=A9ric=20Bour?= Date: Fri, 3 Apr 2020 11:36:39 +0200 Subject: [PATCH 4/4] Finer keyed caching --- src/kernel/mpipeline.ml | 28 +++++++++++++++++++++++++++- 1 file changed, 27 insertions(+), 1 deletion(-) diff --git a/src/kernel/mpipeline.ml b/src/kernel/mpipeline.ml index 3d74adaed4..c835cf95ef 100644 --- a/src/kernel/mpipeline.ml +++ b/src/kernel/mpipeline.ml @@ -22,9 +22,35 @@ let timed_lazy r x = module Cache = struct let cache = ref [] + (* Values from configuration that are used as a key for the cache. + These values should: + - allow to maximize reuse; associating a single typechecker instance to a + filename and directory is natural, but keying also based on verbosity + makes no sense + - prevent reuse in different environments (if there is a change in + loadpath, a new typechecker should be produced). + + It would be better to guarantee that the typechecker was well-behaved + when the loadpath changes (so that we can reusing the same instance, and + let the typechecker figure which part of its internal state should be + invalidated). + However we already had many bug related to that. There are subtle changes + in the type checker behavior accross the different versions of OCaml. + It is simpler to create new instances upfront. + *) + + let key config = + Mconfig.( + config.query.filename, + config.query.directory, + config.ocaml, + config.findlib, + {config.merlin with log_file = None; log_sections = []} + ) + let get config = let title = "pop_cache" in - let key = config in + let key = key config in match List.assoc key !cache with | state -> cache := (key, state) :: List.remove_assoc key !cache;