diff --git a/compiler/bin-wasm_of_ocaml/build_runtime.ml b/compiler/bin-wasm_of_ocaml/build_runtime.ml new file mode 100644 index 000000000..b0dbc4fb1 --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/build_runtime.ml @@ -0,0 +1,33 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2020 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open! Js_of_ocaml_compiler.Stdlib + +let info = + Info.make + ~name:"build-runtime" + ~doc:"Build standalone runtime. Used for separate compilation." + ~description: + "Js_of_ocaml is a compiler from OCaml bytecode to Javascript. It makes it possible \ + to run pure OCaml programs in JavaScript environments like web browsers and \ + Node.js." + +let command = + let t = Cmdliner.Term.(const Compile.run $ Cmd_arg.options_runtime_only) in + Cmdliner.Cmd.v info t diff --git a/compiler/bin-wasm_of_ocaml/build_runtime.mli b/compiler/bin-wasm_of_ocaml/build_runtime.mli new file mode 100644 index 000000000..969933f7a --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/build_runtime.mli @@ -0,0 +1,20 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2020 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +val command : unit Cmdliner.Cmd.t diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.ml b/compiler/bin-wasm_of_ocaml/cmd_arg.ml index f2e12cfd3..b1b414f59 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.ml +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.ml @@ -44,8 +44,9 @@ type t = ; (* compile option *) profile : Driver.profile option ; runtime_files : string list + ; runtime_only : bool ; output_file : string * bool - ; input_file : string + ; input_file : string option ; enable_source_maps : bool ; sourcemap_root : string option ; sourcemap_don't_inline_content : bool @@ -113,9 +114,17 @@ let options = runtime_files = let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in let output_file = + let ext = + try + snd + (List.find + ~f:(fun (ext, _) -> Filename.check_suffix input_file ext) + [ ".cmo", ".wasmo"; ".cma", ".wasma" ]) + with Not_found -> ".js" + in match output_file with | Some s -> s, true - | None -> chop_extension input_file ^ ".js", false + | None -> chop_extension input_file ^ ext, false in let params : (string * string) list = List.flatten set_param in let enable_source_maps = (not no_sourcemap) && sourcemap in @@ -126,8 +135,9 @@ let options = ; include_dirs ; profile ; output_file - ; input_file + ; input_file = Some input_file ; runtime_files + ; runtime_only = false ; enable_source_maps ; sourcemap_root ; sourcemap_don't_inline_content @@ -149,3 +159,82 @@ let options = $ runtime_files) in Term.ret t + +let options_runtime_only = + let runtime_files = + let doc = "Link JavaScript and WebAssembly files [$(docv)]. " in + Arg.(value & pos_all string [] & info [] ~docv:"RUNTIME_FILES" ~doc) + in + let output_file = + let doc = "Set output file name to [$(docv)]." in + Arg.(required & opt (some string) None & info [ "o" ] ~docv:"FILE" ~doc) + in + let no_sourcemap = + let doc = "Currently ignored (for compatibility with Js_of_ocaml)." in + Arg.(value & flag & info [ "no-sourcemap"; "no-source-map" ] ~doc) + in + let sourcemap = + let doc = "Currently ignored (for compatibility with Js_of_ocaml)." in + Arg.(value & flag & info [ "sourcemap"; "source-map"; "source-map-inline" ] ~doc) + in + let sourcemap_don't_inline_content = + let doc = "Do not inline sources in source map." in + Arg.(value & flag & info [ "source-map-no-source" ] ~doc) + in + let sourcemap_root = + let doc = "root dir for source map." in + Arg.(value & opt (some string) None & info [ "source-map-root" ] ~doc) + in + let include_dirs = + let doc = "Add [$(docv)] to the list of include directories." in + Arg.(value & opt_all string [] & info [ "I" ] ~docv:"DIR" ~doc) + in + let set_param = + let doc = "Set compiler options." in + let all = List.map (Config.Param.all ()) ~f:(fun (x, _) -> x, x) in + Arg.( + value + & opt_all (list (pair ~sep:'=' (enum all) string)) [] + & info [ "set" ] ~docv:"PARAM=VALUE" ~doc) + in + let build_t + common + set_param + include_dirs + sourcemap + no_sourcemap + sourcemap_don't_inline_content + sourcemap_root + output_file + runtime_files = + let params : (string * string) list = List.flatten set_param in + let enable_source_maps = (not no_sourcemap) && sourcemap in + let include_dirs = normalize_include_dirs include_dirs in + `Ok + { common + ; params + ; include_dirs + ; profile = None + ; output_file = output_file, true + ; input_file = None + ; runtime_files + ; runtime_only = true + ; enable_source_maps + ; sourcemap_root + ; sourcemap_don't_inline_content + } + in + let t = + Term.( + const build_t + $ Jsoo_cmdline.Arg.t + $ set_param + $ include_dirs + $ sourcemap + $ no_sourcemap + $ sourcemap_don't_inline_content + $ sourcemap_root + $ output_file + $ runtime_files) + in + Term.ret t diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.mli b/compiler/bin-wasm_of_ocaml/cmd_arg.mli index fd9de45dd..0bacf92e1 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.mli +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.mli @@ -24,8 +24,9 @@ type t = ; (* compile option *) profile : Driver.profile option ; runtime_files : string list + ; runtime_only : bool ; output_file : string * bool - ; input_file : string + ; input_file : string option ; enable_source_maps : bool ; sourcemap_root : string option ; sourcemap_don't_inline_content : bool @@ -34,3 +35,5 @@ type t = } val options : t Cmdliner.Term.t + +val options_runtime_only : t Cmdliner.Term.t diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 88198d48d..b91be415c 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -121,7 +121,54 @@ let link_and_optimize opt_sourcemap_file; primitives -let build_js_runtime ~primitives ~runtime_arguments = +let link_runtime ~profile runtime_wasm_files output_file = + Fs.with_intermediate_file (Filename.temp_file "runtime" ".wasm") + @@ fun runtime_file -> + Fs.write_file ~name:runtime_file ~contents:Wa_runtime.wasm_runtime; + Fs.with_intermediate_file (Filename.temp_file "wasm-merged" ".wasm") + @@ fun temp_file -> + Wa_binaryen.link + ~opt_output_sourcemap:None + ~runtime_files:(runtime_file :: runtime_wasm_files) + ~input_files:[] + ~output_file:temp_file; + Wa_binaryen.optimize + ~profile + ~opt_input_sourcemap:None + ~opt_output_sourcemap:None + ~opt_sourcemap_url:None + ~input_file:temp_file + ~output_file + +let generate_prelude ~out_file = + Filename.gen_file out_file + @@ fun ch -> + let code, uinfo = Parse_bytecode.predefined_exceptions ~target:`Wasm in + let live_vars, in_cps, p, debug = + Driver.f ~target:Wasm (Parse_bytecode.Debug.create ~include_cmis:false false) code + in + let context = Wa_generate.start () in + let _ = Wa_generate.f ~context ~unit_name:(Some "prelude") ~live_vars ~in_cps p in + Wa_generate.output ch ~context ~debug; + uinfo.provides + +let build_prelude z = + Fs.with_intermediate_file (Filename.temp_file "prelude" ".wasm") + @@ fun prelude_file -> + Fs.with_intermediate_file (Filename.temp_file "prelude_file" ".wasm") + @@ fun tmp_prelude_file -> + let predefined_exceptions = generate_prelude ~out_file:prelude_file in + Wa_binaryen.optimize + ~profile:(Driver.profile 1) + ~input_file:prelude_file + ~output_file:tmp_prelude_file + ~opt_input_sourcemap:None + ~opt_output_sourcemap:None + ~opt_sourcemap_url:None; + Zip.add_file z ~name:"prelude.wasm" ~file:tmp_prelude_file; + predefined_exceptions + +let build_js_runtime ~primitives ?runtime_arguments () = let always_required_js, primitives = let l = StringSet.fold @@ -152,7 +199,11 @@ let build_js_runtime ~primitives ~runtime_arguments = let launcher = let js = let js = Javascript.call init_fun [ primitives ] N in - let js = Javascript.call js [ runtime_arguments ] N in + let js = + match runtime_arguments with + | None -> js + | Some runtime_arguments -> Javascript.call js [ runtime_arguments ] N + in [ Javascript.Expression_statement js, Javascript.N ] in Wa_link.output_js js @@ -162,6 +213,7 @@ let build_js_runtime ~primitives ~runtime_arguments = let run { Cmd_arg.common ; profile + ; runtime_only ; runtime_files ; input_file ; output_file @@ -210,101 +262,179 @@ let run if times () then Format.eprintf " parsing js: %a@." Timer.print t1; if times () then Format.eprintf "Start parsing...@."; let need_debug = enable_source_maps || Config.Flag.debuginfo () in - let output (one : Parse_bytecode.one) ~standalone ch = + let output (one : Parse_bytecode.one) ~unit_name ch = let code = one.code in + let standalone = Option.is_none unit_name in let live_vars, in_cps, p, debug = - Driver.f - ~target:Wasm - ~standalone - ?profile - ~linkall:false - ~wrap_with_fun:`Iife - one.debug - code + Driver.f ~target:Wasm ~standalone ?profile one.debug code in let context = Wa_generate.start () in let toplevel_name, generated_js = - Wa_generate.f ~context ~unit_name:None ~live_vars ~in_cps p + Wa_generate.f ~context ~unit_name ~live_vars ~in_cps p in - Wa_generate.add_start_function ~context toplevel_name; + if standalone then Wa_generate.add_start_function ~context toplevel_name; Wa_generate.output ch ~context ~debug; if times () then Format.eprintf "compilation: %a@." Timer.print t; generated_js in - (let kind, ic, close_ic, include_dirs = - let ch = open_in_bin input_file in - let res = Parse_bytecode.from_channel ch in - let include_dirs = Filename.dirname input_file :: include_dirs in - res, ch, (fun () -> close_in ch), include_dirs - in - (match kind with - | `Exe -> + (if runtime_only + then ( + Fs.gen_file output_file + @@ fun tmp_output_file -> + Fs.with_intermediate_file (Filename.temp_file "wasm" ".wasm") + @@ fun tmp_wasm_file -> + link_runtime ~profile runtime_wasm_files tmp_wasm_file; + let primitives = + tmp_wasm_file + |> (fun file -> Wa_link.Wasm_binary.read_imports ~file) + |> List.filter_map ~f:(fun { Wa_link.Wasm_binary.module_; name; _ } -> + if String.equal module_ "js" then Some name else None) + |> StringSet.of_list + in + let js_runtime = build_js_runtime ~primitives () in + let z = Zip.open_out tmp_output_file in + Zip.add_file z ~name:"runtime.wasm" ~file:tmp_wasm_file; + Zip.add_entry z ~name:"runtime.js" ~contents:js_runtime; + let predefined_exceptions = build_prelude z in + Wa_link.add_info + z + ~predefined_exceptions + ~build_info:(Build_info.create `Runtime) + ~unit_data:[] + (); + Zip.close_out z) + else + let kind, ic, close_ic, include_dirs = + let input_file = + match input_file with + | None -> assert false + | Some f -> f + in + let ch = open_in_bin input_file in + let res = Parse_bytecode.from_channel ch in + let include_dirs = Filename.dirname input_file :: include_dirs in + res, ch, (fun () -> close_in ch), include_dirs + in + let compile_cmo z cmo = let t1 = Timer.make () in - (* The OCaml compiler can generate code using the - "caml_string_greaterthan" primitive but does not use it - itself. This is (was at some point at least) the only primitive - in this case. Ideally, Js_of_ocaml should parse the .mli files - for primitives as well as marking this primitive as potentially - used. But the -linkall option is probably good enough. *) let code = - Parse_bytecode.from_exe + Parse_bytecode.from_cmo ~target:`Wasm ~includes:include_dirs - ~include_cmis:false - ~link_info:false - ~linkall:false ~debug:need_debug + cmo ic in - if times () then Format.eprintf " parsing: %a@." Timer.print t1; - Fs.gen_file (Filename.chop_extension output_file ^ ".wat") + let unit_info = Unit_info.of_cmo cmo in + let unit_name = StringSet.choose unit_info.provides in + if times () then Format.eprintf " parsing: %a (%s)@." Timer.print t1 unit_name; + Fs.with_intermediate_file (Filename.temp_file unit_name ".wat") @@ fun wat_file -> - let wasm_file = - if Filename.check_suffix output_file ".wasm.js" - then Filename.chop_extension output_file - else Filename.chop_extension output_file ^ ".wasm" - in - Fs.gen_file wasm_file + Fs.with_intermediate_file (Filename.temp_file unit_name ".wasm") @@ fun tmp_wasm_file -> - opt_with - Fs.gen_file - (if enable_source_maps then Some (wasm_file ^ ".map") else None) - @@ fun opt_tmp_sourcemap -> - let generated_js = output_gen wat_file (output code ~standalone:true) in - let primitives = - link_and_optimize - ~profile - ~sourcemap_root - ~sourcemap_don't_inline_content - ~opt_sourcemap:opt_tmp_sourcemap - ~opt_sourcemap_url: - (if enable_source_maps - then Some (Filename.basename wasm_file ^ ".map") - else None) - runtime_wasm_files - [ wat_file ] - tmp_wasm_file + Fs.with_intermediate_file (Filename.temp_file unit_name ".wasm.map") + @@ fun tmp_map_file -> + let strings, fragments = + output_gen wat_file (output code ~unit_name:(Some unit_name)) in - let js_runtime = - let missing_primitives = - let l = Wa_link.Wasm_binary.read_imports ~file:tmp_wasm_file in - List.filter_map - ~f:(fun { Wa_link.Wasm_binary.module_; name; _ } -> - if String.equal module_ "env" then Some name else None) - l - in - build_js_runtime - ~primitives - ~runtime_arguments: - (Wa_link.build_runtime_arguments - ~missing_primitives - ~wasm_file - ~generated_js) + let opt_output_sourcemap = + if enable_source_maps then Some tmp_map_file else None in - Fs.gen_file output_file - @@ fun tmp_output_file -> Fs.write_file ~name:tmp_output_file ~contents:js_runtime - | `Cmo _ | `Cma _ -> assert false); - close_ic ()); + Wa_binaryen.optimize + ~profile + ~opt_input_sourcemap:None + ~opt_output_sourcemap + ~opt_sourcemap_url: + (if enable_source_maps then Some (unit_name ^ ".wasm.map") else None) + ~input_file:wat_file + ~output_file:tmp_wasm_file; + Option.iter + ~f:(update_sourcemap ~sourcemap_root ~sourcemap_don't_inline_content) + opt_output_sourcemap; + Zip.add_file z ~name:(unit_name ^ ".wasm") ~file:tmp_wasm_file; + if enable_source_maps + then Zip.add_file z ~name:(unit_name ^ ".wasm.map") ~file:tmp_map_file; + { Wa_link.unit_info; strings; fragments } + in + (match kind with + | `Exe -> + let t1 = Timer.make () in + let code = + Parse_bytecode.from_exe + ~target:`Wasm + ~includes:include_dirs + ~include_cmis:false + ~link_info:false + ~linkall:false + ~debug:need_debug + ic + in + if times () then Format.eprintf " parsing: %a@." Timer.print t1; + Fs.gen_file (Filename.chop_extension output_file ^ ".wat") + @@ fun wat_file -> + let wasm_file = + if Filename.check_suffix output_file ".wasm.js" + then Filename.chop_extension output_file + else Filename.chop_extension output_file ^ ".wasm" + in + Fs.gen_file wasm_file + @@ fun tmp_wasm_file -> + opt_with + Fs.gen_file + (if enable_source_maps then Some (wasm_file ^ ".map") else None) + @@ fun opt_tmp_sourcemap -> + let generated_js = output_gen wat_file (output code ~unit_name:None) in + let primitives = + link_and_optimize + ~profile + ~sourcemap_root + ~sourcemap_don't_inline_content + ~opt_sourcemap:opt_tmp_sourcemap + ~opt_sourcemap_url: + (if enable_source_maps + then Some (Filename.basename wasm_file ^ ".map") + else None) + runtime_wasm_files + [ wat_file ] + tmp_wasm_file + in + let js_runtime = + let missing_primitives = + let l = Wa_link.Wasm_binary.read_imports ~file:tmp_wasm_file in + List.filter_map + ~f:(fun { Wa_link.Wasm_binary.module_; name; _ } -> + if String.equal module_ "env" then Some name else None) + l + in + build_js_runtime + ~primitives + ~runtime_arguments: + (Wa_link.build_runtime_arguments + ~missing_primitives + ~wasm_file + ~generated_js:[ None, generated_js ] + ()) + () + in + Fs.gen_file output_file + @@ fun tmp_output_file -> + Fs.write_file ~name:tmp_output_file ~contents:js_runtime + | `Cmo cmo -> + Fs.gen_file output_file + @@ fun tmp_output_file -> + let z = Zip.open_out tmp_output_file in + let unit_data = [ compile_cmo z cmo ] in + Wa_link.add_info z ~build_info:(Build_info.create `Cmo) ~unit_data (); + Zip.close_out z + | `Cma cma -> + Fs.gen_file output_file + @@ fun tmp_output_file -> + let z = Zip.open_out tmp_output_file in + let unit_data = List.map ~f:(fun cmo -> compile_cmo z cmo) cma.lib_units in + let unit_data = Wa_link.simplify_unit_info unit_data in + Wa_link.add_info z ~build_info:(Build_info.create `Cma) ~unit_data (); + Zip.close_out z); + close_ic ()); Debug.stop_profiling () let info name = diff --git a/compiler/bin-wasm_of_ocaml/link.ml b/compiler/bin-wasm_of_ocaml/link.ml new file mode 100644 index 000000000..7fa801124 --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/link.ml @@ -0,0 +1,87 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2020 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open! Js_of_ocaml_compiler.Stdlib +open Wasm_of_ocaml_compiler +open Cmdliner + +type t = + { common : Jsoo_cmdline.Arg.t + ; files : string list + ; output_file : string + ; linkall : bool + ; enable_source_maps : bool + } + +let options = + let output_file = + let doc = "Set output file name to [$(docv)]." in + Arg.(required & opt (some string) None & info [ "o" ] ~docv:"FILE" ~doc) + in + let no_sourcemap = + let doc = "Disable sourcemap output." in + Arg.(value & flag & info [ "no-sourcemap"; "no-source-map" ] ~doc) + in + let sourcemap = + let doc = "Output source locations." in + Arg.(value & flag & info [ "sourcemap"; "source-map"; "source-map-inline" ] ~doc) + in + let files = + let doc = + "Link the archive files [$(docv)]. The first archive must be a runtime produced by \ + $(b,wasm_of_ocaml build-runtime). The other archives can be produced by compiling \ + .cma or .cmo files." + in + Arg.(non_empty & pos_all string [] & info [] ~docv:"FILES" ~doc) + in + let linkall = + let doc = "Link all compilation units." in + Arg.(value & flag & info [ "linkall" ] ~doc) + in + let build_t common no_sourcemap sourcemap output_file files linkall = + let enable_source_maps = (not no_sourcemap) && sourcemap in + `Ok { common; output_file; files; linkall; enable_source_maps } + in + let t = + Term.( + const build_t + $ Jsoo_cmdline.Arg.t + $ no_sourcemap + $ sourcemap + $ output_file + $ files + $ linkall) + in + Term.ret t + +let f { common; output_file; files; linkall; enable_source_maps } = + Jsoo_cmdline.Arg.eval common; + Wa_link.link ~output_file ~linkall ~enable_source_maps ~files + +let info = + Info.make + ~name:"link" + ~doc:"Wasm_of_ocaml linker" + ~description: + "wasm_of_ocaml-link is a JavaScript linker. It can concatenate multiple JavaScript \ + files keeping sourcemap information." + +let command = + let t = Cmdliner.Term.(const f $ options) in + Cmdliner.Cmd.v info t diff --git a/compiler/bin-wasm_of_ocaml/link.mli b/compiler/bin-wasm_of_ocaml/link.mli new file mode 100644 index 000000000..969933f7a --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/link.mli @@ -0,0 +1,20 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2020 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +val command : unit Cmdliner.Cmd.t diff --git a/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml b/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml index 313c8bb41..1ea4787d2 100644 --- a/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml +++ b/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml @@ -50,7 +50,7 @@ let () = (Cmdliner.Cmd.group ~default:Compile.term (Compile.info "wasm_of_ocaml") - [ Compile.command ]) + [ Link.command; Build_runtime.command; Compile.command ]) with | Ok (`Ok () | `Help | `Version) -> if !warnings > 0 && !werror diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 29c2078cf..22568f832 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -2681,7 +2681,7 @@ let from_exe Array.fold_right_i globals.constants ~init:body ~f:(fun i _ l -> match globals.vars.(i) with | Some x when globals.is_const.(i) -> - let l = register_global globals ~target i noloc l in + let l = register_global ~target globals i noloc l in (Let (x, Constant globals.constants.(i)), noloc) :: l | _ -> l) in diff --git a/compiler/lib/wasm/wa_link.ml b/compiler/lib/wasm/wa_link.ml index bf31c084a..d9edfab90 100644 --- a/compiler/lib/wasm/wa_link.ml +++ b/compiler/lib/wasm/wa_link.ml @@ -19,6 +19,8 @@ open Stdlib +let times = Debug.find "times" + module Wasm_binary = struct let header = "\000asm\001\000\000\000" @@ -37,6 +39,11 @@ module Wasm_binary = struct check_header f ch; { ch; limit = in_channel_length ch } + let from_channel ~name ch pos len = + seek_in ch pos; + check_header name ch; + { ch; limit = pos + len } + let rec read_uint ?(n = 5) ch = let i = input_byte ch in if n = 1 then assert (i < 16); @@ -133,6 +140,16 @@ module Wasm_binary = struct in { module_; name } + let export ch = + let name = name ch in + let d = read_uint ch in + if d > 4 + then ( + Format.eprintf "Unknown export %x@." d; + assert false); + ignore (read_uint ch); + name + let read_imports ~file = let ch = open_in file in let rec find_section () = @@ -147,8 +164,151 @@ module Wasm_binary = struct let res = if find_section () then vec import ch.ch else [] in close_in ch.ch; res + + type interface = + { imports : import list + ; exports : string list + } + + let read_interface ch = + let rec find_sections i = + match next_section ch with + | None -> i + | Some s -> + if s.id = 2 + then find_sections { i with imports = vec import ch.ch } + else if s.id = 7 + then { i with exports = vec export ch.ch } + else ( + skip_section ch s; + find_sections i) + in + find_sections { imports = []; exports = [] } end +let trim_semi s = + let l = ref (String.length s) in + while + !l > 0 + && + match s.[!l - 1] with + | ';' | '\n' -> true + | _ -> false + do + decr l + done; + String.sub s ~pos:0 ~len:!l + +type unit_data = + { unit_info : Unit_info.t + ; strings : string list + ; fragments : (string * Javascript.expression) list + } + +let info_to_json ~predefined_exceptions ~build_info ~unit_data = + let add nm skip v rem = if skip then rem else (nm, v) :: rem in + let units = + List.map + ~f:(fun { unit_info; strings; fragments } -> + `Assoc + (Unit_info.to_json unit_info + |> Yojson.Basic.Util.to_assoc + |> add + "strings" + (List.is_empty strings) + (`List (List.map ~f:(fun s -> `String s) strings)) + |> add + "fragments" + (List.is_empty fragments) + (`String (Marshal.to_string fragments [])))) + unit_data + in + `Assoc + ([] + |> add + "predefined_exceptions" + (StringSet.is_empty predefined_exceptions) + (`List + (List.map ~f:(fun s -> `String s) (StringSet.elements predefined_exceptions))) + |> add "units" (List.is_empty unit_data) (`List units) + |> add "build_info" false (Build_info.to_json build_info)) + +let info_from_json info = + let open Yojson.Basic.Util in + let build_info = info |> member "build_info" |> Build_info.from_json in + let predefined_exceptions = + info + |> member "predefined_exceptions" + |> to_option to_list + |> Option.value ~default:[] + |> List.map ~f:to_string + |> StringSet.of_list + in + let unit_data = + info + |> member "units" + |> to_option to_list + |> Option.value ~default:[] + |> List.map ~f:(fun u -> + let unit_info = u |> Unit_info.from_json in + let strings = + u + |> member "strings" + |> to_option to_list + |> Option.value ~default:[] + |> List.map ~f:to_string + in + let fragments = + u + |> member "fragments" + |> to_option to_string + |> Option.map ~f:(fun s -> Marshal.from_string s 0) + |> Option.value ~default:[] + (* + |> to_option to_assoc + |> Option.value ~default:[] + |> List.map ~f:(fun (nm, e) -> + ( nm + , let lex = Parse_js.Lexer.of_string (to_string e) in + Parse_js.parse_expr lex ))*) + in + { unit_info; strings; fragments }) + in + build_info, predefined_exceptions, unit_data + +let add_info z ?(predefined_exceptions = StringSet.empty) ~build_info ~unit_data () = + Zip.add_entry + z + ~name:"info.json" + ~contents: + (Yojson.Basic.to_string + (info_to_json ~predefined_exceptions ~build_info ~unit_data)) + +let read_info z = + info_from_json (Yojson.Basic.from_string (Zip.read_entry z ~name:"info.json")) + +let generate_start_function ~to_link ~out_file = + let t1 = Timer.make () in + Fs.gen_file out_file + @@ fun wasm_file -> + let wat_file = Filename.chop_extension out_file ^ ".wat" in + (Filename.gen_file wat_file + @@ fun ch -> + let context = Wa_generate.start () in + Wa_generate.add_init_function ~context ~to_link:("prelude" :: to_link); + Wa_generate.output + ch + ~context + ~debug:(Parse_bytecode.Debug.create ~include_cmis:false false)); + Wa_binaryen.optimize + ~profile:(Driver.profile 1) + ~opt_input_sourcemap:None + ~opt_output_sourcemap:None + ~opt_sourcemap_url:None + ~input_file:wat_file + ~output_file:wasm_file; + if times () then Format.eprintf " generate start: %a@." Timer.print t1 + let output_js js = Code.Var.reset (); let b = Buffer.create 1024 in @@ -182,11 +342,14 @@ let report_missing_primitives missing = List.iter ~f:(fun nm -> warn " %s@." nm) missing) let build_runtime_arguments + ?(link_spec = []) + ?(separate_compilation = false) ~missing_primitives ~wasm_file - ~generated_js:(strings, fragments) = + ~generated_js + () = let missing_primitives = if Config.Flag.genprim () then missing_primitives else [] in - report_missing_primitives missing_primitives; + if not separate_compilation then report_missing_primitives missing_primitives; let obj l = Javascript.EObj (List.map @@ -196,21 +359,31 @@ let build_runtime_arguments l) in let generated_js = - let strings = - if List.is_empty strings - then [] - else - [ ( "strings" - , Javascript.EArr - (List.map - ~f:(fun s -> Javascript.Element (EStr (Utf8_string.of_string_exn s))) - strings) ) - ] - in - let fragments = - if List.is_empty fragments then [] else [ "fragments", obj fragments ] - in - strings @ fragments + List.concat + @@ List.map + ~f:(fun (unit_name, (strings, fragments)) -> + let name s = + match unit_name with + | None -> s + | Some nm -> nm ^ "." ^ s + in + let strings = + if List.is_empty strings + then [] + else + [ ( name "strings" + , Javascript.EArr + (List.map + ~f:(fun s -> + Javascript.Element (EStr (Utf8_string.of_string_exn s))) + strings) ) + ] + in + let fragments = + if List.is_empty fragments then [] else [ name "fragments", obj fragments ] + in + strings @ fragments) + generated_js in let generated_js = if not (List.is_empty missing_primitives) @@ -275,6 +448,283 @@ let build_runtime_arguments N in obj - [ "generated", generated_js + [ ( "link" + , if List.is_empty link_spec + then ENum (Javascript.Num.of_int32 (if separate_compilation then 1l else 0l)) + else + EArr + (List.map + ~f:(fun (m, deps) -> + Javascript.Element + (EArr + [ Element (EStr (Utf8_string.of_string_exn m)) + ; Element + (match deps with + | None -> ENum (Javascript.Num.of_int32 0l) + | Some l -> + EArr + (List.map + ~f:(fun i -> + Javascript.Element + (ENum (Javascript.Num.of_int32 (Int32.of_int i)))) + l)) + ])) + link_spec) ) + ; "generated", generated_js ; "src", EStr (Utf8_string.of_string_exn (Filename.basename wasm_file)) ] + +let link_to_directory ~set_to_link ~files ~enable_source_maps ~dir = + let read_interface z ~name = + Wasm_binary.read_interface + (let ch, pos, len = Zip.get_entry z ~name in + Wasm_binary.from_channel ~name ch pos len) + in + let z = Zip.open_in (fst (List.hd files)) in + let runtime_intf = read_interface z ~name:"runtime.wasm" in + Zip.extract_file z ~name:"runtime.wasm" ~file:(Filename.concat dir "runtime.wasm"); + Zip.extract_file z ~name:"prelude.wasm" ~file:(Filename.concat dir "prelude.wasm"); + Zip.close_in z; + let intfs = ref [] in + List.iter + ~f:(fun (file, (_, units)) -> + let z = Zip.open_in file in + List.iter + ~f:(fun { unit_info; _ } -> + let unit_name = StringSet.choose unit_info.provides in + if StringSet.mem unit_name set_to_link + then ( + let name = unit_name ^ ".wasm" in + intfs := read_interface z ~name :: !intfs; + Zip.extract_file z ~name ~file:(Filename.concat dir name); + let map = name ^ ".map" in + if enable_source_maps && Zip.has_entry z ~name:map + then Zip.extract_file z ~name:map ~file:(Filename.concat dir map))) + units; + Zip.close_in z) + files; + runtime_intf, List.rev !intfs + +(* Remove some unnecessary dependencies *) +let simplify_unit_info l = + let t = Timer.make () in + let prev_requires = Hashtbl.create 16 in + let res = + List.map + ~f:(fun (unit_data : unit_data) -> + let info = unit_data.unit_info in + assert (StringSet.cardinal info.provides = 1); + let name = StringSet.choose info.provides in + assert (not (StringSet.mem name info.requires)); + let requires = + StringSet.fold + (fun dep (requires : StringSet.t) -> + match Hashtbl.find prev_requires dep with + | exception Not_found -> requires + | s -> StringSet.union s requires) + info.requires + StringSet.empty + in + let info = { info with requires = StringSet.diff info.requires requires } in + Hashtbl.add prev_requires name (StringSet.union info.requires requires); + { unit_data with unit_info = info }) + l + in + if times () then Format.eprintf "unit info simplification: %a@." Timer.print t; + res + +let compute_dependencies ~set_to_link ~files = + let h = Hashtbl.create 128 in + let l = List.concat (List.map ~f:(fun (_, (_, units)) -> units) files) in + (* + let l = simplify_unit_info l in + *) + List.filter_map + ~f:(fun { unit_info; _ } -> + let unit_name = StringSet.choose unit_info.provides in + if StringSet.mem unit_name set_to_link + then ( + Hashtbl.add h unit_name (Hashtbl.length h); + Some + ( unit_name + , Some + (List.sort ~cmp:compare + @@ List.filter_map + ~f:(fun req -> Option.map ~f:(fun i -> i + 2) (Hashtbl.find_opt h req)) + (StringSet.elements unit_info.requires)) )) + else None) + l + +let compute_missing_primitives (runtime_intf, intfs) = + let provided_primitives = StringSet.of_list runtime_intf.Wasm_binary.exports in + StringSet.elements + @@ List.fold_left + ~f:(fun s { Wasm_binary.imports; _ } -> + List.fold_left + ~f:(fun s { Wasm_binary.module_; name; _ } -> + if String.equal module_ "env" && not (StringSet.mem name provided_primitives) + then StringSet.add name s + else s) + ~init:s + imports) + ~init:StringSet.empty + intfs + +let load_information files = + match files with + | [] -> assert false + | runtime :: other_files -> + let build_info, predefined_exceptions, _unit_data = + Zip.with_open_in runtime read_info + in + ( predefined_exceptions + , (runtime, (build_info, [])) + :: List.map other_files ~f:(fun file -> + let build_info, _predefined_exceptions, unit_data = + Zip.with_open_in file read_info + in + file, (build_info, unit_data)) ) + +let link ~output_file ~linkall ~enable_source_maps ~files = + let rec loop n = + if times () then Format.eprintf "linking@."; + let t = Timer.make () in + let predefined_exceptions, files = load_information files in + (match files with + | [] -> assert false + | (file, (bi, _)) :: r -> + (match Build_info.kind bi with + | `Runtime -> () + | _ -> + failwith + "The first input file should be a runtime built using 'wasm_of_ocaml \ + build-runtime'."); + Build_info.configure bi; + ignore + (List.fold_left + ~init:bi + ~f:(fun bi (file', (bi', _)) -> + (match Build_info.kind bi' with + | `Runtime -> + failwith "The runtime file should be listed first on the command line." + | _ -> ()); + Build_info.merge file bi file' bi') + r)); + if times () then Format.eprintf " reading information: %a@." Timer.print t; + let t1 = Timer.make () in + let missing, to_link = + List.fold_right + files + ~init:(StringSet.empty, []) + ~f:(fun (_file, (build_info, units)) acc -> + let cmo_file = + match Build_info.kind build_info with + | `Cmo -> true + | `Cma | `Exe | `Runtime | `Unknown -> false + in + List.fold_right units ~init:acc ~f:(fun { unit_info; _ } (requires, to_link) -> + if (not (Config.Flag.auto_link ())) + || cmo_file + || linkall + || unit_info.force_link + || not (StringSet.is_empty (StringSet.inter requires unit_info.provides)) + then + ( StringSet.diff + (StringSet.union unit_info.requires requires) + unit_info.provides + , StringSet.elements unit_info.provides @ to_link ) + else requires, to_link)) + in + let set_to_link = StringSet.of_list to_link in + let files = + if linkall + then files + else + List.filter + ~f:(fun (_file, (build_info, units)) -> + (match Build_info.kind build_info with + | `Cma | `Exe | `Unknown -> false + | `Cmo | `Runtime -> true) + || List.exists + ~f:(fun { unit_info; _ } -> + StringSet.exists + (fun nm -> StringSet.mem nm set_to_link) + unit_info.provides) + units) + files + in + let missing = StringSet.diff missing predefined_exceptions in + if not (StringSet.is_empty missing) + then + failwith + (Printf.sprintf + "Could not find compilation unit for %s" + (String.concat ~sep:", " (StringSet.elements missing))); + if times () then Format.eprintf " finding what to link: %a@." Timer.print t1; + if times () then Format.eprintf " scan: %a@." Timer.print t; + let t = Timer.make () in + let interfaces, wasm_file, link_spec = + let dir = Filename.chop_extension output_file ^ ".assets" in + Fs.gen_file dir + @@ fun tmp_dir -> + Sys.mkdir tmp_dir 0o777; + generate_start_function ~to_link ~out_file:(Filename.concat tmp_dir "start.wasm"); + ( link_to_directory ~set_to_link ~files ~enable_source_maps ~dir:tmp_dir + , dir + , let to_link = compute_dependencies ~set_to_link ~files in + ("runtime", None) :: ("prelude", None) :: (to_link @ [ "start", None ]) ) + in + let missing_primitives = compute_missing_primitives interfaces in + if times () then Format.eprintf " copy wasm files: %a@." Timer.print t; + let t1 = Timer.make () in + let js_runtime = + match files with + | (file, _) :: _ -> + Zip.with_open_in file (fun z -> Zip.read_entry z ~name:"runtime.js") + | _ -> assert false + in + let generated_js = + List.concat + @@ List.map files ~f:(fun (_, (_, units)) -> + List.map units ~f:(fun { unit_info; strings; fragments } -> + Some (StringSet.choose unit_info.provides), (strings, fragments))) + in + let runtime_args = + let js = + build_runtime_arguments + ~link_spec + ~separate_compilation:true + ~missing_primitives + ~wasm_file + ~generated_js + () + in + output_js [ Javascript.Expression_statement js, Javascript.N ] + in + Fs.gen_file output_file + @@ fun tmp_output_file -> + Fs.write_file + ~name:tmp_output_file + ~contents:(trim_semi js_runtime ^ "\n" ^ runtime_args); + if times () then Format.eprintf " build JS runtime: %a@." Timer.print t1; + if times () then Format.eprintf " emit: %a@." Timer.print t; + if n > 0 then loop (n - 1) + in + loop 0 + +let link ~output_file ~linkall ~enable_source_maps ~files = + try link ~output_file ~linkall ~enable_source_maps ~files + with Build_info.Incompatible_build_info { key; first = f1, v1; second = f2, v2 } -> + let string_of_v = function + | None -> "" + | Some v -> v + in + failwith + (Printf.sprintf + "Incompatible build info detected while linking.\n - %s: %s=%s\n - %s: %s=%s" + f1 + key + (string_of_v v1) + f2 + key + (string_of_v v2)) diff --git a/compiler/lib/wasm/wa_link.mli b/compiler/lib/wasm/wa_link.mli index ee0a4dc69..3601efcc8 100644 --- a/compiler/lib/wasm/wa_link.mli +++ b/compiler/lib/wasm/wa_link.mli @@ -17,6 +17,8 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +open Stdlib + module Wasm_binary : sig type import = { module_ : string @@ -26,10 +28,37 @@ module Wasm_binary : sig val read_imports : file:string -> import list end +type unit_data = + { unit_info : Unit_info.t + ; strings : string list + ; fragments : (string * Javascript.expression) list + } + +val add_info : + Zip.output + -> ?predefined_exceptions:StringSet.t + -> build_info:Build_info.t + -> unit_data:unit_data list + -> unit + -> unit + val build_runtime_arguments : - missing_primitives:string list + ?link_spec:(string * int list option) list + -> ?separate_compilation:bool + -> missing_primitives:string list -> wasm_file:string - -> generated_js:string list * (string * Javascript.expression) list + -> generated_js: + (string option * (string list * (string * Javascript.expression) list)) list + -> unit -> Javascript.expression +val simplify_unit_info : unit_data list -> unit_data list + val output_js : Javascript.program -> string + +val link : + output_file:string + -> linkall:bool + -> enable_source_maps:bool + -> files:string list + -> unit diff --git a/runtime/wasm/runtime.js b/runtime/wasm/runtime.js index 259218f31..2576ec624 100644 --- a/runtime/wasm/runtime.js +++ b/runtime/wasm/runtime.js @@ -1,18 +1,8 @@ ((js) => async (args) => { "use strict"; - let {src, generated} = args; - function loadRelative(src) { - const path = require('path'); - const f = path.join(path.dirname(require.main.filename),src); - return require('fs/promises').readFile(f) - } - function fetchRelative(src) { - const base = globalThis?.document?.currentScript?.src; - const url = base?new URL(src, base):src; - return fetch(url) - } + let {link, src, generated} = args; + const isNode = globalThis?.process?.versions?.node; - const code = isNode?loadRelative(src):fetchRelative(src); let math = {cos:Math.cos, sin:Math.sin, tan:Math.tan, @@ -357,9 +347,42 @@ env:{}}, generated) const options = { builtins: ['js-string', 'text-decoder', 'text-encoder'] } + + function loadRelative(src) { + const path = require('path'); + const f = path.join(path.dirname(require.main.filename),src); + return require('fs/promises').readFile(f) + } + function fetchRelative(src) { + const base = globalThis?.document?.currentScript?.src; + const url = base?new URL(src, base):src; + return fetch(url) + } + const loadCode= isNode?loadRelative:fetchRelative; + async function instantiateModule(code) { + return isNode?WebAssembly.instantiate(await code, imports, options) + :WebAssembly.instantiateStreaming(code,imports, options) + } + async function instantiateFromDir() { + imports.OCaml = {}; + const deps = [] + for (const module of link) { + const sync = module[1].constructor !== Array + async function instantiate () { + const code = loadCode(src + "/" + module[0] + ".wasm") + await Promise.all(sync?deps:module[1].map((i)=>deps[i])); + const wasmModule = await instantiateModule(code) + Object.assign(deps.length?imports.OCaml:imports.env, + wasmModule.instance.exports); + } + deps.push(sync?await instantiate():instantiate()) + } + await deps.pop(); + return {instance:{exports: Object.assign(imports.env, imports.OCaml)}} + } const wasmModule = - isNode?await WebAssembly.instantiate(await code, imports, options) - :await WebAssembly.instantiateStreaming(code,imports, options) + await ((link)?instantiateFromDir() + :instantiateModule(loadCode(src))) var {caml_callback, caml_alloc_tm, caml_start_fiber, caml_handle_uncaught_exception, caml_buffer,