Skip to content

Commit 4352708

Browse files
committed
get rid of global locks in favor of domain local caches
1 parent 4d74fcc commit 4352708

File tree

7 files changed

+109
-95
lines changed

7 files changed

+109
-95
lines changed

analysis/bin/main.ml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -119,7 +119,7 @@ let main () =
119119
| [_; "cache-delete"; rootPath] -> (
120120
Cfg.readProjectConfigCache := false;
121121
let uri = Uri.fromPath rootPath in
122-
match Packages.findRoot ~uri (Hashtbl.create 0) with
122+
match Packages.findRoot ~uri with
123123
| Some (`Bs rootPath) -> (
124124
match BuildSystem.getLibBs rootPath with
125125
| None -> print_endline "\"ERR\""

analysis/src/AnalysisCache.ml

Lines changed: 7 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,7 @@
1+
(* Helpers for domain-local caches *)
2+
3+
let make_hashtbl (size : int) : ('k, 'v) Hashtbl.t Domain.DLS.key =
4+
Domain.DLS.new_key (fun () -> Hashtbl.create size)
5+
6+
let get_hashtbl (key : ('k, 'v) Hashtbl.t Domain.DLS.key) : ('k, 'v) Hashtbl.t =
7+
Domain.DLS.get key

analysis/src/Cmt.ml

Lines changed: 54 additions & 28 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,12 @@
11
open SharedTypes
22

3+
module FullCache = struct
4+
let key : (string, full) Hashtbl.t Domain.DLS.key =
5+
AnalysisCache.make_hashtbl 64
6+
7+
let get () : (string, full) Hashtbl.t = AnalysisCache.get_hashtbl key
8+
end
9+
310
let fullForCmt ~moduleName ~package ~uri cmt =
411
match Shared.tryReadCmt cmt with
512
| None -> None
@@ -8,45 +15,64 @@ let fullForCmt ~moduleName ~package ~uri cmt =
815
let extra = ProcessExtra.getExtra ~file ~infos in
916
Some {file; extra; package}
1017

11-
let fullFromUri ~uri =
18+
let fullFromUriWithPackage ~package ~uri =
1219
let path = Uri.toPath uri in
13-
match Packages.getPackage ~uri with
14-
| None -> None
15-
| Some package -> (
16-
let moduleName =
17-
BuildSystem.namespacedName package.namespace (FindFiles.getName path)
18-
in
19-
let incremental =
20-
if !Cfg.inIncrementalTypecheckingMode then
21-
let incrementalCmtPath =
22-
package.rootPath ^ "/lib/bs/___incremental" ^ "/" ^ moduleName
23-
^
24-
match Files.classifySourceFile path with
25-
| Resi -> ".cmti"
26-
| _ -> ".cmt"
27-
in
28-
fullForCmt ~moduleName ~package ~uri incrementalCmtPath
29-
else None
20+
let moduleName =
21+
BuildSystem.namespacedName package.namespace (FindFiles.getName path)
22+
in
23+
let cached_full cmt_path =
24+
let cache = FullCache.get () in
25+
match Hashtbl.find_opt cache cmt_path with
26+
| Some v -> Some v
27+
| None -> (
28+
match fullForCmt ~moduleName ~package ~uri cmt_path with
29+
| Some v as res ->
30+
Hashtbl.replace cache cmt_path v;
31+
res
32+
| None -> None)
33+
in
34+
if !Cfg.inIncrementalTypecheckingMode then
35+
let incrementalCmtPath =
36+
package.rootPath ^ "/lib/bs/___incremental" ^ "/" ^ moduleName
37+
^
38+
match Files.classifySourceFile path with
39+
| Resi -> ".cmti"
40+
| _ -> ".cmt"
3041
in
31-
match incremental with
32-
| Some cmtInfo ->
33-
if Debug.verbose () then Printf.printf "[cmt] Found incremental cmt\n";
34-
Some cmtInfo
42+
match cached_full incrementalCmtPath with
43+
| Some _ as x -> x
3544
| None -> (
45+
(* Fallback to non-incremental *)
3646
match Hashtbl.find_opt package.pathsForModule moduleName with
3747
| Some paths ->
3848
let cmt = getCmtPath ~uri paths in
39-
fullForCmt ~moduleName ~package ~uri cmt
49+
cached_full cmt
4050
| None ->
4151
prerr_endline ("can't find module " ^ moduleName);
42-
None))
52+
None)
53+
else
54+
match Hashtbl.find_opt package.pathsForModule moduleName with
55+
| Some paths ->
56+
let cmt = getCmtPath ~uri paths in
57+
cached_full cmt
58+
| None ->
59+
prerr_endline ("can't find module " ^ moduleName);
60+
None
61+
62+
let fullFromUri ~uri =
63+
match Packages.getPackage ~uri with
64+
| None -> None
65+
| Some package -> fullFromUriWithPackage ~package ~uri
4366

4467
let fullsFromModule ~package ~moduleName =
45-
if Hashtbl.mem package.pathsForModule moduleName then
46-
let paths = Hashtbl.find package.pathsForModule moduleName in
68+
match Hashtbl.find_opt package.pathsForModule moduleName with
69+
| None -> []
70+
| Some paths ->
4771
let uris = getUris paths in
48-
uris |> List.filter_map (fun uri -> fullFromUri ~uri)
49-
else []
72+
uris
73+
|> List.filter_map (fun uri ->
74+
let cmt = getCmtPath ~uri paths in
75+
fullForCmt ~moduleName ~package ~uri cmt)
5076

5177
let loadFullCmtFromPath ~path =
5278
let uri = Uri.fromPath path in

analysis/src/Packages.ml

Lines changed: 32 additions & 23 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,17 @@
11
open SharedTypes
22

3+
(* Domain-local caches for packages and URI->root mapping. *)
4+
module LocalCache = struct
5+
let packages_key : (string, package) Hashtbl.t Domain.DLS.key =
6+
AnalysisCache.make_hashtbl 1
7+
8+
let roots_key : (Uri.t, string) Hashtbl.t Domain.DLS.key =
9+
AnalysisCache.make_hashtbl 30
10+
11+
let packages () = AnalysisCache.get_hashtbl packages_key
12+
let roots () = AnalysisCache.get_hashtbl roots_key
13+
end
14+
315
(* Creates the `pathsForModule` hashtbl, which maps a `moduleName` to it's `paths` (the ml/re, mli/rei, cmt, and cmti files) *)
416
let makePathsForModule ~projectFilesAndPaths ~dependenciesFilesAndPaths =
517
let pathsForModule = Hashtbl.create 30 in
@@ -200,14 +212,11 @@ let newBsPackage ~rootPath =
200212
Log.log ("Unable to read " ^ bsconfigJson);
201213
None)
202214

203-
let findRoot ~uri packagesByRoot =
215+
let findRoot ~uri =
204216
let path = Uri.toPath uri in
205217
let rec loop path =
206218
if path = "/" then None
207-
else if
208-
SharedTypes.StateSync.with_lock (fun () ->
209-
Hashtbl.mem packagesByRoot path)
210-
then Some (`Root path)
219+
else if Hashtbl.mem (LocalCache.packages ()) path then Some (`Root path)
211220
else if
212221
Files.exists (Filename.concat path "rescript.json")
213222
|| Files.exists (Filename.concat path "bsconfig.json")
@@ -219,29 +228,29 @@ let findRoot ~uri packagesByRoot =
219228
loop (if Sys.is_directory path then path else Filename.dirname path)
220229

221230
let getPackage ~uri =
222-
let open SharedTypes in
223-
match
224-
SharedTypes.StateSync.with_lock (fun () ->
225-
if Hashtbl.mem state.rootForUri uri then
226-
let root = Hashtbl.find state.rootForUri uri in
227-
Some (Hashtbl.find state.packagesByRoot root)
228-
else None)
229-
with
230-
| Some pkg -> Some pkg
231+
let roots = LocalCache.roots () in
232+
let packages = LocalCache.packages () in
233+
match Hashtbl.find_opt roots uri with
234+
| Some root -> Hashtbl.find_opt packages root
231235
| None -> (
232-
match findRoot ~uri state.packagesByRoot with
236+
match findRoot ~uri with
233237
| None ->
234238
Log.log "No root directory found";
235239
None
236-
| Some (`Root rootPath) ->
237-
SharedTypes.StateSync.with_lock (fun () ->
238-
Hashtbl.replace state.rootForUri uri rootPath;
239-
Some (Hashtbl.find state.packagesByRoot rootPath))
240+
| Some (`Root rootPath) -> (
241+
Hashtbl.replace roots uri rootPath;
242+
match Hashtbl.find_opt packages rootPath with
243+
| Some pkg -> Some pkg
244+
| None -> (
245+
match newBsPackage ~rootPath with
246+
| Some pkg ->
247+
Hashtbl.replace packages rootPath pkg;
248+
Some pkg
249+
| None -> None))
240250
| Some (`Bs rootPath) -> (
241251
match newBsPackage ~rootPath with
242252
| None -> None
243253
| Some package ->
244-
SharedTypes.StateSync.with_lock (fun () ->
245-
Hashtbl.replace state.rootForUri uri package.rootPath;
246-
Hashtbl.replace state.packagesByRoot package.rootPath package;
247-
Some package)))
254+
Hashtbl.replace roots uri package.rootPath;
255+
Hashtbl.replace packages package.rootPath package;
256+
Some package))

analysis/src/ProcessCmt.ml

Lines changed: 4 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -773,27 +773,16 @@ let fileForCmtInfos ~moduleName ~uri
773773
| _ -> File.create moduleName uri
774774

775775
let fileForCmt ~moduleName ~cmt ~uri =
776-
(* Double-checked locking: fast path under lock; if missing, compute without
777-
holding the lock, then insert under lock if still absent. *)
778-
match
779-
SharedTypes.StateSync.with_lock (fun () ->
780-
Hashtbl.find_opt state.cmtCache cmt)
781-
with
776+
let local = SharedTypes.CmtCache.get () in
777+
match Hashtbl.find_opt local cmt with
782778
| Some file -> Some file
783779
| None -> (
784780
match Shared.tryReadCmt cmt with
785781
| None -> None
786782
| Some infos ->
787783
let file = fileForCmtInfos ~moduleName ~uri infos in
788-
let cached =
789-
SharedTypes.StateSync.with_lock (fun () ->
790-
match Hashtbl.find_opt state.cmtCache cmt with
791-
| Some f -> Some f
792-
| None ->
793-
Hashtbl.replace state.cmtCache cmt file;
794-
Some file)
795-
in
796-
cached)
784+
Hashtbl.replace local cmt file;
785+
Some file)
797786

798787
let fileForModule moduleName ~package =
799788
match Hashtbl.find_opt package.pathsForModule moduleName with

analysis/src/References.ml

Lines changed: 5 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -219,7 +219,9 @@ let alternateDeclared ~(file : File.t) ~package (declared : _ Declared.t) tip =
219219
maybeLog
220220
("alternateDeclared for " ^ file.moduleName ^ " has both resi and res");
221221
let alternateUri = if Uri.isInterface file.uri then res else resi in
222-
match Cmt.fullFromUri ~uri:(Uri.fromPath alternateUri) with
222+
match
223+
Cmt.fullFromUriWithPackage ~package ~uri:(Uri.fromPath alternateUri)
224+
with
223225
| None -> None
224226
| Some {file; extra} -> (
225227
let env = QueryEnv.fromFile file in
@@ -568,7 +570,7 @@ let allReferencesForLocItem ~domain_mgr ~full:({file; package} as full) locItem
568570
match ProcessCmt.fileForModule ~package name with
569571
| None -> []
570572
| Some file -> (
571-
match Cmt.fullFromUri ~uri:file.uri with
573+
match Cmt.fullFromUriWithPackage ~package ~uri:file.uri with
572574
| None -> []
573575
| Some full -> (
574576
match
@@ -612,7 +614,7 @@ let allReferencesForLocItem ~domain_mgr ~full:({file; package} as full) locItem
612614
match exportedForTip ~env ~path ~package ~tip with
613615
| None -> []
614616
| Some (env, _name, stamp) -> (
615-
match Cmt.fullFromUri ~uri:env.file.uri with
617+
match Cmt.fullFromUriWithPackage ~package ~uri:env.file.uri with
616618
| None -> []
617619
| Some full ->
618620
maybeLog

analysis/src/SharedTypes.ml

Lines changed: 6 additions & 25 deletions
Original file line numberDiff line numberDiff line change
@@ -537,34 +537,15 @@ let initExtra () =
537537
locItems = [];
538538
}
539539

540-
type state = {
541-
packagesByRoot: (string, package) Hashtbl.t;
542-
rootForUri: (Uri.t, string) Hashtbl.t;
543-
cmtCache: (filePath, File.t) Hashtbl.t;
544-
}
540+
module CmtCache = struct
541+
let key : (filePath, File.t) Hashtbl.t Domain.DLS.key =
542+
AnalysisCache.make_hashtbl 30
545543

546-
(* There's only one state, so it can as well be global *)
547-
let state =
548-
{
549-
packagesByRoot = Hashtbl.create 1;
550-
rootForUri = Hashtbl.create 30;
551-
cmtCache = Hashtbl.create 30;
552-
}
553-
554-
module StateSync = struct
555-
let mutex : Mutex.t = Mutex.create ()
556-
557-
let with_lock f =
558-
Mutex.lock mutex;
559-
match f () with
560-
| v ->
561-
Mutex.unlock mutex;
562-
v
563-
| exception exn ->
564-
Mutex.unlock mutex;
565-
raise exn
544+
let get () : (filePath, File.t) Hashtbl.t = AnalysisCache.get_hashtbl key
566545
end
567546

547+
module StringMap = Map.Make (String)
548+
568549
let locKindToString = function
569550
| LocalReference (_, tip) -> "(LocalReference " ^ Tip.toString tip ^ ")"
570551
| GlobalReference _ -> "GlobalReference"

0 commit comments

Comments
 (0)