Revert "Revert "Revert ocaml#7415 and ocaml#7450 (ocaml#7887) (ocaml#…

…7890)""

This reverts commit 4323a7c.

src/dune_rules/buildable_rules.ml

@@ -56,8 +56,9 @@ let modules_rules ~preprocess ~preprocessor_deps ~lint
         (Preprocess.Per_module.instrumentation_deps preprocess
            ~instrumentation_backend)
     in
-    Preprocessing.make sctx ~dir ~preprocess:preprocess_with_instrumentation
-      ~expander ~preprocessor_deps ~instrumentation_deps ~lint ~lib_name
+    Preprocessing.make sctx ~dir ~scope
+      ~preprocess:preprocess_with_instrumentation ~expander ~preprocessor_deps
+      ~instrumentation_deps ~lint ~lib_name
   in
   let add_empty_intf =
     let default = empty_module_interface_if_absent in

src/dune_rules/cinaps.ml

@@ -120,7 +120,7 @@ let gen_rules sctx t ~dir ~scope =
     Preprocessing.make sctx ~dir ~expander
       ~lint:(Preprocess.Per_module.no_preprocessing ())
       ~preprocess:t.preprocess ~preprocessor_deps:t.preprocessor_deps
-      ~instrumentation_deps:[] ~lib_name:None
+      ~instrumentation_deps:[] ~lib_name:None ~scope
   in
   let* modules =
     Modules.singleton_exe module_

src/dune_rules/expander.ml

@@ -65,8 +65,6 @@ type t =
 
 let scope t = t.scope
 
-let scope_host t = t.scope_host
-
 let artifacts t = t.bin_artifacts_host
 
 let dir t = t.dir

src/dune_rules/expander.mli

@@ -6,8 +6,6 @@ type t
 
 val scope : t -> Scope.t
 
-val scope_host : t -> Scope.t
-
 val dir : t -> Path.Build.t
 
 val context : t -> Context.t

src/dune_rules/jsoo/jsoo_rules.ml

@@ -355,7 +355,7 @@ let setup_separate_compilation_rules sctx components =
     let pkg = Lib_name.parse_string_exn (Loc.none, s_pkg) in
     let ctx = Super_context.context sctx in
     let open Memo.O in
-    let* installed_libs = Lib.DB.installed ~host:None ctx in
+    let* installed_libs = Lib.DB.installed ctx in
     Lib.DB.find installed_libs pkg >>= function
     | None -> Memo.return ()
     | Some pkg ->

src/dune_rules/lib.ml

@@ -298,7 +298,7 @@ module T = struct
     ; (* [requires] is contains all required libraries, including the ones
          mentioned in [re_exports]. *)
       requires : t list Resolve.t
-    ; ppx_runtime_deps_host : t list Resolve.t Memo.Lazy.t
+    ; ppx_runtime_deps : t list Resolve.t
     ; pps : t list Resolve.t
     ; resolved_selects : Resolved_select.t list Resolve.t
     ; implements : t Resolve.t option
@@ -352,30 +352,6 @@ module Hidden = struct
     { lib = info; reason = "unsatisfied 'exist_if'"; path }
 end
 
-module Private_deps = struct
-  type t =
-    | From_same_project of [ `Public | `Private_package ]
-    | Allow_all
-
-  let equal a b =
-    match (a, b) with
-    | Allow_all, Allow_all
-    | From_same_project `Public, From_same_project `Public
-    | From_same_project `Private_package, From_same_project `Private_package ->
-      true
-    | _ -> false
-
-  let check t ~loc ~lib =
-    match t with
-    | Allow_all -> Ok lib
-    | From_same_project kind -> (
-      match Lib_info.status lib.info with
-      | Private (_, Some _) -> Ok lib
-      | Private (_, None) ->
-        Error (Error.private_deps_not_allowed ~kind ~loc lib.info)
-      | _ -> Ok lib)
-end
-
 module Status = struct
   type t =
     | Found of lib
@@ -395,10 +371,7 @@ end
 
 type db =
   { parent : db option
-  ; host : db Memo.Lazy.t option
   ; resolve : Lib_name.t -> resolve_result Memo.t
-  ; resolve_ppx_runtime_deps :
-      (Path.t Lib_info.t * Private_deps.t, t list Resolve.t) Memo.Table.t
   ; all : Lib_name.t list Memo.Lazy.t
   ; lib_config : Lib_config.t
   }
@@ -424,7 +397,7 @@ let implements t = Option.map ~f:Memo.return t.implements
 
 let requires t = Memo.return t.requires
 
-let ppx_runtime_deps t = Memo.Lazy.force t.ppx_runtime_deps_host
+let ppx_runtime_deps t = Memo.return t.ppx_runtime_deps
 
 let pps t = Memo.return t.pps
 
@@ -628,6 +601,20 @@ end = struct
         { stack = x :: t.stack; seen = Id.Set.add t.seen x; implements_via }
 end
 
+type private_deps =
+  | From_same_project of [ `Public | `Private_package ]
+  | Allow_all
+
+let check_private_deps lib ~loc ~(private_deps : private_deps) =
+  match private_deps with
+  | Allow_all -> Ok lib
+  | From_same_project kind -> (
+    match Lib_info.status lib.info with
+    | Private (_, Some _) -> Ok lib
+    | Private (_, None) ->
+      Error (Error.private_deps_not_allowed ~kind ~loc lib.info)
+    | _ -> Ok lib)
+
 module Vlib : sig
   (** Make sure that for every virtual library in the list there is at most one
       corresponding implementation.
@@ -787,10 +774,7 @@ module rec Resolve_names : sig
   val find_internal : db -> Lib_name.t -> Status.t Memo.t
 
   val resolve_dep :
-       db
-    -> Loc.t * Lib_name.t
-    -> private_deps:Private_deps.t
-    -> lib Resolve.Memo.t
+    db -> Loc.t * Lib_name.t -> private_deps:private_deps -> lib Resolve.Memo.t
 
   val resolve_name : db -> Lib_name.t -> Status.t Memo.t
 
@@ -799,7 +783,7 @@ module rec Resolve_names : sig
   val resolve_simple_deps :
        db
     -> (Loc.t * Lib_name.t) list
-    -> private_deps:Private_deps.t
+    -> private_deps:private_deps
     -> t list Resolve.Memo.t
 
   type resolved =
@@ -812,7 +796,7 @@ module rec Resolve_names : sig
   val resolve_deps_and_add_runtime_deps :
        db
     -> Lib_dep.t list
-    -> private_deps:Private_deps.t
+    -> private_deps:private_deps
     -> pps:(Loc.t * Lib_name.t) list
     -> dune_version:Dune_lang.Syntax.Version.t option
     -> resolved Memo.t
@@ -845,13 +829,13 @@ end = struct
   let instantiate_impl (db, name, info, hidden) =
     let open Memo.O in
     let unique_id = Id.make ~name ~path:(Lib_info.src_dir info) in
+    let status = Lib_info.status info in
     let private_deps =
-      match Lib_info.status info with
+      match status with
       (* [Allow_all] is used for libraries that are installed because we don't
          have to check it again. It has been checked when compiling the
          libraries before their installation *)
-      | Installed_private | Private (_, None) | Installed ->
-        Private_deps.Allow_all
+      | Installed_private | Private (_, None) | Installed -> Allow_all
       | Private (_, Some _) -> From_same_project `Private_package
       | Public (_, _) -> From_same_project `Public
     in
@@ -961,17 +945,16 @@ end = struct
           let+ impl = impl in
           impl :: requires)
     in
+    let* ppx_runtime_deps =
+      Lib_info.ppx_runtime_deps info |> resolve_simple_deps db ~private_deps
+    in
+    let src_dir = Lib_info.src_dir info in
     let map_error x =
-      let src_dir = Lib_info.src_dir info in
       Resolve.push_stack_frame x ~human_readable_description:(fun () ->
           Dep_path.Entry.Lib.pp { name; path = src_dir })
     in
-    let ppx_runtime_deps_host =
-      Memo.lazy_ (fun () ->
-          Memo.exec db.resolve_ppx_runtime_deps (info, private_deps)
-          |> Memo.map ~f:map_error)
-    in
     let requires = map_error requires in
+    let ppx_runtime_deps = map_error ppx_runtime_deps in
     let* project =
       let status = Lib_info.status info in
       match Lib_info.Status.project status with
@@ -992,7 +975,7 @@ end = struct
         ; name
         ; unique_id
         ; requires
-        ; ppx_runtime_deps_host
+        ; ppx_runtime_deps
         ; pps
         ; resolved_selects
         ; re_exports
@@ -1008,25 +991,27 @@ end = struct
         })
     in
     let t = Lazy.force t in
-    let+ hidden =
+    let res =
+      let hidden =
+        match hidden with
+        | Some _ -> hidden
+        | None -> (
+          let enabled = Lib_info.enabled info in
+          match enabled with
+          | Normal -> None
+          | Disabled_because_of_enabled_if -> Some "unsatisfied 'enabled_if'"
+          | Optional ->
+            (* TODO this could be made lazier *)
+            let requires = Resolve.is_ok requires in
+            let ppx_runtime_deps = Resolve.is_ok t.ppx_runtime_deps in
+            if requires && ppx_runtime_deps then None
+            else Some "optional with unavailable dependencies")
+      in
       match hidden with
-      | Some _ -> Memo.return hidden
-      | None -> (
-        let enabled = Lib_info.enabled info in
-        match enabled with
-        | Normal -> Memo.return None
-        | Disabled_because_of_enabled_if ->
-          Memo.return (Some "unsatisfied 'enabled_if'")
-        | Optional ->
-          (* TODO this could be made lazier *)
-          let requires = Resolve.is_ok requires in
-          let+ ppx_runtime_deps = ppx_runtime_deps t >>| Resolve.is_ok in
-          if requires && ppx_runtime_deps then None
-          else Some "optional with unavailable dependencies")
+      | None -> Status.Found t
+      | Some reason -> Hidden (Hidden.of_lib t ~reason)
     in
-    match hidden with
-    | None -> Status.Found t
-    | Some reason -> Hidden (Hidden.of_lib t ~reason)
+    Memo.return res
 
   let memo =
     let module Input = struct
@@ -1056,7 +1041,7 @@ end = struct
     let open Memo.O in
     find_internal db name >>= function
     | Found lib ->
-      Resolve.Memo.of_result (Private_deps.check private_deps ~loc ~lib)
+      Resolve.Memo.of_result (check_private_deps lib ~loc ~private_deps)
     | Not_found -> Error.not_found ~loc ~name
     | Invalid why -> Resolve.Memo.of_result (Error why)
     | Hidden h -> Hidden.error h ~loc ~name
@@ -1297,20 +1282,8 @@ end = struct
       in
       let pps =
         let* pps =
-          let open Memo.O in
-          let* db_host =
-            match db.host with
-            | None -> Memo.return db
-            | Some host ->
-              (* PPXes run in the host context, so their dependencies have to
-                 be resolved accordingly. *)
-              Memo.Lazy.force host
-          in
           Resolve.Memo.List.map pps ~f:(fun (loc, name) ->
-              let open Resolve.Memo.O in
-              let* lib =
-                resolve_dep db_host (loc, name) ~private_deps:Allow_all
-              in
+              let* lib = resolve_dep db (loc, name) ~private_deps:Allow_all in
               match (allow_only_ppx_deps, Lib_info.kind lib.info) with
               | true, Normal -> Error.only_ppx_deps_allowed ~loc lib.info
               | _ -> Resolve.Memo.return lib)
@@ -1320,25 +1293,12 @@ end = struct
       in
       let runtime_deps =
         let* pps = pps in
-        Resolve.Memo.List.concat_map pps ~f:(fun pp ->
-            let* ppx_runtime_deps =
-              match db.host with
-              | None -> ppx_runtime_deps pp
-              | Some _host ->
-                (* (ppx_runtime_libraries ...) run in the target context, so
-                   these dependencies need to be resolved here rather than at
-                   instantiation of the ppx library (in the host context). *)
-                Memo.exec db.resolve_ppx_runtime_deps (pp.info, private_deps)
-                |> Memo.map ~f:(fun x ->
-                       Resolve.push_stack_frame x
-                         ~human_readable_description:(fun () ->
-                           Dep_path.Entry.Lib.pp
-                             { name = pp.name; path = Lib_info.src_dir pp.info }))
-            in
+        Resolve.List.concat_map pps ~f:(fun pp ->
+            let open Resolve.O in
+            let* ppx_runtime_deps = pp.ppx_runtime_deps in
             Resolve.List.map ppx_runtime_deps ~f:(fun dep ->
-                Private_deps.check private_deps ~lib:dep ~loc
-                |> Resolve.of_result)
-            |> Memo.return)
+                check_private_deps ~loc ~private_deps dep |> Resolve.of_result))
+        |> Memo.return
       in
       { runtime_deps; pps }
 
@@ -1664,7 +1624,7 @@ let descriptive_closure (l : lib list) ~with_pps : lib list Memo.t =
         let* todo =
           if with_pps then register_work todo lib.pps else Memo.return todo
         in
-        let* todo = ppx_runtime_deps lib >>= register_work todo in
+        let* todo = register_work todo lib.ppx_runtime_deps in
         let* todo = register_work todo lib.requires in
         work todo acc
   in
@@ -1764,47 +1724,12 @@ module DB = struct
 
   type t = db
 
-  let create =
-    let module Input = struct
-      type t = Path.t Lib_info.t * Private_deps.t
-
-      let to_dyn = Dyn.opaque
-
-      let hash x = Poly.hash x
-
-      let equal (t, private_deps) (t', private_deps') =
-        equal t t' && Private_deps.equal private_deps private_deps'
-    end in
-    let resolve_ppx_runtime_deps db =
-      let resolve_ppx_runtime_deps_impl (info, private_deps) =
-        Resolve_names.resolve_simple_deps (Lazy.force db)
-          (Lib_info.ppx_runtime_deps info)
-          ~private_deps
-      in
-      Memo.create "lib-resolve-ppx-runtime-libraries"
-        ~input:(module Input)
-        resolve_ppx_runtime_deps_impl
-        ~human_readable_description:(fun (info, _private_deps) ->
-          Dep_path.Entry.Lib.pp
-            { name = Lib_info.name info; path = Lib_info.src_dir info })
-    in
-    (* TODO: unneeded unit argument *)
-    fun ~parent ~host ~resolve ~all ~lib_config () ->
-      let rec db =
-        lazy
-          { parent
-          ; host
-          ; resolve
-          ; resolve_ppx_runtime_deps = resolve_ppx_runtime_deps db
-          ; all = Memo.lazy_ all
-          ; lib_config
-          }
-      in
-      Lazy.force db
+  let create ~parent ~resolve ~all ~lib_config () =
+    { parent; resolve; all = Memo.lazy_ all; lib_config }
 
-  let create_from_findlib ~host findlib =
+  let create_from_findlib findlib =
     let lib_config = Findlib.lib_config findlib in
-    create () ~parent:None ~host ~lib_config
+    create () ~parent:None ~lib_config
       ~resolve:(fun name ->
         let open Memo.O in
         Findlib.find findlib name >>| function
@@ -1820,12 +1745,12 @@ module DB = struct
         let open Memo.O in
         Findlib.all_packages findlib >>| List.map ~f:Dune_package.Entry.name)
 
-  let installed (context : Context.t) ~host =
+  let installed (context : Context.t) =
     let open Memo.O in
     let+ findlib =
       Findlib.create ~paths:context.findlib_paths ~lib_config:context.lib_config
     in
-    create_from_findlib ~host findlib
+    create_from_findlib findlib
 
   let find t name =
     let open Memo.O in
@@ -1995,7 +1920,7 @@ let to_dune_lib ({ info; _ } as lib) ~modules ~foreign_objects
     use_public_name
       ~info_field:(Lib_info.default_implementation info)
       ~lib_field:(Option.map ~f:Memo.Lazy.force lib.default_implementation)
-  and+ ppx_runtime_deps = ppx_runtime_deps lib
+  and+ ppx_runtime_deps = Memo.return lib.ppx_runtime_deps
   and+ requires = Memo.return lib.requires
   and+ re_exports = Memo.return lib.re_exports in
   let ppx_runtime_deps = add_loc ppx_runtime_deps in