Use Eio for parallelizing some analysis commands

.github/workflows/ci.yml

@@ -58,12 +58,6 @@ jobs:
             node-target: win32-x64
             rust-target: x86_64-pc-windows-gnu
 
-          # Verify that the compiler still builds with the oldest OCaml version we support.
-          - os: ubuntu-24.04
-            ocaml_compiler: ocaml-variants.4.14.2+options,ocaml-option-static
-            node-target: linux-x64
-            rust-target: x86_64-unknown-linux-musl
-
     runs-on: ${{matrix.os}}
 
     env:
@@ -102,7 +96,7 @@ jobs:
         uses: awalsh128/[email protected]
         with:
           # See https://github.com/ocaml/setup-ocaml/blob/b2105f9/packages/setup-ocaml/src/unix.ts#L9
-          packages: bubblewrap darcs g++-multilib gcc-multilib mercurial musl-tools rsync
+          packages: bubblewrap darcs g++-multilib gcc-multilib mercurial musl-tools rsync linux-libc-dev dpkg-dev
           version: v3
 
       - name: Restore rewatch build cache
@@ -181,7 +175,13 @@ jobs:
 
       - name: Install OPAM dependencies
         if: steps.cache-opam-env.outputs.cache-hit != 'true'
-        run: opam install . --deps-only --with-test
+        run: |
+          if [ "$RUNNER_OS" = "Linux" ]; then
+            arch=$(dpkg-architecture -qDEB_HOST_MULTIARCH)
+            C_INCLUDE_PATH="/usr/include:/usr/include/$arch" CPATH="/usr/include:/usr/include/$arch" opam install . --deps-only --with-test
+          else
+            opam install . --deps-only --with-test
+          fi
 
       - name: Cache OPAM environment
         if: steps.cache-opam-env.outputs.cache-hit != 'true'
@@ -262,7 +262,9 @@ jobs:
 
       - name: Build compiler (Linux static)
         if: runner.os == 'Linux'
-        run: opam exec -- dune build --display quiet --profile static
+        run: |
+          arch=$(dpkg-architecture -qDEB_HOST_MULTIARCH)
+          C_INCLUDE_PATH="/usr/include:/usr/include/$arch" CPATH="/usr/include:/usr/include/$arch" opam exec -- dune build --display quiet --profile static
 
       - name: Delete stable compiler build state
         if: github.event_name == 'push' && github.ref == 'refs/heads/master'

analysis.opam

@@ -7,8 +7,10 @@ license: "LGPL-3.0-or-later"
 homepage: "https://github.com/rescript-lang/rescript-compiler"
 bug-reports: "https://github.com/rescript-lang/rescript-compiler/issues"
 depends: [
-  "ocaml" {>= "4.14"}
+  "ocaml" {>= "5.3"}
   "cppo" {= "1.8.0"}
+  "eio"
+  "eio_main"
   "dune" {>= "3.17"}
   "odoc" {with-doc}
 ]

analysis/bin/dune

@@ -8,4 +8,4 @@
  (package analysis)
  (modes byte exe)
  (name main)
- (libraries analysis))
+ (libraries analysis eio eio_main))

analysis/bin/main.ml

@@ -194,21 +194,23 @@ let main () =
     Sys.argv.(len - 1) <- "";
     Reanalyze.cli ()
   | [_; "references"; path; line; col] ->
-    Commands.references ~path
-      ~pos:(int_of_string line, int_of_string col)
-      ~debug
+    Eio_main.run (fun env ->
+        Commands.references ~env ~path
+          ~pos:(int_of_string line, int_of_string col)
+          ~debug)
   | [_; "rename"; path; line; col; newName] ->
-    Commands.rename ~path
-      ~pos:(int_of_string line, int_of_string col)
-      ~newName ~debug
+    Eio_main.run (fun env ->
+        Commands.rename ~env ~path
+          ~pos:(int_of_string line, int_of_string col)
+          ~newName ~debug)
   | [_; "semanticTokens"; currentFile] ->
     SemanticTokens.semanticTokens ~currentFile
   | [_; "createInterface"; path; cmiFile] ->
     Printf.printf "\"%s\""
       (Json.escape (CreateInterface.command ~path ~cmiFile))
   | [_; "format"; path] ->
     Printf.printf "\"%s\"" (Json.escape (Commands.format ~path))
-  | [_; "test"; path] -> Commands.test ~path
+  | [_; "test"; path] -> Eio_main.run (fun env -> Commands.test ~env ~path)
   | [_; "cmt"; rescript_json; cmt_path] -> CmtViewer.dump rescript_json cmt_path
   | args when List.mem "-h" args || List.mem "--help" args -> prerr_endline help
   | _ ->

analysis/src/Commands.ml

@@ -177,101 +177,95 @@ let typeDefinition ~path ~pos ~debug =
     | None -> Protocol.null
     | Some location -> location |> Protocol.stringifyLocation)
 
-let references ~path ~pos ~debug =
-  let allLocs =
-    match Cmt.loadFullCmtFromPath ~path with
+(* Shared helper: collect references in parallel using Eio, like 'references'. *)
+let collect_all_references_parallel ~env ~path ~pos ~debug =
+  match Cmt.loadFullCmtFromPath ~path with
+  | None -> []
+  | Some full -> (
+    match References.getLocItem ~full ~pos ~debug with
     | None -> []
-    | Some full -> (
-      match References.getLocItem ~full ~pos ~debug with
-      | None -> []
-      | Some locItem ->
-        let allReferences = References.allReferencesForLocItem ~full locItem in
-        allReferences
-        |> List.fold_left
-             (fun acc {References.uri = uri2; locOpt} ->
-               let loc =
-                 match locOpt with
-                 | Some loc -> loc
-                 | None -> Uri.toTopLevelLoc uri2
-               in
-               Protocol.stringifyLocation
-                 {uri = Uri.toString uri2; range = Utils.cmtLocToRange loc}
-               :: acc)
-             [])
+    | Some locItem ->
+      References.allReferencesForLocItem ~domain_mgr:env#domain_mgr ~full
+        locItem)
+
+let references ~env ~path ~pos ~debug =
+  let allRefs = collect_all_references_parallel ~env ~path ~pos ~debug in
+  let allLocs =
+    allRefs
+    |> List.fold_left
+         (fun acc {References.uri = uri2; locOpt} ->
+           let loc =
+             match locOpt with
+             | Some loc -> loc
+             | None -> Uri.toTopLevelLoc uri2
+           in
+           Protocol.stringifyLocation
+             {uri = Uri.toString uri2; range = Utils.cmtLocToRange loc}
+           :: acc)
+         []
   in
   print_endline
     (if allLocs = [] then Protocol.null
      else "[\n" ^ (allLocs |> String.concat ",\n") ^ "\n]")
 
-let rename ~path ~pos ~newName ~debug =
-  let result =
-    match Cmt.loadFullCmtFromPath ~path with
-    | None -> Protocol.null
-    | Some full -> (
-      match References.getLocItem ~full ~pos ~debug with
-      | None -> Protocol.null
-      | Some locItem ->
-        let allReferences = References.allReferencesForLocItem ~full locItem in
-        let referencesToToplevelModules =
-          allReferences
-          |> Utils.filterMap (fun {References.uri = uri2; locOpt} ->
-                 if locOpt = None then Some uri2 else None)
-        in
-        let referencesToItems =
-          allReferences
-          |> Utils.filterMap (function
-               | {References.uri = uri2; locOpt = Some loc} -> Some (uri2, loc)
-               | {locOpt = None} -> None)
-        in
-        let fileRenames =
-          referencesToToplevelModules
-          |> List.map (fun uri ->
-                 let path = Uri.toPath uri in
-                 let dir = Filename.dirname path in
-                 let newPath =
-                   Filename.concat dir (newName ^ Filename.extension path)
-                 in
-                 let newUri = Uri.fromPath newPath in
-                 Protocol.
-                   {
-                     oldUri = uri |> Uri.toString;
-                     newUri = newUri |> Uri.toString;
-                   })
-        in
-        let textDocumentEdits =
-          let module StringMap = Misc.StringMap in
-          let textEditsByUri =
-            referencesToItems
-            |> List.map (fun (uri, loc) -> (Uri.toString uri, loc))
-            |> List.fold_left
-                 (fun acc (uri, loc) ->
-                   let textEdit =
-                     Protocol.
-                       {range = Utils.cmtLocToRange loc; newText = newName}
-                   in
-                   match StringMap.find_opt uri acc with
-                   | None -> StringMap.add uri [textEdit] acc
-                   | Some prevEdits ->
-                     StringMap.add uri (textEdit :: prevEdits) acc)
-                 StringMap.empty
-          in
-          StringMap.fold
-            (fun uri edits acc ->
-              let textDocumentEdit =
-                Protocol.{textDocument = {uri; version = None}; edits}
-              in
-              textDocumentEdit :: acc)
-            textEditsByUri []
-        in
-        let fileRenamesString =
-          fileRenames |> List.map Protocol.stringifyRenameFile
-        in
-        let textDocumentEditsString =
-          textDocumentEdits |> List.map Protocol.stringifyTextDocumentEdit
+let rename ~env ~path ~pos ~newName ~debug =
+  let allReferences = collect_all_references_parallel ~env ~path ~pos ~debug in
+  let referencesToToplevelModules =
+    allReferences
+    |> Utils.filterMap (fun {References.uri = uri2; locOpt} ->
+           if locOpt = None then Some uri2 else None)
+  in
+  let referencesToItems =
+    allReferences
+    |> Utils.filterMap (function
+         | {References.uri = uri2; locOpt = Some loc} -> Some (uri2, loc)
+         | {locOpt = None} -> None)
+  in
+  let fileRenames =
+    referencesToToplevelModules
+    |> List.map (fun uri ->
+           let path = Uri.toPath uri in
+           let dir = Filename.dirname path in
+           let newPath =
+             Filename.concat dir (newName ^ Filename.extension path)
+           in
+           let newUri = Uri.fromPath newPath in
+           Protocol.
+             {oldUri = uri |> Uri.toString; newUri = newUri |> Uri.toString})
+  in
+  let textDocumentEdits =
+    let module StringMap = Misc.StringMap in
+    let textEditsByUri =
+      referencesToItems
+      |> List.map (fun (uri, loc) -> (Uri.toString uri, loc))
+      |> List.fold_left
+           (fun acc (uri, loc) ->
+             let textEdit =
+               Protocol.{range = Utils.cmtLocToRange loc; newText = newName}
+             in
+             match StringMap.find_opt uri acc with
+             | None -> StringMap.add uri [textEdit] acc
+             | Some prevEdits -> StringMap.add uri (textEdit :: prevEdits) acc)
+           StringMap.empty
+    in
+    StringMap.fold
+      (fun uri edits acc ->
+        let textDocumentEdit =
+          Protocol.{textDocument = {uri; version = None}; edits}
         in
-        "[\n"
-        ^ (fileRenamesString @ textDocumentEditsString |> String.concat ",\n")
-        ^ "\n]")
+        textDocumentEdit :: acc)
+      textEditsByUri []
+  in
+  let fileRenamesString =
+    fileRenames |> List.map Protocol.stringifyRenameFile
+  in
+  let textDocumentEditsString =
+    textDocumentEdits |> List.map Protocol.stringifyTextDocumentEdit
+  in
+  let result =
+    "[\n"
+    ^ (fileRenamesString @ textDocumentEditsString |> String.concat ",\n")
+    ^ "\n]"
   in
   print_endline result
 
@@ -294,7 +288,7 @@ let format ~path =
 let diagnosticSyntax ~path =
   print_endline (Diagnostics.document_syntax ~path |> Protocol.array)
 
-let test ~path =
+let test ~env ~path =
   Uri.stripPath := true;
   match Files.readFile path with
   | None -> assert false
@@ -414,15 +408,15 @@ let test ~path =
             print_endline
               ("References " ^ path ^ " " ^ string_of_int line ^ ":"
              ^ string_of_int col);
-            references ~path ~pos:(line, col) ~debug:true
+            references ~env ~path ~pos:(line, col) ~debug:true
           | "ren" ->
             let newName = String.sub rest 4 (len - mlen - 4) in
             let () =
               print_endline
                 ("Rename " ^ path ^ " " ^ string_of_int line ^ ":"
                ^ string_of_int col ^ " " ^ newName)
             in
-            rename ~path ~pos:(line, col) ~newName ~debug:true
+            rename ~env ~path ~pos:(line, col) ~newName ~debug:true
           | "typ" ->
             print_endline
               ("TypeDefinition " ^ path ^ " " ^ string_of_int line ^ ":"

analysis/src/Packages.ml

@@ -204,7 +204,10 @@ let findRoot ~uri packagesByRoot =
   let path = Uri.toPath uri in
   let rec loop path =
     if path = "/" then None
-    else if Hashtbl.mem packagesByRoot path then Some (`Root path)
+    else if
+      SharedTypes.StateSync.with_lock (fun () ->
+          Hashtbl.mem packagesByRoot path)
+    then Some (`Root path)
     else if
       Files.exists (Filename.concat path "rescript.json")
       || Files.exists (Filename.concat path "bsconfig.json")
@@ -217,21 +220,28 @@ let findRoot ~uri packagesByRoot =
 
 let getPackage ~uri =
   let open SharedTypes in
-  if Hashtbl.mem state.rootForUri uri then
-    Some (Hashtbl.find state.packagesByRoot (Hashtbl.find state.rootForUri uri))
-  else
+  match
+    SharedTypes.StateSync.with_lock (fun () ->
+        if Hashtbl.mem state.rootForUri uri then
+          let root = Hashtbl.find state.rootForUri uri in
+          Some (Hashtbl.find state.packagesByRoot root)
+        else None)
+  with
+  | Some pkg -> Some pkg
+  | None -> (
     match findRoot ~uri state.packagesByRoot with
     | None ->
       Log.log "No root directory found";
       None
     | Some (`Root rootPath) ->
-      Hashtbl.replace state.rootForUri uri rootPath;
-      Some
-        (Hashtbl.find state.packagesByRoot (Hashtbl.find state.rootForUri uri))
+      SharedTypes.StateSync.with_lock (fun () ->
+          Hashtbl.replace state.rootForUri uri rootPath;
+          Some (Hashtbl.find state.packagesByRoot rootPath))
     | Some (`Bs rootPath) -> (
       match newBsPackage ~rootPath with
       | None -> None
       | Some package ->
-        Hashtbl.replace state.rootForUri uri package.rootPath;
-        Hashtbl.replace state.packagesByRoot package.rootPath package;
-        Some package)
+        SharedTypes.StateSync.with_lock (fun () ->
+            Hashtbl.replace state.rootForUri uri package.rootPath;
+            Hashtbl.replace state.packagesByRoot package.rootPath package;
+            Some package)))

analysis/src/ProcessCmt.ml

@@ -773,15 +773,27 @@ let fileForCmtInfos ~moduleName ~uri
   | _ -> File.create moduleName uri
 
 let fileForCmt ~moduleName ~cmt ~uri =
-  match Hashtbl.find_opt state.cmtCache cmt with
+  (* Double-checked locking: fast path under lock; if missing, compute without
+     holding the lock, then insert under lock if still absent. *)
+  match
+    SharedTypes.StateSync.with_lock (fun () ->
+        Hashtbl.find_opt state.cmtCache cmt)
+  with
   | Some file -> Some file
   | None -> (
     match Shared.tryReadCmt cmt with
     | None -> None
     | Some infos ->
       let file = fileForCmtInfos ~moduleName ~uri infos in
-      Hashtbl.replace state.cmtCache cmt file;
-      Some file)
+      let cached =
+        SharedTypes.StateSync.with_lock (fun () ->
+            match Hashtbl.find_opt state.cmtCache cmt with
+            | Some f -> Some f
+            | None ->
+              Hashtbl.replace state.cmtCache cmt file;
+              Some file)
+      in
+      cached)
 
 let fileForModule moduleName ~package =
   match Hashtbl.find_opt package.pathsForModule moduleName with