Implement --target-exec

bin/common.ml

@@ -648,6 +648,7 @@ module Builder = struct
     ; stats_trace_file : string option
     ; allow_builds : bool
     ; default_root_is_cwd : bool
+    ; target_exec : string option
     }
 
   let root t = t.root
@@ -864,10 +865,25 @@ module Builder = struct
       =
       Options_implied_by_dash_p.term
     and+ x =
+      let doc = "Cross-compile using this toolchain." in
       Arg.(
         value
         & opt (some Arg.context_name) None
-        & info [ "x" ] ~docs ~doc:(Some "Cross-compile using this toolchain."))
+        & info [ "x" ] ~docs ~doc:(Some doc) ~env:(Cmd.Env.info ~doc "DUNE_CROSS_TARGET"))
+    and+ target_exec =
+      let doc =
+        "Wrapper command for running target binaries when cross-compiling. Format: \
+         TOOLCHAIN=CMD (e.g., 'windows=wine')."
+      in
+      Arg.(
+        value
+        & opt (some string) None
+        & info
+            [ "target-exec" ]
+            ~docs
+            ~docv:"TOOLCHAIN=CMD"
+            ~doc:(Some doc)
+            ~env:(Cmd.Env.info ~doc "DUNE_TARGET_EXEC"))
     and+ build_dir =
       let doc = "Specified build directory. _build if unspecified" in
       Arg.(
@@ -1068,6 +1084,7 @@ module Builder = struct
     ; stats_trace_file
     ; allow_builds = true
     ; default_root_is_cwd = false
+    ; target_exec
     }
   ;;
 
@@ -1112,6 +1129,7 @@ module Builder = struct
         ; stats_trace_file
         ; allow_builds
         ; default_root_is_cwd
+        ; target_exec
         }
     =
     Bool.equal t.debug_dep_path debug_dep_path
@@ -1151,6 +1169,7 @@ module Builder = struct
     && Option.equal String.equal t.stats_trace_file stats_trace_file
     && Bool.equal t.allow_builds allow_builds
     && Bool.equal t.default_root_is_cwd default_root_is_cwd
+    && Option.equal String.equal t.target_exec target_exec
   ;;
 end
 
@@ -1401,6 +1420,22 @@ let init_with_root ~(root : Workspace_root.t) (builder : Builder.t) =
    := match config.cache_enabled with
       | Disabled | Enabled_except_user_rules -> false
       | Enabled -> true);
+  (match c.builder.target_exec with
+   | None -> Dune_engine.Clflags.target_exec := None
+   | Some spec ->
+     let toolchain, wrapper_cmd =
+       match String.lsplit2 spec ~on:'=' with
+       | Some (tc, cmd) -> tc, cmd
+       | None -> User_error.raise [ Pp.textf "--target-exec: invalid format" ]
+     in
+     let parts =
+       String.split wrapper_cmd ~on:' '
+       |> List.filter ~f:(fun s -> not (String.is_empty s))
+     in
+     (match parts with
+      | [] ->
+        User_error.raise [ Pp.textf "--target-exec: wrapper command cannot be empty" ]
+      | prog :: args -> Dune_engine.Clflags.target_exec := Some (toolchain, prog, args)));
   Log.info
     "Workspace root"
     [ "root", Dyn.string (Path.to_absolute_filename Path.root |> String.maybe_quoted) ];

src/dune_engine/clflags.ml

@@ -15,6 +15,7 @@ module Promote = struct
   ;;
 end
 
+let target_exec = ref None
 let report_errors_config = ref Report_errors_config.default
 let stop_on_first_error = ref false
 let debug_fs_cache = ref false

src/dune_engine/clflags.mli

@@ -1,5 +1,8 @@
 (** Command line flags *)
 
+(** Wrapper for target executables in cross-compilation: (toolchain, prog, args) *)
+val target_exec : (string * string * string list) option ref
+
 val report_errors_config : Report_errors_config.t ref
 
 (** Stop the build upon encountering an error. *)

src/dune_lang/action.ml

@@ -147,6 +147,7 @@ end
 
 type t =
   | Run of Slang.t list
+  | Runexec of Slang.t list
   | With_accepted_exit_codes of int Predicate_lang.t * t
   | Dynamic_run of String_with_vars.t * String_with_vars.t list
   | Chdir of String_with_vars.t * t
@@ -372,6 +373,14 @@ let decode_dune_file =
           Slang.Literal prog :: List.map args ~f:(fun arg -> Slang.Literal arg)
         in
         Run slang )
+    ; ( "runexec"
+      , Syntax.since Stanza.syntax (3, 21)
+        >>> let+ prog = sw
+            and+ args = repeat sw in
+            let slang =
+              Slang.Literal prog :: List.map args ~f:(fun arg -> Slang.Literal arg)
+            in
+            Runexec slang )
     ]
   in
   Decoder.fix @@ fun t -> Decoder.sum (cstrs_dune_file t @ dune_file_specific)
@@ -407,6 +416,10 @@ let decode_pkg =
           repeat Slang.decode
         in
         Run args )
+    ; ( "runexec"
+      , Syntax.since Stanza.syntax (3, 21)
+        >>> let+ args = repeat Slang.decode in
+            Runexec args )
     ]
   in
   Decoder.fix @@ fun t -> Decoder.sum (cstrs_dune_file t @ cstrs_pkg t)
@@ -416,6 +429,7 @@ let rec encode =
   let sw = String_with_vars.encode in
   function
   | Run xs -> List (atom "run" :: List.map xs ~f:Slang.encode)
+  | Runexec xs -> List (atom "runexec" :: List.map xs ~f:Slang.encode)
   | With_accepted_exit_codes (pred, t) ->
     List
       [ atom "with-accepted-exit-codes"
@@ -490,6 +504,7 @@ let ensure_at_most_one_dynamic_run ~loc action =
     | When (_, t)
     | No_infer t -> loop t
     | Run _
+    | Runexec _
     | Echo _
     | Cat _
     | Copy _
@@ -567,6 +582,11 @@ let rec map t ~string_with_vars ~slang ~blang =
       (List.map
          ~f:(fun slang_ -> slang slang_ |> slang_map_string_with_vars ~f:string_with_vars)
          xs)
+  | Runexec xs ->
+    Runexec
+      (List.map
+         ~f:(fun slang_ -> slang slang_ |> slang_map_string_with_vars ~f:string_with_vars)
+         xs)
   | With_accepted_exit_codes (lang, t) ->
     With_accepted_exit_codes (lang, map t ~string_with_vars ~slang ~blang)
   | Dynamic_run (sw, sws) ->

src/dune_lang/action.mli

@@ -89,6 +89,7 @@ end
 
 type t =
   | Run of Slang.t list
+  | Runexec of Slang.t list
   | With_accepted_exit_codes of int Predicate_lang.t * t
   | Dynamic_run of String_with_vars.t * String_with_vars.t list
   | Chdir of String_with_vars.t * t

src/dune_rules/action_unexpanded.ml

@@ -78,7 +78,11 @@ module Action_expander : sig
     (* Evaluate a path that "consumes" a target, such as in [(diff? ...
        <file>)] *)
     val consume_file : String_with_vars.t -> Path.Build.t t
-    val prog_and_args : String_with_vars.t -> (Action.Prog.t * string list) t
+
+    val prog_and_args
+      :  force_host:bool
+      -> String_with_vars.t
+      -> (Action.Prog.t * string list) t
 
     module At_rule_eval_stage : sig
       (* Expansion that happens at the time the rule is constructed rather than
@@ -376,7 +380,7 @@ end = struct
 
     let target = add_or_remove_target ~what:"Target" ~f:Path.Build.Map.set
 
-    let prog_and_args sw env acc =
+    let prog_args_and_deps ~force_host sw env acc =
       let b =
         let dir = Path.build env.dir in
         let loc = loc sw in
@@ -413,13 +417,24 @@ end = struct
                in
                Artifacts.binary ?hint ~loc:(Some loc) ~where artifacts s)
         in
-        let prog = Result.map prog ~f:(Expander.map_exe env.expander) in
         let args = Value.L.to_strings ~dir args in
-        prog, args
+        match prog with
+        | Ok prog ->
+          let dep, prog, args = Expander.map_exe ~force_host env.expander prog args in
+          Ok prog, args, [ dep ]
+        | Error _ as v -> v, args, []
       in
-      register_deps b env acc ~f:(function
-        | Ok p, _ -> [ p ]
-        | Error _, _ -> [])
+      register_deps b env acc ~f:(function _, _, deps -> deps)
+    ;;
+
+    let prog_and_args ~force_host sw env acc =
+      Memo.map
+        ~f:(fun (x, v) ->
+          ( Action_builder.bind
+              ~f:(fun (prog, args, _) -> Action_builder.return (prog, args))
+              x
+          , v ))
+        (prog_args_and_deps ~force_host sw env acc)
     ;;
   end
 end
@@ -429,31 +444,38 @@ let rec expand (t : Dune_lang.Action.t) : Action.t Action_expander.t =
   let module E = Action_expander.E in
   let open Action_expander.O in
   let module O (* [O] for "outcome" *) = Action in
-  let expand_run prog args =
+  let expand_run ~force_host prog args =
     let+ args = A.all (List.map args ~f:E.strings)
-    and+ prog, more_args = E.prog_and_args prog in
+    and+ prog, more_args = E.prog_and_args ~force_host prog in
     let args = List.concat args in
     prog, more_args @ args
   in
-  match t with
-  | Run args ->
+  let expand_run_action ~force_host ~action_name args =
     let string_args =
       List.filter_map args ~f:(function
         | Slang.Literal sw -> Some sw
         | _ -> None)
     in
     if List.length string_args < List.length args
-    then User_error.raise [ Pp.text "All arguments to \"run\" action must be strings" ];
-    (match string_args with
-     | prog :: args ->
-       let+ prog, args = expand_run prog args in
-       O.Run (prog, Array.Immutable.of_list args)
-     | [] -> User_error.raise [ Pp.text "\"run\" action must have at least one argument" ])
+    then
+      User_error.raise
+        [ Pp.textf "All arguments to \"%s\" action must be strings" action_name ];
+    match string_args with
+    | prog :: args ->
+      let+ prog, args = expand_run ~force_host prog args in
+      O.Run (prog, Array.Immutable.of_list args)
+    | [] ->
+      User_error.raise
+        [ Pp.textf "\"%s\" action must have at least one argument" action_name ]
+  in
+  match t with
+  | Run args -> expand_run_action ~force_host:false ~action_name:"run" args
+  | Runexec args -> expand_run_action ~force_host:true ~action_name:"runexec" args
   | With_accepted_exit_codes (pred, t) ->
     let+ t = expand t in
     O.With_accepted_exit_codes (pred, t)
   | Dynamic_run (prog, args) ->
-    let+ prog, args = expand_run prog args in
+    let+ prog, args = expand_run ~force_host:false prog args in
     Action_plugin.action ~prog ~args
   | Chdir (fn, t) ->
     E.At_rule_eval_stage.path fn ~f:(fun dir ->

src/dune_rules/context.ml

@@ -76,6 +76,7 @@ type builder =
   ; env : Env.t Memo.t
   ; implicit : bool
   ; findlib_toolchain : Context_name.t option
+  ; target_exec : (string * string list) option
   ; for_host : (Context_name.t * t Memo.t) option
   ; path : Path.t list
   }
@@ -91,6 +92,15 @@ and t =
   ; which : Filename.t -> Path.t option Memo.t
   }
 
+let default_target_exec ~target_exec toolchain =
+  match
+    target_exec, !Dune_engine.Clflags.target_exec, Context_name.to_string toolchain
+  with
+  | _, Some (name, prog, args), toolchain when name = toolchain -> Some (prog, args)
+  | Some target_exec, _, _ -> Some target_exec
+  | _ -> None
+;;
+
 module Builder = struct
   type t = builder
 
@@ -105,6 +115,7 @@ module Builder = struct
     ; env = Memo.return Env.empty
     ; implicit = false
     ; findlib_toolchain = None
+    ; target_exec = None
     ; for_host = None
     ; path = []
     }
@@ -161,6 +172,7 @@ module Builder = struct
     ; name
     ; env = Memo.return env
     ; findlib_toolchain = toolchain
+    ; target_exec = None
     }
   ;;
 end
@@ -567,12 +579,16 @@ module Group = struct
       in
       List.filter_map targets ~f:(function
         | Native -> None
-        | Named findlib_toolchain ->
+        | Named { name = findlib_toolchain; target_exec } ->
           Some
             (Memo.Lazy.create ~name:"findlib_toolchain" (fun () ->
                let name = Context_name.target builder.name ~toolchain:findlib_toolchain in
                create
-                 { builder with name; findlib_toolchain = Some findlib_toolchain }
+                 { builder with
+                   name
+                 ; findlib_toolchain = Some findlib_toolchain
+                 ; target_exec = default_target_exec ~target_exec findlib_toolchain
+                 }
                  ~kind
                |> Memo.return)))
     in
@@ -728,16 +744,34 @@ module DB = struct
   ;;
 end
 
-let map_exe (context : t) =
-  match context.builder.for_host with
-  | None -> fun exe -> exe
-  | Some (name, _) ->
-    fun exe ->
-      let build_dir = Context_name.build_dir name in
-      (match Path.extract_build_context_dir exe with
-       | Some (dir, exe) when Path.equal dir (Path.build context.build_dir) ->
-         Path.append_source (Path.build build_dir) exe
-       | _ -> exe)
+let map_exe ~force_host (context : t) =
+  match force_host, context.builder with
+  | false, { target_exec = Some (wrapper, wrapper_args); _ } ->
+    fun prog args ->
+      (match Path.extract_build_context_dir prog with
+       | Some (dir, _) when Path.equal dir (Path.build context.build_dir) ->
+         let args = wrapper_args @ (Path.to_absolute_filename prog :: args) in
+         let wrapper =
+           match Bin.which ~path:(Env_path.path Env.initial) wrapper with
+           | Some p -> p
+           | None ->
+             User_error.raise
+               [ Pp.textf "Target exec wrapper %s could not be found in the path!" wrapper
+               ]
+         in
+         prog, wrapper, args
+       | _ -> prog, prog, args)
+  | _, { for_host = None; _ } -> fun prog args -> prog, prog, args
+  | _, { for_host = Some (name, _); _ } ->
+    let build_dir = Context_name.build_dir name in
+    fun prog args ->
+      let prog =
+        match Path.extract_build_context_dir prog with
+        | Some (dir, prog) when Path.equal dir (Path.build context.build_dir) ->
+          Path.append_source (Path.build build_dir) prog
+        | _ -> prog
+      in
+      prog, prog, args
 ;;
 
 let roots =

src/dune_rules/context.mli

@@ -90,11 +90,16 @@ val implicit : t -> bool
 (** Compare the context names *)
 val compare : t -> t -> Ordering.t
 
-(** [map_exe t exe] returns a version of [exe] that is suitable for being
-    executed on the current machine. For instance, if [t] is a cross-compilation
-    build context, [map_exe t exe] returns the version of [exe] that lives in
-    the host build context. Otherwise, it just returns [exe]. *)
-val map_exe : t -> Path.t -> Path.t
+(** [map_exe ~force_host t exe] returns a version of [exe] that is suitable for
+    being executed on the current machine. When [force_host] is true, always
+    runs as a native host binary, bypassing any target_exec wrapper. Returns:
+    [dependency, actual_program, actual_arguments] *)
+val map_exe
+  :  force_host:bool
+  -> t
+  -> Path.t
+  -> string list
+  -> Path.t * Path.t * string list
 
 (** Query where build artifacts should be installed if the user doesn't specify
     an explicit installation directory. *)