Merge pull request #3848 from rgrinberg/github-3336

Use Exe to generate ppx executable

CHANGES.md

@@ -49,12 +49,16 @@ Unreleased
   (#3853, @kit-ty-kate)
 
 - Fix `$ dune install` modifying the build directory. This made the build
-  directory unusable when `$ sudo dune install` modified permissions.  (fix
+  directory unusable when `$ sudo dune install` modified permissions. (fix
   #3857, @rgrinberg)
 
 - Fix handling of aliases given on the command line (using the `@` and `@@`
   syntax) so as to correctly handle relative paths. (#3874, fixes #3850, @nojb)
 
+- Allow link time code generation to be used in preprocessing executable. This
+  makes it possible to use the build info module inside the preprocessor.
+  (#3848, fix #3848, @rgrinberg)
+
 2.7.1 (2/09/2020)
 -----------------
 

src/dune_rules/cinaps.ml

@@ -87,7 +87,7 @@ let gen_rules sctx t ~dir ~scope =
   in
   let modules =
     Modules.singleton_exe module_
-    |> Modules.map_user_written ~f:(Preprocessing.pp_module preprocess)
+    |> Modules.map_user_written ~f:(Pp_spec.pp_module preprocess)
   in
   let dune_version = Scope.project scope |> Dune_project.dune_version in
   let compile_info =

src/dune_rules/compilation_context.ml

@@ -60,7 +60,7 @@ type t =
   ; requires_compile : Lib.t list Or_exn.t
   ; requires_link : Lib.t list Or_exn.t Lazy.t
   ; includes : Includes.t
-  ; preprocessing : Preprocessing.t
+  ; preprocessing : Pp_spec.t
   ; opaque : bool
   ; stdlib : Ocaml_stdlib.t option
   ; js_of_ocaml : Dune_file.Js_of_ocaml.t option
@@ -115,9 +115,9 @@ let bin_annot t = t.bin_annot
 let context t = Super_context.context t.super_context
 
 let create ~super_context ~scope ~expander ~obj_dir ~modules ~flags
-    ~requires_compile ~requires_link ?(preprocessing = Preprocessing.dummy)
-    ~opaque ?stdlib ~js_of_ocaml ~dynlink ~package ?vimpl ?modes
-    ?(bin_annot = true) () =
+    ~requires_compile ~requires_link ?(preprocessing = Pp_spec.dummy) ~opaque
+    ?stdlib ~js_of_ocaml ~dynlink ~package ?vimpl ?modes ?(bin_annot = true) ()
+    =
   let project = Scope.project scope in
   let requires_compile =
     if Dune_project.implicit_transitive_deps project then

src/dune_rules/compilation_context.mli

@@ -31,7 +31,7 @@ val create :
   -> flags:Ocaml_flags.t
   -> requires_compile:Lib.t list Or_exn.t
   -> requires_link:Lib.t list Or_exn.t Lazy.t
-  -> ?preprocessing:Preprocessing.t
+  -> ?preprocessing:Pp_spec.t
   -> opaque:opaque
   -> ?stdlib:Ocaml_stdlib.t
   -> js_of_ocaml:Dune_file.Js_of_ocaml.t option
@@ -70,7 +70,7 @@ val requires_compile : t -> Lib.t list Or_exn.t
 
 val includes : t -> Command.Args.dynamic Command.Args.t Cm_kind.Dict.t
 
-val preprocessing : t -> Preprocessing.t
+val preprocessing : t -> Pp_spec.t
 
 val opaque : t -> bool
 

src/dune_rules/exe_rules.ml

@@ -113,7 +113,7 @@ let executables_rules ~sctx ~dir ~expander ~dir_contents ~scope ~compile_info
   let modules =
     Modules.map_user_written modules ~f:(fun m ->
         let name = Module.name m in
-        Preprocessing.pp_module_as pp name m)
+        Pp_spec.pp_module_as pp name m)
   in
   let programs = programs ~modules ~exes in
   let explicit_js_mode = Dune_project.explicit_js_mode (Scope.project scope) in

src/dune_rules/lib_rules.ml

@@ -359,7 +359,7 @@ let cctx (lib : Library.t) ~sctx ~source_modules ~dir ~expander ~scope
       ~lib_name:(Some (snd lib.name))
   in
   let modules =
-    Modules.map_user_written source_modules ~f:(Preprocessing.pp_module pp)
+    Modules.map_user_written source_modules ~f:(Pp_spec.pp_module pp)
   in
   let modules = Vimpl.impl_modules vimpl modules in
   let requires_compile = Lib.Compile.direct_requires compile_info in

src/dune_rules/menhir.ml

@@ -194,7 +194,7 @@ module Run (P : PARAMS) : sig end = struct
       Module.of_source ~visibility:Public ~kind:Impl source
     in
     let mock_module =
-      Preprocessing.pp_module_as
+      Pp_spec.pp_module_as
         (Compilation_context.preprocessing cctx)
         name mock_module ~lint:false
     in

src/dune_rules/obj_dir.ml

@@ -283,6 +283,11 @@ let as_local_exn (t : Path.t t) =
 
 let make_exe ~dir ~name = Local (Local.make_exe ~dir ~name)
 
+let for_pp ~dir =
+  Local
+    (Local.make ~dir ~obj_dir:dir ~native_dir:dir ~byte_dir:dir
+       ~public_cmi_dir:None ~private_lib:false)
+
 let to_local (t : Path.t t) =
   match t with
   | Local _ -> assert false

src/dune_rules/obj_dir.mli

@@ -77,6 +77,8 @@ val to_dyn : _ t -> Dyn.t
 
 val make_exe : dir:Path.Build.t -> name:string -> Path.Build.t t
 
+val for_pp : dir:Path.Build.t -> Path.Build.t t
+
 val as_local_exn : Path.t t -> Path.Build.t t
 
 (** For local libraries with private modules, all public cmi's are symlinked to

src/dune_rules/pp_spec.ml

@@ -0,0 +1,11 @@
+type t = (Module.t -> lint:bool -> Module.t) Module_name.Per_item.t
+
+let make x = x
+
+let dummy : t = Module_name.Per_item.for_all (fun m ~lint:_ -> m)
+
+let pp_module t ?(lint = true) m =
+  Module_name.Per_item.get t (Module.name m) m ~lint
+
+let pp_module_as t ?(lint = true) name m =
+  Module_name.Per_item.get t name m ~lint

src/dune_rules/pp_spec.mli

@@ -0,0 +1,16 @@
+(** A specification for preprocessing modules. To setup rules based on this
+    specification, use [Preprocessing] *)
+
+type t
+
+val dummy : t
+
+val make : (Module.t -> lint:bool -> Module.t) Module_name.Per_item.t -> t
+
+(** Setup the preprocessing rules for the following modules and returns the
+    translated modules *)
+val pp_module : t -> ?lint:bool -> Module.t -> Module.t
+
+(** Preprocess a single module, using the configuration for the given module
+    name. *)
+val pp_module_as : t -> ?lint:bool -> Module_name.t -> Module.t -> Module.t

src/dune_rules/preprocessing.ml

@@ -2,7 +2,6 @@ open! Dune_engine
 open! Stdune
 open Import
 open Build.O
-open Dune_file
 module SC = Super_context
 
 (* Encoded representation of a set of library names + scope *)
@@ -296,15 +295,8 @@ let ppx_exe sctx ~key =
   let build_dir = (Super_context.context sctx).build_dir in
   Path.Build.relative build_dir (".ppx/" ^ key ^ "/ppx.exe")
 
-let build_ppx_driver sctx ~dep_kind ~target ~pps ~pp_names =
+let build_ppx_driver sctx ~scope ~target ~pps ~pp_names =
   let ctx = SC.context sctx in
-  let mode = Context.best_mode ctx in
-  let link_mode : Link_mode.t =
-    match mode with
-    | Byte -> Byte_with_stubs_statically_linked_in
-    | Native -> Native
-  in
-  let compiler = Context.compiler ctx mode in
   let jbuild_driver, pps, pp_names = (None, pps, pp_names) in
   let driver_and_libs =
     let open Result.O in
@@ -323,72 +315,67 @@ let build_ppx_driver sctx ~dep_kind ~target ~pps ~pp_names =
   (* CR-someday diml: what we should do is build the .cmx/.cmo once and for all
      at the point where the driver is defined. *)
   let dir = Path.Build.parent_exn target in
-  let ml = Path.Build.relative dir "_ppx.ml" in
+  let main_module_name =
+    Module_name.of_string_allow_invalid (Loc.none, "_ppx")
+  in
+  let module_ = Module.generated ~src_dir:(Path.build dir) main_module_name in
+  let ml_source =
+    Module.file ~ml_kind:Impl module_
+    |> Option.value_exn |> Path.as_in_build_dir_exn
+  in
   let add_rule ~sandbox = SC.add_rule ~sandbox sctx ~dir in
-  let open Build.With_targets.O in
   add_rule ~sandbox:Sandbox_config.default
     ( Build.of_result_map driver_and_libs ~f:(fun (driver, _) ->
           Build.return (sprintf "let () = %s ()\n" driver.info.main))
-    |> Build.write_file_dyn ml );
-  add_rule ~sandbox:Sandbox_config.no_special_requirements
-    ( Build.with_no_targets
-        (Build.label
-           (Lib_deps_info.Label
-              (Lib_deps.info ~kind:dep_kind (Lib_deps.of_pps pp_names))))
-    >>> Command.run compiler ~dir:(Path.build ctx.build_dir)
-          [ A "-g"
-          ; A "-o"
-          ; Target target
-          ; A "-w"
-          ; A "-24"
-          ; As
-              ( match link_mode with
-              | Byte_with_stubs_statically_linked_in ->
-                [ Ocaml_version.custom_or_output_complete_exe ctx.version ]
-              | Byte
-              | Native ->
-                [] )
-          ; Command.of_result
-              (Result.map driver_and_libs ~f:(fun (_driver, libs) ->
-                   Command.Args.S
-                     [ Lib.L.compile_and_link_flags ~mode:link_mode
-                         ~compile:libs ~link:libs
-                     ; Hidden_deps
-                         (Lib_file_deps.deps libs ~groups:[ Cmi; Cmx ])
-                     ]))
-          ; Dep (Path.build ml)
-          ] )
+    |> Build.write_file_dyn ml_source );
+  let linkages = [ Exe.Linkage.native_or_custom ctx ] in
+  let program : Exe.Program.t =
+    { name = Filename.remove_extension (Path.Build.basename target)
+    ; main_module_name
+    ; loc = Loc.none
+    }
+  in
+  let obj_dir = Obj_dir.for_pp ~dir in
+  let cctx =
+    let expander = Super_context.expander sctx ~dir in
+    let requires_compile = Result.map driver_and_libs ~f:snd in
+    let requires_link = lazy requires_compile in
+    let flags = Ocaml_flags.of_list [ "-g"; "-w"; "-24" ] in
+    let opaque = Compilation_context.Explicit false in
+    let modules = Modules.singleton_exe module_ in
+    Compilation_context.create ~super_context:sctx ~scope ~expander ~obj_dir
+      ~modules ~flags ~requires_compile ~requires_link ~opaque ~js_of_ocaml:None
+      ~dynlink:false ~package:None ~bin_annot:false ()
+  in
+  Exe.build_and_link ~program ~linkages cctx ~promote:None
 
 let get_rules sctx key =
   let exe = ppx_exe sctx ~key in
-  let pps, pp_names =
-    let names, lib_db =
-      match Digest.from_hex key with
-      | None ->
-        User_error.raise
-          [ Pp.textf "invalid ppx key for %s"
-              (Path.Build.to_string_maybe_quoted exe)
-          ]
-      | Some key ->
-        let { Key.Decoded.pps; project_root } = Key.decode key in
-        let lib_db =
+  let pp_names, scope =
+    match Digest.from_hex key with
+    | None ->
+      User_error.raise
+        [ Pp.textf "invalid ppx key for %s"
+            (Path.Build.to_string_maybe_quoted exe)
+        ]
+    | Some key ->
+      let { Key.Decoded.pps; project_root } = Key.decode key in
+      let scope =
+        let dir =
           match project_root with
-          | None -> SC.public_libs sctx
+          | None -> (Super_context.context sctx).build_dir
           | Some dir ->
-            let dir =
-              Path.Build.append_source (Super_context.context sctx).build_dir
-                dir
-            in
-            Scope.libs (SC.find_scope_by_dir sctx dir)
+            Path.Build.append_source (Super_context.context sctx).build_dir dir
         in
-        (pps, lib_db)
-    in
-    let pps =
-      Lib.DB.resolve_pps lib_db (List.map names ~f:(fun x -> (Loc.none, x)))
-    in
-    (pps, names)
+        Super_context.find_scope_by_dir sctx dir
+      in
+      (pps, scope)
+  in
+  let pps =
+    let lib_db = Scope.libs scope in
+    List.map pp_names ~f:(fun x -> (Loc.none, x)) |> Lib.DB.resolve_pps lib_db
   in
-  build_ppx_driver sctx ~pps ~pp_names ~dep_kind:Required ~target:exe
+  build_ppx_driver sctx ~scope ~pps ~pp_names ~target:exe
 
 let gen_rules sctx components =
   match components with
@@ -588,10 +575,6 @@ let lint_module sctx ~dir ~expander ~dep_kind ~lint ~lib_name ~scope =
      fun ~(source : Module.t) ~ast ->
        Module_name.Per_item.get lint (Module.name source) ~source ~ast)
 
-type t = (Module.t -> lint:bool -> Module.t) Module_name.Per_item.t
-
-let dummy = Module_name.Per_item.for_all (fun m ~lint:_ -> m)
-
 let make sctx ~dir ~expander ~dep_kind ~lint ~preprocess ~preprocessor_deps
     ~lib_name ~scope =
   let preprocess =
@@ -705,12 +688,7 @@ let make sctx ~dir ~expander ~dep_kind ~lint ~preprocess ~preprocessor_deps
             let ast = setup_dialect_rules sctx ~dir ~dep_kind ~expander m in
             if lint then lint_module ~ast ~source:m;
             Module.set_pp ast pp)
-
-let pp_module t ?(lint = true) m =
-  Module_name.Per_item.get t (Module.name m) m ~lint
-
-let pp_module_as t ?(lint = true) name m =
-  Module_name.Per_item.get t name m ~lint
+  |> Pp_spec.make
 
 let get_ppx_driver sctx ~loc ~expander ~scope ~lib_name ~flags pps =
   let open Result.O in

src/dune_rules/preprocessing.mli

@@ -4,11 +4,6 @@ open! Dune_engine
 open! Stdune
 open! Import
 
-(** Preprocessing object *)
-type t
-
-val dummy : t
-
 val make :
      Super_context.t
   -> dir:Path.Build.t
@@ -19,15 +14,7 @@ val make :
   -> preprocessor_deps:Dep_conf.t list
   -> lib_name:Lib_name.Local.t option
   -> scope:Scope.t
-  -> t
-
-(** Setup the preprocessing rules for the following modules and returns the
-    translated modules *)
-val pp_module : t -> ?lint:bool -> Module.t -> Module.t
-
-(** Preprocess a single module, using the configuration for the given module
-    name. *)
-val pp_module_as : t -> ?lint:bool -> Module_name.t -> Module.t -> Module.t
+  -> Pp_spec.t
 
 (** Get a path to a cached ppx driver with some extra flags for cookies. *)
 val get_ppx_driver :

src/dune_rules/toplevel.ml

@@ -25,7 +25,7 @@ module Source = struct
   let obj_dir { dir; name; _ } = Obj_dir.make_exe ~dir ~name
 
   let modules t pp =
-    main_module t |> Preprocessing.pp_module pp |> Modules.singleton_exe
+    main_module t |> Pp_spec.pp_module pp |> Modules.singleton_exe
 
   let make ~dir ~loc ~main ~name = { dir; main; name; loc }
 

src/dune_rules/toplevel.mli

@@ -8,7 +8,7 @@ module Source : sig
 
   val loc : t -> Loc.t
 
-  val modules : t -> Preprocessing.t -> Modules.t
+  val modules : t -> Pp_spec.t -> Modules.t
 
   val obj_dir : t -> Path.Build.t Obj_dir.t
 end

test/blackbox-tests/test-cases/github3336.t/dune-project

@@ -0,0 +1 @@
+(lang dune 2.4)

test/blackbox-tests/test-cases/github3336.t/executable/dune

@@ -0,0 +1,3 @@
+(executable
+ (name exec)
+ (preprocess (pps ppx)))

test/blackbox-tests/test-cases/github3336.t/executable/exec.ml

@@ -0,0 +1 @@
+let () = ()

test/blackbox-tests/test-cases/github3336.t/library/dune

@@ -0,0 +1,4 @@
+(library
+ (name lib)
+ (library_flags (-linkall))
+ (libraries dune-build-info))

test/blackbox-tests/test-cases/github3336.t/library/lib.ml

@@ -0,0 +1 @@
+let version () = Option.map Build_info.V1.Version.to_string (Build_info.V1.version ())

test/blackbox-tests/test-cases/github3336.t/library/lib.mli

@@ -0,0 +1 @@
+val version : unit -> string option

test/blackbox-tests/test-cases/github3336.t/ppx/dune

@@ -0,0 +1,5 @@
+(library
+ (name ppx)
+ (kind ppx_rewriter)
+ (libraries lib)
+ (ppx.driver (main Ppx.main)))

test/blackbox-tests/test-cases/github3336.t/ppx/ppx.ml

@@ -0,0 +1 @@
+let main () = ()

test/blackbox-tests/test-cases/github3336.t/ppx/ppx.mli

@@ -0,0 +1 @@
+val main : unit -> unit