diff --git a/src/dune_rules/jsoo/jsoo_rules.ml b/src/dune_rules/jsoo/jsoo_rules.ml index e65879f040e..8317a3620db 100644 --- a/src/dune_rules/jsoo/jsoo_rules.ml +++ b/src/dune_rules/jsoo/jsoo_rules.ml @@ -41,6 +41,50 @@ let js_env = compute_env ~mode:JS let wasm_env = compute_env ~mode:Wasm let jsoo_env ~dir ~mode = (Js_of_ocaml.Mode.select ~mode ~js:js_env ~wasm:wasm_env) ~dir +module Version = struct + type t = int * int + + let of_string s : t option = + let s = + match + String.findi s ~f:(function + | '+' | '-' | '~' -> true + | _ -> false) + with + | None -> s + | Some i -> String.take s i + in + try + match String.split s ~on:'.' with + | [] -> None + | [ major ] -> Some (int_of_string major, 0) + | major :: minor :: _ -> Some (int_of_string major, int_of_string minor) + with + | _ -> None + ;; + + let compare (ma1, mi1) (ma2, mi2) = + match Int.compare ma1 ma2 with + | Eq -> Int.compare mi1 mi2 + | n -> n + ;; + + let impl_version bin = + let* _ = Build_system.build_file bin in + Memo.of_reproducible_fiber + @@ Process.run_capture_line ~display:Quiet Strict bin [ "--version" ] + |> Memo.map ~f:of_string + ;; + + let version_memo = Memo.create "jsoo-version" ~input:(module Path) impl_version + + let jsoo_version jsoo = + match jsoo with + | Ok jsoo_path -> Memo.exec version_memo jsoo_path + | Error e -> Action.Prog.Not_found.raise e + ;; +end + module Config : sig type t @@ -48,48 +92,75 @@ module Config : sig val path : t -> string val of_string : string -> t val of_flags : string list -> t - val to_flags : t -> string list + val to_flags : jsoo_version:Version.t option -> t -> string list + val remove_config_flags : string list -> string list end = struct + type effects_backend = + | Cps + | Double_translation + type t = { js_string : bool option - ; effects : bool option + ; effects : effects_backend option ; toplevel : bool option } let default = { js_string = None; effects = None; toplevel = None } let bool_opt = [ None; Some true; Some false ] + let effects_opt = [ None; Some Cps; Some Double_translation ] let all = List.concat_map bool_opt ~f:(fun js_string -> - List.concat_map bool_opt ~f:(fun effects -> + List.concat_map effects_opt ~f:(fun effects -> List.concat_map bool_opt ~f:(fun toplevel -> [ { js_string; effects; toplevel } ]))) ;; - let get t = - List.filter_map - [ "use-js-string", t.js_string; "effects", t.effects; "toplevel", t.toplevel ] - ~f:(fun (n, v) -> - match v with - | None -> None - | Some v -> Some (n, v)) + let enable name acc = + match name with + | "use-js-string" -> { acc with js_string = Some true } + | "effects" -> + (* [--enable effects], used alone, implies [--effects=cps] *) + (match acc.effects with + | None -> { acc with effects = Some Cps } + | Some _ -> acc) + | "toplevel" -> { acc with toplevel = Some true } + | _ -> acc ;; - let set acc name v = + let disable name acc = match name with - | "use-js-string" -> { acc with js_string = Some v } - | "effects" -> { acc with effects = Some v } - | "toplevel" -> { acc with toplevel = Some v } + | "use-js-string" -> { acc with js_string = Some false } + | "effects" -> { acc with effects = None } + | "toplevel" -> { acc with toplevel = Some false } | _ -> acc ;; + let string_of_effects = function + | Cps -> "cps" + | Double_translation -> "double-translation" + ;; + let path t = if t = default then "default" - else - List.map (get t) ~f:(function - | x, true -> x - | x, false -> "!" ^ x) - |> String.concat ~sep:"+" + else ( + let of_bool_opt key = + Option.map ~f:(function + | true -> key + | false -> "!" ^ key) + in + List.filter_opt + [ of_bool_opt "use-js-string" t.js_string + ; Option.map t.effects ~f:(fun e -> "effects=" ^ string_of_effects e) + ; of_bool_opt "toplevel" t.toplevel + ] + |> String.concat ~sep:"+") + ;; + + let effects_of_string = function + | "cps" -> Some Cps + | "double-translation" -> Some Double_translation + | _ -> None ;; let of_string x = @@ -97,80 +168,105 @@ end = struct | "default" -> default | _ -> List.fold_left (String.split ~on:'+' x) ~init:default ~f:(fun acc name -> - match String.drop_prefix ~prefix:"!" name with - | Some name -> set acc name false - | None -> set acc name true) + match + String.drop_prefix ~prefix:"!" name, String.drop_prefix ~prefix:"effects=" name + with + | Some name, _ -> disable name acc + | None, None -> enable name acc + | None, Some backend -> + (match effects_of_string backend with + | Some backend -> { acc with effects = Some backend } + | None -> acc)) ;; let of_flags l = let rec loop acc = function | [] -> acc - | "--enable" :: name :: rest -> loop (set acc name true) rest + | "--enable" :: name :: rest -> loop (enable name acc) rest | maybe_enable :: rest when String.is_prefix maybe_enable ~prefix:"--enable=" -> (match String.drop_prefix maybe_enable ~prefix:"--enable=" with - | Some name -> loop (set acc name true) rest + | Some name -> loop (enable name acc) rest | _ -> assert false) - | "--disable" :: name :: rest -> loop (set acc name false) rest + | "--disable" :: name :: rest -> loop (disable name acc) rest | maybe_disable :: rest when String.is_prefix maybe_disable ~prefix:"--disable=" -> (match String.drop_prefix maybe_disable ~prefix:"--disable=" with - | Some name -> loop (set acc name false) rest + | Some name -> loop (disable name acc) rest | _ -> assert false) - | "--toplevel" :: rest -> loop (set acc "toplevel" true) rest + | "--toplevel" :: rest -> loop (enable "toplevel" acc) rest + | "--effects" :: "cps" :: rest -> loop { acc with effects = Some Cps } rest + | "--effects" :: "double-translation" :: rest -> + loop { acc with effects = Some Double_translation } rest + | maybe_effects :: rest when String.is_prefix maybe_effects ~prefix:"--effects=" -> + let backend = + Option.bind + (String.drop_prefix maybe_effects ~prefix:"--effects=") + ~f:effects_of_string + in + (match backend with + | Some backend -> loop { acc with effects = Some backend } rest + | None -> loop acc rest) | _ :: rest -> loop acc rest in loop default l ;; - let to_flags t = - List.concat_map (get t) ~f:(function - | "toplevel", true -> [ "--toplevel" ] - | "toplevel", false -> [] - | name, true -> [ "--enable"; name ] - | name, false -> [ "--disable"; name ]) - ;; -end - -module Version = struct - type t = int * int - - let of_string s : t option = - let s = - match - String.findi s ~f:(function - | '+' | '-' | '~' -> true - | _ -> false) - with - | None -> s - | Some i -> String.take s i - in - try - match String.split s ~on:'.' with - | [] -> None - | [ major ] -> Some (int_of_string major, 0) - | major :: minor :: _ -> Some (int_of_string major, int_of_string minor) - with - | _ -> None + let backward_compatible_effects ~jsoo_version str = + match str with + | None -> + (* For jsoo, this means unsupported effects. For wasmoo, this means effects go + through the Javascript Promise API. *) + None + | Some Cps -> + let v6_or_higher = + match jsoo_version with + | Some v -> + (match Version.compare v (6, 0) with + | Gt | Eq -> true + | Lt -> false) + | None -> false + in + if v6_or_higher then Some "--effects=cps" else Some "--enable=effects" + | Some Double_translation -> + (* For js_of_ocaml < 6.0, this flag does not exist and will raise an error, + which is fine. *) + Some "--effects=double-translation" ;; - let compare (ma1, mi1) (ma2, mi2) = - match Int.compare ma1 ma2 with - | Eq -> Int.compare mi1 mi2 - | n -> n - ;; - - let impl_version bin = - let* _ = Build_system.build_file bin in - Memo.of_reproducible_fiber - @@ Process.run_capture_line ~display:Quiet Strict bin [ "--version" ] - |> Memo.map ~f:of_string + let to_flags ~jsoo_version t = + List.filter_opt + [ (match t.toplevel with + | Some true -> Some "--toplevel" + | _ -> None) + ; backward_compatible_effects ~jsoo_version t.effects + ; (match t.js_string with + | Some true -> Some "--enable=use-js-string" + | Some false -> Some "--disable=use-js-string" + | None -> None) + ] ;; - let version_memo = Memo.create "jsoo-version" ~input:(module Path) impl_version - - let jsoo_version jsoo = - match jsoo with - | Ok jsoo_path -> Memo.exec version_memo jsoo_path - | Error e -> Action.Prog.Not_found.raise e + let remove_config_flags flags = + let rec loop acc = function + | [] -> acc + | "--enable" :: ("effects" | "use-js-string") :: rest -> loop acc rest + | maybe_enable :: rest when String.is_prefix maybe_enable ~prefix:"--enable=" -> + (match String.drop_prefix maybe_enable ~prefix:"--enable=" with + | Some ("effects" | "use-js-string") -> loop acc rest + | Some _ -> loop (maybe_enable :: acc) rest + | None -> assert false) + | "--disable" :: ("effects" | "use-js-string") :: rest -> loop acc rest + | maybe_disable :: rest when String.is_prefix maybe_disable ~prefix:"--disable=" -> + (match String.drop_prefix maybe_disable ~prefix:"--disable=" with + | Some ("effects" | "use-js-string") -> loop acc rest + | Some _ -> loop (maybe_disable :: acc) rest + | None -> assert false) + | "--effects" :: _backend :: rest -> loop acc rest + | maybe_effects :: rest when String.is_prefix maybe_effects ~prefix:"--effects=" -> + loop acc rest + | "--toplevel" :: rest -> loop acc rest + | other :: rest -> loop (other :: acc) rest + in + loop [] flags |> List.rev ;; end @@ -259,6 +355,13 @@ let js_of_ocaml_rule | Link -> flags.link | Build_runtime -> flags.build_runtime in + let flags = + (* Avoid duplicating flags that are covered by the config *) + Action_builder.map flags ~f:(fun flags -> + match config with + | None -> flags + | Some _ -> Config.remove_config_flags flags) + in Command.run_dyn_prog ~dir:(Path.build dir) jsoo @@ -280,9 +383,14 @@ let js_of_ocaml_rule | None -> S [] | Some config -> Dyn - (Action_builder.map config ~f:(fun config -> - Command.Args.S - (List.map (Config.to_flags config) ~f:(fun x -> Command.Args.A x))))) + (let+ config = config + and+ jsoo_version = + let* jsoo = jsoo in + Action_builder.of_memo (Version.jsoo_version jsoo) + in + Command.Args.S + (List.map (Config.to_flags ~jsoo_version config) ~f:(fun x -> + Command.Args.A x)))) ; A "-o" ; Target target ; spec diff --git a/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin1.ml b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin1.ml new file mode 100644 index 00000000000..bf7f3d4d481 --- /dev/null +++ b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin1.ml @@ -0,0 +1,6 @@ +let name = "bin1" +let hello name = print_endline ("Hi " ^ name) + +let () = Library1.hello name + +let () = hello Library1.name diff --git a/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin2.ml b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin2.ml new file mode 100644 index 00000000000..87c52bec613 --- /dev/null +++ b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin2.ml @@ -0,0 +1,6 @@ +let name = "bin2" +let hello name = print_endline ("Hi " ^ name) + +let () = Library1.hello name + +let () = hello Library1.name diff --git a/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin3.ml b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin3.ml new file mode 100644 index 00000000000..d94b8d12e3a --- /dev/null +++ b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/bin3.ml @@ -0,0 +1,6 @@ +let name = "bin3" +let hello name = print_endline ("Hi " ^ name) + +let () = Library1.hello name + +let () = hello Library1.name diff --git a/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/dune b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/dune new file mode 100644 index 00000000000..318d0199e47 --- /dev/null +++ b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/bin/dune @@ -0,0 +1,23 @@ +(executable + (name bin1) + (modules bin1) + (modes js) + (libraries library1) + (js_of_ocaml + (flags (:standard --enable use-js-string)))) + +(executable + (name bin2) + (modules bin2) + (modes js) + (libraries library1) + (js_of_ocaml + (flags (:standard --disable use-js-string)))) + +(executable + (name bin3) + (modules bin3) + (modes js) + (libraries library1) + (js_of_ocaml + (flags (:standard --effects=cps)))) diff --git a/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/dune b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/dune new file mode 100644 index 00000000000..1b049a5f23f --- /dev/null +++ b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/dune @@ -0,0 +1,5 @@ +(env + (_ + (js_of_ocaml + (flags (:standard --quiet)) + (compilation_mode separate)))) diff --git a/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/dune-project b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/dune-project new file mode 100644 index 00000000000..ef5a4287866 --- /dev/null +++ b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/dune-project @@ -0,0 +1 @@ +(lang dune 3.0) \ No newline at end of file diff --git a/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/lib/dune b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/lib/dune new file mode 100644 index 00000000000..b049d501c31 --- /dev/null +++ b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/lib/dune @@ -0,0 +1,6 @@ +(library + (name library1) + (js_of_ocaml + ;; This will be ignored as the library is compiled once for every effect + ;; config and then the version needed by each individual executable is used + (flags (:standard --effects=double-translation)))) diff --git a/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/lib/library1.ml b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/lib/library1.ml new file mode 100644 index 00000000000..70ad25d7d71 --- /dev/null +++ b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/lib/library1.ml @@ -0,0 +1,3 @@ +let name = "library1" + +let hello name = print_endline ("Hello " ^ name) diff --git a/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/run.t b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/run.t new file mode 100644 index 00000000000..c5c7922d8c8 --- /dev/null +++ b/test/blackbox-tests/test-cases/jsoo/jsoo-config-effects.t/run.t @@ -0,0 +1,13 @@ +This tests a js_of_ocaml config of linking the same library with different, +incompatible `--effects` flags + + $ dune build bin/bin1.bc.js bin/bin2.bc.js bin/bin3.bc.js + $ node _build/default/bin/bin1.bc.js + Hello bin1 + Hi library1 + $ node _build/default/bin/bin2.bc.js + Hello bin2 + Hi library1 + $ node _build/default/bin/bin3.bc.js + Hello bin3 + Hi library1 diff --git a/test/blackbox-tests/test-cases/jsoo/no-check-prim.t/run.t b/test/blackbox-tests/test-cases/jsoo/no-check-prim.t/run.t index 280a783d2ed..a4086af8964 100644 --- a/test/blackbox-tests/test-cases/jsoo/no-check-prim.t/run.t +++ b/test/blackbox-tests/test-cases/jsoo/no-check-prim.t/run.t @@ -2,11 +2,11 @@ Compilation using jsoo $ dune build --display short bin/technologic.bc.js @install 2>&1 | \ > sed s,^\ *$(ocamlc -config-var c_compiler),\ \ C_COMPILER,g - js_of_ocaml bin/.technologic.eobjs/jsoo/technologic.bc.runtime.js ocamldep bin/.technologic.eobjs/technologic.impl.d ocamldep lib/.x.objs/x.impl.d ocamlc lib/.x.objs/byte/x__.{cmi,cmo,cmt} ocamldep lib/.x.objs/x__Y.impl.d + js_of_ocaml bin/.technologic.eobjs/jsoo/technologic.bc.runtime.js ocamldep bin/.technologic.eobjs/z.impl.d ocamlopt lib/.x.objs/native/x__.{cmx,o} ocamlc lib/.x.objs/byte/x__Y.{cmi,cmo,cmt} diff --git a/test/blackbox-tests/test-cases/wasmoo/no-check-prim.t/run.t b/test/blackbox-tests/test-cases/wasmoo/no-check-prim.t/run.t index 79999cde7db..04b6dec2de9 100644 --- a/test/blackbox-tests/test-cases/wasmoo/no-check-prim.t/run.t +++ b/test/blackbox-tests/test-cases/wasmoo/no-check-prim.t/run.t @@ -2,11 +2,11 @@ Compilation using WasmOO $ dune build --display short bin/technologic.bc.wasm.js @install 2>&1 | \ > sed s,^\ *$(ocamlc -config-var c_compiler),\ \ C_COMPILER,g - wasm_of_ocaml bin/.technologic.eobjs/jsoo/technologic.bc.runtime.wasma ocamldep bin/.technologic.eobjs/dune__exe__Technologic.impl.d ocamldep lib/.x.objs/x.impl.d ocamlc lib/.x.objs/byte/x__.{cmi,cmo,cmt} ocamldep lib/.x.objs/x__Y.impl.d + wasm_of_ocaml bin/.technologic.eobjs/jsoo/technologic.bc.runtime.wasma ocamldep bin/.technologic.eobjs/dune__exe__Z.impl.d ocamlopt lib/.x.objs/native/x__.{cmx,o} ocamlc lib/.x.objs/byte/x__Y.{cmi,cmo,cmt}