diff --git a/.git-blame-ignore-revs b/.git-blame-ignore-revs index ac1dc77c40..503897a820 100644 --- a/.git-blame-ignore-revs +++ b/.git-blame-ignore-revs @@ -4,3 +4,8 @@ 7de742a776fcdad4b098695617b9e7afab822c82 # Biome 5a78e2466221c91fc3607be5b6549797551de4d1 +# Wasm_of_ocaml: renamed files +02b848f0dae1924326aceb5e2b689eb4870b9e0c +f51c956d4294c55b45a05fa6520cb5cdc9e2ade3 +40f4d4e4034d8fd21e28d74e5ff127dcd3fec37d +a1d6554ea9d055f817edea5d32e485d836001cb3 diff --git a/.gitattributes b/.gitattributes index e9a3efdd53..e32e0c03c0 100644 --- a/.gitattributes +++ b/.gitattributes @@ -1,2 +1,6 @@ *.ml linguist-language=OCaml *.mli linguist-language=OCaml + +# We are pinning wasm_of_ocaml using this file in the CI. This would +# fail on Windows otherwise. +VERSION -text diff --git a/.github/workflows/build-wasm_of_ocaml.yml b/.github/workflows/build-wasm_of_ocaml.yml new file mode 100644 index 0000000000..e4ffefcff5 --- /dev/null +++ b/.github/workflows/build-wasm_of_ocaml.yml @@ -0,0 +1,150 @@ +name: Build wasm_of_ocaml + +on: + pull_request: + push: + branches: + - master + +jobs: + build: + env: + OPAMJOBS: 2 + OPAMYES: true + + strategy: + fail-fast: false + matrix: + os: + - ubuntu-latest + ocaml-compiler: + - 4.14.x + - 5.00.x + - 5.01.x + - 5.02.x + - ocaml-compiler.5.3.0~beta2 + separate_compilation: + - true + include: + - os: macos-latest + ocaml-compiler: 5.02.x + separate_compilation: true + - os: ubuntu-latest + ocaml-compiler: 4.14.x + separate_compilation: false + + runs-on: ${{ matrix.os }} + + steps: + - name: Set git to use LF + run: | + git config --global core.autocrlf false + git config --global core.eol lf + git config --global core.ignorecase false + + - name: Install node + uses: actions/setup-node@v4 + with: + node-version: 23 + + - name: Install OCaml ${{ matrix.ocaml-compiler }} + uses: ocaml/setup-ocaml@v3 + with: + ocaml-compiler: ${{ matrix.ocaml-compiler }} + + - name: Checkout code + uses: actions/checkout@v4 + with: + path: wasm_of_ocaml + + - name: Set-up Binaryen + uses: Aandreba/setup-binaryen@v1.0.0 + with: + version: 118 + token: ${{ secrets.GITHUB_TOKEN }} + + - name: Pin faked binaryen-bin package + # It's faster to use a cached version + run: opam install --fake binaryen-bin + + - name: Checkout Jane Street opam repository + uses: actions/checkout@v4 + with: + repository: janestreet/opam-repository + ref: feaf8f831051fd5f316963b28efd728cf0b0eca1 + path: jane-street/opam-repository + + - name: Pin wasm_of_ocaml + working-directory: ./wasm_of_ocaml + run: opam pin -n --with-version `< VERSION` . + + - name: Install some needed packages + run: opam install opam-format ocamlfind dune graphics cmdliner sexplib0.v0.16.0 + + - name: Checkout Jane Street packages + run: opam exec -- ocaml wasm_of_ocaml/tools/ci_setup.ml + + - name: Install wasm_of_ocaml and its test dependencies + working-directory: ./wasm_of_ocaml + run: | + opam install `basename -s .opam *.opam` num cohttp-lwt-unix ppx_expect cstruct + + - name: Run tests + if: ${{ matrix.separate_compilation }} + working-directory: ./wasm_of_ocaml + run: opam exec -- dune build @all @runtest --profile wasm + + - name: Run tests with CPS effects + if: ${{ matrix.ocaml-compiler >= '5.' && matrix.separate_compilation }} + working-directory: ./wasm_of_ocaml + run: opam exec -- dune build @all @runtest --profile wasm-effects + + - name: Run Base tests + if: ${{ matrix.ocaml-compiler < '5.' && matrix.separate_compilation }} + working-directory: ./jane-street/lib/base + run: opam exec -- dune runtest + + - name: Run Base bigstring tests + if: ${{ matrix.ocaml-compiler < '5.' && matrix.separate_compilation }} + working-directory: ./jane-street/lib/base_bigstring + run: opam exec -- dune runtest + + - name: Run Core tests + if: ${{ matrix.ocaml-compiler < '5.' && matrix.separate_compilation }} + working-directory: ./jane-street/lib/core + run: opam exec -- dune runtest + + - name: Run Bignum tests + if: ${{ matrix.ocaml-compiler < '5.' && matrix.separate_compilation }} + working-directory: ./jane-street/lib/bignum + run: opam exec -- dune runtest + + - name: Run Bin_prot tests + if: ${{ matrix.ocaml-compiler < '5.' && matrix.separate_compilation }} + working-directory: ./jane-street/lib/bin_prot + run: opam exec -- dune runtest + + - name: Run String_dict tests + if: ${{ matrix.ocaml-compiler < '5.' && matrix.separate_compilation }} + working-directory: ./jane-street/lib/string_dict + run: opam exec -- dune runtest + + - name: Run Zarith tests + if: ${{ matrix.ocaml-compiler < '5.' && matrix.separate_compilation }} + working-directory: ./jane-street/lib/zarith_stubs_js + run: opam exec -- dune runtest + + - name: Run Virtual_dom tests + if: ${{ matrix.ocaml-compiler < '5.' && matrix.separate_compilation }} + working-directory: ./jane-street/lib/virtual_dom + run: opam exec -- dune runtest + + - name: Run Bonsai tests + if: ${{ matrix.ocaml-compiler < '5.' && matrix.separate_compilation }} + working-directory: ./jane-street/lib/bonsai + run: opam exec -- dune runtest + + - name: Run Bonsai tests (release profile) + if: ${{ ! matrix.separate_compilation }} + working-directory: ./jane-street/lib/bonsai + run: opam exec -- dune runtest --profile release diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 78ee7afaac..32cf3f341a 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -115,10 +115,29 @@ jobs: - run: opam install conf-pkg-config if: runner.os == 'Windows' + - name: Set-up Binaryen + uses: Aandreba/setup-binaryen@v1.0.0 + with: + version: 118 + token: ${{ secrets.GITHUB_TOKEN }} + + - name: Install faked binaryen-bin package + # It's faster to use a cached version + run: opam install --fake binaryen-bin + - run: opam install . --best-effort if: ${{ matrix.skip-test }} - - run: opam install . --with-test + - run: cat VERSION | xargs opam pin . -n --with-version + if: ${{ !matrix.skip-test }} + shell: bash + + - run: opam install . --with-test --deps-only + # Install the test dependencies + if: ${{ !matrix.skip-test }} + + - run: opam install . + # Install the packages (without running the tests) if: ${{ !matrix.skip-test }} - run: opam exec -- make all @@ -146,4 +165,4 @@ jobs: branch: wikidoc folder: doc-dev clean: true - target-folder: doc/dev/ \ No newline at end of file + target-folder: doc/dev/ diff --git a/CHANGES.md b/CHANGES.md index 2e8ad43b60..83b2dab691 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -3,6 +3,7 @@ ## Features/Changes * Lib: fix the type of some DOM properties and methods (#1747) * Test: use dune test stanzas (#1631) +* Merged Wasm_of_ocaml (#1724) # 5.9.1 (02-12-2024) - Lille diff --git a/README_wasm_of_ocaml.md b/README_wasm_of_ocaml.md new file mode 100644 index 0000000000..ee5c69df18 --- /dev/null +++ b/README_wasm_of_ocaml.md @@ -0,0 +1,68 @@ +# Wasm_of_ocaml + +Wasm_of_ocaml is a fork of Js_of_ocaml which compiles OCaml bytecode to WebAssembly. + +## Supported engines + +The generated code works with Chrome 11.9, Node.js 22 and Firefox 122 (or more recent versions of these applications). + +In particular, the output code requires the following [Wasm extensions](https://webassembly.org/roadmap/) to run: +- [the GC extension](https://github.com/WebAssembly/gc), including functional references and 31-bit integers +- [the tail-call extension](https://github.com/WebAssembly/tail-call/blob/main/proposals/tail-call/Overview.md) +- [the exception handling extension](https://github.com/WebAssembly/exception-handling/blob/master/proposals/exception-handling/Exceptions.md) + +OCaml 5.x code using effect handlers can be compiled in two different ways: +One can enable the CPS transformation from `js_of_ocaml` by passing the +`--enable=effects` flag. Without the flag `wasm_of_ocaml` will instead emit code +utilizing +- [the JavaScript-Promise Integration extension](https://github.com/WebAssembly/js-promise-integration/blob/main/proposals/js-promise-integration/Overview.md) + + +## Installation + +The following commands will perform a minimal installation: +``` +git clone https://github.com/ocaml-wasm/wasm_of_ocaml +cd wasm_of_ocaml +opam pin add -n --with-version 6.0.0 . +opam install dune.3.17.0 wasm_of_ocaml-compiler +``` +You may want to install additional packages. For instance: + +``` +opam install js_of_ocaml-ppx js_of_ocaml-lwt +``` + +## Usage + +You can try compiling the program in `examples/cubes`. Your program must first be compiled using the OCaml bytecode compiler `ocamlc`. JavaScript bindings are provided by the `js_of_ocaml` package. The syntax extension is provided by `js_of_ocaml-ppx` package. Package `js_of_ocaml-lwt` provides Javascript specific Lwt functions. + +``` +ocamlfind ocamlc -package js_of_ocaml,js_of_ocaml-ppx,js_of_ocaml-lwt -linkpkg -o cubes.byte cubes.mli cubes.ml +``` + +Then, run the `wasm_of_ocaml` compiler to produce WebAssembly code: + +``` +wasm_of_ocaml cubes.byte +``` + +This outputs a file `cubes.js` which loads the WebAssembly code from file `cube.wasm`. For debugging, we currently also output the generated WebAssembly code in text file to `cube.wat`. Since Chrome does not allow loading from the filesystem, you need to serve the files using some Web server. For instance: +``` +python3 -m http.server 8000 --directory . +``` + +As a larger example, you can try [CAMLBOY](https://github.com/linoscope/CAMLBOY). You need to install a forked version of [Brr](https://github.com/ocaml-wasm/brr/tree/wasm). Once the Js_of_ocaml UI is compiled (with `dune build --profile release`), you can generate WebAssembly code instead with the following command: +``` +wasm_of_ocaml _build/default/bin/web/index.bc-for-jsoo +``` + +## Implementation status + +A large part of the runtime is [implemented](https://github.com/ocaml-wasm/wasm_of_ocaml/issues/5). File-related functions and dynamic linking are not supported yet. + +## Compatibility with Js_of_ocaml + +Since the value representation is different, some adaptations are necessary. + +The most notable change is that, except for integers, OCaml numbers are no longer mapped to JavaScript numbers. So, explicit conversions `Js.to_float` and `Js.float` are now necessary to convert between OCaml floats and JavaScript numbers. The typing of JavaScript Typed Arrays has also been changed to deal with this. 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 0000000000..79762a70b7 --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/build_runtime.ml @@ -0,0 +1,29 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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:"Wasm_of_ocaml is a compiler from OCaml bytecode to WebAssembly." + +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 0000000000..952975461c --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/build_runtime.mli @@ -0,0 +1,19 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 new file mode 100644 index 0000000000..5b6c86b399 --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.ml @@ -0,0 +1,247 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Js_of_ocaml_compiler +open Cmdliner + +let is_dir_sep = function + | '/' -> true + | '\\' when String.equal Filename.dir_sep "\\" -> true + | _ -> false + +let trim_trailing_dir_sep s = + if String.equal s "" + then s + else + let len = String.length s in + let j = ref (len - 1) in + while !j >= 0 && is_dir_sep (String.unsafe_get s !j) do + decr j + done; + if !j >= 0 then String.sub s ~pos:0 ~len:(!j + 1) else String.sub s ~pos:0 ~len:1 + +let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep + +type t = + { common : Jsoo_cmdline.Arg.t + ; (* compile option *) + profile : Driver.profile option + ; runtime_files : string list + ; runtime_only : bool + ; output_file : string * bool + ; input_file : string option + ; enable_source_maps : bool + ; sourcemap_root : string option + ; sourcemap_don't_inline_content : bool + ; params : (string * string) list + ; include_dirs : string list + } + +let options = + let runtime_files = + let doc = "Link JavaScript and WebAssembly files [$(docv)]. " in + Arg.(value & pos_left ~rev:true 0 string [] & info [] ~docv:"RUNTIME_FILES" ~doc) + in + let output_file = + let doc = "Set output file name to [$(docv)]." in + Arg.(value & opt (some string) None & info [ "o" ] ~docv:"FILE" ~doc) + in + let input_file = + let doc = "Compile the bytecode program [$(docv)]. " in + Arg.(required & pos ~rev:true 0 (some string) None & info [] ~docv:"PROGRAM" ~doc) + in + let profile = + let doc = "Set optimization profile : [$(docv)]." in + let profile = List.map Driver.profiles ~f:(fun (i, p) -> string_of_int i, p) in + Arg.(value & opt (some (enum profile)) None & info [ "opt" ] ~docv:"NUM" ~doc) + in + let linkall = + let doc = "Currently ignored (for compatibility with Js_of_ocaml)." in + Arg.(value & flag & info [ "linkall" ] ~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 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 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 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 build_t + common + set_param + include_dirs + profile + _ + sourcemap + no_sourcemap + sourcemap_don't_inline_content + sourcemap_root + output_file + input_file + 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 ^ ext, false + in + 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 + ; output_file + ; input_file = Some input_file + ; runtime_files + ; runtime_only = false + ; enable_source_maps + ; sourcemap_root + ; sourcemap_don't_inline_content + } + in + let t = + Term.( + const build_t + $ Lazy.force Jsoo_cmdline.Arg.t + $ set_param + $ include_dirs + $ profile + $ linkall + $ sourcemap + $ no_sourcemap + $ sourcemap_don't_inline_content + $ sourcemap_root + $ output_file + $ input_file + $ 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 = + "Don't generate source map. All other source map related flags will be ignored." + in + Arg.(value & flag & info [ "no-sourcemap"; "no-source-map" ] ~doc) + in + let sourcemap = + let doc = "Generate source map." 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 + $ Lazy.force 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 new file mode 100644 index 0000000000..74d38c76fc --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.mli @@ -0,0 +1,38 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 + +type t = + { common : Jsoo_cmdline.Arg.t + ; (* compile option *) + profile : Driver.profile option + ; runtime_files : string list + ; runtime_only : bool + ; output_file : string * bool + ; input_file : string option + ; enable_source_maps : bool + ; sourcemap_root : string option + ; sourcemap_don't_inline_content : bool + ; params : (string * string) list + ; include_dirs : string list + } + +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 new file mode 100644 index 0000000000..9957756643 --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -0,0 +1,557 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Js_of_ocaml_compiler +open Wasm_of_ocaml_compiler + +let times = Debug.find "times" + +let debug_mem = Debug.find "mem" + +let () = Sys.catch_break true + +let update_sourcemap ~sourcemap_root ~sourcemap_don't_inline_content sourcemap_file = + if Option.is_some sourcemap_root || not sourcemap_don't_inline_content + then ( + let open Source_map in + let source_map = + match Source_map.of_file sourcemap_file with + | Index _ -> assert false + | Standard sm -> sm + in + assert (List.is_empty (Option.value source_map.sources_content ~default:[])); + (* Add source file contents to source map *) + let sources_content = + if sourcemap_don't_inline_content + then None + else + Some + (List.map source_map.sources ~f:(fun file -> + if String.equal file Wasm_source_map.blackbox_filename + then + Some (Source_map.Source_content.create Wasm_source_map.blackbox_contents) + else if Sys.file_exists file && not (Sys.is_directory file) + then Some (Source_map.Source_content.create (Fs.read_file file)) + else None)) + in + let source_map = + { source_map with + sources_content + ; sourceroot = + (if Option.is_some sourcemap_root then sourcemap_root else source_map.sourceroot) + ; ignore_list = + (if List.mem Wasm_source_map.blackbox_filename ~set:source_map.sources + then [ Wasm_source_map.blackbox_filename ] + else []) + } + in + Source_map.to_file (Standard source_map) sourcemap_file) + +let opt_with action x f = + match x with + | None -> f None + | Some x -> action x (fun y -> f (Some y)) + +let output_gen output_file f = + Code.Var.set_pretty true; + Code.Var.set_stable (Config.Flag.stable_var ()); + Filename.gen_file output_file f + +let link_and_optimize + ~profile + ~sourcemap_root + ~sourcemap_don't_inline_content + ~opt_sourcemap + runtime_wasm_files + wat_files + output_file = + let opt_sourcemap_file = + (* Check that Binaryen supports the necessary sourcemaps options (requires + version >= 118) *) + match opt_sourcemap with + | Some _ when Sys.command "wasm-merge -osm foo 2> /dev/null" <> 0 -> None + | Some _ | None -> opt_sourcemap + in + let enable_source_maps = Option.is_some opt_sourcemap_file in + 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 -> + opt_with + Fs.with_intermediate_file + (if enable_source_maps + then Some (Filename.temp_file "wasm-merged" ".wasm.map") + else None) + @@ fun opt_temp_sourcemap -> + Binaryen.link + ~runtime_files:(runtime_file :: runtime_wasm_files) + ~input_files:wat_files + ~opt_output_sourcemap:opt_temp_sourcemap + ~output_file:temp_file; + Fs.with_intermediate_file (Filename.temp_file "wasm-dce" ".wasm") + @@ fun temp_file' -> + opt_with + Fs.with_intermediate_file + (if enable_source_maps then Some (Filename.temp_file "wasm-dce" ".wasm.map") else None) + @@ fun opt_temp_sourcemap' -> + let primitives = + Binaryen.dead_code_elimination + ~dependencies:Wa_runtime.dependencies + ~opt_input_sourcemap:opt_temp_sourcemap + ~opt_output_sourcemap:opt_temp_sourcemap' + ~input_file:temp_file + ~output_file:temp_file' + in + Binaryen.optimize + ~profile + ~opt_input_sourcemap:opt_temp_sourcemap' + ~opt_output_sourcemap:opt_sourcemap + ~input_file:temp_file' + ~output_file; + Option.iter + ~f:(update_sourcemap ~sourcemap_root ~sourcemap_don't_inline_content) + opt_sourcemap_file; + primitives + +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 -> + Binaryen.link + ~opt_output_sourcemap:None + ~runtime_files:(runtime_file :: runtime_wasm_files) + ~input_files:[] + ~output_file:temp_file; + Binaryen.optimize + ~profile + ~opt_input_sourcemap:None + ~opt_output_sourcemap: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 () in + let profile = + match Driver.profile 1 with + | Some p -> p + | None -> assert false + in + let Driver.{ program; variable_uses; in_cps; deadcode_sentinal; _ } = + Driver.optimize ~profile code + in + let context = Generate.start () in + let debug = Parse_bytecode.Debug.create ~include_cmis:false false in + let _ = + Generate.f + ~context + ~unit_name:(Some "prelude") + ~live_vars:variable_uses + ~in_cps + ~deadcode_sentinal + ~debug + program + in + Generate.output ch ~context; + 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 + Binaryen.optimize + ~profile:(Driver.profile 1) + ~input_file:prelude_file + ~output_file:tmp_prelude_file + ~opt_input_sourcemap:None + ~opt_output_sourcemap: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 + (fun nm l -> + let id = Utf8_string.of_string_exn nm in + Javascript.Property (PNI id, EVar (S { name = id; var = None; loc = N })) :: l) + primitives + [] + in + match + List.split_last + @@ Driver.link_and_pack + ~link:`Needed + [ Javascript.Return_statement (Some (EObj l), N), N ] + with + | Some x -> x + | None -> assert false + in + let primitives = + match primitives with + | Javascript.Expression_statement e, N -> e + | _ -> assert false + in + let prelude = Link.output_js always_required_js in + let init_fun = + match Parse_js.parse (Parse_js.Lexer.of_string Wa_runtime.js_runtime) with + | [ (Expression_statement f, _) ] -> f + | _ -> assert false + in + let launcher = + let js = + let js = Javascript.call init_fun [ primitives ] 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 + Link.output_js js + in + prelude ^ launcher + +let add_source_map sourcemap_don't_inline_content z opt_source_map = + let sm = + match opt_source_map with + | `File opt_file -> + Option.map opt_file ~f:(fun file -> + Zip.add_file z ~name:"source_map.map" ~file; + Source_map.of_file file) + | `Source_map sm -> + Zip.add_entry z ~name:"source_map.map" ~contents:(Source_map.to_string sm); + Some sm + in + Option.iter sm ~f:(fun sm -> + if not sourcemap_don't_inline_content + then + Wasm_source_map.iter_sources sm (fun i j file -> + if Sys.file_exists file && not (Sys.is_directory file) + then + let sm = Fs.read_file file in + Zip.add_entry + z + ~name:(Link.source_name i j file) + ~contents:(Yojson.Basic.to_string (`String sm)))) + +let run + { Cmd_arg.common + ; profile + ; runtime_only + ; runtime_files + ; input_file + ; output_file + ; enable_source_maps + ; params + ; include_dirs + ; sourcemap_root + ; sourcemap_don't_inline_content + } = + Config.set_target `Wasm; + Jsoo_cmdline.Arg.eval common; + Generate.init (); + let output_file = fst output_file in + if debug_mem () then Debug.start_profiling output_file; + List.iter params ~f:(fun (s, v) -> Config.Param.set s v); + let t = Timer.make () in + let include_dirs = + List.filter_map (include_dirs @ [ "+stdlib/" ]) ~f:(fun d -> Findlib.find [] d) + in + let runtime_wasm_files, runtime_js_files = + List.partition runtime_files ~f:(fun name -> + List.exists + ~f:(fun s -> Filename.check_suffix name s) + [ ".wasm"; ".wat"; ".wast" ]) + in + let runtime_js_files, builtin = + List.partition_map runtime_js_files ~f:(fun name -> + match Builtins.find name with + | Some t -> `Snd t + | None -> `Fst name) + in + let t1 = Timer.make () in + let builtin = Js_of_ocaml_compiler_runtime_files.runtime @ builtin in + List.iter builtin ~f:(fun t -> + let filename = Builtins.File.name t in + let runtimes = Linker.Fragment.parse_builtin t in + Linker.load_fragments ~target_env:Target_env.Isomorphic ~filename runtimes); + Linker.load_files ~target_env:Target_env.Isomorphic runtime_js_files; + Linker.check_deps (); + 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 check_debug (one : Parse_bytecode.one) = + if + (not runtime_only) + && enable_source_maps + && Parse_bytecode.Debug.is_empty one.debug + && not (Code.is_empty one.code) + then + warn + "Warning: '--source-map' is enabled but the bytecode program was compiled with \ + no debugging information.\n\ + Warning: Consider passing '-g' option to ocamlc.\n\ + %!" + in + let output (one : Parse_bytecode.one) ~unit_name ch = + check_debug one; + let code = one.code in + let standalone = Option.is_none unit_name in + let profile = + match profile, Driver.profile 1 with + | Some p, _ -> p + | None, Some p -> p + | None, None -> assert false + in + let Driver.{ program; variable_uses; in_cps; deadcode_sentinal; _ } = + Driver.optimize ~profile code + in + let context = Generate.start () in + let debug = one.debug in + let toplevel_name, generated_js = + Generate.f + ~context + ~unit_name + ~live_vars:variable_uses + ~in_cps + ~deadcode_sentinal + ~debug + program + in + if standalone then Generate.add_start_function ~context toplevel_name; + Generate.output ch ~context; + if times () then Format.eprintf "compilation: %a@." Timer.print t; + generated_js + in + (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 -> Link.Wasm_binary.read_imports ~file) + |> List.filter_map ~f:(fun { 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 + 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 cmo cont = + let t1 = Timer.make () in + let code = + Parse_bytecode.from_cmo ~includes:include_dirs ~debug:need_debug cmo ic + in + let unit_info = Unit_info.of_cmo cmo in + let unit_name = Ocaml_compiler.Cmo_format.name cmo in + if times () then Format.eprintf " parsing: %a (%s)@." Timer.print t1 unit_name; + Fs.with_intermediate_file (Filename.temp_file unit_name ".wasm") + @@ fun tmp_wasm_file -> + opt_with + Fs.with_intermediate_file + (if enable_source_maps + then Some (Filename.temp_file unit_name ".wasm.map") + else None) + @@ fun opt_tmp_map_file -> + let unit_data = + Fs.with_intermediate_file (Filename.temp_file unit_name ".wat") + @@ fun wat_file -> + let strings, fragments = + output_gen wat_file (output code ~unit_name:(Some unit_name)) + in + Binaryen.optimize + ~profile + ~opt_input_sourcemap:None + ~opt_output_sourcemap:opt_tmp_map_file + ~input_file:wat_file + ~output_file:tmp_wasm_file; + { Link.unit_name; unit_info; strings; fragments } + in + cont unit_data unit_name tmp_wasm_file opt_tmp_map_file + in + (match kind with + | `Exe -> + let t1 = Timer.make () in + let code = + Parse_bytecode.from_exe + ~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 dir = Filename.chop_extension output_file ^ ".assets" in + Link.gen_dir dir + @@ fun tmp_dir -> + Sys.mkdir tmp_dir 0o777; + let opt_sourcemap = + if enable_source_maps + then Some (Filename.concat tmp_dir "code.wasm.map") + else None + in + let generated_js = output_gen wat_file (output code ~unit_name:None) in + let tmp_wasm_file = Filename.concat tmp_dir "code.wasm" in + let primitives = + link_and_optimize + ~profile + ~sourcemap_root + ~sourcemap_don't_inline_content + ~opt_sourcemap + runtime_wasm_files + [ wat_file ] + tmp_wasm_file + in + let wasm_name = + Printf.sprintf + "code-%s" + (String.sub (Digest.to_hex (Digest.file tmp_wasm_file)) ~pos:0 ~len:20) + in + let tmp_wasm_file' = Filename.concat tmp_dir (wasm_name ^ ".wasm") in + Sys.rename tmp_wasm_file tmp_wasm_file'; + if enable_source_maps + then ( + Sys.rename (Filename.concat tmp_dir "code.wasm.map") (tmp_wasm_file' ^ ".map"); + Link.Wasm_binary.append_source_map_section + ~file:tmp_wasm_file' + ~url:(wasm_name ^ ".wasm.map")); + let js_runtime = + let missing_primitives = + let l = Link.Wasm_binary.read_imports ~file:tmp_wasm_file' in + List.filter_map + ~f:(fun { Link.Wasm_binary.module_; name; _ } -> + if String.equal module_ "env" then Some name else None) + l + in + build_js_runtime + ~primitives + ~runtime_arguments: + (Link.build_runtime_arguments + ~missing_primitives + ~wasm_dir:dir + ~link_spec:[ wasm_name, None ] + ~separate_compilation:false + ~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 compile_cmo' z cmo = + compile_cmo cmo (fun unit_data _ tmp_wasm_file opt_tmp_map_file -> + Zip.add_file z ~name:"code.wasm" ~file:tmp_wasm_file; + add_source_map sourcemap_don't_inline_content z (`File opt_tmp_map_file); + unit_data) + in + let unit_data = [ compile_cmo' z cmo ] in + 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 = + let tmp_buf = Buffer.create 10000 in + List.fold_right + ~f:(fun cmo cont l -> + compile_cmo cmo + @@ fun unit_data unit_name tmp_wasm_file opt_tmp_map_file -> + cont ((unit_data, unit_name, tmp_wasm_file, opt_tmp_map_file) :: l)) + cma.lib_units + ~init:(fun l -> + Fs.with_intermediate_file (Filename.temp_file "wasm" ".wasm") + @@ fun tmp_wasm_file -> + let l = List.rev l in + let source_map = + Wasm_link.f + (List.map + ~f:(fun (_, _, file, opt_source_map) -> + { Wasm_link.module_name = "OCaml" + ; file + ; code = None + ; opt_source_map = + Option.map + ~f:(fun f -> Source_map.Standard.of_file ~tmp_buf f) + opt_source_map + }) + l) + ~output_file:tmp_wasm_file + in + Zip.add_file z ~name:"code.wasm" ~file:tmp_wasm_file; + if enable_source_maps + then + add_source_map sourcemap_don't_inline_content z (`Source_map source_map); + List.map ~f:(fun (unit_data, _, _, _) -> unit_data) l) + [] + in + Link.add_info z ~build_info:(Build_info.create `Cma) ~unit_data (); + Zip.close_out z); + close_ic ()); + Debug.stop_profiling () + +let info name = + Info.make + ~name + ~doc:"Wasm_of_ocaml compiler" + ~description:"Wasm_of_ocaml is a compiler from OCaml bytecode to WebAssembly." + +let term = Cmdliner.Term.(const run $ Cmd_arg.options) + +let command = + let t = Cmdliner.Term.(const run $ Cmd_arg.options) in + Cmdliner.Cmd.v (info "compile") t diff --git a/compiler/bin-wasm_of_ocaml/compile.mli b/compiler/bin-wasm_of_ocaml/compile.mli new file mode 100644 index 0000000000..a2a0703faf --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/compile.mli @@ -0,0 +1,25 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 run : Cmd_arg.t -> unit + +val command : unit Cmdliner.Cmd.t + +val term : unit Cmdliner.Term.t + +val info : string -> Cmdliner.Cmd.info diff --git a/compiler/bin-wasm_of_ocaml/dune b/compiler/bin-wasm_of_ocaml/dune new file mode 100644 index 0000000000..cd5f1a468a --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/dune @@ -0,0 +1,46 @@ +(executable + (name wasm_of_ocaml) + (public_name wasm_of_ocaml) + (package wasm_of_ocaml-compiler) + (libraries + jsoo_cmdline + wasm_of_ocaml-compiler + cmdliner + compiler-libs.common + js_of_ocaml-compiler.runtime-files + yojson + (select + findlib_support.ml + from + ;; Only link wasm_of_ocaml-compiler.findlib-support if it exists + (js_of_ocaml-compiler.findlib-support -> findlib_support.empty.ml) + (-> findlib_support.empty.ml))) + (modes + byte + (best exe)) + (flags + (:standard -safe-string))) + +(rule + (target wa_runtime.ml) + (deps + gen/gen.exe + ../../runtime/wasm/runtime.wasm + ../../runtime/wasm/runtime.js + ../../runtime/wasm/deps.json) + (action + (with-stdout-to + %{target} + (run %{deps})))) + +(rule + (targets wasm_of_ocaml.1) + (action + (with-stdout-to + %{targets} + (run %{bin:wasm_of_ocaml} --help=groff)))) + +(install + (section man) + (package wasm_of_ocaml-compiler) + (files wasm_of_ocaml.1)) diff --git a/compiler/bin-wasm_of_ocaml/findlib_support.empty.ml b/compiler/bin-wasm_of_ocaml/findlib_support.empty.ml new file mode 100644 index 0000000000..cc6700682b --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/findlib_support.empty.ml @@ -0,0 +1,17 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) diff --git a/compiler/bin-wasm_of_ocaml/gen/dune b/compiler/bin-wasm_of_ocaml/gen/dune new file mode 100644 index 0000000000..9df6b5100e --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/gen/dune @@ -0,0 +1,2 @@ +(executable + (name gen)) diff --git a/compiler/bin-wasm_of_ocaml/gen/gen.ml b/compiler/bin-wasm_of_ocaml/gen/gen.ml new file mode 100644 index 0000000000..b7a20c4e3e --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/gen/gen.ml @@ -0,0 +1,13 @@ +let read_file ic = really_input_string ic (in_channel_length ic) + +let () = + let () = set_binary_mode_out stdout true in + Format.printf + "let wasm_runtime = \"%s\"@." + (String.escaped (read_file (open_in_bin Sys.argv.(1)))); + Format.printf + "let js_runtime = \"%s\"@." + (String.escaped (read_file (open_in_bin Sys.argv.(2)))); + Format.printf + "let dependencies = \"%s\"@." + (String.escaped (read_file (open_in_bin Sys.argv.(3)))) diff --git a/compiler/bin-wasm_of_ocaml/info.ml b/compiler/bin-wasm_of_ocaml/info.ml new file mode 100644 index 0000000000..c297de5b6c --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/info.ml @@ -0,0 +1,48 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 +open Cmdliner + +let make ~name ~doc ~description = + let man = + [ `S "DESCRIPTION" + ; `P description + ; `S "BUGS" + ; `P + "Bugs are tracked on github at \ + $(i,https://github.com/ocsigen/js_of_ocaml/issues)." + ; `S "SEE ALSO" + ; `P "ocaml(1)" + ; `S "AUTHORS" + ; `P "Jerome Vouillon, Hugo Heuzard." + ; `S "LICENSE" + ; `P "Copyright (C) 2010-2024." + ; `P + "js_of_ocaml 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." + ] + in + let version = + match Compiler_version.git_version with + | "" -> Compiler_version.s + | v -> Printf.sprintf "%s+git-%s" Compiler_version.s v + in + Cmd.info name ~version ~doc ~man diff --git a/compiler/bin-wasm_of_ocaml/info.mli b/compiler/bin-wasm_of_ocaml/info.mli new file mode 100644 index 0000000000..c97f81629f --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/info.mli @@ -0,0 +1,19 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 make : name:string -> doc:string -> description:string -> Cmdliner.Cmd.info diff --git a/compiler/bin-wasm_of_ocaml/link.ml b/compiler/bin-wasm_of_ocaml/link.ml new file mode 100644 index 0000000000..f158abbbfa --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/link.ml @@ -0,0 +1,96 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 + ; mklib : 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)]. Unless the $(b,-a) option is used, 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 mklib = + let doc = + "Build a library (.wasma file) with the .wasmo files given on the command line. \ + Similar to ocamlc -a." + in + Arg.(value & flag & info [ "a" ] ~doc) + in + let build_t common no_sourcemap sourcemap output_file files linkall mklib = + let enable_source_maps = (not no_sourcemap) && sourcemap in + `Ok { common; output_file; files; linkall; mklib; enable_source_maps } + in + let t = + Term.( + const build_t + $ Lazy.force Jsoo_cmdline.Arg.t + $ no_sourcemap + $ sourcemap + $ output_file + $ files + $ linkall + $ mklib) + in + Term.ret t + +let f { common; output_file; files; linkall; enable_source_maps; mklib } = + Js_of_ocaml_compiler.Config.set_target `Wasm; + Jsoo_cmdline.Arg.eval common; + Link.link ~output_file ~linkall ~mklib ~enable_source_maps ~files + +let info = + Info.make + ~name:"link" + ~doc:"Wasm_of_ocaml linker" + ~description: + "wasm_of_ocaml-link links together several wasm_of_ocaml intermediate files to \ + produce either a library or some executable code." + +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 0000000000..952975461c --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/link.mli @@ -0,0 +1,19 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 new file mode 100644 index 0000000000..fdb2df384e --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.ml @@ -0,0 +1,110 @@ +(* Wams_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Js_of_ocaml_compiler + +let () = + Sys.catch_break true; + let argv = Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv in + let argv = + let like_arg x = String.length x > 0 && Char.equal x.[0] '-' in + let like_command x = + String.length x > 0 + && (not (Char.equal x.[0] '-')) + && String.for_all x ~f:(function + | 'a' .. 'z' | 'A' .. 'Z' | '-' -> true + | _ -> false) + in + match Array.to_list argv with + | exe :: maybe_command :: rest -> + if like_command maybe_command || like_arg maybe_command + then argv + else + (* Keep compatibility with js_of_ocaml < 3.6.0 *) + Array.of_list (exe :: Cmdliner.Cmd.name Compile.command :: maybe_command :: rest) + | _ -> argv + in + try + match + Cmdliner.Cmd.eval_value + ~catch:false + ~argv + (Cmdliner.Cmd.group + ~default:Compile.term + (Compile.info "wasm_of_ocaml") + [ Link.command; Build_runtime.command; Compile.command ]) + with + | Ok (`Ok () | `Help | `Version) -> + if !warnings > 0 && !werror + then ( + Format.eprintf "%s: all warnings being treated as errors@." Sys.argv.(0); + exit 1) + else exit 0 + | Error `Term -> exit 1 + | Error `Parse -> exit Cmdliner.Cmd.Exit.cli_error + | Error `Exn -> () + (* should not happen *) + with + | (Match_failure _ | Assert_failure _ | Not_found) as exc -> + let backtrace = Printexc.get_backtrace () in + Format.eprintf + "%s: You found a bug. Please report it at \ + https://github.com/ocsigen/js_of_ocaml/issues :@." + Sys.argv.(0); + Format.eprintf "Error: %s@." (Printexc.to_string exc); + prerr_string backtrace; + exit Cmdliner.Cmd.Exit.internal_error + | Magic_number.Bad_magic_number s -> + Format.eprintf "%s: Error: Not an ocaml bytecode file@." Sys.argv.(0); + Format.eprintf "%s: Error: Invalid magic number %S@." Sys.argv.(0) s; + exit 1 + | Magic_number.Bad_magic_version h -> + Format.eprintf "%s: Error: Bytecode version mismatch.@." Sys.argv.(0); + let k = + match Magic_number.kind h with + | (`Cmo | `Cma | `Exe) as x -> x + | `Other _ -> assert false + in + let comp = + if Magic_number.compare h (Magic_number.current k) < 0 + then "an older" + else "a newer" + in + Format.eprintf + "%s: Error: Your ocaml bytecode and the wasm_of_ocaml compiler have to be \ + compiled with the same version of ocaml.@." + Sys.argv.(0); + Format.eprintf + "%s: Error: The Wasm_of_ocaml compiler has been compiled with ocaml version %s.@." + Sys.argv.(0) + Sys.ocaml_version; + Format.eprintf + "%s: Error: Its seems that your ocaml bytecode has been compiled with %s version \ + of ocaml.@." + Sys.argv.(0) + comp; + exit 1 + | Failure s -> + Format.eprintf "%s: Error: %s@." Sys.argv.(0) s; + exit 1 + | exc -> + let backtrace = Printexc.get_backtrace () in + Format.eprintf "%s: Error: %s@." Sys.argv.(0) (Printexc.to_string exc); + prerr_string backtrace; + exit 1 diff --git a/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.mli b/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.mli new file mode 100644 index 0000000000..cc6700682b --- /dev/null +++ b/compiler/bin-wasm_of_ocaml/wasm_of_ocaml.mli @@ -0,0 +1,17 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) diff --git a/compiler/lib-wasm/binaryen.ml b/compiler/lib-wasm/binaryen.ml new file mode 100644 index 0000000000..93b0b7b7fb --- /dev/null +++ b/compiler/lib-wasm/binaryen.ml @@ -0,0 +1,130 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Stdlib + +let debug = Debug.find "binaryen" + +let command cmdline = + let cmdline = String.concat ~sep:" " cmdline in + if debug () then Format.eprintf "+ %s@." cmdline; + let res = Sys.command cmdline in + if res <> 0 then failwith ("the following command terminated unsuccessfully: " ^ cmdline) + +let common_options () = + let l = + [ "--enable-gc" + ; "--enable-multivalue" + ; "--enable-exception-handling" + ; "--enable-reference-types" + ; "--enable-tail-call" + ; "--enable-bulk-memory" + ; "--enable-nontrapping-float-to-int" + ; "--enable-strings" + ] + in + if Config.Flag.pretty () then "-g" :: l else l + +let opt_flag flag v = + match v with + | None -> [] + | Some v -> [ flag; Filename.quote v ] + +let link ~runtime_files ~input_files ~opt_output_sourcemap ~output_file = + command + ("wasm-merge" + :: (common_options () + @ List.flatten + (List.map + ~f:(fun runtime_file -> [ Filename.quote runtime_file; "env" ]) + runtime_files) + @ List.flatten + (List.map + ~f:(fun input_file -> [ Filename.quote input_file; "OCaml" ]) + input_files) + @ [ "-o"; Filename.quote output_file ] + @ opt_flag "--output-source-map" opt_output_sourcemap)) + +let generate_dependencies ~dependencies primitives = + Yojson.Basic.to_string + (`List + (StringSet.fold + (fun nm s -> + `Assoc + [ "name", `String ("js:" ^ nm) + ; "import", `List [ `String "js"; `String nm ] + ] + :: s) + primitives + (Yojson.Basic.Util.to_list (Yojson.Basic.from_string dependencies)))) + +let filter_unused_primitives primitives usage_file = + let ch = open_in usage_file in + let s = ref primitives in + (try + while true do + let l = input_line ch in + match String.drop_prefix ~prefix:"unused: js:" l with + | Some nm -> s := StringSet.remove nm !s + | None -> () + done + with End_of_file -> ()); + !s + +let dead_code_elimination + ~dependencies + ~opt_input_sourcemap + ~input_file + ~opt_output_sourcemap + ~output_file = + Fs.with_intermediate_file (Filename.temp_file "deps" ".json") + @@ fun deps_file -> + Fs.with_intermediate_file (Filename.temp_file "usage" ".txt") + @@ fun usage_file -> + let primitives = Linker.list_all () in + Fs.write_file ~name:deps_file ~contents:(generate_dependencies ~dependencies primitives); + command + ("wasm-metadce" + :: (common_options () + @ [ "--graph-file"; Filename.quote deps_file; Filename.quote input_file ] + @ opt_flag "--input-source-map" opt_input_sourcemap + @ [ "-o"; Filename.quote output_file ] + @ opt_flag "--output-source-map" opt_output_sourcemap + @ [ ">"; Filename.quote usage_file ])); + filter_unused_primitives primitives usage_file + +let optimization_options = + [| [ "-O2"; "--skip-pass=inlining-optimizing"; "--traps-never-happen" ] + ; [ "-O2"; "--skip-pass=inlining-optimizing"; "--traps-never-happen" ] + ; [ "-O3"; "--skip-pass=inlining-optimizing"; "--traps-never-happen" ] + |] + +let optimize ~profile ~opt_input_sourcemap ~input_file ~opt_output_sourcemap ~output_file + = + let level = + match profile with + | None -> 1 + | Some p -> fst (List.find ~f:(fun (_, p') -> Poly.equal p p') Driver.profiles) + in + command + ("wasm-opt" + :: (common_options () + @ optimization_options.(level - 1) + @ [ Filename.quote input_file; "-o"; Filename.quote output_file ]) + @ opt_flag "--input-source-map" opt_input_sourcemap + @ opt_flag "--output-source-map" opt_output_sourcemap) diff --git a/compiler/lib-wasm/binaryen.mli b/compiler/lib-wasm/binaryen.mli new file mode 100644 index 0000000000..3e07e06f88 --- /dev/null +++ b/compiler/lib-wasm/binaryen.mli @@ -0,0 +1,40 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 link : + runtime_files:string list + -> input_files:string list + -> opt_output_sourcemap:string option + -> output_file:string + -> unit + +val dead_code_elimination : + dependencies:string + -> opt_input_sourcemap:string option + -> input_file:string + -> opt_output_sourcemap:string option + -> output_file:string + -> Stdlib.StringSet.t + +val optimize : + profile:Driver.profile option + -> opt_input_sourcemap:string option + -> input_file:string + -> opt_output_sourcemap:string option + -> output_file:string + -> unit diff --git a/compiler/lib-wasm/closure_conversion.ml b/compiler/lib-wasm/closure_conversion.ml new file mode 100644 index 0000000000..162989496c --- /dev/null +++ b/compiler/lib-wasm/closure_conversion.ml @@ -0,0 +1,166 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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! Stdlib +open Code + +type closure = + { functions : (Var.t * int) list + ; free_variables : Var.t list + } + +module SCC = Strongly_connected_components.Make (Var) + +let iter_closures ~f instrs = + let rec iter_closures_rec f instr_acc clos_acc instrs = + let push_closures clos_acc instr_acc = + if Var.Map.is_empty clos_acc + then instr_acc + else + let l = f clos_acc in + List.rev_map + ~f:(fun g -> + let params, cont = Var.Map.find g clos_acc in + Let (g, Closure (params, cont))) + l + @ instr_acc + in + match instrs with + | [] -> List.rev (push_closures clos_acc instr_acc) + | Let (g, Closure (params, cont)) :: rem -> + iter_closures_rec f instr_acc (Var.Map.add g (params, cont) clos_acc) rem + | i :: rem -> + iter_closures_rec f (i :: push_closures clos_acc instr_acc) Var.Map.empty rem + in + iter_closures_rec f [] Var.Map.empty instrs + +let collect_free_vars program var_depth depth pc closures = + let vars = ref Var.Set.empty in + let add_if_free_variable x = + let idx = Var.idx x in + let d = var_depth.(idx) in + assert (d >= 0); + if d < depth then vars := Var.Set.add x !vars + in + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc () -> + let block = Code.Addr.Map.find pc program.blocks in + Freevars.iter_block_free_vars add_if_free_variable block; + List.iter block.body ~f:(fun i -> + match i with + | Let (f, Closure _) -> ( + match Var.Map.find_opt f closures with + | Some { functions = (g, _) :: _; free_variables; _ } when Var.equal f g -> + List.iter ~f:add_if_free_variable free_variables + | Some _ | None -> ()) + | _ -> ())) + pc + program.blocks + (); + !vars + +let mark_bound_variables var_depth block depth = + Freevars.iter_block_bound_vars (fun x -> var_depth.(Var.idx x) <- depth) block; + List.iter block.body ~f:(fun i -> + match i with + | Let (_, Closure (params, _)) -> + List.iter params ~f:(fun x -> var_depth.(Var.idx x) <- depth + 1) + | _ -> ()) + +let rec traverse var_depth closures program pc depth = + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc (program : Code.program) -> + let block = Code.Addr.Map.find pc program.blocks in + mark_bound_variables var_depth block depth; + let program = + List.fold_left + ~f:(fun program i -> + match i with + | Let (_, Closure (_, (pc', _))) -> + traverse var_depth closures program pc' (depth + 1) + | _ -> program) + ~init:program + block.body + in + let body = + iter_closures block.body ~f:(fun l -> + let free_vars = + Var.Map.fold + (fun f (_, (pc', _)) free_vars -> + Var.Map.add + f + (collect_free_vars program var_depth (depth + 1) pc' !closures) + free_vars) + l + Var.Map.empty + in + let domain = Var.Map.fold (fun f _ s -> Var.Set.add f s) l Var.Set.empty in + let graph = Var.Map.map (fun s -> Var.Set.inter s domain) free_vars in + let components = SCC.connected_components_sorted_from_roots_to_leaf graph in + let l = + Array.map + ~f:(fun component -> + let fun_lst = + match component with + | SCC.No_loop x -> [ x ] + | SCC.Has_loop l -> l + in + let free_variables = + Var.Set.elements + (List.fold_left + ~f:(fun fv x -> Var.Set.remove x fv) + ~init: + (List.fold_left + ~f:(fun fv x -> Var.Set.union fv (Var.Map.find x free_vars)) + ~init:Var.Set.empty + fun_lst) + fun_lst) + in + let functions = + let arities = + Var.Map.fold + (fun f (params, _) m -> Var.Map.add f (List.length params) m) + l + Var.Map.empty + in + List.map ~f:(fun f -> f, Var.Map.find f arities) fun_lst + in + List.iter + ~f:(fun (f, _) -> + closures := Var.Map.add f { functions; free_variables } !closures) + functions; + fun_lst) + components + in + List.concat (List.rev (Array.to_list l))) + in + { program with blocks = Code.Addr.Map.add pc { block with body } program.blocks }) + pc + program.blocks + program + +let f p = + let t = Timer.make () in + let nv = Var.count () in + let var_depth = Array.make nv (-1) in + let closures = ref Var.Map.empty in + let p = traverse var_depth closures p p.start 0 in + if Debug.find "times" () then Format.eprintf " closure conversion: %a@." Timer.print t; + p, !closures diff --git a/compiler/lib-wasm/closure_conversion.mli b/compiler/lib-wasm/closure_conversion.mli new file mode 100644 index 0000000000..41a5e0642c --- /dev/null +++ b/compiler/lib-wasm/closure_conversion.mli @@ -0,0 +1,24 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +type closure = + { functions : (Code.Var.t * int) list + ; free_variables : Code.Var.t list + } + +val f : Code.program -> Code.program * closure Code.Var.Map.t diff --git a/compiler/lib-wasm/code_generation.ml b/compiler/lib-wasm/code_generation.ml new file mode 100644 index 0000000000..cd23a3db7e --- /dev/null +++ b/compiler/lib-wasm/code_generation.ml @@ -0,0 +1,656 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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! Stdlib +open Code +module W = Wasm_ast + +(* +LLVM type checker does not work well. It does not handle 'br', and +there is a bug with `return` in clang 15. +Use 'clang-16 --target=wasm32 -Wa,--no-type-check' to disable it. +https://github.com/llvm/llvm-project/issues/56935 +https://github.com/llvm/llvm-project/issues/58438 +*) + +(* binaryen does not support block input parameters + https://github.com/WebAssembly/binaryen/issues/5047 *) + +type constant_global = + { init : W.expression option + ; constant : bool + } + +type context = + { constants : (Var.t, W.expression) Hashtbl.t + ; mutable data_segments : string Var.Map.t + ; mutable constant_globals : constant_global Var.Map.t + ; mutable other_fields : W.module_field list + ; mutable imports : (Var.t * Wasm_ast.import_desc) StringMap.t StringMap.t + ; type_names : (string, Var.t) Hashtbl.t + ; types : (Var.t, Wasm_ast.type_field) Hashtbl.t + ; mutable closure_envs : Var.t Var.Map.t + (** GC: mapping of recursive functions to their shared environment *) + ; mutable apply_funs : Var.t IntMap.t + ; mutable cps_apply_funs : Var.t IntMap.t + ; mutable curry_funs : Var.t IntMap.t + ; mutable cps_curry_funs : Var.t IntMap.t + ; mutable dummy_funs : Var.t IntMap.t + ; mutable cps_dummy_funs : Var.t IntMap.t + ; mutable init_code : W.instruction list + ; mutable string_count : int + ; mutable strings : string list + ; mutable string_index : int StringMap.t + ; mutable fragments : Javascript.expression StringMap.t + ; mutable globalized_variables : Var.Set.t + ; value_type : W.value_type + ; mutable unit_name : string option + } + +let make_context ~value_type = + { constants = Hashtbl.create 128 + ; data_segments = Var.Map.empty + ; constant_globals = Var.Map.empty + ; other_fields = [] + ; imports = StringMap.empty + ; type_names = Hashtbl.create 128 + ; types = Hashtbl.create 128 + ; closure_envs = Var.Map.empty + ; apply_funs = IntMap.empty + ; cps_apply_funs = IntMap.empty + ; curry_funs = IntMap.empty + ; cps_curry_funs = IntMap.empty + ; dummy_funs = IntMap.empty + ; cps_dummy_funs = IntMap.empty + ; init_code = [] + ; string_count = 0 + ; strings = [] + ; string_index = StringMap.empty + ; fragments = StringMap.empty + ; globalized_variables = Var.Set.empty + ; value_type + ; unit_name = None + } + +type var = + | Local of int * Var.t * W.value_type option + | Expr of W.expression t + +and state = + { var_count : int + ; vars : var Var.Map.t + ; instrs : W.instruction list + ; context : context + } + +and 'a t = state -> 'a * state + +type expression = Wasm_ast.expression t + +let ( let* ) (type a b) (e : a t) (f : a -> b t) : b t = + fun st -> + let v, st = e st in + f v st + +let return x st = x, st + +let expression_list f l = + let rec loop acc l = + match l with + | [] -> return (List.rev acc) + | x :: r -> + let* x = f x in + loop (x :: acc) r + in + loop [] l + +let register_data_segment x v st = + st.context.data_segments <- Var.Map.add x v st.context.data_segments; + (), st + +let get_context st = st.context, st + +let register_constant x e st = + Hashtbl.add st.context.constants x e; + (), st + +type type_def = + { supertype : Wasm_ast.var option + ; final : bool + ; typ : Wasm_ast.str_type + } + +let register_type nm gen_typ st = + let context = st.context in + let { supertype; final; typ }, st = gen_typ () st in + ( (try Hashtbl.find context.type_names nm + with Not_found -> + let name = Var.fresh_n nm in + let type_field = { Wasm_ast.name; typ; supertype; final } in + context.other_fields <- Type [ type_field ] :: context.other_fields; + Hashtbl.add context.type_names nm name; + Hashtbl.add context.types name type_field; + name) + , st ) + +let rec type_index_sub ty ty' st = + if Var.equal ty ty' + then true, st + else + let type_field = Hashtbl.find st.context.types ty in + match type_field.supertype with + | None -> false, st + | Some ty -> type_index_sub ty ty' st + +let heap_type_sub (ty : W.heap_type) (ty' : W.heap_type) st = + match ty, ty' with + | Func, Func + | Extern, Extern + | (Any | Eq | I31 | Type _), Any + | (Eq | I31 | Type _), Eq + | I31, I31 -> true, st + | Type t, Type t' -> type_index_sub t t' st + (* Func and Extern are only in suptyping relation with themselves *) + | Func, _ + | _, Func + | Extern, _ + | _, Extern + (* Any has no supertype *) + | Any, _ + (* I31, struct and arrays have no subtype (of a different kind) *) + | _, (I31 | Type _) -> false, st + +let register_global name ?exported_name ?(constant = false) typ init st = + st.context.other_fields <- + W.Global { name; exported_name; typ; init } :: st.context.other_fields; + st.context.constant_globals <- + Var.Map.add + name + { init = (if not typ.mut then Some init else None) + ; constant = (not typ.mut) || constant + } + st.context.constant_globals; + (), st + +let global_is_registered name = + let* ctx = get_context in + return (Var.Map.mem name ctx.constant_globals) + +let global_is_constant name = + let* ctx = get_context in + return + (match Var.Map.find_opt name ctx.constant_globals with + | Some { constant = true; _ } -> true + | _ -> false) + +let get_global name = + let* ctx = get_context in + return + (match Var.Map.find_opt name ctx.constant_globals with + | Some { init; _ } -> init + | _ -> None) + +let register_import ?(import_module = "env") ~name typ st = + ( (try + let x, typ' = + StringMap.find name (StringMap.find import_module st.context.imports) + in + (*ZZZ error message*) + assert (Poly.equal typ typ'); + x + with Not_found -> + let x = Var.fresh_n name in + st.context.imports <- + StringMap.update + import_module + (fun m -> + Some + (match m with + | None -> StringMap.singleton name (x, typ) + | Some m -> StringMap.add name (x, typ) m)) + st.context.imports; + x) + , st ) + +let register_init_code code st = + let st' = { var_count = 0; vars = Var.Map.empty; instrs = []; context = st.context } in + let (), st' = code st' in + st.context.init_code <- st'.instrs @ st.context.init_code; + (), st + +let register_string s st = + let context = st.context in + try StringMap.find s context.string_index, st + with Not_found -> + let n = context.string_count in + context.string_count <- 1 + context.string_count; + context.strings <- s :: context.strings; + context.string_index <- StringMap.add s n context.string_index; + n, st + +let register_fragment name f st = + let context = st.context in + if not (StringMap.mem name context.fragments) + then context.fragments <- StringMap.add name (f ()) context.fragments; + (), st + +let set_closure_env f env st = + st.context.closure_envs <- Var.Map.add f env st.context.closure_envs; + (), st + +let get_closure_env f st = Var.Map.find f st.context.closure_envs, st + +let is_closure f st = Var.Map.mem f st.context.closure_envs, st + +let unit_name st = st.context.unit_name, st + +let var x st = + try Var.Map.find x st.vars, st + with Not_found -> Expr (return (Hashtbl.find st.context.constants x)), st + +let add_var ?typ x ({ var_count; vars; _ } as st) = + match Var.Map.find_opt x vars with + | Some (Local (_, x', typ')) -> + assert (Poly.equal typ typ'); + x', st + | Some (Expr _) -> assert false + | None -> + let i = var_count in + let vars = Var.Map.add x (Local (i, x, typ)) vars in + x, { st with var_count = var_count + 1; vars } + +let define_var x e st = (), { st with vars = Var.Map.add x (Expr e) st.vars } + +let instr i : unit t = fun st -> (), { st with instrs = i :: st.instrs } + +let instrs l : unit t = fun st -> (), { st with instrs = List.rev_append l st.instrs } + +let blk l st = + let instrs = st.instrs in + let (), st = l { st with instrs = [] } in + List.rev st.instrs, { st with instrs } + +let event loc : unit t = + fun st -> + ( () + , match st.instrs with + | Event _ :: instrs | instrs -> { st with instrs = Event loc :: instrs } ) + +let hidden_location = + { Parse_info.src = Some Wasm_source_map.blackbox_filename + ; name = None + ; col = 0 + ; line = 1 + ; idx = 0 + } + +let no_event = event hidden_location + +let cast ?(nullable = false) typ e = + let* e = e in + match typ, e with + | W.I31, W.RefI31 _ -> return e + | _ -> return (W.RefCast ({ W.nullable; typ }, e)) + +module Arith = struct + let binary op e e' = + let* e = e in + let* e' = e' in + return (W.BinOp (I32 op, e, e')) + + let unary op e = + let* e = e in + return (W.UnOp (I32 op, e)) + + let ( + ) e e' = + let* e = e in + let* e' = e' in + return + (match e, e' with + | W.BinOp (I32 Add, e1, W.Const (I32 n)), W.Const (I32 n') -> + let n'' = Int32.add n n' in + if Int32.equal n'' 0l + then e1 + else W.BinOp (I32 Add, e1, W.Const (I32 (Int32.add n n'))) + | W.Const (I32 n), W.Const (I32 n') -> W.Const (I32 (Int32.add n n')) + | W.Const (I32 0l), _ -> e' + | _, W.Const (I32 0l) -> e + | W.Const _, _ -> W.BinOp (I32 Add, e', e) + | _ -> W.BinOp (I32 Add, e, e')) + + let ( - ) e e' = + let* e = e in + let* e' = e' in + return + (match e, e' with + | W.BinOp (I32 Add, e1, W.Const (I32 n)), W.Const (I32 n') -> + let n'' = Int32.sub n n' in + if Int32.equal n'' 0l then e1 else W.BinOp (I32 Add, e1, W.Const (I32 n'')) + | W.Const (I32 n), W.Const (I32 n') -> W.Const (I32 (Int32.sub n n')) + | _, W.Const (I32 n) -> + if Int32.equal n 0l then e else W.BinOp (I32 Add, e, W.Const (I32 (Int32.neg n))) + | _ -> W.BinOp (I32 Sub, e, e')) + + let ( * ) = binary Mul + + let ( / ) = binary (Div S) + + let ( mod ) = binary (Rem S) + + let ( lsl ) e e' = + let* e = e in + let* e' = e' in + return + (match e, e' with + | W.Const (I32 n), W.Const (I32 n') when Poly.(n' < 31l) -> + W.Const (I32 (Int32.shift_left n (Int32.to_int n'))) + | _ -> W.BinOp (I32 Shl, e, e')) + + let ( lsr ) = binary (Shr U) + + let ( asr ) = binary (Shr S) + + let ( land ) = binary And + + let ( lor ) = binary Or + + let ( lxor ) = binary Xor + + let ( < ) = binary (Lt S) + + let ( <= ) = binary (Le S) + + let ( = ) = binary Eq + + let ( <> ) = binary Ne + + let ult = binary (Lt U) + + let uge = binary (Ge U) + + let eqz = unary Eqz + + let const n = return (W.Const (I32 n)) + + let to_int31 n = + let* n = n in + match n with + | W.I31Get (S, n') -> return n' + | _ -> return (W.RefI31 n) + + let wrap31 n = Targetint.(of_int32_truncate n |> to_int32) + + let of_int31 n = + let* n = n in + match n with + | W.RefI31 (Const (I32 n)) -> return (W.Const (I32 (wrap31 n))) + | _ -> return (W.I31Get (S, n)) +end + +let is_small_constant e = + match e with + | W.Const _ | W.RefI31 (W.Const _) | W.RefFunc _ -> return true + | W.GlobalGet name -> global_is_constant name + | _ -> return false + +let un_op_is_smi op = + match op with + | W.Clz | Ctz | Popcnt | Eqz -> true + | TruncSatF64 _ | ReinterpretF -> false + +let bin_op_is_smi (op : W.int_bin_op) = + match op with + | W.Add | Sub | Mul | Div _ | Rem _ | And | Or | Xor | Shl | Shr _ | Rotl | Rotr -> + false + | Eq | Ne | Lt _ | Gt _ | Le _ | Ge _ -> true + +let rec is_smi e = + match e with + | W.Const (I32 i) -> Int32.equal (Arith.wrap31 i) i + | UnOp ((I32 op | I64 op), _) -> un_op_is_smi op + | BinOp ((I32 op | I64 op), _, _) -> bin_op_is_smi op + | I31Get (S, _) -> true + | I31Get (U, _) + | Const (I64 _ | F32 _ | F64 _) + | UnOp ((F32 _ | F64 _), _) + | I32WrapI64 _ + | I64ExtendI32 _ + | F32DemoteF64 _ + | F64PromoteF32 _ + | LocalGet _ + | LocalTee _ + | GlobalGet _ + | BlockExpr _ + | Call _ + | Seq _ + | Pop _ + | RefFunc _ + | Call_ref _ + | RefI31 _ + | ArrayNew _ + | ArrayNewFixed _ + | ArrayNewData _ + | ArrayGet _ + | ArrayLen _ + | StructNew _ + | StructGet _ + | RefCast _ + | RefNull _ + | Br_on_cast _ + | Br_on_cast_fail _ + | Try _ -> false + | BinOp ((F32 _ | F64 _), _, _) | RefTest _ | RefEq _ -> true + | IfExpr (_, _, ift, iff) -> is_smi ift && is_smi iff + +let get_i31_value x st = + match st.instrs with + | LocalSet (x', RefI31 e) :: rem when Code.Var.equal x x' && is_smi e -> + let x = Var.fresh () in + let x, st = add_var ~typ:I32 x st in + Some x, { st with instrs = LocalSet (x', RefI31 (LocalTee (x, e))) :: rem } + | Event loc :: LocalSet (x', RefI31 e) :: rem when Code.Var.equal x x' && is_smi e -> + let x = Var.fresh () in + let x, st = add_var ~typ:I32 x st in + ( Some x + , { st with instrs = Event loc :: LocalSet (x', RefI31 (LocalTee (x, e))) :: rem } ) + | _ -> None, st + +let load x = + let* x = var x in + match x with + | Local (_, x, _) -> return (W.LocalGet x) + | Expr e -> e + +let tee ?typ x e = + let* e = e in + let* b = is_small_constant e in + if b + then + let* () = register_constant x e in + return e + else + let* i = add_var ?typ x in + return (W.LocalTee (i, e)) + +let should_make_global x st = Var.Set.mem x st.context.globalized_variables, st + +let value_type st = st.context.value_type, st + +let rec store ?(always = false) ?typ x e = + let* e = e in + match e with + | W.Seq (l, e') -> + let* () = instrs l in + store ~always ?typ x (return e') + | _ -> + let* b = is_small_constant e in + if b && not always + then register_constant x e + else + let* b = should_make_global x in + if b + then + let* typ = + match typ with + | Some typ -> return typ + | None -> value_type + in + let* () = + let* b = global_is_registered x in + if b + then return () + else + register_global + ~constant:true + x + { mut = true; typ } + (W.RefI31 (Const (I32 0l))) + in + let* () = register_constant x (W.GlobalGet x) in + instr (GlobalSet (x, e)) + else + let* i = add_var ?typ x in + instr (LocalSet (i, e)) + +let assign x e = + let* x = var x in + let* e = e in + match x with + | Local (_, x, _) -> instr (W.LocalSet (x, e)) + | Expr _ -> assert false + +let seq l e = + let* instrs = blk l in + let* e = e in + return (W.Seq (instrs, e)) + +let drop e = + let* e = e in + match e with + | W.Seq (l, e') -> + let* b = is_small_constant e' in + let* () = instrs l in + if b then return () else instr (Drop e') + | _ -> instr (Drop e) + +let push e = + let* e = e in + match e with + | W.Seq (l, e') -> + let* () = instrs l in + instr (Push e') + | _ -> instr (Push e) + +let loop ty l = + let* instrs = blk l in + instr (Loop (ty, instrs)) + +let block ty l = + let* instrs = blk l in + instr (Block (ty, instrs)) + +let block_expr ty l = + let* instrs = blk l in + return (W.BlockExpr (ty, instrs)) + +let if_ ty e l1 l2 = + let* e = e in + let* instrs1 = blk l1 in + let* instrs2 = blk l2 in + match e with + | W.UnOp (I32 Eqz, e') -> instr (If (ty, e', instrs2, instrs1)) + | _ -> instr (If (ty, e, instrs1, instrs2)) + +let try_expr ty body handlers = + let* body = blk body in + return (W.Try (ty, body, handlers)) + +let need_apply_fun ~cps ~arity st = + let ctx = st.context in + ( (if cps + then ( + try IntMap.find arity ctx.cps_apply_funs + with Not_found -> + let x = Var.fresh_n (Printf.sprintf "cps_apply_%d" arity) in + ctx.cps_apply_funs <- IntMap.add arity x ctx.cps_apply_funs; + x) + else + try IntMap.find arity ctx.apply_funs + with Not_found -> + let x = Var.fresh_n (Printf.sprintf "apply_%d" arity) in + ctx.apply_funs <- IntMap.add arity x ctx.apply_funs; + x) + , st ) + +let need_curry_fun ~cps ~arity st = + let ctx = st.context in + ( (if cps + then ( + try IntMap.find arity ctx.cps_curry_funs + with Not_found -> + let x = Var.fresh_n (Printf.sprintf "cps_curry_%d" arity) in + ctx.cps_curry_funs <- IntMap.add arity x ctx.cps_curry_funs; + x) + else + try IntMap.find arity ctx.curry_funs + with Not_found -> + let x = Var.fresh_n (Printf.sprintf "curry_%d" arity) in + ctx.curry_funs <- IntMap.add arity x ctx.curry_funs; + x) + , st ) + +let need_dummy_fun ~cps ~arity st = + let ctx = st.context in + ( (if cps + then ( + try IntMap.find arity ctx.cps_dummy_funs + with Not_found -> + let x = Var.fresh_n (Printf.sprintf "cps_dummy_%d" arity) in + ctx.cps_dummy_funs <- IntMap.add arity x ctx.cps_dummy_funs; + x) + else + try IntMap.find arity ctx.dummy_funs + with Not_found -> + let x = Var.fresh_n (Printf.sprintf "dummy_%d" arity) in + ctx.dummy_funs <- IntMap.add arity x ctx.dummy_funs; + x) + , st ) + +let init_code context = instrs context.init_code + +let function_body ~context ~param_names ~body = + let st = { var_count = 0; vars = Var.Map.empty; instrs = []; context } in + let (), st = body st in + let local_count, body = st.var_count, List.rev st.instrs in + let local_types = Array.make local_count (Var.fresh (), None) in + List.iteri ~f:(fun i x -> local_types.(i) <- x, None) param_names; + Var.Map.iter + (fun _ v -> + match v with + | Local (i, x, typ) -> local_types.(i) <- x, typ + | Expr _ -> ()) + st.vars; + let body = Tail_call.f body in + let param_count = List.length param_names in + let locals = + local_types + |> Array.map ~f:(fun (x, v) -> x, Option.value ~default:context.value_type v) + |> (fun a -> Array.sub a ~pos:param_count ~len:(Array.length a - param_count)) + |> Array.to_list + in + locals, body diff --git a/compiler/lib-wasm/code_generation.mli b/compiler/lib-wasm/code_generation.mli new file mode 100644 index 0000000000..f03af255a1 --- /dev/null +++ b/compiler/lib-wasm/code_generation.mli @@ -0,0 +1,205 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Stdlib + +type constant_global + +type context = + { constants : (Code.Var.t, Wasm_ast.expression) Hashtbl.t + ; mutable data_segments : string Code.Var.Map.t + ; mutable constant_globals : constant_global Code.Var.Map.t + ; mutable other_fields : Wasm_ast.module_field list + ; mutable imports : (Code.Var.t * Wasm_ast.import_desc) StringMap.t StringMap.t + ; type_names : (string, Code.Var.t) Hashtbl.t + ; types : (Code.Var.t, Wasm_ast.type_field) Hashtbl.t + ; mutable closure_envs : Code.Var.t Code.Var.Map.t + (** GC: mapping of recursive functions to their shared environment *) + ; mutable apply_funs : Code.Var.t Stdlib.IntMap.t + ; mutable cps_apply_funs : Code.Var.t Stdlib.IntMap.t + ; mutable curry_funs : Code.Var.t Stdlib.IntMap.t + ; mutable cps_curry_funs : Code.Var.t Stdlib.IntMap.t + ; mutable dummy_funs : Code.Var.t Stdlib.IntMap.t + ; mutable cps_dummy_funs : Code.Var.t Stdlib.IntMap.t + ; mutable init_code : Wasm_ast.instruction list + ; mutable string_count : int + ; mutable strings : string list + ; mutable string_index : int StringMap.t + ; mutable fragments : Javascript.expression StringMap.t + ; mutable globalized_variables : Code.Var.Set.t + ; value_type : Wasm_ast.value_type + ; mutable unit_name : string option + } + +val make_context : value_type:Wasm_ast.value_type -> context + +type 'a t + +type expression = Wasm_ast.expression t + +val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t + +val return : 'a -> 'a t + +val instr : Wasm_ast.instruction -> unit t + +val seq : unit t -> expression -> expression + +val expression_list : ('a -> expression) -> 'a list -> Wasm_ast.expression list t + +module Arith : sig + val const : int32 -> expression + + val to_int31 : expression -> expression + + val of_int31 : expression -> expression + + val ( + ) : expression -> expression -> expression + + val ( - ) : expression -> expression -> expression + + val ( * ) : expression -> expression -> expression + + val ( / ) : expression -> expression -> expression + + val ( mod ) : expression -> expression -> expression + + val ( lsl ) : expression -> expression -> expression + + val ( lsr ) : expression -> expression -> expression + + val ( asr ) : expression -> expression -> expression + + val ( land ) : expression -> expression -> expression + + val ( lor ) : expression -> expression -> expression + + val ( lxor ) : expression -> expression -> expression + + val ( < ) : expression -> expression -> expression + + val ( <= ) : expression -> expression -> expression + + val ( = ) : expression -> expression -> expression + + val ( <> ) : expression -> expression -> expression + + val ult : expression -> expression -> expression + + val uge : expression -> expression -> expression + + val eqz : expression -> expression +end + +val cast : ?nullable:bool -> Wasm_ast.heap_type -> expression -> expression + +val load : Wasm_ast.var -> expression + +val tee : ?typ:Wasm_ast.value_type -> Wasm_ast.var -> expression -> expression + +val store : + ?always:bool -> ?typ:Wasm_ast.value_type -> Wasm_ast.var -> expression -> unit t + +val assign : Wasm_ast.var -> expression -> unit t + +val drop : expression -> unit t + +val push : expression -> unit t + +val loop : Wasm_ast.func_type -> unit t -> unit t + +val block : Wasm_ast.func_type -> unit t -> unit t + +val block_expr : Wasm_ast.func_type -> unit t -> expression + +val if_ : Wasm_ast.func_type -> expression -> unit t -> unit t -> unit t + +val try_expr : + Wasm_ast.func_type + -> unit t + -> (Code.Var.t * int * Wasm_ast.value_type) list + -> expression + +val add_var : ?typ:Wasm_ast.value_type -> Wasm_ast.var -> Wasm_ast.var t + +val define_var : Wasm_ast.var -> expression -> unit t + +val is_small_constant : Wasm_ast.expression -> bool t + +val get_i31_value : Wasm_ast.var -> Wasm_ast.var option t + +val event : Parse_info.t -> unit t + +val no_event : unit t + +val hidden_location : Parse_info.t + +type type_def = + { supertype : Wasm_ast.var option + ; final : bool + ; typ : Wasm_ast.str_type + } + +val register_type : string -> (unit -> type_def t) -> Wasm_ast.var t + +val heap_type_sub : Wasm_ast.heap_type -> Wasm_ast.heap_type -> bool t + +val register_import : + ?import_module:string -> name:string -> Wasm_ast.import_desc -> Wasm_ast.var t + +val register_global : + Wasm_ast.var + -> ?exported_name:string + -> ?constant:bool + -> Wasm_ast.global_type + -> Wasm_ast.expression + -> unit t + +val get_global : Code.Var.t -> Wasm_ast.expression option t + +val register_data_segment : Code.Var.t -> string -> unit t + +val register_init_code : unit t -> unit t + +val init_code : context -> unit t + +val register_string : string -> int t + +val register_fragment : string -> (unit -> Javascript.expression) -> unit t + +val get_context : context t + +val set_closure_env : Code.Var.t -> Code.Var.t -> unit t + +val get_closure_env : Code.Var.t -> Code.Var.t t + +val is_closure : Code.Var.t -> bool t + +val unit_name : string option t + +val need_apply_fun : cps:bool -> arity:int -> Code.Var.t t + +val need_curry_fun : cps:bool -> arity:int -> Code.Var.t t + +val need_dummy_fun : cps:bool -> arity:int -> Code.Var.t t + +val function_body : + context:context + -> param_names:Code.Var.t list + -> body:unit t + -> (Wasm_ast.var * Wasm_ast.value_type) list * Wasm_ast.instruction list diff --git a/compiler/lib-wasm/curry.ml b/compiler/lib-wasm/curry.ml new file mode 100644 index 0000000000..0d96ad5cb9 --- /dev/null +++ b/compiler/lib-wasm/curry.ml @@ -0,0 +1,347 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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! Stdlib +open Code +module W = Wasm_ast +open Code_generation + +module Make (Target : Target_sig.S) = struct + open Target + + let func_type n = + { W.params = List.init ~len:(n + 1) ~f:(fun _ -> Value.value) + ; result = [ Value.value ] + } + + let bind_parameters l = + List.fold_left + ~f:(fun l x -> + let* _ = l in + let* _ = add_var x in + return ()) + ~init:(return ()) + l + + let call ?typ ~cps ~arity closure args = + let funct = Var.fresh () in + let* closure = tee ?typ funct closure in + let args = args @ [ closure ] in + let* ty, funct = + Memory.load_function_pointer + ~cps + ~arity + ~skip_cast:(Option.is_some typ) + (load funct) + in + return (W.Call_ref (ty, funct, args)) + + let curry_app_name n m = Printf.sprintf "curry_app %d_%d" n m + + (* ZZZ + curry_app: load m arguments from the env; + get (m - n) arguments as parameters; + apply to f + parameters : closure_{n - m} + + local.set closure_(n -1) (field 4 (local.get closure_n)) + + local.set closure_(n - 1) (field 4 (local.get closure_n)) + call + (load_func (local.get closure_0)) (field 3 (local.get closure_1)) (field 3 (local.get closure_2)) ... (local.get closure_{n - m})) (local.get x1) ... (local.get xm) (local.get closure_0)) + *) + let curry_app ~context ~arity m ~name = + let args = + List.init ~f:(fun i -> Code.Var.fresh_n (Printf.sprintf "x_%d" i)) ~len:m + in + let f = Code.Var.fresh_n "f" in + let body = + let* () = no_event in + let* () = bind_parameters args in + let* _ = add_var f in + let* args' = expression_list load args in + let* _f = load f in + let rec loop m args closure closure_typ = + if m = arity + then + let* e = + call + ?typ:closure_typ + ~cps:false + ~arity + (load closure) + (List.append args args') + in + instr (W.Push e) + else + let* load_arg, load_closure, closure_typ = + Closure.curry_load ~cps:false ~arity m closure + in + let* x = load_arg in + let closure' = Code.Var.fresh_n "f" in + let* () = store ?typ:closure_typ closure' load_closure in + loop (m + 1) (x :: args) closure' closure_typ + in + loop m [] f None + in + let param_names = args @ [ f ] in + let locals, body = function_body ~context ~param_names ~body in + W.Function + { name; exported_name = None; typ = func_type 1; param_names; locals; body } + + let curry_name n m = Printf.sprintf "curry_%d_%d" n m + + let rec curry ~context ~arity m ~name = + assert (m > 1); + let name', functions = + if m = 2 + then + let nm = Var.fresh_n (curry_app_name arity 1) in + let func = curry_app ~context ~arity 1 ~name:nm in + nm, [ func ] + else + let nm = Var.fresh_n (curry_name arity (m - 1)) in + let functions = curry ~context ~arity (m - 1) ~name:nm in + nm, functions + in + let x = Code.Var.fresh_n "x" in + let f = Code.Var.fresh_n "f" in + let body = + let* () = no_event in + let* _ = add_var x in + let* _ = add_var f in + push (Closure.curry_allocate ~cps:false ~arity m ~f:name' ~closure:f ~arg:x) + in + let param_names = [ x; f ] in + let locals, body = function_body ~context ~param_names ~body in + W.Function + { name; exported_name = None; typ = func_type 1; param_names; locals; body } + :: functions + + let curry ~arity ~name = curry ~arity arity ~name + + let cps_curry_app_name n m = Printf.sprintf "cps_curry_app %d_%d" n m + + let cps_curry_app ~context ~arity m ~name = + let args = + List.init ~f:(fun i -> Code.Var.fresh_n (Printf.sprintf "x_%d" i)) ~len:(m + 1) + in + let f = Code.Var.fresh_n "f" in + let body = + let* () = no_event in + let* () = bind_parameters args in + let* _ = add_var f in + let* args' = expression_list load args in + let* _f = load f in + let rec loop m args closure closure_typ = + if m = arity + then + let* e = + call + ?typ:closure_typ + ~cps:true + ~arity:(arity + 1) + (load closure) + (List.append args args') + in + instr (W.Push e) + else + let* load_arg, load_closure, closure_typ = + Closure.curry_load ~cps:true ~arity m closure + in + let* x = load_arg in + let closure' = Code.Var.fresh_n "f" in + let* () = store ?typ:closure_typ closure' load_closure in + loop (m + 1) (x :: args) closure' closure_typ + in + loop m [] f None + in + let param_names = args @ [ f ] in + let locals, body = function_body ~context ~param_names ~body in + W.Function + { name; exported_name = None; typ = func_type 2; param_names; locals; body } + + let cps_curry_name n m = Printf.sprintf "cps_curry_%d_%d" n m + + let rec cps_curry ~context ~arity m ~name = + assert (m > 1); + let name', functions = + if m = 2 + then + let nm = Var.fresh_n (cps_curry_app_name arity 1) in + let func = cps_curry_app ~context ~arity 1 ~name:nm in + nm, [ func ] + else + let nm = Var.fresh_n (cps_curry_name arity (m - 1)) in + let functions = cps_curry ~context ~arity (m - 1) ~name:nm in + nm, functions + in + let x = Code.Var.fresh_n "x" in + let cont = Code.Var.fresh_n "cont" in + let f = Code.Var.fresh_n "f" in + let body = + let* () = no_event in + let* _ = add_var x in + let* _ = add_var cont in + let* _ = add_var f in + let* e = Closure.curry_allocate ~cps:true ~arity m ~f:name' ~closure:f ~arg:x in + let* c = call ~cps:false ~arity:1 (load cont) [ e ] in + instr (W.Return (Some c)) + in + let param_names = [ x; cont; f ] in + let locals, body = function_body ~context ~param_names ~body in + W.Function + { name; exported_name = None; typ = func_type 2; param_names; locals; body } + :: functions + + let cps_curry ~arity ~name = cps_curry ~arity arity ~name + + let apply ~context ~arity ~name = + assert (arity > 1); + let l = + List.rev + (List.init ~len:arity ~f:(fun i -> Code.Var.fresh_n (Printf.sprintf "x%d" i))) + in + let f = Code.Var.fresh_n "f" in + let body = + let* () = no_event in + let* () = bind_parameters l in + let* _ = add_var f in + Memory.check_function_arity + f + ~cps:false + ~arity + (fun ~typ closure -> + let* l = expression_list load l in + call ?typ ~cps:false ~arity closure l) + (let rec build_applies y l = + match l with + | [] -> + let* y = y in + instr (Push y) + | x :: rem -> + let* x = load x in + build_applies (call ~cps:false ~arity:1 y [ x ]) rem + in + build_applies (load f) l) + in + let param_names = l @ [ f ] in + let locals, body = function_body ~context ~param_names ~body in + W.Function + { name; exported_name = None; typ = func_type arity; param_names; locals; body } + + let cps_apply ~context ~arity ~name = + assert (arity > 2); + let l = + List.rev + (List.init ~len:arity ~f:(fun i -> Code.Var.fresh_n (Printf.sprintf "x%d" i))) + in + let f = Code.Var.fresh_n "f" in + let body = + let* () = no_event in + let* () = bind_parameters l in + let* _ = add_var f in + Memory.check_function_arity + f + ~cps:true + ~arity:(arity - 1) + (fun ~typ closure -> + let* l = expression_list load l in + call ?typ ~cps:true ~arity closure l) + (let* args = + (* We don't need the deadcode sentinal when the tag is 0 *) + Memory.allocate + ~tag:0 + ~deadcode_sentinal:(Code.Var.fresh ()) + (List.map ~f:(fun x -> `Var x) (List.tl l)) + in + let* make_iterator = + register_import ~name:"caml_apply_continuation" (Fun (func_type 0)) + in + let iterate = Var.fresh_n "iterate" in + let* () = store iterate (return (W.Call (make_iterator, [ args ]))) in + let x = List.hd l in + let* x = load x in + let* iterate = load iterate in + push (call ~cps:true ~arity:2 (load f) [ x; iterate ])) + in + let param_names = l @ [ f ] in + let locals, body = function_body ~context ~param_names ~body in + W.Function + { name; exported_name = None; typ = func_type arity; param_names; locals; body } + + let dummy ~context ~cps ~arity ~name = + let arity = if cps then arity + 1 else arity in + let l = + List.rev + (List.init ~len:arity ~f:(fun i -> Code.Var.fresh_n (Printf.sprintf "x%d" i))) + in + let f = Code.Var.fresh_n "f" in + let body = + let* () = no_event in + let* () = bind_parameters l in + let* _ = add_var f in + let* typ, closure = Memory.load_real_closure ~cps ~arity (load f) in + let* l = expression_list load l in + let* e = + call + ~typ:(W.Ref { nullable = false; typ = Type typ }) + ~cps + ~arity + (return closure) + l + in + instr (W.Return (Some e)) + in + let param_names = l @ [ f ] in + let locals, body = function_body ~context ~param_names ~body in + W.Function + { name; exported_name = None; typ = func_type arity; param_names; locals; body } + + let f ~context = + IntMap.iter + (fun arity name -> + let f = apply ~context ~arity ~name in + context.other_fields <- f :: context.other_fields) + context.apply_funs; + IntMap.iter + (fun arity name -> + let f = cps_apply ~context ~arity ~name in + context.other_fields <- f :: context.other_fields) + context.cps_apply_funs; + IntMap.iter + (fun arity name -> + let l = curry ~context ~arity ~name in + context.other_fields <- List.rev_append l context.other_fields) + context.curry_funs; + IntMap.iter + (fun arity name -> + let l = cps_curry ~context ~arity ~name in + context.other_fields <- List.rev_append l context.other_fields) + context.cps_curry_funs; + IntMap.iter + (fun arity name -> + let f = dummy ~context ~cps:false ~arity ~name in + context.other_fields <- f :: context.other_fields) + context.dummy_funs; + IntMap.iter + (fun arity name -> + let f = dummy ~context ~cps:true ~arity ~name in + context.other_fields <- f :: context.other_fields) + context.cps_dummy_funs +end diff --git a/compiler/lib-wasm/curry.mli b/compiler/lib-wasm/curry.mli new file mode 100644 index 0000000000..efb4dc225c --- /dev/null +++ b/compiler/lib-wasm/curry.mli @@ -0,0 +1,21 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +module Make (_ : Target_sig.S) : sig + val f : context:Code_generation.context -> unit +end diff --git a/compiler/lib-wasm/dune b/compiler/lib-wasm/dune new file mode 100644 index 0000000000..2a54c9316f --- /dev/null +++ b/compiler/lib-wasm/dune @@ -0,0 +1,7 @@ +(library + (name wasm_of_ocaml_compiler) + (public_name wasm_of_ocaml-compiler) + (synopsis "Wasm_of_ocaml compiler library") + (libraries js_of_ocaml_compiler) + (flags + (:standard -w -7-37 -safe-string -open Js_of_ocaml_compiler))) diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml new file mode 100644 index 0000000000..f2e6b7eccd --- /dev/null +++ b/compiler/lib-wasm/gc_target.ml @@ -0,0 +1,1726 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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! Stdlib +module W = Wasm_ast +open Code_generation + +type expression = Wasm_ast.expression Code_generation.t + +let include_closure_arity = false + +module Type = struct + let value = W.Ref { nullable = false; typ = Eq } + + let block_type = + register_type "block" (fun () -> + return + { supertype = None + ; final = true + ; typ = W.Array { mut = true; typ = Value value } + }) + + let string_type = + register_type "string" (fun () -> + return + { supertype = None + ; final = true + ; typ = W.Array { mut = true; typ = Packed I8 } + }) + + let float_type = + register_type "float" (fun () -> + return + { supertype = None + ; final = true + ; typ = W.Struct [ { mut = false; typ = Value F64 } ] + }) + + let float_array_type = + register_type "float_array" (fun () -> + return + { supertype = None + ; final = true + ; typ = W.Array { mut = true; typ = Value F64 } + }) + + let js_type = + register_type "js" (fun () -> + return + { supertype = None + ; final = true + ; typ = + W.Struct + [ { mut = false; typ = Value (Ref { nullable = true; typ = Any }) } ] + }) + + let compare_type = + register_type "compare" (fun () -> + return + { supertype = None + ; final = true + ; typ = W.Func { W.params = [ value; value; I32 ]; result = [ I32 ] } + }) + + let hash_type = + register_type "hash" (fun () -> + return + { supertype = None + ; final = true + ; typ = W.Func { W.params = [ value ]; result = [ I32 ] } + }) + + let fixed_length_type = + register_type "fixed_length" (fun () -> + return + { supertype = None + ; final = true + ; typ = + W.Struct + [ { mut = false; typ = Value I32 }; { mut = false; typ = Value I32 } ] + }) + + let serialize_type = + register_type "serialize" (fun () -> + return + { supertype = None + ; final = true + ; typ = W.Func { W.params = [ value; value ]; result = [ I32; I32 ] } + }) + + let deserialize_type = + register_type "deserialize" (fun () -> + return + { supertype = None + ; final = true + ; typ = W.Func { W.params = [ value ]; result = [ value; I32 ] } + }) + + let dup_type = + register_type "dup" (fun () -> + return + { supertype = None + ; final = true + ; typ = W.Func { W.params = [ value ]; result = [ value ] } + }) + + let custom_operations_type = + register_type "custom_operations" (fun () -> + let* string = string_type in + let* compare = compare_type in + let* hash = hash_type in + let* fixed_length = fixed_length_type in + let* serialize = serialize_type in + let* deserialize = deserialize_type in + let* dup = dup_type in + return + { supertype = None + ; final = true + ; typ = + W.Struct + [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type string }) + } + ; { mut = false + ; typ = Value (Ref { nullable = true; typ = Type compare }) + } + ; { mut = false + ; typ = Value (Ref { nullable = true; typ = Type compare }) + } + ; { mut = false; typ = Value (Ref { nullable = true; typ = Type hash }) } + ; { mut = false + ; typ = Value (Ref { nullable = true; typ = Type fixed_length }) + } + ; { mut = false + ; typ = Value (Ref { nullable = true; typ = Type serialize }) + } + ; { mut = false + ; typ = Value (Ref { nullable = true; typ = Type deserialize }) + } + ; { mut = false; typ = Value (Ref { nullable = true; typ = Type dup }) } + ] + }) + + let custom_type = + register_type "custom" (fun () -> + let* custom_operations = custom_operations_type in + return + { supertype = None + ; final = false + ; typ = + W.Struct + [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type custom_operations }) + } + ] + }) + + let int32_type = + register_type "int32" (fun () -> + let* custom_operations = custom_operations_type in + let* custom = custom_type in + return + { supertype = Some custom + ; final = true + ; typ = + W.Struct + [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type custom_operations }) + } + ; { mut = false; typ = Value I32 } + ] + }) + + let int64_type = + register_type "int64" (fun () -> + let* custom_operations = custom_operations_type in + let* custom = custom_type in + return + { supertype = Some custom + ; final = true + ; typ = + W.Struct + [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type custom_operations }) + } + ; { mut = false; typ = Value I64 } + ] + }) + + let func_type n = + { W.params = List.init ~len:(n + 1) ~f:(fun _ -> value); result = [ value ] } + + let function_type ~cps n = + let n = if cps then n + 1 else n in + register_type (Printf.sprintf "function_%d" n) (fun () -> + return { supertype = None; final = true; typ = W.Func (func_type n) }) + + let closure_common_fields ~cps = + let* fun_ty = function_type ~cps 1 in + return + (let function_pointer = + [ { W.mut = false; typ = W.Value (Ref { nullable = false; typ = Type fun_ty }) } + ] + in + if include_closure_arity + then { W.mut = false; typ = W.Value I32 } :: function_pointer + else function_pointer) + + let closure_type_1 ~cps = + register_type + (if cps then "cps_closure" else "closure") + (fun () -> + let* fields = closure_common_fields ~cps in + return { supertype = None; final = false; typ = W.Struct fields }) + + let closure_last_arg_type ~cps = + register_type + (if cps then "cps_closure_last_arg" else "closure_last_arg") + (fun () -> + let* cl_typ = closure_type_1 ~cps in + let* fields = closure_common_fields ~cps in + return { supertype = Some cl_typ; final = false; typ = W.Struct fields }) + + let closure_type ~usage ~cps arity = + if arity = 1 + then + match usage with + | `Alloc -> closure_last_arg_type ~cps + | `Access -> closure_type_1 ~cps + else if arity = 0 + then + register_type + (if cps then "cps_closure_0" else "closure_0") + (fun () -> + let* fun_ty' = function_type ~cps arity in + return + { supertype = None + ; final = false + ; typ = + W.Struct + [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) + } + ] + }) + else + register_type + (if cps + then Printf.sprintf "cps_closure_%d" arity + else Printf.sprintf "closure_%d" arity) + (fun () -> + let* cl_typ = closure_type_1 ~cps in + let* common = closure_common_fields ~cps in + let* fun_ty' = function_type ~cps arity in + return + { supertype = Some cl_typ + ; final = false + ; typ = + W.Struct + (common + @ [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) + } + ]) + }) + + let env_type ~cps ~arity n = + register_type + (if cps + then Printf.sprintf "cps_env_%d_%d" arity n + else Printf.sprintf "env_%d_%d" arity n) + (fun () -> + let* cl_typ = closure_type ~usage:`Alloc ~cps arity in + let* common = closure_common_fields ~cps in + let* fun_ty' = function_type ~cps arity in + return + { supertype = Some cl_typ + ; final = true + ; typ = + W.Struct + ((if arity = 1 + then common + else if arity = 0 + then + [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) + } + ] + else + common + @ [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) + } + ]) + @ List.init + ~f:(fun _ -> + { W.mut = false + ; typ = W.Value (Ref { nullable = false; typ = Eq }) + }) + ~len:n) + }) + + let rec_env_type ~function_count ~free_variable_count = + register_type + (Printf.sprintf "rec_env_%d_%d" function_count free_variable_count) + (fun () -> + return + { supertype = None + ; final = true + ; typ = + W.Struct + (List.init + ~f:(fun i -> + { W.mut = i < function_count + ; typ = W.Value (Ref { nullable = false; typ = Eq }) + }) + ~len:(function_count + free_variable_count)) + }) + + let rec_closure_type ~cps ~arity ~function_count ~free_variable_count = + register_type + (if cps + then + Printf.sprintf + "cps_closure_rec_%d_%d_%d" + arity + function_count + free_variable_count + else Printf.sprintf "closure_rec_%d_%d_%d" arity function_count free_variable_count) + (fun () -> + let* cl_typ = closure_type ~usage:`Alloc ~cps arity in + let* common = closure_common_fields ~cps in + let* fun_ty' = function_type ~cps arity in + let* env_ty = rec_env_type ~function_count ~free_variable_count in + return + { supertype = Some cl_typ + ; final = true + ; typ = + W.Struct + ((if arity = 1 + then common + else + common + @ [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) + } + ]) + @ [ { W.mut = false + ; typ = W.Value (Ref { nullable = false; typ = Type env_ty }) + } + ]) + }) + + let rec curry_type ~cps arity m = + register_type + (if cps + then Printf.sprintf "cps_curry_%d_%d" arity m + else Printf.sprintf "curry_%d_%d" arity m) + (fun () -> + let* cl_typ = closure_type ~usage:(if m = 2 then `Alloc else `Access) ~cps 1 in + let* common = closure_common_fields ~cps in + let* cl_ty = + if m = arity + then closure_type ~usage:`Alloc ~cps arity + else curry_type ~cps arity (m + 1) + in + return + { supertype = Some cl_typ + ; final = true + ; typ = + W.Struct + (common + @ [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type cl_ty }) + } + ; { W.mut = false; typ = Value value } + ]) + }) + + let dummy_closure_type ~cps ~arity = + register_type + (if cps + then Printf.sprintf "cps_dummy_closure_%d" arity + else Printf.sprintf "dummy_closure_%d" arity) + (fun () -> + let* cl_typ = closure_type ~cps ~usage:`Alloc arity in + let* cl_typ' = closure_type ~cps ~usage:`Access arity in + let* common = closure_common_fields ~cps in + let* fun_ty' = function_type ~cps arity in + return + { supertype = Some cl_typ + ; final = true + ; typ = + W.Struct + ((if arity = 1 + then common + else + common + @ [ { mut = false + ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) + } + ]) + @ [ { W.mut = true + ; typ = W.Value (Ref { nullable = true; typ = Type cl_typ' }) + } + ]) + }) +end + +module Value = struct + let value = Type.value + + let block_type = + let* t = Type.block_type in + return (W.Ref { nullable = false; typ = Type t }) + + let dummy_block = + let* t = Type.block_type in + return (W.ArrayNewFixed (t, [])) + + let as_block e = + let* t = Type.block_type in + let* e = e in + return (W.RefCast ({ nullable = false; typ = Type t }, e)) + + let unit = return (W.RefI31 (Const (I32 0l))) + + let val_int = Arith.to_int31 + + let int_val i = Arith.of_int31 (cast I31 i) + + let check_is_not_zero i = + let* i = i in + match i with + | W.LocalGet x -> ( + let* x_opt = get_i31_value x in + match x_opt with + | Some x' -> return (W.LocalGet x') + | None -> return (W.UnOp (I32 Eqz, RefEq (i, W.RefI31 (Const (I32 0l)))))) + | _ -> return (W.UnOp (I32 Eqz, RefEq (i, W.RefI31 (Const (I32 0l))))) + + let check_is_int i = + let* i = i in + return (W.RefTest ({ nullable = false; typ = I31 }, i)) + + let not i = val_int (Arith.eqz (int_val i)) + + let binop op i i' = val_int (op (int_val i) (int_val i')) + + let lt = binop Arith.( < ) + + let le = binop Arith.( <= ) + + let ref_eq i i' = + let* i = i in + let* i' = i' in + return (W.RefEq (i, i')) + + let ref ty = { W.nullable = false; typ = Type ty } + + let ref_test (typ : W.ref_type) e = + let* e = e in + match e with + | W.RefI31 _ -> ( + match typ.typ with + | W.I31 | Eq | Any -> return (W.Const (I32 1l)) + | Type _ | Func | Extern -> return (W.Const (I32 0l))) + | GlobalGet nm -> ( + let* init = get_global nm in + match init with + | Some (W.ArrayNewFixed (t, _) | W.StructNew (t, _)) -> + let* b = heap_type_sub (Type t) typ.typ in + if b then return (W.Const (I32 1l)) else return (W.Const (I32 0l)) + | _ -> return (W.RefTest (typ, e))) + | _ -> return (W.RefTest (typ, e)) + + let caml_js_strict_equals x y = + let* x = x in + let* y = y in + let* f = + register_import + ~name:"caml_js_strict_equals" + ~import_module:"env" + (Fun { params = [ Type.value; Type.value ]; result = [ Type.value ] }) + in + return (W.Call (f, [ x; y ])) + + let rec effect_free e = + match e with + | W.Const _ | LocalGet _ | GlobalGet _ | RefFunc _ | RefNull _ -> true + | UnOp (_, e') + | I32WrapI64 e' + | I64ExtendI32 (_, e') + | F32DemoteF64 e' + | F64PromoteF32 e' + | RefI31 e' + | I31Get (_, e') + | ArrayLen e' + | StructGet (_, _, _, e') + | RefCast (_, e') + | RefTest (_, e') -> effect_free e' + | BinOp (_, e1, e2) + | ArrayNew (_, e1, e2) + | ArrayNewData (_, _, e1, e2) + | ArrayGet (_, _, e1, e2) + | RefEq (e1, e2) -> effect_free e1 && effect_free e2 + | LocalTee _ + | BlockExpr _ + | Call _ + | Seq _ + | Pop _ + | Call_ref _ + | Br_on_cast _ + | Br_on_cast_fail _ + | Try _ -> false + | IfExpr (_, e1, e2, e3) -> effect_free e1 && effect_free e2 && effect_free e3 + | ArrayNewFixed (_, l) | StructNew (_, l) -> List.for_all ~f:effect_free l + + let if_expr ty cond ift iff = + let* cond = cond in + let* ift = ift in + let* iff = iff in + match cond with + | W.Const (I32 n) -> return (if Int32.equal n 0l then iff else ift) + | _ -> + if Poly.equal ift iff && effect_free cond + then return ift + else return (W.IfExpr (ty, cond, ift, iff)) + + let map f x = + let* x = x in + return (f x) + + let ( >>| ) x f = map f x + + let eq_gen ~negate x y = + let xv = Code.Var.fresh () in + let yv = Code.Var.fresh () in + let* js = Type.js_type in + let n = + if_expr + I32 + (* We mimic an "and" on the two conditions, but in a way that is nicer to the + binaryen optimizer. *) + (if_expr + I32 + (ref_test (ref js) (load xv)) + (ref_test (ref js) (load yv)) + (Arith.const 0l)) + (caml_js_strict_equals (load xv) (load yv) + >>| (fun e -> W.RefCast ({ nullable = false; typ = I31 }, e)) + >>| fun e -> W.I31Get (S, e)) + (ref_eq (load xv) (load yv)) + in + seq + (let* () = store xv x in + let* () = store yv y in + return ()) + (val_int (if negate then Arith.eqz n else n)) + + let eq x y = eq_gen ~negate:false x y + + let neq x y = eq_gen ~negate:true x y + + let ult = binop Arith.(ult) + + let is_int i = + let* i = i in + val_int (return (W.RefTest ({ nullable = false; typ = I31 }, i))) + + let int_add = binop Arith.( + ) + + let int_sub = binop Arith.( - ) + + let int_mul = binop Arith.( * ) + + let int_div = binop Arith.( / ) + + let int_mod = binop Arith.( mod ) + + let int_neg i = val_int Arith.(const 0l - int_val i) + + let int_or = binop Arith.( lor ) + + let int_and = binop Arith.( land ) + + let int_xor = binop Arith.( lxor ) + + let int_lsl = binop Arith.( lsl ) + + let int_lsr i i' = val_int Arith.((int_val i land const 0x7fffffffl) lsr int_val i') + + let int_asr = binop Arith.( asr ) +end + +module Memory = struct + let wasm_cast ty e = + let* e = e in + return (W.RefCast ({ nullable = false; typ = Type ty }, e)) + + let wasm_struct_get ty e i = + let* e = e in + match e with + | W.RefCast ({ typ; _ }, GlobalGet nm) -> ( + let* init = get_global nm in + match init with + | Some (W.StructNew (ty', l)) -> + let* b = heap_type_sub (Type ty') typ in + if b + then + let e' = List.nth l i in + let* b = is_small_constant e' in + if b then return e' else return (W.StructGet (None, ty, i, e)) + else return (W.StructGet (None, ty, i, e)) + | _ -> return (W.StructGet (None, ty, i, e))) + | _ -> return (W.StructGet (None, ty, i, e)) + + let wasm_struct_set ty e i e' = + let* e = e in + let* e' = e' in + instr (W.StructSet (ty, i, e, e')) + + let wasm_array_get ?(ty = Type.block_type) e e' = + let* ty = ty in + let* e = wasm_cast ty e in + let* e' = e' in + return (W.ArrayGet (None, ty, e, e')) + + let wasm_array_set ?(ty = Type.block_type) e e' e'' = + let* ty = ty in + let* e = wasm_cast ty e in + let* e' = e' in + let* e'' = e'' in + instr (W.ArraySet (ty, e, e', e'')) + + let box_float e = + let* ty = Type.float_type in + let* e = e in + return (W.StructNew (ty, [ e ])) + + let unbox_float e = + let* ty = Type.float_type in + wasm_struct_get ty (wasm_cast ty e) 0 + + let allocate ~tag ~deadcode_sentinal l = + if tag = 254 + then + let* l = + expression_list + (fun v -> + match v with + | `Var y -> + if Code.Var.equal y deadcode_sentinal + then return (W.Const (F64 0.)) + else unbox_float (load y) + | `Expr e -> unbox_float (return e)) + l + in + let* ty = Type.float_array_type in + return (W.ArrayNewFixed (ty, l)) + else + let* l = + expression_list + (fun v -> + match v with + | `Var y -> load y + | `Expr e -> return e) + l + in + let* ty = Type.block_type in + return (W.ArrayNewFixed (ty, RefI31 (Const (I32 (Int32.of_int tag))) :: l)) + + let tag e = wasm_array_get e (Arith.const 0l) + + let array_length e = + let* block = Type.block_type in + let* e = wasm_cast block e in + Arith.(return (W.ArrayLen e) - const 1l) + + let float_array_length e = + let* float_array = Type.float_array_type in + let* e = wasm_cast float_array e in + return (W.ArrayLen e) + + let gen_array_length e = + let a = Code.Var.fresh_n "a" in + block_expr + { params = []; result = [ I32 ] } + (let* () = store a e in + let* () = + drop + (block_expr + { params = []; result = [ Type.value ] } + (let* block = Type.block_type in + let* a = load a in + let* e = + Arith.( + return + (W.ArrayLen + (W.Br_on_cast_fail + ( 0 + , { nullable = false; typ = Eq } + , { nullable = false; typ = Type block } + , a ))) + - const 1l) + in + instr (Br (1, Some e)))) + in + let* e = float_array_length (load a) in + instr (W.Push e)) + + let array_get e e' = wasm_array_get e Arith.(Value.int_val e' + const 1l) + + let array_set e e' e'' = wasm_array_set e Arith.(Value.int_val e' + const 1l) e'' + + let float_array_get e e' = + box_float (wasm_array_get ~ty:Type.float_array_type e (Value.int_val e')) + + let float_array_set e e' e'' = + wasm_array_set ~ty:Type.float_array_type e (Value.int_val e') (unbox_float e'') + + let gen_array_get e e' = + let a = Code.Var.fresh_n "a" in + let i = Code.Var.fresh_n "i" in + block_expr + { params = []; result = [ Value.value ] } + (let* () = store a e in + let* () = store ~typ:I32 i (Value.int_val e') in + let* () = + drop + (block_expr + { params = []; result = [ Value.value ] } + (let* block = Type.block_type in + let* a = load a in + let* e = + wasm_array_get + (return + (W.Br_on_cast_fail + ( 0 + , { nullable = false; typ = Eq } + , { nullable = false; typ = Type block } + , a ))) + Arith.(load i + const 1l) + in + instr (Br (1, Some e)))) + in + let* e = box_float (wasm_array_get ~ty:Type.float_array_type (load a) (load i)) in + instr (W.Push e)) + + let gen_array_set e e' e'' = + let a = Code.Var.fresh_n "a" in + let i = Code.Var.fresh_n "i" in + let v = Code.Var.fresh_n "v" in + let* () = store a e in + let* () = store ~typ:I32 i (Value.int_val e') in + let* () = store v e'' in + block + { params = []; result = [] } + (let* () = + drop + (block_expr + { params = []; result = [ Value.value ] } + (let* block = Type.block_type in + let* a = load a in + let* () = + wasm_array_set + (return + (W.Br_on_cast_fail + ( 0 + , { nullable = false; typ = Eq } + , { nullable = false; typ = Type block } + , a ))) + Arith.(load i + const 1l) + (load v) + in + instr (Br (1, None)))) + in + wasm_array_set ~ty:Type.float_array_type (load a) (load i) (unbox_float (load v))) + + let bytes_length e = + let* ty = Type.string_type in + let* e = wasm_cast ty e in + return (W.ArrayLen e) + + let bytes_get e e' = + Value.val_int (wasm_array_get ~ty:Type.string_type e (Value.int_val e')) + + let bytes_set e e' e'' = + wasm_array_set ~ty:Type.string_type e (Value.int_val e') (Value.int_val e'') + + let field e idx = wasm_array_get e (Arith.const (Int32.of_int (idx + 1))) + + let set_field e idx e' = wasm_array_set e (Arith.const (Int32.of_int (idx + 1))) e' + + let env_start arity = + if arity = 0 + then 1 + else (if include_closure_arity then 1 else 0) + if arity = 1 then 1 else 2 + + let load_function_pointer ~cps ~arity ?(skip_cast = false) closure = + let arity = if cps then arity - 1 else arity in + let* ty = Type.closure_type ~usage:`Access ~cps arity in + let* fun_ty = Type.function_type ~cps arity in + let casted_closure = if skip_cast then closure else wasm_cast ty closure in + let* e = wasm_struct_get ty casted_closure (env_start arity - 1) in + return (fun_ty, e) + + let load_real_closure ~cps ~arity closure = + let arity = if cps then arity - 1 else arity in + let* ty = Type.dummy_closure_type ~cps ~arity in + let* cl_typ = Type.closure_type ~usage:`Access ~cps arity in + let* e = + wasm_cast cl_typ (wasm_struct_get ty (wasm_cast ty closure) (env_start arity)) + in + return (cl_typ, e) + + let check_function_arity f ~cps ~arity if_match if_mismatch = + let* fun_ty = Type.closure_type ~usage:`Access ~cps arity in + let* closure = load f in + let* () = + drop + (block_expr + { params = []; result = [ Value.value ] } + (let* e = + if_match + ~typ:(Some (W.Ref { nullable = false; typ = Type fun_ty })) + (return + (W.Br_on_cast_fail + ( 0 + , { nullable = false; typ = Eq } + , { nullable = false; typ = Type fun_ty } + , closure ))) + in + instr (W.Return (Some e)))) + in + if_mismatch + + let make_int32 ~kind e = + let* custom_operations = Type.custom_operations_type in + let* int32_ops = + register_import + ~name: + (match kind with + | `Int32 -> "int32_ops" + | `Nativeint -> "nativeint_ops") + (Global + { mut = false; typ = Ref { nullable = false; typ = Type custom_operations } }) + in + let* ty = Type.int32_type in + let* e = e in + return (W.StructNew (ty, [ GlobalGet int32_ops; e ])) + + let box_int32 e = make_int32 ~kind:`Int32 e + + let unbox_int32 e = + let* ty = Type.int32_type in + wasm_struct_get ty (wasm_cast ty e) 1 + + let make_int64 e = + let* custom_operations = Type.custom_operations_type in + let* int64_ops = + register_import + ~name:"int64_ops" + (Global + { mut = false; typ = Ref { nullable = false; typ = Type custom_operations } }) + in + let* ty = Type.int64_type in + let* e = e in + return (W.StructNew (ty, [ GlobalGet int64_ops; e ])) + + let box_int64 e = make_int64 e + + let unbox_int64 e = + let* ty = Type.int64_type in + wasm_struct_get ty (wasm_cast ty e) 1 + + let box_nativeint e = make_int32 ~kind:`Nativeint e + + let unbox_nativeint e = + let* ty = Type.int32_type in + wasm_struct_get ty (wasm_cast ty e) 1 +end + +module Constant = struct + (* dune-build-info use a 64-byte placeholder. This ensures that such + strings are encoded as a sequence of bytes in the wasm module. *) + let string_length_threshold = 64 + + let store_in_global ?(name = "const") c = + let name = Code.Var.fresh_n name in + let* () = register_global name { mut = false; typ = Type.value } c in + return (W.GlobalGet name) + + let str_js_utf8 s = + let b = Buffer.create (String.length s) in + String.iter s ~f:(function + | '\\' -> Buffer.add_string b "\\\\" + | c -> Buffer.add_char b c); + Buffer.contents b + + let str_js_byte s = + let b = Buffer.create (String.length s) in + String.iter s ~f:(function + | '\\' -> Buffer.add_string b "\\\\" + | '\128' .. '\255' as c -> + Buffer.add_string b "\\x"; + Buffer.add_char_hex b c + | c -> Buffer.add_char b c); + Buffer.contents b + + type t = + | Const + | Const_named of string + | Mutated + + let rec translate_rec c = + match c with + | Code.Int i -> return (Const, W.RefI31 (Const (I32 (Targetint.to_int32 i)))) + | Tuple (tag, a, _) -> + let* ty = Type.block_type in + let* l = + Array.fold_left + ~f:(fun prev c -> + let* acc = prev in + let* c = translate_rec c in + return (c :: acc)) + ~init:(return []) + a + in + let l = List.rev l in + let l' = + List.map + ~f:(fun (const, v) -> + match const with + | Const | Const_named _ -> v + | Mutated -> W.RefI31 (Const (I32 0l))) + l + in + let c = W.ArrayNewFixed (ty, RefI31 (Const (I32 (Int32.of_int tag))) :: l') in + if + List.exists + ~f:(fun (const, _) -> + match const with + | Const | Const_named _ -> false + | Mutated -> true) + l + then + let* c = store_in_global c in + let* () = + register_init_code + (snd + (List.fold_left + ~f:(fun (i, before) (const, v) -> + ( i + 1 + , let* () = before in + match const with + | Const | Const_named _ -> return () + | Mutated -> + Memory.wasm_array_set + (return c) + (Arith.const (Int32.of_int i)) + (return v) )) + ~init:(1, return ()) + l)) + in + return (Const, c) + else return (Const, c) + | NativeString s -> + let s = + match s with + | Utf (Utf8 s) -> str_js_utf8 s + | Byte s -> str_js_byte s + in + let* i = register_string s in + let* x = + let* name = unit_name in + register_import + ~import_module: + (match name with + | None -> "strings" + | Some name -> name ^ ".strings") + ~name:(string_of_int i) + (Global { mut = false; typ = Ref { nullable = false; typ = Any } }) + in + let* ty = Type.js_type in + return (Const_named ("str_" ^ s), W.StructNew (ty, [ GlobalGet x ])) + | String s -> + let* ty = Type.string_type in + if String.length s >= string_length_threshold + then + let name = Code.Var.fresh_n "string" in + let* () = register_data_segment name s in + return + ( Mutated + , W.ArrayNewData + (ty, name, Const (I32 0l), Const (I32 (Int32.of_int (String.length s)))) + ) + else + let l = + String.fold_right + ~f:(fun c r -> W.Const (I32 (Int32.of_int (Char.code c))) :: r) + s + ~init:[] + in + return (Const_named ("str_" ^ s), W.ArrayNewFixed (ty, l)) + | Float f -> + let* ty = Type.float_type in + return (Const, W.StructNew (ty, [ Const (F64 f) ])) + | Float_array l -> + let l = Array.to_list l in + let* ty = Type.float_array_type in + (*ZZZ Boxed array? *) + return (Const, W.ArrayNewFixed (ty, List.map ~f:(fun f -> W.Const (F64 f)) l)) + | Int64 i -> + let* e = Memory.make_int64 (return (W.Const (I64 i))) in + return (Const, e) + | Int32 i -> + let* e = Memory.make_int32 ~kind:`Int32 (return (W.Const (I32 i))) in + return (Const, e) + | NativeInt i -> + let* e = Memory.make_int32 ~kind:`Nativeint (return (W.Const (I32 i))) in + return (Const, e) + + let translate c = + let* const, c = translate_rec c in + match const with + | Const -> + let* b = is_small_constant c in + if b then return c else store_in_global c + | Const_named name -> store_in_global ~name c + | Mutated -> + let name = Code.Var.fresh_n "const" in + let* () = + register_global + ~constant:true + name + { mut = true; typ = Type.value } + (W.RefI31 (Const (I32 0l))) + in + let* () = register_init_code (instr (W.GlobalSet (name, c))) in + return (W.GlobalGet name) +end + +module Closure = struct + let get_free_variables ~context info = + List.filter + ~f:(fun x -> not (Hashtbl.mem context.constants x)) + info.Closure_conversion.free_variables + + let rec is_last_fun l f = + match l with + | [] -> false + | [ (g, _) ] -> Code.Var.equal f g + | _ :: r -> is_last_fun r f + + let translate ~context ~closures ~cps f = + let info = Code.Var.Map.find f closures in + let free_variables = get_free_variables ~context info in + assert ( + not + (List.exists + ~f:(fun x -> Code.Var.Set.mem x context.globalized_variables) + free_variables)); + let arity = List.assoc f info.functions in + let arity = if cps then arity - 1 else arity in + let* curry_fun = if arity > 1 then need_curry_fun ~cps ~arity else return f in + if List.is_empty free_variables + then + let* typ = Type.closure_type ~usage:`Alloc ~cps arity in + let name = Code.Var.fork f in + let* () = + register_global + name + { mut = false; typ = Type.value } + (W.StructNew + ( typ + , if arity = 0 + then [ W.RefFunc f ] + else + let code_pointers = + if arity = 1 then [ W.RefFunc f ] else [ RefFunc curry_fun; RefFunc f ] + in + if include_closure_arity + then Const (I32 (Int32.of_int arity)) :: code_pointers + else code_pointers )) + in + return (W.GlobalGet name) + else + let free_variable_count = List.length free_variables in + match info.Closure_conversion.functions with + | [] -> assert false + | [ _ ] -> + let* typ = Type.env_type ~cps ~arity free_variable_count in + let* l = expression_list load free_variables in + return + (W.StructNew + ( typ + , (if arity = 0 + then [ W.RefFunc f ] + else + let code_pointers = + if arity = 1 + then [ W.RefFunc f ] + else [ RefFunc curry_fun; RefFunc f ] + in + if include_closure_arity + then W.Const (I32 (Int32.of_int arity)) :: code_pointers + else code_pointers) + @ l )) + | (g, _) :: _ as functions -> + let function_count = List.length functions in + let* env_typ = Type.rec_env_type ~function_count ~free_variable_count in + let env = + if Code.Var.equal f g + then + let env = Code.Var.fresh () in + let* () = set_closure_env f env in + let* l = expression_list load free_variables in + tee + ~typ:(W.Ref { nullable = false; typ = Type env_typ }) + env + (return + (W.StructNew + ( env_typ + , List.init ~len:function_count ~f:(fun _ -> + W.RefI31 (W.Const (I32 0l))) + @ l ))) + else + let* env = get_closure_env g in + let* () = set_closure_env f env in + load env + in + let* typ = + Type.rec_closure_type ~cps ~arity ~function_count ~free_variable_count + in + let res = + let* env = env in + return + (W.StructNew + ( typ + , (let code_pointers = + if arity = 1 + then [ W.RefFunc f ] + else [ RefFunc curry_fun; RefFunc f ] + in + if include_closure_arity + then W.Const (I32 (Int32.of_int arity)) :: code_pointers + else code_pointers) + @ [ env ] )) + in + if is_last_fun functions f + then + seq + (snd + (List.fold_left + ~f:(fun (i, prev) (g, _) -> + ( i + 1 + , let* () = prev in + Memory.wasm_struct_set + env_typ + env + i + (if Code.Var.equal f g then tee f res else load g) )) + ~init:(0, return ()) + functions)) + (load f) + else res + + let bind_environment ~context ~closures ~cps f = + let info = Code.Var.Map.find f closures in + let free_variables = get_free_variables ~context info in + let free_variable_count = List.length free_variables in + if free_variable_count = 0 + then + (* The closures are all constants and the environment is empty. *) + let* _ = add_var (Code.Var.fresh ()) in + return () + else + let arity = List.assoc f info.functions in + let arity = if cps then arity - 1 else arity in + let offset = Memory.env_start arity in + match info.Closure_conversion.functions with + | [ _ ] -> + let* typ = Type.env_type ~cps ~arity free_variable_count in + let* _ = add_var f in + let env = Code.Var.fresh_n "env" in + let* () = + store + ~typ:(W.Ref { nullable = false; typ = Type typ }) + env + Memory.(wasm_cast typ (load f)) + in + snd + (List.fold_left + ~f:(fun (i, prev) x -> + ( i + 1 + , let* () = prev in + define_var x Memory.(wasm_struct_get typ (load env) i) )) + ~init:(offset, return ()) + free_variables) + | functions -> + let function_count = List.length functions in + let* typ = + Type.rec_closure_type ~cps ~arity ~function_count ~free_variable_count + in + let* _ = add_var f in + let env = Code.Var.fresh_n "env" in + let* env_typ = Type.rec_env_type ~function_count ~free_variable_count in + let* () = + store + ~typ:(W.Ref { nullable = false; typ = Type env_typ }) + env + Memory.(wasm_struct_get typ (wasm_cast typ (load f)) offset) + in + snd + (List.fold_left + ~f:(fun (i, prev) x -> + ( i + 1 + , let* () = prev in + define_var x Memory.(wasm_struct_get env_typ (load env) i) )) + ~init:(0, return ()) + (List.map ~f:fst functions @ free_variables)) + + let curry_allocate ~cps ~arity m ~f ~closure ~arg = + let* ty = Type.curry_type ~cps arity m in + let* cl_ty = + if m = arity + then Type.closure_type ~usage:`Alloc ~cps arity + else Type.curry_type ~cps arity (m + 1) + in + let* closure = Memory.wasm_cast cl_ty (load closure) in + let* arg = load arg in + let closure_contents = [ W.RefFunc f; closure; arg ] in + return + (W.StructNew + ( ty + , if include_closure_arity + then Const (I32 1l) :: closure_contents + else closure_contents )) + + let curry_load ~cps ~arity m closure = + let m = m + 1 in + let* ty = Type.curry_type ~cps arity m in + let* cl_ty = + if m = arity + then Type.closure_type ~usage:`Alloc ~cps arity + else Type.curry_type ~cps arity (m + 1) + in + let cast e = if m = 2 then Memory.wasm_cast ty e else e in + let offset = Memory.env_start 1 in + return + ( Memory.wasm_struct_get ty (cast (load closure)) (offset + 1) + , Memory.wasm_struct_get ty (cast (load closure)) offset + , Some (W.Ref { nullable = false; typ = Type cl_ty }) ) + + let dummy ~cps ~arity = + (* The runtime only handle function with arity up to 4 + (1 for CPS functions) *) + let arity = if cps then 1 else if arity > 4 then 1 else arity in + let* dummy_fun = need_dummy_fun ~cps ~arity in + let* ty = Type.dummy_closure_type ~cps ~arity in + let* curry_fun = if arity > 1 then need_curry_fun ~cps ~arity else return dummy_fun in + let* cl_typ = Type.closure_type ~usage:`Alloc ~cps arity in + let closure_contents = + if arity = 1 + then [ W.RefFunc dummy_fun; RefNull (Type cl_typ) ] + else [ RefFunc curry_fun; RefFunc dummy_fun; RefNull (Type cl_typ) ] + in + return + (W.StructNew + ( ty + , if include_closure_arity + then Const (I32 1l) :: closure_contents + else closure_contents )) +end + +module Math = struct + let float_func_type n = + { W.params = List.init ~len:n ~f:(fun _ : W.value_type -> F64); result = [ F64 ] } + + let unary name x = + let* f = register_import ~import_module:"Math" ~name (Fun (float_func_type 1)) in + let* x = x in + return (W.Call (f, [ x ])) + + let cos f = unary "cos" f + + let sin f = unary "sin" f + + let tan f = unary "tan" f + + let acos f = unary "acos" f + + let asin f = unary "asin" f + + let atan f = unary "atan" f + + let cosh f = unary "cosh" f + + let sinh f = unary "sinh" f + + let tanh f = unary "tanh" f + + let acosh f = unary "acosh" f + + let asinh f = unary "asinh" f + + let atanh f = unary "atanh" f + + let cbrt f = unary "cbrt" f + + let exp f = unary "exp" f + + let expm1 f = unary "expm1" f + + let log f = unary "log" f + + let log1p f = unary "log1p" f + + let log2 f = unary "log2" f + + let log10 f = unary "log10" f + + let binary name x y = + let* f = register_import ~import_module:"Math" ~name (Fun (float_func_type 2)) in + let* x = x in + let* y = y in + return (W.Call (f, [ x; y ])) + + let atan2 f g = binary "atan2" f g + + let hypot f g = binary "hypot" f g + + let power f g = binary "pow" f g + + let fmod f g = binary "fmod" f g + + let round x = + let* f = register_import ~name:"caml_round" (Fun (float_func_type 1)) in + let* x = x in + return (W.Call (f, [ x ])) + + let exp2 x = power (return (W.Const (F64 2.))) x +end + +module JavaScript = struct + let anyref = W.Ref { nullable = true; typ = Any } + + let invoke_fragment name args = + let* f = + let* unit = unit_name in + register_import + ~import_module: + (match unit with + | None -> "fragments" + | Some unit -> unit ^ ".fragments") + ~name + (Fun { params = List.map ~f:(fun _ -> anyref) args; result = [ anyref ] }) + in + let* wrap = + register_import ~name:"wrap" (Fun { params = [ anyref ]; result = [ Type.value ] }) + in + let* unwrap = + register_import + ~name:"unwrap" + (Fun { params = [ Type.value ]; result = [ anyref ] }) + in + let* args = + expression_list + (fun e -> + let* e = e in + return (W.Call (unwrap, [ e ]))) + args + in + return (W.Call (wrap, [ Call (f, args) ])) +end + +let internal_primitives = Hashtbl.create 100 + +let () = + let register name f = Hashtbl.add internal_primitives name f in + let module J = Javascript in + let call_prim ~transl_prim_arg name args = + let arity = List.length args in + (* [Type.func_type] counts one additional argument for the closure environment (absent + here) *) + let* f = register_import ~name (Fun (Type.func_type (arity - 1))) in + let args = List.map ~f:transl_prim_arg args in + let* args = expression_list Fun.id args in + return (W.Call (f, args)) + in + let register_js_expr prim_name = + register prim_name (fun transl_prim_arg l -> + let* wrap = + register_import + ~name:"wrap" + (Fun { params = [ JavaScript.anyref ]; result = [ Value.value ] }) + in + match l with + | Code.[ Pc (String str) ] -> ( + try + let lex = Parse_js.Lexer.of_string str in + let e = Parse_js.parse_expr lex in + let name = Printf.sprintf "js_expr_%x" (String.hash str) in + let* () = + register_fragment name (fun () -> + EArrow + (J.fun_ [] [ Return_statement (Some e, N), N ] N, true, AUnknown)) + in + let* js_val = JavaScript.invoke_fragment name [] in + return (W.Call (wrap, [ js_val ])) + with Parse_js.Parsing_error pi -> + failwith + (Printf.sprintf + "Parse error in argument of %s %S at position %d:%d" + prim_name + str + pi.Parse_info.line + pi.Parse_info.col)) + | [ Pv _ ] -> + let* () = + register_fragment "eval" (fun () -> + let lex = Parse_js.Lexer.of_string {|(x)=>eval("("+x+")")|} in + Parse_js.parse_expr lex) + in + JavaScript.invoke_fragment + "eval" + [ call_prim ~transl_prim_arg "caml_jsstring_of_string" l ] + | [] | _ :: _ -> + failwith (Printf.sprintf "Wrong number argument to primitive %s" prim_name)) + in + List.iter + ~f:register_js_expr + [ "caml_js_expr"; "caml_pure_js_expr"; "caml_js_var"; "caml_js_eval_string" ]; + register "%caml_js_opt_call" (fun transl_prim_arg l -> + let arity = List.length l - 2 in + let name = Printf.sprintf "call_%d" arity in + let* () = + register_fragment name (fun () -> + let f = Utf8_string.of_string_exn "f" in + let o = Utf8_string.of_string_exn "o" in + let params = + List.init ~len:arity ~f:(fun i -> + Utf8_string.of_string_exn (Printf.sprintf "x%d" i)) + in + EArrow + ( J.fun_ + (List.map ~f:J.ident (f :: o :: params)) + [ ( Return_statement + ( Some + (J.call + (J.dot + (EVar (J.ident f)) + (Utf8_string.of_string_exn "call")) + (List.map ~f:(fun x -> J.EVar (J.ident x)) (o :: params)) + N) + , N ) + , N ) + ] + N + , true + , AUnknown )) + in + let l = List.map ~f:transl_prim_arg l in + JavaScript.invoke_fragment name l); + register "%caml_js_opt_fun_call" (fun transl_prim_arg l -> + let arity = List.length l - 1 in + let name = Printf.sprintf "fun_call_%d" arity in + let* () = + register_fragment name (fun () -> + let f = Utf8_string.of_string_exn "f" in + let params = + List.init ~len:arity ~f:(fun i -> + Utf8_string.of_string_exn (Printf.sprintf "x%d" i)) + in + EArrow + ( J.fun_ + (List.map ~f:J.ident (f :: params)) + [ ( Return_statement + ( Some + (J.call + (EVar (J.ident f)) + (List.map ~f:(fun x -> J.EVar (J.ident x)) params) + N) + , N ) + , N ) + ] + N + , true + , AUnknown )) + in + let l = List.map ~f:transl_prim_arg l in + JavaScript.invoke_fragment name l); + register "%caml_js_opt_meth_call" (fun transl_prim_arg l -> + match l with + | o :: Code.Pc (NativeString (Utf meth)) :: args -> + let arity = List.length args in + let name = + let (Utf8 name) = meth in + Printf.sprintf "meth_call_%d_%s" arity name + in + let* () = + register_fragment name (fun () -> + let o = Utf8_string.of_string_exn "o" in + let params = + List.init ~len:arity ~f:(fun i -> + Utf8_string.of_string_exn (Printf.sprintf "x%d" i)) + in + EArrow + ( J.fun_ + (List.map ~f:J.ident (o :: params)) + [ ( Return_statement + ( Some + (J.call + (J.dot (EVar (J.ident o)) meth) + (List.map ~f:(fun x -> J.EVar (J.ident x)) params) + N) + , N ) + , N ) + ] + N + , true + , AUnknown )) + in + let o = transl_prim_arg o in + let args = List.map ~f:transl_prim_arg args in + JavaScript.invoke_fragment name (o :: args) + | _ -> assert false); + register "%caml_js_opt_new" (fun transl_prim_arg l -> + let arity = List.length l - 1 in + let name = Printf.sprintf "new_%d" arity in + let* () = + register_fragment name (fun () -> + let c = Utf8_string.of_string_exn "c" in + let params = + List.init ~len:arity ~f:(fun i -> + Utf8_string.of_string_exn (Printf.sprintf "x%d" i)) + in + EArrow + ( J.fun_ + (List.map ~f:J.ident (c :: params)) + [ ( Return_statement + ( Some + (ENew + ( EVar (J.ident c) + , Some + (List.map + ~f:(fun x -> J.Arg (EVar (J.ident x))) + params) + , N )) + , N ) + , N ) + ] + N + , true + , AUnknown )) + in + let l = List.map ~f:transl_prim_arg l in + JavaScript.invoke_fragment name l); + register "caml_js_get" (fun transl_prim_arg l -> + match l with + | [ x; Code.Pc (NativeString (Utf prop)) ] when J.is_ident' prop -> + let name = + let (Utf8 name) = prop in + Printf.sprintf "get_%s" name + in + let* () = + register_fragment name (fun () -> + let o = Utf8_string.of_string_exn "o" in + EArrow + ( J.fun_ + [ J.ident o ] + [ Return_statement (Some (J.dot (EVar (J.ident o)) prop), N), N ] + N + , true + , AUnknown )) + in + JavaScript.invoke_fragment name [ transl_prim_arg x ] + | [ _; _ ] -> call_prim ~transl_prim_arg "caml_js_get" l + | _ -> assert false); + register "caml_js_set" (fun transl_prim_arg l -> + match l with + | [ x; Code.Pc (NativeString (Utf prop)); y ] when J.is_ident' prop -> + let name = + let (Utf8 name) = prop in + Printf.sprintf "set_%s" name + in + let* () = + register_fragment name (fun () -> + let o = Utf8_string.of_string_exn "o" in + let v = Utf8_string.of_string_exn "v" in + EArrow + ( J.fun_ + [ J.ident o; J.ident v ] + [ ( Return_statement + ( Some + (J.EBin + (J.Eq, J.dot (EVar (J.ident o)) prop, EVar (J.ident v))) + , N ) + , N ) + ] + N + , true + , AUnknown )) + in + let l = List.map ~f:transl_prim_arg [ x; y ] in + JavaScript.invoke_fragment name l + | [ _; _; _ ] -> call_prim ~transl_prim_arg "caml_js_set" l + | _ -> assert false); + let counter = ref (-1) in + register "%caml_js_opt_object" (fun transl_prim_arg l -> + let rec split kl vl l = + match l with + | [] -> List.rev kl, List.rev vl + | Code.Pc (NativeString (Utf k)) :: v :: r -> split (k :: kl) (v :: vl) r + | _ -> assert false + in + let kl, vl = split [] [] l in + let name = + incr counter; + Printf.sprintf "obj_%d" !counter + in + let* () = + register_fragment name (fun () -> + let arity = List.length kl in + let params = + List.init ~len:arity ~f:(fun i -> + Utf8_string.of_string_exn (Printf.sprintf "x%d" i)) + in + EArrow + ( J.fun_ + (List.map ~f:J.ident params) + [ ( Return_statement + ( Some + (EObj + (List.map2 + ~f:(fun k x -> + J.Property + ( (if J.is_ident' k then J.PNI k else J.PNS k) + , EVar (J.ident x) )) + kl + params)) + , N ) + , N ) + ] + N + , true + , AUnknown )) + in + let l = List.map ~f:transl_prim_arg vl in + JavaScript.invoke_fragment name l) + +let externref = W.Ref { nullable = true; typ = Extern } + +let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler = + let* js_tag = register_import ~name:"javascript_exception" (Tag externref) in + let* ocaml_tag = register_import ~name:"ocaml_exception" (Tag Value.value) in + let* f = + register_import + ~name:"caml_wrap_exception" + (Fun { params = [ externref ]; result = [ Value.value ] }) + in + block + { params = []; result = result_typ } + (let* () = + store + x + (block_expr + { params = []; result = [ Value.value ] } + (let* exn = + block_expr + { params = []; result = [ externref ] } + (let* e = + try_expr + { params = []; result = [ externref ] } + (body + ~result_typ:[ externref ] + ~fall_through:`Skip + ~context:(`Skip :: `Skip :: `Catch :: context)) + [ ocaml_tag, 1, Value.value; js_tag, 0, externref ] + in + instr (W.Push e)) + in + instr (W.CallInstr (f, [ exn ])))) + in + let* () = no_event in + exn_handler ~result_typ ~fall_through ~context) + +let post_process_function_body = Initialize_locals.f + +let entry_point ~toplevel_fun = + let code = + let* () = + if Config.Flag.effects () + then + let* f = + register_import + ~name:"caml_cps_initialize_effects" + (Fun { W.params = []; result = [] }) + in + instr (W.CallInstr (f, [])) + else return () + in + let* main = + register_import + ~name:"caml_main" + (Fun { params = [ W.Ref { nullable = false; typ = Func } ]; result = [] }) + in + instr (W.CallInstr (main, [ RefFunc toplevel_fun ])) + in + { W.params = []; result = [] }, [], code diff --git a/compiler/lib-wasm/gc_target.mli b/compiler/lib-wasm/gc_target.mli new file mode 100644 index 0000000000..fdb5b9cd29 --- /dev/null +++ b/compiler/lib-wasm/gc_target.mli @@ -0,0 +1,19 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +include Target_sig.S diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml new file mode 100644 index 0000000000..d5e590dff2 --- /dev/null +++ b/compiler/lib-wasm/generate.ml @@ -0,0 +1,1245 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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! Stdlib +open Code +module W = Wasm_ast +open Code_generation + +module Generate (Target : Target_sig.S) = struct + open Target + + let transl_prim_arg x = + match x with + | Pv x -> load x + | Pc c -> Constant.translate c + + type ctx = + { live : int array + ; in_cps : Effects.in_cps + ; deadcode_sentinal : Var.t + ; blocks : block Addr.Map.t + ; closures : Closure_conversion.closure Var.Map.t + ; global_context : Code_generation.context + ; debug : Parse_bytecode.Debug.t + } + + type repr = + | Value + | Float + | Int32 + | Nativeint + | Int64 + + let repr_type r = + match r with + | Value -> Value.value + | Float -> F64 + | Int32 -> I32 + | Nativeint -> I32 + | Int64 -> I64 + + let specialized_func_type (params, result) = + { W.params = List.map ~f:repr_type params; result = [ repr_type result ] } + + let box_value r e = + match r with + | Value -> e + | Float -> Memory.box_float e + | Int32 -> Memory.box_int32 e + | Nativeint -> Memory.box_nativeint e + | Int64 -> Memory.box_int64 e + + let unbox_value r e = + match r with + | Value -> e + | Float -> Memory.unbox_float e + | Int32 -> Memory.unbox_int32 e + | Nativeint -> Memory.unbox_nativeint e + | Int64 -> Memory.unbox_int64 e + + let specialized_primitives = + let h = Hashtbl.create 18 in + List.iter + ~f:(fun (nm, typ) -> Hashtbl.add h nm typ) + [ "caml_int32_bswap", ([ Int32 ], Int32) + ; "caml_nativeint_bswap", ([ Nativeint ], Nativeint) + ; "caml_int64_bswap", ([ Int64 ], Int64) + ; "caml_int32_compare", ([ Int32; Int32 ], Value) + ; "caml_nativeint_compare", ([ Nativeint; Nativeint ], Value) + ; "caml_int64_compare", ([ Int64; Int64 ], Value) + ; "caml_string_get32", ([ Value; Value ], Int32) + ; "caml_string_get64", ([ Value; Value ], Int64) + ; "caml_bytes_get32", ([ Value; Value ], Int32) + ; "caml_bytes_get64", ([ Value; Value ], Int64) + ; "caml_bytes_set32", ([ Value; Value; Int32 ], Value) + ; "caml_bytes_set64", ([ Value; Value; Int64 ], Value) + ; "caml_lxm_next", ([ Value ], Int64) + ; "caml_ba_uint8_get32", ([ Value; Value ], Int32) + ; "caml_ba_uint8_get64", ([ Value; Value ], Int64) + ; "caml_ba_uint8_set32", ([ Value; Value; Int32 ], Value) + ; "caml_ba_uint8_set64", ([ Value; Value; Int64 ], Value) + ; "caml_nextafter_float", ([ Float; Float ], Float) + ; "caml_classify_float", ([ Float ], Value) + ; "caml_ldexp_float", ([ Float; Value ], Float) + ; "caml_signbit_float", ([ Float ], Value) + ; "caml_erf_float", ([ Float ], Float) + ; "caml_erfc_float", ([ Float ], Float) + ; "caml_float_compare", ([ Float; Float ], Value) + ]; + h + + let func_type n = + { W.params = List.init ~len:n ~f:(fun _ -> Value.value); result = [ Value.value ] } + + let float_bin_op' op f g = + Memory.box_float (op (Memory.unbox_float f) (Memory.unbox_float g)) + + let float_bin_op op f g = + let* f = Memory.unbox_float f in + let* g = Memory.unbox_float g in + Memory.box_float (return (W.BinOp (F64 op, f, g))) + + let float_un_op' op f = Memory.box_float (op (Memory.unbox_float f)) + + let float_un_op op f = + let* f = Memory.unbox_float f in + Memory.box_float (return (W.UnOp (F64 op, f))) + + let float_comparison op f g = + let* f = Memory.unbox_float f in + let* g = Memory.unbox_float g in + Value.val_int (return (W.BinOp (F64 op, f, g))) + + let int32_bin_op op f g = + let* f = Memory.unbox_int32 f in + let* g = Memory.unbox_int32 g in + Memory.box_int32 (return (W.BinOp (I32 op, f, g))) + + let int32_shift_op op f g = + let* f = Memory.unbox_int32 f in + let* g = Value.int_val g in + Memory.box_int32 (return (W.BinOp (I32 op, f, g))) + + let int64_bin_op op f g = + let* f = Memory.unbox_int64 f in + let* g = Memory.unbox_int64 g in + Memory.box_int64 (return (W.BinOp (I64 op, f, g))) + + let int64_shift_op op f g = + let* f = Memory.unbox_int64 f in + let* g = Value.int_val g in + Memory.box_int64 (return (W.BinOp (I64 op, f, I64ExtendI32 (S, g)))) + + let nativeint_bin_op op f g = + let* f = Memory.unbox_nativeint f in + let* g = Memory.unbox_nativeint g in + Memory.box_nativeint (return (W.BinOp (I32 op, f, g))) + + let nativeint_shift_op op f g = + let* f = Memory.unbox_nativeint f in + let* g = Value.int_val g in + Memory.box_nativeint (return (W.BinOp (I32 op, f, g))) + + let label_index context pc = + let rec index_rec context pc i = + match context with + | `Block pc' :: _ when pc = pc' -> i + | (`Block _ | `Skip | `Catch) :: rem -> index_rec rem pc (i + 1) + | [] -> assert false + in + index_rec context pc 0 + + let catch_index context = + let rec index_rec context i = + match context with + | `Catch :: _ -> Some i + | (`Block _ | `Skip | `Return) :: rem -> index_rec rem (i + 1) + | [] -> None + in + index_rec context 0 + + let bound_error_pc = -1 + + let zero_divide_pc = -2 + + let rec translate_expr ctx context x e = + match e with + | Apply { f; args; exact } + when exact || List.length args = if Var.Set.mem x ctx.in_cps then 2 else 1 -> + let rec loop acc l = + match l with + | [] -> ( + let arity = List.length args in + let funct = Var.fresh () in + let* closure = tee funct (load f) in + let* ty, funct = + Memory.load_function_pointer + ~cps:(Var.Set.mem x ctx.in_cps) + ~arity + (load funct) + in + let* b = is_closure f in + if b + then return (W.Call (f, List.rev (closure :: acc))) + else + match funct with + | W.RefFunc g -> + (* Functions with constant closures ignore their + environment. In case of partial application, we + still need the closure. *) + let* cl = if exact then Value.unit else return closure in + return (W.Call (g, List.rev (cl :: acc))) + | _ -> return (W.Call_ref (ty, funct, List.rev (closure :: acc)))) + | x :: r -> + let* x = load x in + loop (x :: acc) r + in + loop [] args + | Apply { f; args; _ } -> + let* apply = + need_apply_fun ~cps:(Var.Set.mem x ctx.in_cps) ~arity:(List.length args) + in + let* args = expression_list load args in + let* closure = load f in + return (W.Call (apply, args @ [ closure ])) + | Block (tag, a, _, _) -> + Memory.allocate + ~deadcode_sentinal:ctx.deadcode_sentinal + ~tag + (List.map ~f:(fun x -> `Var x) (Array.to_list a)) + | Field (x, n, Non_float) -> Memory.field (load x) n + | Field (x, n, Float) -> + Memory.float_array_get + (load x) + (Constant.translate (Int (Targetint.of_int_warning_on_overflow n))) + | Closure _ -> + Closure.translate + ~context:ctx.global_context + ~closures:ctx.closures + ~cps:(Var.Set.mem x ctx.in_cps) + x + | Constant c -> Constant.translate c + | Special (Alias_prim _) -> assert false + | Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int arity) ]) -> + Closure.dummy ~cps:(Config.Flag.effects ()) ~arity:(Targetint.to_int_exn arity) + | Prim (Extern "caml_alloc_dummy_infix", _) -> + Closure.dummy ~cps:(Config.Flag.effects ()) ~arity:1 + | Prim (Extern "caml_get_global", [ Pc (String name) ]) -> + let* x = + let* context = get_context in + match + List.find_map + ~f:(fun f -> + match f with + | W.Global { name = name'; exported_name = Some exported_name; _ } + when String.equal exported_name name -> Some name' + | _ -> None) + context.other_fields + with + | Some x -> return x + | _ -> + let* typ = Value.block_type in + register_import ~import_module:"OCaml" ~name (Global { mut = true; typ }) + in + return (W.GlobalGet x) + | Prim (Extern "caml_set_global", [ Pc (String name); v ]) -> + let v = transl_prim_arg v in + let x = Var.fresh_n name in + let* () = + let* typ = Value.block_type in + let* dummy = Value.dummy_block in + register_global x ~exported_name:name { mut = true; typ } dummy + in + seq + (let* v = Value.as_block v in + instr (W.GlobalSet (x, v))) + Value.unit + | Prim (p, l) -> ( + match p with + | Extern name when Hashtbl.mem internal_primitives name -> + Hashtbl.find internal_primitives name transl_prim_arg l + | _ -> ( + let l = List.map ~f:transl_prim_arg l in + match p, l with + | Extern "caml_array_unsafe_get", [ x; y ] -> Memory.gen_array_get x y + | Extern "caml_floatarray_unsafe_get", [ x; y ] -> Memory.float_array_get x y + | Extern "caml_array_unsafe_set", [ x; y; z ] -> + seq (Memory.gen_array_set x y z) Value.unit + | Extern "caml_array_unsafe_set_addr", [ x; y; z ] -> + seq (Memory.array_set x y z) Value.unit + | Extern "caml_floatarray_unsafe_set", [ x; y; z ] -> + seq (Memory.float_array_set x y z) Value.unit + | Extern ("caml_string_unsafe_get" | "caml_bytes_unsafe_get"), [ x; y ] -> + Memory.bytes_get x y + | Extern ("caml_string_unsafe_set" | "caml_bytes_unsafe_set"), [ x; y; z ] -> + seq (Memory.bytes_set x y z) Value.unit + | Extern ("caml_string_get" | "caml_bytes_get"), [ x; y ] -> + seq + (let* cond = Arith.uge (Value.int_val y) (Memory.bytes_length x) in + instr (W.Br_if (label_index context bound_error_pc, cond))) + (Memory.bytes_get x y) + | Extern ("caml_string_set" | "caml_bytes_set"), [ x; y; z ] -> + seq + (let* cond = Arith.uge (Value.int_val y) (Memory.bytes_length x) in + let* () = instr (W.Br_if (label_index context bound_error_pc, cond)) in + Memory.bytes_set x y z) + Value.unit + | Extern ("caml_ml_string_length" | "caml_ml_bytes_length"), [ x ] -> + Value.val_int (Memory.bytes_length x) + | Extern "%int_add", [ x; y ] -> Value.int_add x y + | Extern "%int_sub", [ x; y ] -> Value.int_sub x y + | Extern ("%int_mul" | "%direct_int_mul"), [ x; y ] -> Value.int_mul x y + | Extern "%direct_int_div", [ x; y ] -> Value.int_div x y + | Extern "%int_div", [ x; y ] -> + seq + (let* cond = Arith.eqz (Value.int_val y) in + instr (W.Br_if (label_index context zero_divide_pc, cond))) + (Value.int_div x y) + | Extern "%int_mod", [ x; y ] -> + seq + (let* cond = Arith.eqz (Value.int_val y) in + instr (W.Br_if (label_index context zero_divide_pc, cond))) + (Value.int_mod x y) + | Extern "%direct_int_mod", [ x; y ] -> Value.int_mod x y + | Extern "%int_neg", [ x ] -> Value.int_neg x + | Extern "%int_or", [ x; y ] -> Value.int_or x y + | Extern "%int_and", [ x; y ] -> Value.int_and x y + | Extern "%int_xor", [ x; y ] -> Value.int_xor x y + | Extern "%int_lsl", [ x; y ] -> Value.int_lsl x y + | Extern "%int_lsr", [ x; y ] -> Value.int_lsr x y + | Extern "%int_asr", [ x; y ] -> Value.int_asr x y + | Extern "%direct_obj_tag", [ x ] -> Memory.tag x + | Extern "caml_check_bound", [ x; y ] -> + seq + (let* cond = Arith.uge (Value.int_val y) (Memory.array_length x) in + instr (W.Br_if (label_index context bound_error_pc, cond))) + x + | Extern "caml_check_bound_gen", [ x; y ] -> + seq + (let* cond = Arith.uge (Value.int_val y) (Memory.gen_array_length x) in + instr (W.Br_if (label_index context bound_error_pc, cond))) + x + | Extern "caml_check_bound_float", [ x; y ] -> + seq + (let* cond = + Arith.uge (Value.int_val y) (Memory.float_array_length x) + in + instr (W.Br_if (label_index context bound_error_pc, cond))) + x + | Extern "caml_add_float", [ f; g ] -> float_bin_op Add f g + | Extern "caml_sub_float", [ f; g ] -> float_bin_op Sub f g + | Extern "caml_mul_float", [ f; g ] -> float_bin_op Mul f g + | Extern "caml_div_float", [ f; g ] -> float_bin_op Div f g + | Extern "caml_copysign_float", [ f; g ] -> float_bin_op CopySign f g + | Extern "caml_signbit_float", [ f ] -> + let* f = Memory.unbox_float f in + let sign = W.BinOp (F64 CopySign, Const (F64 1.), f) in + Value.val_int (return (W.BinOp (F64 Lt, sign, Const (F64 0.)))) + | Extern "caml_neg_float", [ f ] -> float_un_op Neg f + | Extern "caml_abs_float", [ f ] -> float_un_op Abs f + | Extern "caml_ceil_float", [ f ] -> float_un_op Ceil f + | Extern "caml_floor_float", [ f ] -> float_un_op Floor f + | Extern "caml_trunc_float", [ f ] -> float_un_op Trunc f + | Extern "caml_round_float", [ f ] -> float_un_op' Math.round f + | Extern "caml_sqrt_float", [ f ] -> float_un_op Sqrt f + | Extern "caml_eq_float", [ f; g ] -> float_comparison Eq f g + | Extern "caml_neq_float", [ f; g ] -> float_comparison Ne f g + | Extern "caml_ge_float", [ f; g ] -> float_comparison Ge f g + | Extern "caml_le_float", [ f; g ] -> float_comparison Le f g + | Extern "caml_gt_float", [ f; g ] -> float_comparison Gt f g + | Extern "caml_lt_float", [ f; g ] -> float_comparison Lt f g + | Extern "caml_int_of_float", [ f ] -> + let* f = Memory.unbox_float f in + Value.val_int (return (W.UnOp (I32 (TruncSatF64 S), f))) + | Extern "caml_float_of_int", [ n ] -> + let* n = Value.int_val n in + Memory.box_float (return (W.UnOp (F64 (Convert (`I32, S)), n))) + | Extern "caml_cos_float", [ f ] -> float_un_op' Math.cos f + | Extern "caml_sin_float", [ f ] -> float_un_op' Math.sin f + | Extern "caml_tan_float", [ f ] -> float_un_op' Math.tan f + | Extern "caml_acos_float", [ f ] -> float_un_op' Math.acos f + | Extern "caml_asin_float", [ f ] -> float_un_op' Math.asin f + | Extern "caml_atan_float", [ f ] -> float_un_op' Math.atan f + | Extern "caml_atan2_float", [ f; g ] -> float_bin_op' Math.atan2 f g + | Extern "caml_cosh_float", [ f ] -> float_un_op' Math.cosh f + | Extern "caml_sinh_float", [ f ] -> float_un_op' Math.sinh f + | Extern "caml_tanh_float", [ f ] -> float_un_op' Math.tanh f + | Extern "caml_acosh_float", [ f ] -> float_un_op' Math.acosh f + | Extern "caml_asinh_float", [ f ] -> float_un_op' Math.asinh f + | Extern "caml_atanh_float", [ f ] -> float_un_op' Math.atanh f + | Extern "caml_cbrt_float", [ f ] -> float_un_op' Math.cbrt f + | Extern "caml_exp_float", [ f ] -> float_un_op' Math.exp f + | Extern "caml_exp2_float", [ f ] -> float_un_op' Math.exp2 f + | Extern "caml_log_float", [ f ] -> float_un_op' Math.log f + | Extern "caml_expm1_float", [ f ] -> float_un_op' Math.expm1 f + | Extern "caml_log1p_float", [ f ] -> float_un_op' Math.log1p f + | Extern "caml_log2_float", [ f ] -> float_un_op' Math.log2 f + | Extern "caml_log10_float", [ f ] -> float_un_op' Math.log10 f + | Extern "caml_power_float", [ f; g ] -> float_bin_op' Math.power f g + | Extern "caml_hypot_float", [ f; g ] -> float_bin_op' Math.hypot f g + | Extern "caml_fmod_float", [ f; g ] -> float_bin_op' Math.fmod f g + | Extern "caml_int32_bits_of_float", [ f ] -> + let* f = Memory.unbox_float f in + Memory.box_int32 (return (W.UnOp (I32 ReinterpretF, F32DemoteF64 f))) + | Extern "caml_int32_float_of_bits", [ i ] -> + let* i = Memory.unbox_int32 i in + Memory.box_float (return (W.F64PromoteF32 (UnOp (F32 ReinterpretI, i)))) + | Extern "caml_int32_of_float", [ f ] -> + let* f = Memory.unbox_float f in + Memory.box_int32 (return (W.UnOp (I32 (TruncSatF64 S), f))) + | Extern "caml_int32_to_float", [ n ] -> + let* n = Memory.unbox_int32 n in + Memory.box_float (return (W.UnOp (F64 (Convert (`I32, S)), n))) + | Extern "caml_int32_neg", [ i ] -> + let* i = Memory.unbox_int32 i in + Memory.box_int32 (return (W.BinOp (I32 Sub, Const (I32 0l), i))) + | Extern "caml_int32_add", [ i; j ] -> int32_bin_op Add i j + | Extern "caml_int32_sub", [ i; j ] -> int32_bin_op Sub i j + | Extern "caml_int32_mul", [ i; j ] -> int32_bin_op Mul i j + | Extern "caml_int32_and", [ i; j ] -> int32_bin_op And i j + | Extern "caml_int32_or", [ i; j ] -> int32_bin_op Or i j + | Extern "caml_int32_xor", [ i; j ] -> int32_bin_op Xor i j + | Extern "caml_int32_div", [ i; j ] -> + let res = Var.fresh () in + (*ZZZ Can we do better?*) + let i' = Var.fresh () in + let j' = Var.fresh () in + seq + (let* () = store ~typ:I32 j' (Memory.unbox_int32 j) in + let* () = + let* j = load j' in + instr + (W.Br_if (label_index context zero_divide_pc, W.UnOp (I32 Eqz, j))) + in + let* () = store ~typ:I32 i' (Memory.unbox_int32 i) in + if_ + { params = []; result = [] } + Arith.( + (let* j = load j' in + return (W.BinOp (I32 Eq, j, Const (I32 (-1l))))) + land let* i = load i' in + return (W.BinOp (I32 Eq, i, Const (I32 Int32.min_int)))) + (store + ~always:true + ~typ:I32 + res + (return (W.Const (I32 Int32.min_int)))) + (store + ~always:true + ~typ:I32 + res + (let* i = load i' in + let* j = load j' in + return (W.BinOp (I32 (Div S), i, j))))) + (Memory.box_int32 (load res)) + | Extern "caml_int32_mod", [ i; j ] -> + let j' = Var.fresh () in + seq + (let* () = store ~typ:I32 j' (Memory.unbox_int32 j) in + let* j = load j' in + instr + (W.Br_if (label_index context zero_divide_pc, W.UnOp (I32 Eqz, j)))) + (let* i = Memory.unbox_int32 i in + let* j = load j' in + Memory.box_int32 (return (W.BinOp (I32 (Rem S), i, j)))) + | Extern "caml_int32_shift_left", [ i; j ] -> int32_shift_op Shl i j + | Extern "caml_int32_shift_right", [ i; j ] -> int32_shift_op (Shr S) i j + | Extern "caml_int32_shift_right_unsigned", [ i; j ] -> + int32_shift_op (Shr U) i j + | Extern "caml_int32_to_int", [ i ] -> Value.val_int (Memory.unbox_int32 i) + | Extern "caml_int32_of_int", [ i ] -> Memory.box_int32 (Value.int_val i) + | Extern "caml_nativeint_of_int32", [ i ] -> + Memory.box_nativeint (Memory.unbox_int32 i) + | Extern "caml_nativeint_to_int32", [ i ] -> + Memory.box_int32 (Memory.unbox_nativeint i) + | Extern "caml_int64_bits_of_float", [ f ] -> + let* f = Memory.unbox_float f in + Memory.box_int64 (return (W.UnOp (I64 ReinterpretF, f))) + | Extern "caml_int64_float_of_bits", [ i ] -> + let* i = Memory.unbox_int64 i in + Memory.box_float (return (W.UnOp (F64 ReinterpretI, i))) + | Extern "caml_int64_of_float", [ f ] -> + let* f = Memory.unbox_float f in + Memory.box_int64 (return (W.UnOp (I64 (TruncSatF64 S), f))) + | Extern "caml_int64_to_float", [ n ] -> + let* n = Memory.unbox_int64 n in + Memory.box_float (return (W.UnOp (F64 (Convert (`I64, S)), n))) + | Extern "caml_int64_neg", [ i ] -> + let* i = Memory.unbox_int64 i in + Memory.box_int64 (return (W.BinOp (I64 Sub, Const (I64 0L), i))) + | Extern "caml_int64_add", [ i; j ] -> int64_bin_op Add i j + | Extern "caml_int64_sub", [ i; j ] -> int64_bin_op Sub i j + | Extern "caml_int64_mul", [ i; j ] -> int64_bin_op Mul i j + | Extern "caml_int64_and", [ i; j ] -> int64_bin_op And i j + | Extern "caml_int64_or", [ i; j ] -> int64_bin_op Or i j + | Extern "caml_int64_xor", [ i; j ] -> int64_bin_op Xor i j + | Extern "caml_int64_div", [ i; j ] -> + let res = Var.fresh () in + (*ZZZ Can we do better?*) + let i' = Var.fresh () in + let j' = Var.fresh () in + seq + (let* () = store ~typ:I64 j' (Memory.unbox_int64 j) in + let* () = + let* j = load j' in + instr + (W.Br_if (label_index context zero_divide_pc, W.UnOp (I64 Eqz, j))) + in + let* () = store ~typ:I64 i' (Memory.unbox_int64 i) in + if_ + { params = []; result = [] } + Arith.( + (let* j = load j' in + return (W.BinOp (I64 Eq, j, Const (I64 (-1L))))) + land let* i = load i' in + return (W.BinOp (I64 Eq, i, Const (I64 Int64.min_int)))) + (store + ~always:true + ~typ:I64 + res + (return (W.Const (I64 Int64.min_int)))) + (store + ~always:true + ~typ:I64 + res + (let* i = load i' in + let* j = load j' in + return (W.BinOp (I64 (Div S), i, j))))) + (Memory.box_int64 (load res)) + | Extern "caml_int64_mod", [ i; j ] -> + let j' = Var.fresh () in + seq + (let* () = store ~typ:I64 j' (Memory.unbox_int64 j) in + let* j = load j' in + instr + (W.Br_if (label_index context zero_divide_pc, W.UnOp (I64 Eqz, j)))) + (let* i = Memory.unbox_int64 i in + let* j = load j' in + Memory.box_int64 (return (W.BinOp (I64 (Rem S), i, j)))) + | Extern "caml_int64_shift_left", [ i; j ] -> int64_shift_op Shl i j + | Extern "caml_int64_shift_right", [ i; j ] -> int64_shift_op (Shr S) i j + | Extern "caml_int64_shift_right_unsigned", [ i; j ] -> + int64_shift_op (Shr U) i j + | Extern "caml_int64_to_int", [ i ] -> + let* i = Memory.unbox_int64 i in + Value.val_int (return (W.I32WrapI64 i)) + | Extern "caml_int64_of_int", [ i ] -> + let* i = Value.int_val i in + Memory.box_int64 + (return + (match i with + | Const (I32 i) -> W.Const (I64 (Int64.of_int32 i)) + | _ -> W.I64ExtendI32 (S, i))) + | Extern "caml_int64_to_int32", [ i ] -> + let* i = Memory.unbox_int64 i in + Memory.box_int32 (return (W.I32WrapI64 i)) + | Extern "caml_int64_of_int32", [ i ] -> + let* i = Memory.unbox_int32 i in + Memory.box_int64 (return (W.I64ExtendI32 (S, i))) + | Extern "caml_int64_to_nativeint", [ i ] -> + let* i = Memory.unbox_int64 i in + Memory.box_nativeint (return (W.I32WrapI64 i)) + | Extern "caml_int64_of_nativeint", [ i ] -> + let* i = Memory.unbox_nativeint i in + Memory.box_int64 (return (W.I64ExtendI32 (S, i))) + | Extern "caml_nativeint_bits_of_float", [ f ] -> + let* f = Memory.unbox_float f in + Memory.box_nativeint (return (W.UnOp (I32 ReinterpretF, F32DemoteF64 f))) + | Extern "caml_nativeint_float_of_bits", [ i ] -> + let* i = Memory.unbox_int64 i in + Memory.box_float (return (W.F64PromoteF32 (UnOp (I32 ReinterpretF, i)))) + | Extern "caml_nativeint_of_float", [ f ] -> + let* f = Memory.unbox_float f in + Memory.box_nativeint (return (W.UnOp (I32 (TruncSatF64 S), f))) + | Extern "caml_nativeint_to_float", [ n ] -> + let* n = Memory.unbox_nativeint n in + Memory.box_float (return (W.UnOp (F64 (Convert (`I32, S)), n))) + | Extern "caml_nativeint_neg", [ i ] -> + let* i = Memory.unbox_nativeint i in + Memory.box_nativeint (return (W.BinOp (I32 Sub, Const (I32 0l), i))) + | Extern "caml_nativeint_add", [ i; j ] -> nativeint_bin_op Add i j + | Extern "caml_nativeint_sub", [ i; j ] -> nativeint_bin_op Sub i j + | Extern "caml_nativeint_mul", [ i; j ] -> nativeint_bin_op Mul i j + | Extern "caml_nativeint_and", [ i; j ] -> nativeint_bin_op And i j + | Extern "caml_nativeint_or", [ i; j ] -> nativeint_bin_op Or i j + | Extern "caml_nativeint_xor", [ i; j ] -> nativeint_bin_op Xor i j + | Extern "caml_nativeint_div", [ i; j ] -> + let res = Var.fresh () in + (*ZZZ Can we do better?*) + let i' = Var.fresh () in + let j' = Var.fresh () in + seq + (let* () = store ~typ:I32 j' (Memory.unbox_nativeint j) in + let* () = + let* j = load j' in + instr + (W.Br_if (label_index context zero_divide_pc, W.UnOp (I32 Eqz, j))) + in + let* () = store ~typ:I32 i' (Memory.unbox_nativeint i) in + if_ + { params = []; result = [] } + Arith.( + (let* j = load j' in + return (W.BinOp (I32 Eq, j, Const (I32 (-1l))))) + land let* i = load i' in + return (W.BinOp (I32 Eq, i, Const (I32 Int32.min_int)))) + (store + ~always:true + ~typ:I32 + res + (return (W.Const (I32 Int32.min_int)))) + (store + ~always:true + ~typ:I32 + res + (let* i = load i' in + let* j = load j' in + return (W.BinOp (I32 (Div S), i, j))))) + (Memory.box_nativeint (load res)) + | Extern "caml_nativeint_mod", [ i; j ] -> + let j' = Var.fresh () in + seq + (let* () = store ~typ:I32 j' (Memory.unbox_nativeint j) in + let* j = load j' in + instr + (W.Br_if (label_index context zero_divide_pc, W.UnOp (I32 Eqz, j)))) + (let* i = Memory.unbox_nativeint i in + let* j = load j' in + Memory.box_nativeint (return (W.BinOp (I32 (Rem S), i, j)))) + | Extern "caml_nativeint_shift_left", [ i; j ] -> nativeint_shift_op Shl i j + | Extern "caml_nativeint_shift_right", [ i; j ] -> + nativeint_shift_op (Shr S) i j + | Extern "caml_nativeint_shift_right_unsigned", [ i; j ] -> + nativeint_shift_op (Shr U) i j + | Extern "caml_nativeint_to_int", [ i ] -> + Value.val_int (Memory.unbox_nativeint i) + | Extern "caml_nativeint_of_int", [ i ] -> + Memory.box_nativeint (Value.int_val i) + | Extern "caml_int_compare", [ i; j ] -> + Value.val_int + Arith.( + (Value.int_val j < Value.int_val i) + - (Value.int_val i < Value.int_val j)) + | Extern "%js_array", l -> + let* l = + List.fold_right + ~f:(fun x acc -> + let* x = x in + let* acc = acc in + return (`Expr x :: acc)) + l + ~init:(return []) + in + Memory.allocate ~tag:0 ~deadcode_sentinal:ctx.deadcode_sentinal l + | Extern name, l -> ( + let name = Primitive.resolve name in + try + let typ = Hashtbl.find specialized_primitives name in + let* f = register_import ~name (Fun (specialized_func_type typ)) in + let rec loop acc arg_typ l = + match arg_typ, l with + | [], [] -> box_value (snd typ) (return (W.Call (f, List.rev acc))) + | repr :: rem, x :: r -> + let* x = unbox_value repr x in + loop (x :: acc) rem r + | [], _ :: _ | _ :: _, [] -> assert false + in + loop [] (fst typ) l + with Not_found -> + let* f = register_import ~name (Fun (func_type (List.length l))) in + let rec loop acc l = + match l with + | [] -> return (W.Call (f, List.rev acc)) + | x :: r -> + let* x = x in + loop (x :: acc) r + in + loop [] l) + | Not, [ x ] -> Value.not x + | Lt, [ x; y ] -> Value.lt x y + | Le, [ x; y ] -> Value.le x y + | Eq, [ x; y ] -> Value.eq x y + | Neq, [ x; y ] -> Value.neq x y + | Ult, [ x; y ] -> Value.ult x y + | Array_get, [ x; y ] -> Memory.array_get x y + | IsInt, [ x ] -> Value.is_int x + | Vectlength, [ x ] -> Value.val_int (Memory.gen_array_length x) + | (Not | Lt | Le | Eq | Neq | Ult | Array_get | IsInt | Vectlength), _ -> + assert false)) + + and translate_instr ctx context i = + match i with + | Assign (x, y) -> assign x (load y) + | Let (x, e) -> + if ctx.live.(Var.idx x) = 0 + then drop (translate_expr ctx context x e) + else store x (translate_expr ctx context x e) + | Set_field (x, n, Non_float, y) -> Memory.set_field (load x) n (load y) + | Set_field (x, n, Float, y) -> + Memory.float_array_set + (load x) + (Constant.translate (Int (Targetint.of_int_warning_on_overflow n))) + (load y) + | Offset_ref (x, n) -> + Memory.set_field + (load x) + 0 + (Value.val_int + Arith.(Value.int_val (Memory.field (load x) 0) + const (Int32.of_int n))) + | Array_set (x, y, z) -> Memory.array_set (load x) (load y) (load z) + | Event loc -> event loc + + and translate_instrs ctx context l = + match l with + | [] -> return () + | i :: rem -> + let* () = translate_instr ctx context i in + translate_instrs ctx context rem + + let parallel_renaming params args = + let rec visit visited prev s m x l = + if not (Var.Set.mem x visited) + then + let visited = Var.Set.add x visited in + let y = Var.Map.find x m in + if Code.Var.compare x y = 0 + then visited, None, l + else if Var.Set.mem y prev + then + let t = Code.Var.fresh () in + visited, Some (y, t), (x, t) :: l + else if Var.Set.mem y s + then + let visited, aliases, l = visit visited (Var.Set.add x prev) s m y l in + match aliases with + | Some (a, b) when Code.Var.compare a x = 0 -> + visited, None, (b, a) :: (x, y) :: l + | _ -> visited, aliases, (x, y) :: l + else visited, None, (x, y) :: l + else visited, None, l + in + let visit_all params args = + let m = Subst.build_mapping params args in + let s = List.fold_left params ~init:Var.Set.empty ~f:(fun s x -> Var.Set.add x s) in + let _, l = + Var.Set.fold + (fun x (visited, l) -> + let visited, _, l = visit visited Var.Set.empty s m x l in + visited, l) + s + (Var.Set.empty, []) + in + l + in + let l = visit_all params args in + List.fold_left + l + ~f:(fun continuation (y, x) -> + let* () = continuation in + store ~always:true y (load x)) + ~init:(return ()) + + let exception_name = "ocaml_exception" + + let extend_context fall_through context = + match fall_through with + | (`Block _ | `Catch | `Skip) as b -> b :: context + | `Return -> `Skip :: context + + let needed_handlers (p : program) pc = + Code.traverse + { fold = fold_children_skip_try_body } + (fun pc n -> + let block = Addr.Map.find pc p.blocks in + List.fold_left + ~f:(fun n i -> + match i with + | Let + ( _ + , Prim + ( Extern + ( "caml_string_get" + | "caml_bytes_get" + | "caml_string_set" + | "caml_bytes_set" + | "caml_check_bound" + | "caml_check_bound_gen" + | "caml_check_bound_float" ) + , _ ) ) -> fst n, true + | Let + ( _ + , Prim + ( Extern + ( "%int_div" + | "%int_mod" + | "caml_int32_div" + | "caml_int32_mod" + | "caml_int64_div" + | "caml_int64_mod" + | "caml_nativeint_div" + | "caml_nativeint_mod" ) + , _ ) ) -> true, snd n + | _ -> n) + ~init:n + block.body) + pc + p.blocks + (false, false) + + let wrap_with_handler needed pc handler ~result_typ ~fall_through ~context body = + if needed + then + let* () = + block + { params = []; result = [] } + (body ~result_typ:[] ~fall_through:(`Block pc) ~context:(`Block pc :: context)) + in + if List.is_empty result_typ + then handler + else + let* () = handler in + instr (W.Return (Some (RefI31 (Const (I32 0l))))) + else body ~result_typ ~fall_through ~context + + let wrap_with_handlers p pc ~result_typ ~fall_through ~context body = + let need_zero_divide_handler, need_bound_error_handler = needed_handlers p pc in + wrap_with_handler + need_bound_error_handler + bound_error_pc + (let* f = + register_import ~name:"caml_bound_error" (Fun { params = []; result = [] }) + in + instr (CallInstr (f, []))) + (wrap_with_handler + need_zero_divide_handler + zero_divide_pc + (let* f = + register_import + ~name:"caml_raise_zero_divide" + (Fun { params = []; result = [] }) + in + instr (CallInstr (f, []))) + body) + ~result_typ + ~fall_through + ~context + + let translate_function + p + ctx + name_opt + ~toplevel_name + ~unit_name + params + ((pc, _) as cont) + acc = + let g = Structure.build_graph ctx.blocks pc in + let dom = Structure.dominator_tree g in + let rec translate_tree result_typ fall_through pc context = + let block = Addr.Map.find pc ctx.blocks in + let keep_ouside pc' = + match block.branch with + | Switch _ -> true + | Cond (_, (pc1, _), (pc2, _)) when pc' = pc1 && pc' = pc2 -> true + | _ -> Structure.is_merge_node g pc' + in + let code ~context = + translate_node_within + ~result_typ + ~fall_through + ~pc + ~l: + (pc + |> Structure.get_edges dom + |> Addr.Set.elements + |> List.filter ~f:keep_ouside + |> Structure.sort_in_post_order g) + ~context + in + if Structure.is_loop_header g pc + then + loop { params = []; result = result_typ } (code ~context:(`Block pc :: context)) + else code ~context + and translate_node_within ~result_typ ~fall_through ~pc ~l ~context = + match l with + | pc' :: rem -> + let* () = + let code ~context = + translate_node_within + ~result_typ:[] + ~fall_through:(`Block pc') + ~pc + ~l:rem + ~context + in + (* Do not insert a block if the inner code contains a + structured control flow instruction ([if] or [try] *) + if + (not (List.is_empty rem)) + || + let block = Addr.Map.find pc ctx.blocks in + match block.branch with + | Cond _ | Pushtrap _ -> false (*ZZZ also some Switch*) + | _ -> true + then + block { params = []; result = [] } (code ~context:(`Block pc' :: context)) + else code ~context + in + translate_tree result_typ fall_through pc' context + | [] -> ( + let block = Addr.Map.find pc ctx.blocks in + let* () = translate_instrs ctx context block.body in + let branch = block.branch in + match branch with + | Branch cont -> translate_branch result_typ fall_through pc cont context + | Return x -> ( + let* e = load x in + match fall_through with + | `Return -> instr (Push e) + | `Block _ | `Catch | `Skip -> instr (Return (Some e))) + | Cond (x, cont1, cont2) -> + let context' = extend_context fall_through context in + if_ + { params = []; result = result_typ } + (Value.check_is_not_zero (load x)) + (translate_branch result_typ fall_through pc cont1 context') + (translate_branch result_typ fall_through pc cont2 context') + | Stop -> ( + let* e = Value.unit in + match fall_through with + | `Return -> instr (Push e) + | `Block _ | `Catch | `Skip -> instr (Return (Some e))) + | Switch (x, a) -> + let len = Array.length a in + let l = Array.to_list (Array.sub a ~pos:0 ~len:(len - 1)) in + let dest (pc, args) = + assert (List.is_empty args); + label_index context pc + in + let* e = Value.int_val (load x) in + instr (Br_table (e, List.map ~f:dest l, dest a.(len - 1))) + | Raise (x, _) -> ( + let* e = load x in + let* tag = register_import ~name:exception_name (Tag Value.value) in + match fall_through with + | `Catch -> instr (Push e) + | `Block _ | `Return | `Skip -> ( + match catch_index context with + | Some i -> instr (Br (i, Some e)) + | None -> instr (Throw (tag, e)))) + | Pushtrap (cont, x, cont') -> + handle_exceptions + ~result_typ + ~fall_through + ~context:(extend_context fall_through context) + (wrap_with_handlers + p + (fst cont) + (fun ~result_typ ~fall_through ~context -> + translate_branch result_typ fall_through pc cont context)) + x + (fun ~result_typ ~fall_through ~context -> + translate_branch result_typ fall_through pc cont' context) + | Poptrap cont -> translate_branch result_typ fall_through pc cont context) + and translate_branch result_typ fall_through src (dst, args) context = + let* () = + if List.is_empty args + then return () + else + let block = Addr.Map.find dst ctx.blocks in + parallel_renaming block.params args + in + match fall_through with + | `Block dst' when dst = dst' -> return () + | _ -> + if + (src >= 0 && Structure.is_backward g src dst) || Structure.is_merge_node g dst + then instr (Br (label_index context dst, None)) + else translate_tree result_typ fall_through dst context + in + let bind_parameters = + List.fold_left + ~f:(fun l x -> + let* _ = l in + let* _ = add_var x in + return ()) + ~init:(return ()) + params + in + let build_initial_env = + let* () = bind_parameters in + match name_opt with + | Some f -> + Closure.bind_environment + ~context:ctx.global_context + ~closures:ctx.closures + ~cps:(Var.Set.mem f ctx.in_cps) + f + | None -> return () + in + (* + Format.eprintf "=== %d ===@." pc; +*) + let param_names = + match name_opt with + | None -> [] + | Some f -> params @ [ f ] + in + let param_count = List.length param_names in + (match name_opt with + | None -> ctx.global_context.globalized_variables <- Globalize.f p g ctx.closures + | Some _ -> ()); + let locals, body = + function_body + ~context:ctx.global_context + ~param_names + ~body: + (let* () = + let block = Addr.Map.find pc ctx.blocks in + match block.body with + | Event start_loc :: _ -> event start_loc + | _ -> no_event + in + let* () = build_initial_env in + let* () = + wrap_with_handlers + p + pc + ~result_typ:[ Value.value ] + ~fall_through:`Return + ~context:[] + (fun ~result_typ ~fall_through ~context -> + translate_branch result_typ fall_through (-1) cont context) + in + let end_loc = Parse_bytecode.Debug.find_loc ctx.debug ~position:After pc in + match end_loc with + | Some loc -> event loc + | None -> return ()) + in + let body = post_process_function_body ~param_names ~locals body in + W.Function + { name = + (match name_opt with + | None -> toplevel_name + | Some x -> x) + ; exported_name = + (match name_opt with + | None -> Option.map ~f:(fun name -> name ^ ".init") unit_name + | Some _ -> None) + ; param_names + ; typ = func_type param_count + ; locals + ; body + } + :: acc + + let init_function ~context ~to_link = + let name = Code.Var.fresh_n "initialize" in + let typ = { W.params = []; result = [ Value.value ] } in + let locals, body = + function_body + ~context + ~param_names:[] + ~body: + (List.fold_right + ~f:(fun name cont -> + let* f = + register_import ~import_module:"OCaml" ~name:(name ^ ".init") (Fun typ) + in + let* () = instr (Drop (Call (f, []))) in + cont) + ~init:(instr (Push (RefI31 (Const (I32 0l))))) + to_link) + in + context.other_fields <- + W.Function { name; exported_name = None; typ; param_names = []; locals; body } + :: context.other_fields; + name + + let entry_point context toplevel_fun entry_name = + let typ, param_names, body = entry_point ~toplevel_fun in + let locals, body = function_body ~context ~param_names ~body in + W.Function + { name = Var.fresh_n "entry_point" + ; exported_name = Some entry_name + ; typ + ; param_names + ; locals + ; body + } + + module Curry = Curry.Make (Target) + + let add_start_function ~context toplevel_name = + context.other_fields <- + entry_point context toplevel_name "_initialize" :: context.other_fields + + let add_init_function ~context ~to_link = + add_start_function ~context (init_function ~context ~to_link) + + let f + ~context:global_context + ~unit_name + (p : Code.program) + ~live_vars + ~in_cps (* + ~should_export + ~warn_on_unhandled_effect +*) + ~deadcode_sentinal + ~debug = + global_context.unit_name <- unit_name; + let p, closures = Closure_conversion.f p in + (* + Code.Print.program (fun _ _ -> "") p; +*) + let ctx = + { live = live_vars + ; in_cps + ; deadcode_sentinal + ; blocks = p.blocks + ; closures + ; global_context + ; debug + } + in + let toplevel_name = Var.fresh_n "toplevel" in + let functions = + Code.fold_closures_outermost_first + p + (fun name_opt params cont -> + translate_function p ctx name_opt ~toplevel_name ~unit_name params cont) + [] + in + let functions = + List.map + ~f:(fun f -> + match f with + | W.Function ({ name; _ } as f) when Code.Var.equal name toplevel_name -> + W.Function { f with body = global_context.init_code @ f.body } + | _ -> f) + functions + in + global_context.init_code <- []; + global_context.other_fields <- List.rev_append functions global_context.other_fields; + let js_code = + List.rev global_context.strings, StringMap.bindings global_context.fragments + in + global_context.string_count <- 0; + global_context.strings <- []; + global_context.string_index <- StringMap.empty; + global_context.fragments <- StringMap.empty; + toplevel_name, js_code + + let output ~context = + Curry.f ~context; + let imports = + List.concat + (List.map + ~f:(fun (import_module, m) -> + List.map + ~f:(fun (import_name, (name, desc)) -> + W.Import { import_module; import_name; name; desc }) + (StringMap.bindings m)) + (StringMap.bindings context.imports)) + in + let constant_data = + List.map + ~f:(fun (name, contents) -> W.Data { name; contents }) + (Var.Map.bindings context.data_segments) + in + List.rev_append context.other_fields (imports @ constant_data) +end + +let init () = + let l = + [ "caml_ensure_stack_capacity", "%identity" + ; "caml_process_pending_actions_with_root", "%identity" + ; "caml_callback", "caml_trampoline" + ; "caml_make_array", "caml_array_of_uniform_array" + ] + in + Primitive.register "caml_array_of_uniform_array" `Mutable None None; + let l = + if Config.Flag.effects () + then ("caml_alloc_stack", "caml_cps_alloc_stack") :: l + else l + in + List.iter ~f:(fun (nm, nm') -> Primitive.alias nm nm') l + +(* Make sure we can use [br_table] for switches *) +let fix_switch_branches p = + let p' = ref p in + let updates = ref Addr.Map.empty in + let fix_branches l = + Array.iteri + ~f:(fun i ((pc, args) as cont) -> + if not (List.is_empty args) + then + l.(i) <- + ( (let l = try Addr.Map.find pc !updates with Not_found -> [] in + try List.assoc args l + with Not_found -> + let pc' = !p'.free_pc in + p' := + { !p' with + blocks = + Addr.Map.add + pc' + { params = []; body = []; branch = Branch cont } + !p'.blocks + ; free_pc = pc' + 1 + }; + updates := Addr.Map.add pc ((args, pc') :: l) !updates; + pc') + , [] )) + l + in + Addr.Map.iter + (fun _ block -> + match block.branch with + | Switch (_, l) -> fix_branches l + | _ -> ()) + p.blocks; + !p' + +let start () = make_context ~value_type:Gc_target.Value.value + +let f ~context ~unit_name p ~live_vars ~in_cps ~deadcode_sentinal ~debug = + let p = if Config.Flag.effects () then fix_switch_branches p else p in + let module G = Generate (Gc_target) in + G.f ~context ~unit_name ~live_vars ~in_cps ~deadcode_sentinal ~debug p + +let add_start_function = + let module G = Generate (Gc_target) in + G.add_start_function + +let add_init_function = + let module G = Generate (Gc_target) in + G.add_init_function + +let output ch ~context = + let module G = Generate (Gc_target) in + let fields = G.output ~context in + Wat_output.f ch fields + +let wasm_output ch ~context = + let module G = Generate (Gc_target) in + let fields = G.output ~context in + Wasm_output.f ch fields diff --git a/compiler/lib-wasm/generate.mli b/compiler/lib-wasm/generate.mli new file mode 100644 index 0000000000..773917310b --- /dev/null +++ b/compiler/lib-wasm/generate.mli @@ -0,0 +1,39 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 init : unit -> unit + +val start : unit -> Code_generation.context + +val f : + context:Code_generation.context + -> unit_name:string option + -> Code.program + -> live_vars:int array + -> in_cps:Effects.in_cps + -> deadcode_sentinal:Code.Var.t + -> debug:Parse_bytecode.Debug.t + -> Wasm_ast.var * (string list * (string * Javascript.expression) list) + +val add_start_function : context:Code_generation.context -> Wasm_ast.var -> unit + +val add_init_function : context:Code_generation.context -> to_link:string list -> unit + +val output : out_channel -> context:Code_generation.context -> unit + +val wasm_output : out_channel -> context:Code_generation.context -> unit diff --git a/compiler/lib-wasm/globalize.ml b/compiler/lib-wasm/globalize.ml new file mode 100644 index 0000000000..c4bd6c8ca6 --- /dev/null +++ b/compiler/lib-wasm/globalize.ml @@ -0,0 +1,122 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +(* + +Store some toplevel values into globals. Any variable which is used a +number of instructions after being defined is stored into a global +instead of a local. The goals are the following: +- Turn a large number of closures into constant closures, which has a + significant impact on performance +- Reduce the compilation time of the toplevel function in case the + Wasm engine decide to optimize it: reduce the register pressure by + avoiding long-lived registers in the toplevel function, and make + load elimination less expensive by reducing the number of constant + structures defined in this function. +*) + +open Stdlib + +type st = + { pos : int + ; visited_variables : int Code.Var.Map.t + ; globals : Code.Var.Set.t + ; closures : Closure_conversion.closure Code.Var.Map.t + } + +let threshold = 1000 + +let rec globalize st x = + if Code.Var.Set.mem x st.globals + then st + else + let st = { st with globals = Code.Var.Set.add x st.globals } in + globalize_closure st x + +and globalize_closure st x = + (* If a function is stored in a global variable, its free variables + are also stored in a global variable, since they are retained + anyway. *) + match Code.Var.Map.find x st.closures with + | { free_variables; _ } -> + List.fold_left + ~f:(fun st x -> + if Code.Var.Map.mem x st.visited_variables then globalize st x else st) + ~init:st + free_variables + | exception Not_found -> st + +let use x st = + match Code.Var.Map.find x st.visited_variables with + | pos -> if st.pos > pos + threshold then globalize st x else st + | exception Not_found -> st + +let declare x st = + { st with visited_variables = Code.Var.Map.add x st.pos st.visited_variables } + +let traverse_expression x e st = + match e with + | Code.Apply { f; args; _ } -> + st |> use f |> fun st -> List.fold_left ~f:(fun st x -> use x st) ~init:st args + | Block (_, a, _, _) -> Array.fold_right ~f:use a ~init:st + | Field (x, _, _) -> st |> use x + | Closure _ -> + List.fold_left + ~f:(fun st x -> use x st) + ~init:st + (Code.Var.Map.find x st.closures).Closure_conversion.free_variables + | Constant _ | Special _ -> st + | Prim (_, args) -> + List.fold_left + ~f:(fun st a -> + match a with + | Code.Pv x -> st |> use x + | Pc _ -> st) + ~init:st + args + +let traverse_instruction st i = + let st = { st with pos = st.pos + 1 } in + match i with + | Code.Let (x, e) -> st |> declare x |> traverse_expression x e + | Assign (_, x) | Offset_ref (x, _) -> st |> use x + | Set_field (x, _, _, y) -> st |> use x |> use y + | Array_set (x, y, z) -> st |> use x |> use y |> use z + | Event _ -> st + +let traverse_block p st pc = + let b = Code.Addr.Map.find pc p.Code.blocks in + let st = List.fold_left ~f:(fun st x -> declare x st) ~init:st b.Code.params in + List.fold_left ~f:(fun st i -> traverse_instruction st i) ~init:st b.Code.body + +let f p g closures = + let l = Structure.blocks_in_reverse_post_order g in + let in_loop = Freevars.find_loops_in_closure p p.Code.start in + let st = + List.fold_left + ~f:(fun st pc -> + if Code.Addr.Map.mem pc in_loop then st else traverse_block p st pc) + ~init: + { pos = 0 + ; visited_variables = Code.Var.Map.empty + ; globals = Code.Var.Set.empty + ; closures + } + l + in + st.globals diff --git a/compiler/lib-wasm/globalize.mli b/compiler/lib-wasm/globalize.mli new file mode 100644 index 0000000000..e62874ed0b --- /dev/null +++ b/compiler/lib-wasm/globalize.mli @@ -0,0 +1,23 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 f : + Code.program + -> Structure.t + -> Closure_conversion.closure Code.Var.Map.t + -> Code.Var.Set.t diff --git a/compiler/lib-wasm/initialize_locals.ml b/compiler/lib-wasm/initialize_locals.ml new file mode 100644 index 0000000000..5e15235725 --- /dev/null +++ b/compiler/lib-wasm/initialize_locals.ml @@ -0,0 +1,125 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Stdlib + +type ctx = + { mutable initialized : Code.Var.Set.t + ; uninitialized : Code.Var.Set.t ref + } + +let mark_initialized ctx i = ctx.initialized <- Code.Var.Set.add i ctx.initialized + +let fork_context { initialized; uninitialized } = { initialized; uninitialized } + +let check_initialized ctx i = + if not (Code.Var.Set.mem i ctx.initialized) + then ctx.uninitialized := Code.Var.Set.add i !(ctx.uninitialized) + +let rec scan_expression ctx e = + match e with + | Wasm_ast.Const _ | GlobalGet _ | Pop _ | RefFunc _ | RefNull _ -> () + | UnOp (_, e') + | I32WrapI64 e' + | I64ExtendI32 (_, e') + | F32DemoteF64 e' + | F64PromoteF32 e' + | RefI31 e' + | I31Get (_, e') + | ArrayLen e' + | StructGet (_, _, _, e') + | RefCast (_, e') + | RefTest (_, e') + | Br_on_cast (_, _, _, e') + | Br_on_cast_fail (_, _, _, e') -> scan_expression ctx e' + | BinOp (_, e', e'') + | ArrayNew (_, e', e'') + | ArrayNewData (_, _, e', e'') + | ArrayGet (_, _, e', e'') + | RefEq (e', e'') -> + scan_expression ctx e'; + scan_expression ctx e'' + | LocalGet i -> check_initialized ctx i + | LocalTee (i, e') -> + scan_expression ctx e'; + mark_initialized ctx i + | Call_ref (_, e', l) -> + scan_expressions ctx l; + scan_expression ctx e' + | Call (_, l) | ArrayNewFixed (_, l) | StructNew (_, l) -> scan_expressions ctx l + | BlockExpr (_, l) -> scan_instructions ctx l + | Seq (l, e') -> scan_instructions ctx (l @ [ Push e' ]) + | IfExpr (_, cond, e1, e2) -> + scan_expression ctx cond; + scan_expression (fork_context ctx) e1; + scan_expression (fork_context ctx) e2 + | Try (_, body, _) -> scan_instructions ctx body + +and scan_expressions ctx l = List.iter ~f:(fun e -> scan_expression ctx e) l + +and scan_instruction ctx i = + match i with + | Wasm_ast.Drop e + | GlobalSet (_, e) + | Br (_, Some e) + | Br_if (_, e) + | Br_table (e, _, _) + | Throw (_, e) + | Return (Some e) + | Push e -> scan_expression ctx e + | StructSet (_, _, e, e') -> + scan_expression ctx e; + scan_expression ctx e' + | LocalSet (i, e) -> + scan_expression ctx e; + mark_initialized ctx i + | Loop (_, l) | Block (_, l) -> scan_instructions ctx l + | If (_, e, l, l') -> + scan_expression ctx e; + scan_instructions ctx l; + scan_instructions ctx l' + | CallInstr (_, l) | Return_call (_, l) -> scan_expressions ctx l + | Br (_, None) | Return None | Rethrow _ | Nop | Event _ -> () + | ArraySet (_, e, e', e'') -> + scan_expression ctx e; + scan_expression ctx e'; + scan_expression ctx e'' + | Return_call_ref (_, e', l) -> + scan_expressions ctx l; + scan_expression ctx e' + +and scan_instructions ctx l = + let ctx = fork_context ctx in + List.iter ~f:(fun i -> scan_instruction ctx i) l + +let f ~param_names ~locals instrs = + let ctx = + { initialized = Code.Var.Set.empty; uninitialized = ref Code.Var.Set.empty } + in + List.iter ~f:(fun x -> mark_initialized ctx x) param_names; + List.iter + ~f:(fun (var, typ) -> + match (typ : Wasm_ast.value_type) with + | I32 | I64 | F32 | F64 | Ref { nullable = true; _ } -> mark_initialized ctx var + | Ref { nullable = false; _ } -> ()) + locals; + scan_instructions ctx instrs; + List.map + ~f:(fun i -> Wasm_ast.LocalSet (i, RefI31 (Const (I32 0l)))) + (Code.Var.Set.elements !(ctx.uninitialized)) + @ instrs diff --git a/compiler/lib-wasm/initialize_locals.mli b/compiler/lib-wasm/initialize_locals.mli new file mode 100644 index 0000000000..d43869795d --- /dev/null +++ b/compiler/lib-wasm/initialize_locals.mli @@ -0,0 +1,23 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 f : + param_names:Wasm_ast.var list + -> locals:(Wasm_ast.var * Wasm_ast.value_type) list + -> Wasm_ast.instruction list + -> Wasm_ast.instruction list diff --git a/compiler/lib-wasm/link.ml b/compiler/lib-wasm/link.ml new file mode 100644 index 0000000000..d043d0833e --- /dev/null +++ b/compiler/lib-wasm/link.ml @@ -0,0 +1,974 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Stdlib + +let times = Debug.find "times" + +module Build_info : sig + include module type of Build_info + + val to_sexp : t -> Sexp.t + + val from_sexp : Sexp.t -> t +end = struct + include Build_info + + let to_sexp info = + Sexp.List + (info + |> to_map + |> StringMap.bindings + |> List.map ~f:(fun (k, v) -> Sexp.List [ Atom k; Atom v ])) + + let from_sexp info = + let open Sexp.Util in + info + |> assoc + |> List.fold_left + ~f:(fun m (k, v) -> StringMap.add k (single string v) m) + ~init:StringMap.empty + |> of_map +end + +module Unit_info : sig + include module type of Unit_info + + val to_sexp : t -> Sexp.t list + + val from_sexp : Sexp.t -> t +end = struct + include Unit_info + + let to_sexp t = + let add nm skip v rem = if skip then rem else Sexp.List (Atom nm :: v) :: rem in + let set nm f rem = + add + nm + (List.equal ~eq:String.equal (f empty) (f t)) + (List.map ~f:(fun x -> Sexp.Atom x) (f t)) + rem + in + let bool nm f rem = + add + nm + (Bool.equal (f empty) (f t)) + (if f t then [ Atom "true" ] else [ Atom "false" ]) + rem + in + [] + |> bool "effects_without_cps" (fun t -> t.effects_without_cps) + |> set "primitives" (fun t -> t.primitives) + |> bool "force_link" (fun t -> t.force_link) + |> set "requires" (fun t -> StringSet.elements t.requires) + |> set "provides" (fun t -> StringSet.elements t.provides) + + let from_sexp t = + let open Sexp.Util in + let opt_list l = l |> Option.map ~f:(List.map ~f:string) in + let list default l = Option.value ~default (opt_list l) in + let set default l = + Option.value ~default (Option.map ~f:StringSet.of_list (opt_list l)) + in + let bool default v = Option.value ~default (Option.map ~f:(single bool) v) in + { provides = t |> member "provides" |> set empty.provides + ; requires = t |> member "requires" |> set empty.requires + ; primitives = t |> member "primitives" |> list empty.primitives + ; force_link = t |> member "force_link" |> bool empty.force_link + ; effects_without_cps = + t |> member "effects_without_cps" |> bool empty.effects_without_cps + ; crcs = StringMap.empty + } +end + +module Wasm_binary = struct + let header = "\000asm\001\000\000\000" + + let check_header file ch = + let s = really_input_string ch 8 in + if not (String.equal s header) + then failwith (file ^ " is not a Wasm binary file (bad magic)") + + type t = + { ch : in_channel + ; limit : int + } + + let open_in f = + let ch = open_in_bin f in + 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); + if i < 128 then i else i - 128 + (read_uint ~n:(n - 1) ch lsl 7) + + let rec read_sint ?(n = 5) ch = + let i = input_byte ch in + if n = 1 then assert (i < 8 || (i > 120 && i < 128)); + if i < 64 + then i + else if i < 128 + then i - 128 + else i - 128 + (read_sint ~n:(n - 1) ch lsl 7) + + type section = + { id : int + ; size : int + } + + let next_section ch = + if pos_in ch.ch = ch.limit + then None + else + let id = input_byte ch.ch in + let size = read_uint ch.ch in + Some { id; size } + + let skip_section ch { size; _ } = seek_in ch.ch (pos_in ch.ch + size) + + let vec f ch = + let rec loop acc n = if n = 0 then List.rev acc else loop (f ch :: acc) (n - 1) in + loop [] (read_uint ch) + + let name ch = + let n = read_uint ch in + really_input_string ch n + + let heaptype ch = ignore (read_sint ch) + + let reftype' i ch = + match i with + | 0x6a | 0x6b | 0x6c | 0x6d | 0x6e | 0x6f | 0x70 | 0x71 | 0x72 | 0x73 -> () + | 0x63 | 0x64 -> heaptype ch + | _ -> + Format.eprintf "Unknown reftype %x@." i; + assert false + + let reftype ch = reftype' (input_byte ch) ch + + let valtype ch = + let i = read_uint ch in + match i with + | 0x7b | 0x7c | 0x7d | 0x7e | 0x7f -> () + | _ -> reftype' i ch + + let limits ch = + match input_byte ch with + | 0 -> ignore (read_uint ch) + | 1 -> + ignore (read_uint ch); + ignore (read_uint ch) + | _ -> assert false + + let memtype = limits + + let tabletype ch = + reftype ch; + limits ch + + type import = + { module_ : string + ; name : string + } + + let import ch = + let module_ = name ch in + let name = name ch in + let d = read_uint ch in + let _ = + match d with + | 0 -> ignore (read_uint ch) + | 1 -> tabletype ch + | 2 -> memtype ch + | 3 -> + let _typ = valtype ch in + let _mut = input_byte ch in + () + | 4 -> + assert (read_uint ch = 0); + ignore (read_uint ch) + | _ -> + Format.eprintf "Unknown import %x@." d; + assert false + 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 () = + match next_section ch with + | None -> false + | Some s -> + s.id = 2 + || + (skip_section ch s; + find_section ()) + in + 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 = [] } + + let append_source_map_section ~file ~url = + let ch = open_out_gen [ Open_wronly; Open_append; Open_binary ] 0o666 file in + let rec output_uint buf i = + if i < 128 + then Buffer.add_char buf (Char.chr i) + else ( + Buffer.add_char buf (Char.chr (128 + (i land 127))); + output_uint buf (i lsr 7)) + in + let buf = Buffer.create 16 in + let output_name buf s = + output_uint buf (String.length s); + Buffer.add_string buf s + in + output_name buf "sourceMappingURL"; + output_name buf url; + let section_contents = Buffer.contents buf in + Buffer.clear buf; + Buffer.add_char buf '\000'; + output_uint buf (String.length section_contents); + output_string ch (Buffer.contents buf); + output_string ch section_contents; + close_out ch +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_name : string + ; unit_info : Unit_info.t + ; strings : string list + ; fragments : (string * Javascript.expression) list + } + +let info_to_sexp ~predefined_exceptions ~build_info ~unit_data = + let add nm skip v rem = if skip then rem else Sexp.List (Atom nm :: v) :: rem in + let units = + List.map + ~f:(fun { unit_name; unit_info; strings; fragments } -> + Sexp.List + (Unit_info.to_sexp unit_info + |> add "name" false [ Atom unit_name ] + |> add + "strings" + (List.is_empty strings) + (List.map ~f:(fun s -> Sexp.Atom s) strings) + |> add + "fragments" + (List.is_empty fragments) + [ Sexp.Atom (Base64.encode_string (Marshal.to_string fragments [])) ])) + unit_data + in + Sexp.List + ([] + |> add + "predefined_exceptions" + (StringSet.is_empty predefined_exceptions) + (List.map ~f:(fun s -> Sexp.Atom s) (StringSet.elements predefined_exceptions)) + |> add "units" (List.is_empty unit_data) units + |> add "build_info" false [ Build_info.to_sexp build_info ]) + +let info_from_sexp info = + let open Sexp.Util in + let build_info = + info |> member "build_info" |> mandatory (single Build_info.from_sexp) + in + let predefined_exceptions = + info + |> member "predefined_exceptions" + |> Option.value ~default:[] + |> List.map ~f:string + |> StringSet.of_list + in + let unit_data = + info + |> member "units" + |> Option.value ~default:[] + |> List.map ~f:(fun u -> + let unit_info = u |> Unit_info.from_sexp in + let unit_name = + u |> member "name" |> Option.value ~default:[] |> single string + in + let strings = + u |> member "strings" |> Option.value ~default:[] |> List.map ~f:string + in + let fragments = + u + |> member "fragments" + |> Option.map ~f:(single string) + |> Option.map ~f:(fun s -> Marshal.from_string (Base64.decode_exn 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_name; 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.sexp" + ~contents: + (Sexp.to_string (info_to_sexp ~predefined_exceptions ~build_info ~unit_data)) + +let read_info z = info_from_sexp (Sexp.from_string (Zip.read_entry z ~name:"info.sexp")) + +let generate_start_function ~to_link ~out_file = + let t1 = Timer.make () in + Filename.gen_file out_file + @@ fun ch -> + let context = Generate.start () in + Generate.add_init_function ~context ~to_link:("prelude" :: to_link); + Generate.wasm_output ch ~context; + if times () then Format.eprintf " generate start: %a@." Timer.print t1 + +let output_js js = + Code.Var.reset (); + let b = Buffer.create 1024 in + let f = Pretty_print.to_buffer b in + Driver.configure f; + let traverse = new Js_traverse.free in + let js = traverse#program js in + let free = traverse#get_free in + Javascript.IdentSet.iter + (fun x -> + match x with + | V _ -> assert false + | S { name = Utf8 x; _ } -> Var_printer.add_reserved x) + free; + let js = + if Config.Flag.shortvar () + then (new Js_traverse.rename_variable ~esm:false)#program js + else js + in + let js = (new Js_traverse.simpl)#program js in + let js = (new Js_traverse.clean)#program js in + let js = Js_assign.program js in + ignore (Js_output.program f js); + Buffer.contents b + +let report_missing_primitives missing = + if not (List.is_empty missing) + then ( + warn "There are some missing Wasm primitives@."; + warn "Dummy implementations (raising an exception) "; + warn "will be provided.@."; + warn "Missing primitives:@."; + List.iter ~f:(fun nm -> warn " %s@." nm) missing) + +let build_runtime_arguments + ~link_spec + ~separate_compilation + ~missing_primitives + ~wasm_dir + ~generated_js + () = + let missing_primitives = if Config.Flag.genprim () then missing_primitives else [] in + if not separate_compilation then report_missing_primitives missing_primitives; + let obj l = + Javascript.EObj + (List.map + ~f:(fun (nm, v) -> + let id = Utf8_string.of_string_exn nm in + Javascript.Property (PNS id, v)) + l) + in + let generated_js = + 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) + then + ( "env" + , obj + (List.map + ~f:(fun nm -> + ( nm + , Javascript.EArrow + ( Javascript.fun_ + [] + [ ( Throw_statement + (ENew + ( EVar + (Javascript.ident (Utf8_string.of_string_exn "Error")) + , Some + [ Arg + (EStr + (Utf8_string.of_string_exn + (nm ^ " not implemented"))) + ] + , N )) + , N ) + ] + N + , false + , AUnknown ) )) + missing_primitives) ) + :: generated_js + else generated_js + in + let generated_js = + if List.is_empty generated_js + then obj generated_js + else + let var ident e = + Javascript.variable_declaration [ Javascript.ident ident, (e, N) ], Javascript.N + in + Javascript.call + (EArrow + ( Javascript.fun_ + [ Javascript.ident Global_constant.global_object_ ] + [ var + Global_constant.old_global_object_ + (EVar (Javascript.ident Global_constant.global_object_)) + ; var + Global_constant.exports_ + (EBin + ( Or + , EDot + ( EDot + ( EVar (Javascript.ident Global_constant.global_object_) + , ANullish + , Utf8_string.of_string_exn "module" ) + , ANullish + , Utf8_string.of_string_exn "export" ) + , EVar (Javascript.ident Global_constant.global_object_) )) + ; Return_statement (Some (obj generated_js), N), N + ] + N + , true + , AUnknown )) + [ EVar (Javascript.ident Global_constant.global_object_) ] + N + in + obj + [ ( "link" + , 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_targetint (Targetint.of_int_exn 0)) + | Some l -> + EArr + (List.map + ~f:(fun i -> + Javascript.Element + (ENum + (Javascript.Num.of_targetint + (Targetint.of_int_exn i)))) + l)) + ])) + link_spec) ) + ; "generated", generated_js + ; "src", EStr (Utf8_string.of_string_exn (Filename.basename wasm_dir)) + ] + +let source_name i j file = + let prefix = + match i, j with + | None, None -> "src-" + | Some i, None -> Printf.sprintf "src-%d-" i + | None, Some j -> Printf.sprintf "src-%d-" j + | Some i, Some j -> Printf.sprintf "src-%d.%d-" i j + in + prefix ^ Filename.basename file ^ ".json" + +let extract_source_map ~dir ~name z = + if Zip.has_entry z ~name:"source_map.map" + then ( + let sm = Source_map.of_string (Zip.read_entry z ~name:"source_map.map") in + let sm = + let rewrite_path path = + if Filename.is_relative path + then path + else + match Build_path_prefix_map.get_build_path_prefix_map () with + | Some map -> Build_path_prefix_map.rewrite map path + | None -> path + in + Wasm_source_map.insert_source_contents ~rewrite_path sm (fun i j file -> + let name = source_name i j file in + if Zip.has_entry z ~name then Some (Zip.read_entry z ~name) else None) + in + let map_name = name ^ ".wasm.map" in + Source_map.to_file sm (Filename.concat dir map_name); + Wasm_binary.append_source_map_section + ~file:(Filename.concat dir (name ^ ".wasm")) + ~url:map_name) + +let link_to_directory ~files_to_link ~files ~enable_source_maps ~dir = + let process_file z ~name ~name' = + let ch, pos, len, crc = Zip.get_entry z ~name:(name ^ ".wasm") in + let intf = Wasm_binary.read_interface (Wasm_binary.from_channel ~name ch pos len) in + let name' = Printf.sprintf "%s-%08lx" name' crc in + Zip.extract_file + z + ~name:(name ^ ".wasm") + ~file:(Filename.concat dir (name' ^ ".wasm")); + name', intf + in + let z = Zip.open_in (fst (List.hd files)) in + let runtime, runtime_intf = process_file z ~name:"runtime" ~name':"runtime" in + let prelude, _ = process_file z ~name:"prelude" ~name':"prelude" in + Zip.close_in z; + let lst = + List.tl files + |> List.map ~f:(fun (file, _) -> + if StringSet.mem file files_to_link + then ( + let z = Zip.open_in file in + let name' = file |> Filename.basename |> Filename.remove_extension in + let ((name', _) as res) = process_file z ~name:"code" ~name' in + if enable_source_maps then extract_source_map ~dir ~name:name' z; + Zip.close_in z; + Some res) + else None) + |> List.filter_map ~f:(fun x -> x) + in + runtime :: prelude :: List.map ~f:fst lst, (runtime_intf, List.map ~f:snd lst) + +let compute_dependencies ~files_to_link ~files = + let h = Hashtbl.create 128 in + let i = ref 2 in + List.filter_map + ~f:(fun (file, (_, units)) -> + if StringSet.mem file files_to_link + then ( + let s = + List.fold_left + ~f:(fun s { unit_info; _ } -> + StringSet.fold + (fun unit_name s -> + try IntSet.add (Hashtbl.find h unit_name) s with Not_found -> s) + unit_info.requires + s) + ~init:IntSet.empty + units + in + List.iter ~f:(fun { unit_name; _ } -> Hashtbl.add h unit_name !i) units; + incr i; + Some (Some (IntSet.elements s))) + else None) + (List.tl files) + +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 remove_directory path = + try + let files = Sys.readdir path in + Array.iter ~f:(fun file -> Sys.remove (Filename.concat path file)) files; + Sys.rmdir path (* Since OCaml 4.12, so we cannot put this in fs.ml *) + with Sys_error _ -> () + +let gen_dir dir f = + let d_tmp = + Filename.temp_file_name + ~temp_dir:(Filename.dirname dir) + (Filename.basename dir) + ".tmp" + in + try + let res = f d_tmp in + remove_directory dir; + Sys.rename d_tmp dir; + res + with exc -> + remove_directory d_tmp; + raise exc + +let link ~output_file ~linkall ~enable_source_maps ~files = + 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, files_to_link = + List.fold_right + files + ~init:(StringSet.empty, StringSet.empty) + ~f:(fun (file, (build_info, units)) (requires, files_to_link) -> + let cmo_file = + match Build_info.kind build_info with + | `Cmo -> true + | `Cma | `Exe | `Runtime | `Unknown -> false + in + if + (not (Config.Flag.auto_link ())) + || cmo_file + || linkall + || List.exists ~f:(fun { unit_info; _ } -> unit_info.force_link) units + || List.exists + ~f:(fun { unit_info; _ } -> + not (StringSet.is_empty (StringSet.inter requires unit_info.provides))) + units + then + ( List.fold_right units ~init:requires ~f:(fun { unit_info; _ } requires -> + StringSet.diff + (StringSet.union unit_info.requires requires) + unit_info.provides) + , StringSet.add file files_to_link ) + else requires, files_to_link) + in + let _, 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_name; 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 + , unit_name :: to_link ) + else requires, to_link)) + 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_dir, link_spec = + let dir = Filename.chop_extension output_file ^ ".assets" in + gen_dir dir + @@ fun tmp_dir -> + Sys.mkdir tmp_dir 0o777; + let start_module = + "start-" + ^ String.sub + (Digest.to_hex (Digest.string (String.concat ~sep:"/" to_link))) + ~pos:0 + ~len:8 + in + generate_start_function + ~to_link + ~out_file:(Filename.concat tmp_dir (start_module ^ ".wasm")); + let module_names, interfaces = + link_to_directory ~files_to_link ~files ~enable_source_maps ~dir:tmp_dir + in + ( interfaces + , dir + , let to_link = compute_dependencies ~files_to_link ~files in + List.combine module_names (None :: None :: to_link) @ [ start_module, 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_name; strings; fragments; _ } -> + Some unit_name, (strings, fragments))) + in + let runtime_args = + let js = + build_runtime_arguments + ~link_spec + ~separate_compilation:true + ~missing_primitives + ~wasm_dir + ~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 + +let rec get_source_map_files ~tmp_buf files src_index = + let z = Zip.open_in files.(!src_index) in + incr src_index; + let l = ref [] in + (if Zip.has_entry z ~name:"source_map.map" + then + let data = Zip.read_entry z ~name:"source_map.map" in + let sm = Source_map.Standard.of_string ~tmp_buf data in + if not (Wasm_source_map.is_empty sm) + then + Wasm_source_map.iter_sources (Standard sm) (fun i j file -> + l := source_name i j file :: !l)); + if not (List.is_empty !l) + then z, Array.of_list (List.rev !l) + else ( + Zip.close_in z; + get_source_map_files ~tmp_buf files src_index) + +let add_source_map files z sm = + let tmp_buf = Buffer.create 10000 in + Zip.add_entry z ~name:"source_map.map" ~contents:(Source_map.to_string sm); + let files = Array.of_list files in + let src_index = ref 0 in + let st = ref None in + let finalize () = + match !st with + | Some (_, (z', _)) -> Zip.close_in z' + | None -> () + in + Wasm_source_map.iter_sources sm (fun i j file -> + let z', files = + match !st with + | Some (i', st) when Poly.equal i i' -> st + | _ -> + let st' = get_source_map_files ~tmp_buf files src_index in + finalize (); + st := Some (i, st'); + st' + in + if Array.length files > 0 (* Source has source map *) + then + let name = files.(Option.value ~default:0 j) in + if Zip.has_entry z' ~name + then Zip.copy_file z' z ~src_name:name ~dst_name:(source_name i j file)); + finalize () + +let make_library ~output_file ~enable_source_maps ~files = + let info = + List.map files ~f:(fun file -> + let build_info, _predefined_exceptions, unit_data = + Zip.with_open_in file read_info + in + (match Build_info.kind build_info with + | `Cmo -> () + | `Runtime | `Cma | `Exe | `Unknown -> + failwith (Printf.sprintf "File '%s' is not a .wasmo file." file)); + file, build_info, unit_data) + in + let build_info = + Build_info.with_kind + (match info with + | (file, bi, _) :: r -> + Build_info.configure bi; + List.fold_left + ~init:bi + ~f:(fun bi (file', bi', _) -> Build_info.merge file bi file' bi') + r + | [] -> Build_info.create `Cma) + `Cma + in + let unit_data = List.concat (List.map ~f:(fun (_, _, unit_data) -> unit_data) info) in + Fs.gen_file output_file + @@ fun tmp_output_file -> + let z = Zip.open_out tmp_output_file in + add_info z ~build_info ~unit_data (); + Fs.with_intermediate_file (Filename.temp_file "wasm" ".wasm") + @@ fun tmp_wasm_file -> + let output_sourcemap = + Wasm_link.f + (let tmp_buf = Buffer.create 10000 in + List.map + ~f:(fun file -> + let z' = Zip.open_in file in + { Wasm_link.module_name = "OCaml" + ; file + ; code = Some (Zip.read_entry z' ~name:"code.wasm") + ; opt_source_map = + (if enable_source_maps && Zip.has_entry z' ~name:"source_map.map" + then + Some + (Source_map.Standard.of_string + ~tmp_buf + (Zip.read_entry z' ~name:"source_map.map")) + else None) + }) + files) + ~output_file:tmp_wasm_file + in + Zip.add_file z ~name:"code.wasm" ~file:tmp_wasm_file; + if enable_source_maps then add_source_map files z output_sourcemap; + Zip.close_out z + +let link ~output_file ~linkall ~mklib ~enable_source_maps ~files = + try + if mklib + then make_library ~output_file ~enable_source_maps ~files + else 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/link.mli b/compiler/lib-wasm/link.mli new file mode 100644 index 0000000000..9ad39a4244 --- /dev/null +++ b/compiler/lib-wasm/link.mli @@ -0,0 +1,69 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Stdlib + +module Wasm_binary : sig + type import = + { module_ : string + ; name : string + } + + val read_imports : file:string -> import list + + val append_source_map_section : file:string -> url:string -> unit +end + +type unit_data = + { unit_name : string + ; 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 : + link_spec:(string * int list option) list + -> separate_compilation:bool + -> missing_primitives:string list + -> wasm_dir:string + -> generated_js: + (string option * (string list * (string * Javascript.expression) list)) list + -> unit + -> Javascript.expression + +val output_js : Javascript.program -> string + +val link : + output_file:string + -> linkall:bool + -> mklib:bool + -> enable_source_maps:bool + -> files:string list + -> unit + +val source_name : int option -> int option -> string -> string + +val gen_dir : string -> (string -> 'a) -> 'a diff --git a/compiler/lib-wasm/sexp.ml b/compiler/lib-wasm/sexp.ml new file mode 100644 index 0000000000..78d6f5c521 --- /dev/null +++ b/compiler/lib-wasm/sexp.ml @@ -0,0 +1,171 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Stdlib + +type t = + | Atom of string + | List of t list + +let reserved_char c = + match c with + | '\x00' .. ' ' | '(' | ')' | '#' | ';' | '"' | '\x7f' .. '\xff' -> true + | _ -> false + +let need_escaping s = + let len = String.length s in + len = 0 + || + let res = ref false in + for i = 0 to len - 1 do + res := !res || reserved_char s.[i] + done; + !res + +let should_quote c = + match c with + | '\x00' .. '\x1F' | '"' | '\\' | '\x7f' .. '\xff' -> true + | _ -> false + +let escape_to_buffer buf s = + let start = ref 0 in + let len = String.length s in + Buffer.add_char buf '"'; + for i = 0 to len - 1 do + let c = s.[i] in + if should_quote c + then ( + if !start < i then Buffer.add_substring buf s !start (i - !start); + Buffer.add_char buf '\\'; + let c = Char.code c in + Buffer.add_uint8 buf ((c / 100) + 48); + Buffer.add_uint8 buf ((c / 10 mod 10) + 48); + Buffer.add_uint8 buf ((c mod 10) + 48); + start := i + 1) + done; + if !start < len then Buffer.add_substring buf s !start (len - !start); + Buffer.add_char buf '"' + +let rec add_to_buffer buf v = + match v with + | Atom s -> if need_escaping s then escape_to_buffer buf s else Buffer.add_string buf s + | List l -> + Buffer.add_char buf '('; + List.iteri + ~f:(fun i v' -> + if i > 0 then Buffer.add_char buf ' '; + add_to_buffer buf v') + l; + Buffer.add_char buf ')' + +let to_string v = + let b = Buffer.create 128 in + add_to_buffer b v; + Buffer.contents b + +let parse_error () = failwith "parse error" + +let rec parse buf s pos : t * int = + match s.[pos] with + | '(' -> parse_list buf s [] (pos + 1) + | '\"' -> + Buffer.clear buf; + parse_quoted_atom buf s (pos + 1) (pos + 1) + | _ -> parse_atom buf s pos pos + +and parse_list buf s acc pos = + match s.[pos] with + | ' ' -> parse_list buf s acc (pos + 1) + | ')' -> List (List.rev acc), pos + 1 + | _ -> + let v, pos' = parse buf s pos in + parse_list buf s (v :: acc) pos' + +and parse_atom buf s pos0 pos = + if reserved_char s.[pos] + then ( + if pos0 = pos then parse_error (); + Atom (String.sub s ~pos:pos0 ~len:(pos - pos0)), pos) + else parse_atom buf s pos0 (pos + 1) + +and parse_quoted_atom buf s pos0 pos = + match s.[pos] with + | '\"' -> + if pos0 < pos then Buffer.add_substring buf s pos0 (pos - pos0); + Atom (Buffer.contents buf), pos + 1 + | '\\' -> + if pos0 < pos then Buffer.add_substring buf s pos0 (pos - pos0); + Buffer.add_uint8 + buf + (((Char.code s.[pos + 1] - 48) * 100) + + ((Char.code s.[pos + 2] - 48) * 10) + + Char.code s.[pos + 3] + - 48); + parse_quoted_atom buf s (pos + 4) (pos + 4) + | _ -> parse_quoted_atom buf s pos0 (pos + 1) + +let from_string s = + let v, pos = parse (Buffer.create 16) s 0 in + if pos < String.length s then parse_error (); + v + +module Util = struct + let single f v = + match v with + | [ v ] -> f v + | _ -> invalid_arg "Sexp.Util.single" + + let string v = + match v with + | Atom s -> s + | _ -> invalid_arg "Sexp.Util.string" + + let assoc v = + let invalid_arg () = invalid_arg "Sexp.Util.assoc" in + match v with + | List l -> + List.map + ~f:(fun p -> + match p with + | List (Atom k :: v) -> k, v + | _ -> invalid_arg ()) + l + | Atom _ -> invalid_arg () + + let member nm v = + match v with + | Atom _ -> invalid_arg "Sexp.Util.member" + | List l -> + List.find_map + ~f:(fun p -> + match p with + | List (Atom nm' :: v) when String.equal nm nm' -> Some v + | _ -> None) + l + + let bool v = + match v with + | Atom "true" -> true + | Atom "false" -> false + | _ -> invalid_arg "Sexp.Util.bool" + + let mandatory f v = + match v with + | Some v -> f v + | None -> invalid_arg "Sexp.Util.mandatory" +end diff --git a/compiler/lib-wasm/sexp.mli b/compiler/lib-wasm/sexp.mli new file mode 100644 index 0000000000..41d5fd173f --- /dev/null +++ b/compiler/lib-wasm/sexp.mli @@ -0,0 +1,39 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +type t = + | Atom of string + | List of t list + +val to_string : t -> string + +val from_string : string -> t + +module Util : sig + val single : (t -> 'a) -> t list -> 'a + + val mandatory : (t list -> 'a) -> t list option -> 'a + + val string : t -> string + + val bool : t -> bool + + val assoc : t -> (string * t list) list + + val member : string -> t -> t list option +end diff --git a/compiler/lib-wasm/tail_call.ml b/compiler/lib-wasm/tail_call.ml new file mode 100644 index 0000000000..dfaadad9da --- /dev/null +++ b/compiler/lib-wasm/tail_call.ml @@ -0,0 +1,81 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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! Stdlib + +let get_return ~tail i = + match i with + | Wasm_ast.Return (Some (LocalGet y)) -> Some y + | Push (LocalGet y) when tail -> Some y + | _ -> None + +let rewrite_tail_call ~y i = + match i with + | Wasm_ast.LocalSet (x, Call (symb, l)) when Code.Var.equal x y -> + Some (Wasm_ast.Return_call (symb, l)) + | LocalSet (x, Call_ref (ty, e, l)) when Code.Var.equal x y -> + Some (Return_call_ref (ty, e, l)) + | _ -> None + +let rec instruction ~tail i = + match i with + | Wasm_ast.Loop (ty, l) -> Wasm_ast.Loop (ty, instructions ~tail l) + | Block (ty, l) -> Block (ty, instructions ~tail l) + | If (ty, e, l1, l2) -> If (ty, e, instructions ~tail l1, instructions ~tail l2) + | Return (Some (Call (symb, l))) -> Return_call (symb, l) + | Return (Some (Call_ref (ty, e, l))) -> Return_call_ref (ty, e, l) + | Push (Call (symb, l)) when tail -> Return_call (symb, l) + | Push (Call_ref (ty, e, l)) when tail -> Return_call_ref (ty, e, l) + | Push (Call_ref _) -> i + | Drop (BlockExpr (typ, l)) -> Drop (BlockExpr (typ, instructions ~tail:false l)) + | Drop _ + | LocalSet _ + | GlobalSet _ + | Br_table _ + | Br _ + | Br_if _ + | Return _ + | Throw _ + | Rethrow _ + | CallInstr _ + | Nop + | Push _ + | ArraySet _ + | StructSet _ + | Return_call _ + | Return_call_ref _ + | Event _ -> i + +and instructions ~tail l = + match l with + | [] -> [] + | [ i ] -> [ instruction ~tail i ] + | i :: Nop :: rem -> instructions ~tail (i :: rem) + | i :: i' :: Nop :: rem -> instructions ~tail (i :: i' :: rem) + | i :: i' :: (([] | [ Event _ ]) as event_opt) -> ( + (* There can be an event at the end of the function, which we + should keep. *) + match get_return ~tail i' with + | None -> instruction ~tail:false i :: instruction ~tail i' :: event_opt + | Some y -> ( + match rewrite_tail_call ~y i with + | None -> instruction ~tail:false i :: instruction ~tail i' :: event_opt + | Some i'' -> i'' :: event_opt)) + | i :: rem -> instruction ~tail:false i :: instructions ~tail rem + +let f l = instructions ~tail:true l diff --git a/compiler/lib-wasm/tail_call.mli b/compiler/lib-wasm/tail_call.mli new file mode 100644 index 0000000000..2bcf526ae2 --- /dev/null +++ b/compiler/lib-wasm/tail_call.mli @@ -0,0 +1,19 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 f : Wasm_ast.instruction list -> Wasm_ast.instruction list diff --git a/compiler/lib-wasm/target_sig.ml b/compiler/lib-wasm/target_sig.ml new file mode 100644 index 0000000000..227da6d972 --- /dev/null +++ b/compiler/lib-wasm/target_sig.ml @@ -0,0 +1,274 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +module type S = sig + type expression = Code_generation.expression + + module Memory : sig + val allocate : + tag:int + -> deadcode_sentinal:Code.Var.t + -> [ `Expr of Wasm_ast.expression | `Var of Wasm_ast.var ] list + -> expression + + val load_function_pointer : + cps:bool + -> arity:int + -> ?skip_cast:bool + -> expression + -> (Wasm_ast.var * Wasm_ast.expression) Code_generation.t + + val load_real_closure : + cps:bool + -> arity:int + -> expression + -> (Wasm_ast.var * Wasm_ast.expression) Code_generation.t + + val check_function_arity : + Code.Var.t + -> cps:bool + -> arity:int + -> (typ:Wasm_ast.value_type option -> expression -> expression) + -> unit Code_generation.t + -> unit Code_generation.t + + val tag : expression -> expression + + val field : expression -> int -> expression + + val set_field : expression -> int -> expression -> unit Code_generation.t + + val array_get : expression -> expression -> expression + + val array_set : expression -> expression -> expression -> unit Code_generation.t + + val float_array_get : expression -> expression -> expression + + val float_array_set : expression -> expression -> expression -> unit Code_generation.t + + val gen_array_get : expression -> expression -> expression + + val gen_array_set : expression -> expression -> expression -> unit Code_generation.t + + val array_length : expression -> expression + + val float_array_length : expression -> expression + + val gen_array_length : expression -> expression + + val bytes_length : expression -> expression + + val bytes_get : expression -> expression -> expression + + val bytes_set : expression -> expression -> expression -> unit Code_generation.t + + val box_float : expression -> expression + + val unbox_float : expression -> expression + + val box_int32 : expression -> expression + + val unbox_int32 : expression -> expression + + val box_int64 : expression -> expression + + val unbox_int64 : expression -> expression + + val box_nativeint : expression -> expression + + val unbox_nativeint : expression -> expression + end + + module Value : sig + val value : Wasm_ast.value_type + + val unit : expression + + val val_int : expression -> expression + + val int_val : expression -> expression + + val check_is_not_zero : expression -> expression + (** Returns an int32 value *) + + val check_is_int : expression -> expression + (** Returns an int32 value *) + + val not : expression -> expression + + val lt : expression -> expression -> expression + + val le : expression -> expression -> expression + + val eq : expression -> expression -> expression + + val neq : expression -> expression -> expression + + val ult : expression -> expression -> expression + + val is_int : expression -> expression + + val int_add : expression -> expression -> expression + + val int_sub : expression -> expression -> expression + + val int_mul : expression -> expression -> expression + + val int_div : expression -> expression -> expression + + val int_mod : expression -> expression -> expression + + val int_neg : expression -> expression + + val int_or : expression -> expression -> expression + + val int_and : expression -> expression -> expression + + val int_xor : expression -> expression -> expression + + val int_lsl : expression -> expression -> expression + + val int_lsr : expression -> expression -> expression + + val int_asr : expression -> expression -> expression + + val block_type : Wasm_ast.value_type Code_generation.t + + val dummy_block : expression + + val as_block : expression -> expression + end + + module Constant : sig + val translate : Code.constant -> expression + end + + module Closure : sig + val translate : + context:Code_generation.context + -> closures:Closure_conversion.closure Code.Var.Map.t + -> cps:bool + -> Code.Var.t + -> expression + + val bind_environment : + context:Code_generation.context + -> closures:Closure_conversion.closure Code.Var.Map.t + -> cps:bool + -> Code.Var.t + -> unit Code_generation.t + + val curry_allocate : + cps:bool + -> arity:int + -> int + -> f:Code.Var.t + -> closure:Code.Var.t + -> arg:Code.Var.t + -> Wasm_ast.expression Code_generation.t + + val curry_load : + cps:bool + -> arity:int + -> int + -> Code.Var.t + -> (expression * expression * Wasm_ast.value_type option) Code_generation.t + + val dummy : cps:bool -> arity:int -> Wasm_ast.expression Code_generation.t + end + + module Math : sig + val cos : expression -> expression + + val sin : expression -> expression + + val tan : expression -> expression + + val acos : expression -> expression + + val asin : expression -> expression + + val atan : expression -> expression + + val atan2 : expression -> expression -> expression + + val cosh : expression -> expression + + val sinh : expression -> expression + + val tanh : expression -> expression + + val acosh : expression -> expression + + val asinh : expression -> expression + + val atanh : expression -> expression + + val cbrt : expression -> expression + + val exp : expression -> expression + + val exp2 : expression -> expression + + val log : expression -> expression + + val expm1 : expression -> expression + + val log1p : expression -> expression + + val log2 : expression -> expression + + val log10 : expression -> expression + + val hypot : expression -> expression -> expression + + val power : expression -> expression -> expression + + val fmod : expression -> expression -> expression + + val round : expression -> expression + end + + val internal_primitives : + (string, (Code.prim_arg -> expression) -> Code.prim_arg list -> expression) Hashtbl.t + + val handle_exceptions : + result_typ:Wasm_ast.value_type list + -> fall_through:'a + -> context:([> `Catch | `Skip ] as 'b) list + -> ( result_typ:Wasm_ast.value_type list + -> fall_through:[> `Skip ] + -> context:'b list + -> unit Code_generation.t) + -> Wasm_ast.var + -> ( result_typ:Wasm_ast.value_type list + -> fall_through:'a + -> context:'b list + -> unit Code_generation.t) + -> unit Code_generation.t + + val post_process_function_body : + param_names:Wasm_ast.var list + -> locals:(Wasm_ast.var * Wasm_ast.value_type) list + -> Wasm_ast.instruction list + -> Wasm_ast.instruction list + + val entry_point : + toplevel_fun:Wasm_ast.var + -> Wasm_ast.func_type * Wasm_ast.var list * unit Code_generation.t +end diff --git a/compiler/lib-wasm/wasm_ast.ml b/compiler/lib-wasm/wasm_ast.ml new file mode 100644 index 0000000000..a23addc4a2 --- /dev/null +++ b/compiler/lib-wasm/wasm_ast.ml @@ -0,0 +1,233 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +type var = Code.Var.t + +type packed_type = + | I8 + | I16 + +type heap_type = + | Func + | Extern + | Any + | Eq + | I31 + | Type of var + +type ref_type = + { nullable : bool + ; typ : heap_type + } + +type value_type = + | I32 + | I64 + | F32 + | F64 + | Ref of ref_type + +type storage_type = + | Value of value_type + | Packed of packed_type + +type 'typ mut_type = + { mut : bool + ; typ : 'typ + } + +type field_type = storage_type mut_type + +type global_type = value_type mut_type + +type func_type = + { params : value_type list + ; result : value_type list + } + +type str_type = + | Struct of field_type list + | Array of field_type + | Func of func_type + +type ('i32, 'i64, 'f32, 'f64) op = + | I32 of 'i32 + | I64 of 'i64 + | F32 of 'f32 + | F64 of 'f64 + +type signage = + | S + | U + +type int_un_op = + | Clz + | Ctz + | Popcnt + | Eqz + | TruncSatF64 of signage + | ReinterpretF + +type int_bin_op = + | Add + | Sub + | Mul + | Div of signage + | Rem of signage + | And + | Or + | Xor + | Shl + | Shr of signage + | Rotl + | Rotr + | Eq + | Ne + | Lt of signage + | Gt of signage + | Le of signage + | Ge of signage + +type float_un_op = + | Neg + | Abs + | Ceil + | Floor + | Trunc + | Nearest + | Sqrt + | Convert of [ `I32 | `I64 ] * signage + | ReinterpretI + +type float_bin_op = + | Add + | Sub + | Mul + | Div + | Min + | Max + | CopySign + | Eq + | Ne + | Lt + | Gt + | Le + | Ge + +type memarg = int32 + +type expression = + | Const of (int32, int64, float, float) op + | UnOp of (int_un_op, int_un_op, float_un_op, float_un_op) op * expression + | BinOp of + (int_bin_op, int_bin_op, float_bin_op, float_bin_op) op * expression * expression + | I32WrapI64 of expression + | I64ExtendI32 of signage * expression + | F32DemoteF64 of expression + | F64PromoteF32 of expression + | LocalGet of var + | LocalTee of var * expression + | GlobalGet of var + | BlockExpr of func_type * instruction list + | Call of var * expression list + | Seq of instruction list * expression + | Pop of value_type + | RefFunc of var + | Call_ref of var * expression * expression list + | RefI31 of expression + | I31Get of signage * expression + | ArrayNew of var * expression * expression + | ArrayNewFixed of var * expression list + | ArrayNewData of var * var * expression * expression + | ArrayGet of signage option * var * expression * expression + | ArrayLen of expression + | StructNew of var * expression list + | StructGet of signage option * var * int * expression + | RefCast of ref_type * expression + | RefTest of ref_type * expression + | RefEq of expression * expression + | RefNull of heap_type + | Br_on_cast of int * ref_type * ref_type * expression + | Br_on_cast_fail of int * ref_type * ref_type * expression + | IfExpr of value_type * expression * expression * expression + | Try of func_type * instruction list * (var * int * value_type) list + +and instruction = + | Drop of expression + | LocalSet of var * expression + | GlobalSet of var * expression + | Loop of func_type * instruction list + | Block of func_type * instruction list + | If of func_type * expression * instruction list * instruction list + | Br_table of expression * int list * int + | Br of int * expression option + | Br_if of int * expression + | Return of expression option + | CallInstr of var * expression list + | Nop + | Push of expression + | Throw of var * expression + | Rethrow of int + | ArraySet of var * expression * expression * expression + | StructSet of var * int * expression * expression + | Return_call of var * expression list + | Return_call_ref of var * expression * expression list + | Event of Parse_info.t (** Location information *) + +type import_desc = + | Fun of func_type + | Global of global_type + | Tag of value_type + +type type_field = + { name : var + ; typ : str_type + ; supertype : var option + ; final : bool + } + +type module_field = + | Function of + { name : var + ; exported_name : string option + ; typ : func_type + ; param_names : var list + ; locals : (var * value_type) list + ; body : instruction list + } + | Data of + { name : var + ; contents : string + } + | Global of + { name : var + ; exported_name : string option + ; typ : global_type + ; init : expression + } + | Tag of + { name : var + ; typ : value_type + } + | Import of + { import_module : string + ; import_name : string + ; name : var + ; desc : import_desc + } + | Type of type_field list diff --git a/compiler/lib-wasm/wasm_link.ml b/compiler/lib-wasm/wasm_link.ml new file mode 100644 index 0000000000..c3a84b2e05 --- /dev/null +++ b/compiler/lib-wasm/wasm_link.ml @@ -0,0 +1,2451 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Stdlib + +type heaptype = + | Func + | Nofunc + | Extern + | Noextern + | Any + | Eq + | I31 + | Struct + | Array + | None_ + | Type of int + +type reftype = + { nullable : bool + ; typ : heaptype + } + +type valtype = + | I32 + | I64 + | F32 + | F64 + | V128 + | Ref of reftype + +type packedtype = + | I8 + | I16 + +type storagetype = + | Val of valtype + | Packed of packedtype + +type 'ty mut = + { mut : bool + ; typ : 'ty + } + +type fieldtype = storagetype mut + +type comptype = + | Func of + { params : valtype array + ; results : valtype array + } + | Struct of fieldtype array + | Array of fieldtype + +type subtype = + { final : bool + ; supertype : int option + ; typ : comptype + } + +type rectype = subtype array + +type limits = + { min : int + ; max : int option + ; shared : bool + ; index_type : [ `I32 | `I64 ] + } + +type tabletype = + { limits : limits + ; typ : reftype + } + +type importdesc = + | Func of int + | Table of tabletype + | Mem of limits + | Global of valtype mut + | Tag of int + +type import = + { module_ : string + ; name : string + ; desc : importdesc + } + +type exportable = + | Func + | Table + | Mem + | Global + | Tag + +let rec output_uint ch i = + if i < 128 + then output_byte ch i + else ( + output_byte ch (128 + (i land 127)); + output_uint ch (i lsr 7)) + +module Write = struct + type st = { mutable type_index_count : int } + + let byte ch b = Buffer.add_char ch (Char.chr b) + + let string ch s = Buffer.add_string ch s + + let rec sint ch i = + if i >= -64 && i < 64 + then byte ch (i land 127) + else ( + byte ch (128 + (i land 127)); + sint ch (i asr 7)) + + let rec uint ch i = + if i < 128 + then byte ch i + else ( + byte ch (128 + (i land 127)); + uint ch (i lsr 7)) + + let vec f ch l = + uint ch (Array.length l); + Array.iter ~f:(fun x -> f ch x) l + + let name ch name = + uint ch (String.length name); + string ch name + + let typeidx st idx = if idx < 0 then lnot idx + st.type_index_count else idx + + let heaptype st ch typ = + match (typ : heaptype) with + | Nofunc -> byte ch 0x73 + | Noextern -> byte ch 0x72 + | None_ -> byte ch 0x71 + | Func -> byte ch 0x70 + | Extern -> byte ch 0x6F + | Any -> byte ch 0x6E + | Eq -> byte ch 0x6D + | I31 -> byte ch 0x6C + | Struct -> byte ch 0x6B + | Array -> byte ch 0x6A + | Type idx -> sint ch (typeidx st idx) + + let reftype st ch { nullable; typ } = + (match nullable, typ with + | false, _ -> byte ch 0x64 + | true, Type _ -> byte ch 0x63 + | _ -> ()); + heaptype st ch typ + + let valtype st ch (typ : valtype) = + match typ with + | I32 -> byte ch 0x7F + | I64 -> byte ch 0x7E + | F32 -> byte ch 0x7D + | F64 -> byte ch 0x7C + | V128 -> byte ch 0x7B + | Ref typ -> reftype st ch typ + + let mutability ch mut = byte ch (if mut then 0x01 else 0x00) + + let fieldtype st ch { mut; typ } = + (match typ with + | Val typ -> valtype st ch typ + | Packed typ -> ( + match typ with + | I8 -> byte ch 0x78 + | I16 -> byte ch 0x77)); + mutability ch mut + + let functype st ch params results = + byte ch 0x60; + vec (valtype st) ch params; + vec (valtype st) ch results + + let subtype st ch { final; supertype; typ } = + (match supertype, final with + | None, true -> () + | None, false -> + byte ch 0x50; + byte ch 0 + | Some supertype, _ -> + byte ch (if final then 0X4F else 0x50); + byte ch 1; + uint ch (typeidx st supertype)); + match typ with + | Array field_type -> + byte ch 0x5E; + fieldtype st ch field_type + | Struct l -> + byte ch 0x5F; + vec (fieldtype st) ch l + | Func { params; results } -> functype st ch params results + + let rectype st ch l = + let len = Array.length l in + if len > 1 + then ( + byte ch 0x4E; + uint ch len); + Array.iter ~f:(subtype st ch) l; + st.type_index_count <- st.type_index_count + len + + let types ch l = + let st = { type_index_count = 0 } in + vec (rectype st) ch l; + st + + let limits ch { min; max; shared; index_type } = + let kind = + (if Option.is_none max then 0 else 1) + + (if shared then 2 else 0) + + + match index_type with + | `I64 -> 4 + | `I32 -> 0 + in + byte ch kind; + uint ch min; + Option.iter ~f:(uint ch) max + + let globaltype st ch mut typ = + valtype st ch typ; + mutability ch mut + + let tabletype st ch { limits = l; typ } = + reftype st ch typ; + limits ch l + + let imports st ch imports = + vec + (fun ch { module_; name = nm; desc } -> + name ch module_; + name ch nm; + match desc with + | Func typ -> + byte ch 0x00; + uint ch typ + | Table typ -> + byte ch 0x01; + tabletype st ch typ + | Mem l -> + byte ch 0x03; + limits ch l + | Global { mut; typ } -> + byte ch 0x03; + globaltype st ch mut typ + | Tag typ -> + byte ch 0x04; + byte ch 0x00; + uint ch typ) + ch + imports + + let functions = vec uint + + let memtype = limits + + let memories = vec memtype + + let export ch kind nm idx = + name ch nm; + byte + ch + (match kind with + | Func -> 0 + | Table -> 1 + | Mem -> 2 + | Global -> 3 + | Tag -> 4); + uint ch idx + + let start = uint + + let tag ch tag = + byte ch 0; + uint ch tag + + let tags = vec tag + + let data_count = uint + + let nameassoc ch idx nm = + uint ch idx; + name ch nm + + let namemap = vec (fun ch (idx, name) -> nameassoc ch idx name) +end + +type 'a exportable_info = + { mutable func : 'a + ; mutable table : 'a + ; mutable mem : 'a + ; mutable global : 'a + ; mutable tag : 'a + } + +let iter_exportable_info f { func; table; mem; global; tag } = + f Func func; + f Table table; + f Mem mem; + f Global global; + f Tag tag + +let map_exportable_info f { func; table; mem; global; tag } = + { func = f Func func + ; table = f Table table + ; mem = f Mem mem + ; global = f Global global + ; tag = f Tag tag + } + +let fold_exportable_info f acc { func; table; mem; global; tag } = + acc |> f Func func |> f Table table |> f Mem mem |> f Global global |> f Tag tag + +let init_exportable_info f = + { func = f (); table = f (); mem = f (); global = f (); tag = f () } + +let make_exportable_info v = init_exportable_info (fun _ -> v) + +let exportable_kind d = + match d with + | 0 -> Func + | 1 -> Table + | 2 -> Mem + | 3 -> Global + | 4 -> Tag + | _ -> assert false + +let get_exportable_info info kind = + match kind with + | Func -> info.func + | Table -> info.table + | Mem -> info.mem + | Global -> info.global + | Tag -> info.tag + +let set_exportable_info info kind v = + match kind with + | Func -> info.func <- v + | Table -> info.table <- v + | Mem -> info.mem <- v + | Global -> info.global <- v + | Tag -> info.tag <- v + +module Read = struct + let header = "\000asm\001\000\000\000" + + let check_header file contents = + if + String.length contents < 8 + || not (String.equal header (String.sub contents ~pos:0 ~len:8)) + then failwith (file ^ " is not a Wasm binary file (bad magic)") + + type ch = + { buf : string + ; mutable pos : int + ; limit : int + } + + let pos_in ch = ch.pos + + let seek_in ch pos = ch.pos <- pos + + let input_byte ch = + let pos = ch.pos in + ch.pos <- pos + 1; + Char.code ch.buf.[pos] + + let peek_byte ch = Char.code ch.buf.[ch.pos] + + let really_input_string ch len = + let pos = ch.pos in + ch.pos <- pos + len; + String.sub ch.buf ~pos ~len + + let rec uint ?(n = 5) ch = + let i = input_byte ch in + if n = 1 then assert (i < 16); + if i < 128 then i else i - 128 + (uint ~n:(n - 1) ch lsl 7) + + let rec sint ?(n = 5) ch = + let i = input_byte ch in + if n = 1 then assert (i < 8 || (i > 120 && i < 128)); + if i < 64 then i else if i < 128 then i - 128 else i - 128 + (sint ~n:(n - 1) ch lsl 7) + + let repeat n f ch = Array.init n ~f:(fun _ -> f ch) + + let vec f ch = repeat (uint ch) f ch + + let repeat' n f ch = + for _ = 1 to n do + f ch + done + + let vec' f ch = repeat' (uint ch) f ch + + let name ch = really_input_string ch (uint ch) + + type section = + { id : int + ; pos : int + ; size : int + } + + type index = + { sections : (int, section) Hashtbl.t + ; custom_sections : (string, section) Hashtbl.t + } + + let next_section ch = + if pos_in ch = ch.limit + then None + else + let id = input_byte ch in + let size = uint ch in + Some { id; pos = pos_in ch; size } + + let skip_section ch { pos; size; _ } = seek_in ch (pos + size) + + let index ch = + let index = { sections = Hashtbl.create 16; custom_sections = Hashtbl.create 16 } in + let rec loop () = + match next_section ch with + | None -> index + | Some sect -> + if sect.id = 0 + then Hashtbl.add index.custom_sections (name ch) sect + else Hashtbl.add index.sections sect.id sect; + skip_section ch sect; + loop () + in + loop () + + type t = + { ch : ch + ; mutable type_mapping : int array + ; mutable type_index_count : int + ; index : index + } + + let open_in f buf = + check_header f buf; + let ch = { buf; pos = 8; limit = String.length buf } in + { ch; type_mapping = [||]; type_index_count = 0; index = index ch } + + let find_section contents n = + match Hashtbl.find contents.index.sections n with + | { pos; _ } -> + seek_in contents.ch pos; + true + | exception Not_found -> false + + let get_custom_section contents name = + Hashtbl.find_opt contents.index.custom_sections name + + let focus_on_custom_section contents section = + let pos, limit = + match get_custom_section contents section with + | Some { pos; size; _ } -> pos, pos + size + | None -> 0, 0 + in + let ch = { buf = contents.ch.buf; pos; limit } in + if limit > 0 then ignore (name ch); + { contents with index = index ch } + + module RecTypeTbl = Hashtbl.Make (struct + type t = rectype + + let hash t = + (* We have large structs, that tend to hash to the same value *) + Hashtbl.hash_param 15 100 t + + let heaptype_eq t1 t2 = + Stdlib.phys_equal t1 t2 + || + match t1, t2 with + | Type i1, Type i2 -> i1 = i2 + | _ -> false + + let reftype_eq { nullable = n1; typ = t1 } { nullable = n2; typ = t2 } = + Bool.(n1 = n2) && heaptype_eq t1 t2 + + let valtype_eq t1 t2 = + Stdlib.phys_equal t1 t2 + || + match t1, t2 with + | Ref t1, Ref t2 -> reftype_eq t1 t2 + | _ -> false + + let storagetype_eq t1 t2 = + match t1, t2 with + | Val v1, Val v2 -> valtype_eq v1 v2 + | Packed p1, Packed p2 -> Stdlib.phys_equal p1 p2 + | _ -> false + + let fieldtype_eq { mut = m1; typ = t1 } { mut = m2; typ = t2 } = + Bool.(m1 = m2) && storagetype_eq t1 t2 + + (* Does not allocate and return false on length mismatch *) + let array_for_all2 p a1 a2 = + let n1 = Array.length a1 and n2 = Array.length a2 in + n1 = n2 + && + let rec loop p a1 a2 n1 i = + i = n1 || (p a1.(i) a2.(i) && loop p a1 a2 n1 (succ i)) + in + loop p a1 a2 n1 0 + + let comptype_eq (t1 : comptype) (t2 : comptype) = + match t1, t2 with + | Func { params = p1; results = r1 }, Func { params = p2; results = r2 } -> + array_for_all2 valtype_eq p1 p2 && array_for_all2 valtype_eq r1 r2 + | Struct l1, Struct l2 -> array_for_all2 fieldtype_eq l1 l2 + | Array f1, Array f2 -> fieldtype_eq f1 f2 + | _ -> false + + let subtype_eq + { final = f1; supertype = s1; typ = t1 } + { final = f2; supertype = s2; typ = t2 } = + Bool.(f1 = f2) + && (match s1, s2 with + | Some _, None | None, Some _ -> false + | None, None -> true + | Some i1, Some i2 -> i1 = i2) + && comptype_eq t1 t2 + + let equal t1 t2 = + match t1, t2 with + | [| t1 |], [| t2 |] -> subtype_eq t1 t2 + | _ -> array_for_all2 subtype_eq t1 t2 + end) + + type types = + { types : int RecTypeTbl.t + ; mutable last_index : int + ; mutable rev_list : rectype list + } + + let create_types () = { types = RecTypeTbl.create 2000; last_index = 0; rev_list = [] } + + let add_rectype types typ = + try RecTypeTbl.find types.types typ + with Not_found -> + let index = types.last_index in + RecTypeTbl.add types.types typ index; + types.last_index <- Array.length typ + index; + types.rev_list <- typ :: types.rev_list; + index + + let heaptype st ch = + let i = sint ch in + match i + 128 with + | 0X73 -> Nofunc + | 0x72 -> Noextern + | 0x71 -> None_ + | 0x70 -> Func + | 0x6F -> Extern + | 0x6E -> Any + | 0x6D -> Eq + | 0x6C -> I31 + | 0x6B -> Struct + | 0x6A -> Array + | _ -> + if i < 0 then failwith (Printf.sprintf "Unknown heaptype %x@." i); + let i = + if i >= st.type_index_count + then lnot (i - st.type_index_count) + else st.type_mapping.(i) + in + Type i + + let nullable typ = { nullable = true; typ } + + let ref_eq = { nullable = false; typ = Eq } + + let ref_i31 = { nullable = false; typ = I31 } + + let reftype' st i ch = + match i with + | 0X73 -> nullable Nofunc + | 0x72 -> nullable Noextern + | 0x71 -> nullable None_ + | 0x70 -> nullable Func + | 0x6F -> nullable Extern + | 0x6E -> nullable Any + | 0x6D -> nullable Eq + | 0x6C -> nullable I31 + | 0x6B -> nullable Struct + | 0x6A -> nullable Array + | 0x63 -> nullable (heaptype st ch) + | 0x64 -> { nullable = false; typ = heaptype st ch } + | _ -> failwith (Printf.sprintf "Unknown reftype %x@." i) + + let reftype st ch = reftype' st (input_byte ch) ch + + let ref_i31 = Ref ref_i31 + + let ref_eq = Ref ref_eq + + let valtype' st i ch = + match i with + | 0x7B -> V128 + | 0x7C -> F64 + | 0x7D -> F32 + | 0x7E -> I64 + | 0x7F -> I32 + | 0x64 -> ( + match peek_byte ch with + | 0x6C -> + ignore (input_byte ch); + ref_i31 + | 0x6D -> + ignore (input_byte ch); + ref_eq + | _ -> Ref { nullable = false; typ = heaptype st ch }) + | _ -> Ref (reftype' st i ch) + + let valtype st ch = + let i = uint ch in + valtype' st i ch + + let storagetype st ch = + let i = uint ch in + match i with + | 0x78 -> Packed I8 + | 0x77 -> Packed I16 + | _ -> Val (valtype' st i ch) + + let fieldtype st ch = + let typ = storagetype st ch in + let mut = input_byte ch <> 0 in + { mut; typ } + + let comptype st i ch = + match i with + | 0x5E -> Array (fieldtype st ch) + | 0x5F -> Struct (vec (fieldtype st) ch) + | 0x60 -> + let params = vec (valtype st) ch in + let results = vec (valtype st) ch in + Func { params; results } + | c -> failwith (Printf.sprintf "Unknown comptype %d" c) + + let supertype st ch = + match input_byte ch with + | 0 -> None + | 1 -> + let t = uint ch in + Some + (if t >= st.type_index_count + then lnot (t - st.type_index_count) + else st.type_mapping.(t)) + | _ -> assert false + + let subtype st i ch = + match i with + | 0x50 -> + let supertype = supertype st ch in + { final = false; supertype; typ = comptype st (input_byte ch) ch } + | 0x4F -> + let supertype = supertype st ch in + { final = true; supertype; typ = comptype st (input_byte ch) ch } + | _ -> { final = true; supertype = None; typ = comptype st i ch } + + let rectype st ch = + match input_byte ch with + | 0x4E -> vec (fun ch -> subtype st (input_byte ch) ch) ch + | i -> [| subtype st i ch |] + + let type_section st types ch = + let n = uint ch in + st.type_mapping <- Array.make n 0; + st.type_index_count <- 0; + repeat' + n + (fun ch -> + let ty = rectype st ch in + let pos = st.type_index_count in + let pos' = add_rectype types ty in + let count = Array.length ty in + for i = 0 to count - 1 do + st.type_mapping.(pos + i) <- pos' + i + done; + st.type_index_count <- pos + count) + ch + + let limits ch = + let kind = input_byte ch in + assert (kind < 8); + let shared = kind land 2 <> 0 in + let index_type = if kind land 4 = 0 then `I32 else `I64 in + let min = uint ch in + let max = if kind land 1 = 0 then None else Some (uint ch) in + { min; max; shared; index_type } + + let memtype = limits + + let tabletype st ch = + let typ = reftype st ch in + let limits = limits ch in + { limits; typ } + + let typeidx st ch = st.type_mapping.(uint ch) + + let globaltype st ch = + let typ = valtype st ch in + let mut = input_byte ch in + assert (mut < 2); + { mut = mut <> 0; typ } + + let import tbl st ch = + let module_ = name ch in + let name = name ch in + let d = uint ch in + if d > 4 then failwith (Printf.sprintf "Unknown import %x@." d); + let importdesc : importdesc = + match d with + | 0 -> Func st.type_mapping.(uint ch) + | 1 -> Table (tabletype st ch) + | 2 -> Mem (memtype ch) + | 3 -> Global (globaltype st ch) + | 4 -> + let b = uint ch in + assert (b = 0); + Tag st.type_mapping.(uint ch) + | _ -> assert false + in + let entry = { module_; name; desc = importdesc } in + let kind = exportable_kind d in + set_exportable_info tbl kind (entry :: get_exportable_info tbl kind) + + let export tbl ch = + let name = name ch in + let d = uint ch in + if d > 4 then failwith (Printf.sprintf "Unknown export %x@." d); + let idx = uint ch in + let entry = name, idx in + let kind = exportable_kind d in + set_exportable_info tbl kind (entry :: get_exportable_info tbl kind) + + type interface = + { imports : import array exportable_info + ; exports : (string * int) list exportable_info + } + + let type_section types contents = + if find_section contents 1 then type_section contents types contents.ch + + let interface contents = + let imports = + if find_section contents 2 + then ( + let tbl = make_exportable_info [] in + vec' (import tbl contents) contents.ch; + map_exportable_info (fun _ l -> Array.of_list (List.rev l)) tbl) + else make_exportable_info [||] + in + let exports = + let tbl = make_exportable_info [] in + if find_section contents 7 then vec' (export tbl) contents.ch; + tbl + in + { imports; exports } + + let functions contents = + if find_section contents 3 + then vec (fun ch -> typeidx contents ch) contents.ch + else [||] + + let memories contents = if find_section contents 5 then vec memtype contents.ch else [||] + + let tag contents ch = + let b = input_byte ch in + assert (b = 0); + typeidx contents ch + + let tags contents = + if find_section contents 13 then vec (tag contents) contents.ch else [||] + + let data_count contents = + if find_section contents 12 + then uint contents.ch + else if find_section contents 11 + then uint contents.ch + else 0 + + let start contents = if find_section contents 8 then Some (uint contents.ch) else None + + let nameassoc ch = + let idx = uint ch in + let name = name ch in + idx, name + + let namemap contents = vec nameassoc contents.ch +end + +module Scan = struct + let debug = false + + type maps = + { typ : int array + ; func : int array + ; table : int array + ; mem : int array + ; global : int array + ; elem : int array + ; data : int array + ; tag : int array + } + + let default_maps = + { typ = [||] + ; func = [||] + ; table = [||] + ; mem = [||] + ; global = [||] + ; elem = [||] + ; data = [||] + ; tag = [||] + } + + type resize_data = Wasm_source_map.resize_data = + { mutable i : int + ; mutable pos : int array + ; mutable delta : int array + } + + let push_resize resize_data pos delta = + let p = resize_data.pos in + let i = resize_data.i in + let p = + if i = Array.length p + then ( + let p = Array.make (2 * i) 0 in + let d = Array.make (2 * i) 0 in + Array.blit ~src:resize_data.pos ~src_pos:0 ~dst:p ~dst_pos:0 ~len:i; + Array.blit ~src:resize_data.delta ~src_pos:0 ~dst:d ~dst_pos:0 ~len:i; + resize_data.pos <- p; + resize_data.delta <- d; + p) + else p + in + p.(i) <- pos; + resize_data.delta.(i) <- delta; + resize_data.i <- i + 1 + + let create_resize_data () = + { i = 0; pos = Array.make 1024 0; delta = Array.make 1024 0 } + + let clear_resize_data resize_data = resize_data.i <- 0 + + type position_data = + { mutable i : int + ; mutable pos : int array + } + + let create_position_data () = { i = 0; pos = Array.make 100 0 } + + let clear_position_data position_data = position_data.i <- 0 + + let push_position position_data pos = + let p = position_data.pos in + let i = position_data.i in + let p = + if i = Array.length p + then ( + let p = Array.make (2 * i) 0 in + Array.blit ~src:position_data.pos ~src_pos:0 ~dst:p ~dst_pos:0 ~len:i; + position_data.pos <- p; + p) + else p + in + p.(i) <- pos; + position_data.i <- i + 1 + + let scanner report mark maps buf code = + let rec output_uint buf i = + if i < 128 + then Buffer.add_char buf (Char.chr i) + else ( + Buffer.add_char buf (Char.chr (128 + (i land 127))); + output_uint buf (i lsr 7)) + in + let rec output_sint buf i = + if i >= -64 && i < 64 + then Buffer.add_char buf (Char.chr (i land 127)) + else ( + Buffer.add_char buf (Char.chr (128 + (i land 127))); + output_sint buf (i asr 7)) + in + let start = ref 0 in + let get pos = Char.code (String.get code pos) in + let rec int pos = if get pos >= 128 then int (pos + 1) else pos + 1 in + let rec uint32 pos = + let i = get pos in + if i < 128 + then pos + 1, i + else + let pos, i' = pos + 1 |> uint32 in + pos, (i' lsl 7) + (i land 0x7f) + in + let rec sint32 pos = + let i = get pos in + if i < 64 + then pos + 1, i + else if i < 128 + then pos + 1, i - 128 + else + let pos, i' = pos + 1 |> sint32 in + pos, i - 128 + (i' lsl 7) + in + let rec repeat n f pos = if n = 0 then pos else repeat (n - 1) f (f pos) in + let vector f pos = + let pos, i = + let i = get pos in + if i < 128 then pos + 1, i else uint32 pos + in + repeat i f pos + in + let name pos = + let pos', i = + let i = get pos in + if i < 128 then pos + 1, i else uint32 pos + in + pos' + i + in + let flush' pos pos' = + if !start < pos then Buffer.add_substring buf code !start (pos - !start); + start := pos' + in + let flush pos = flush' pos pos in + let rewrite map pos = + let pos', idx = + let i = get pos in + if i < 128 + then pos + 1, i + else + let i' = get (pos + 1) in + if i' < 128 then pos + 2, (i' lsl 7) + (i land 0x7f) else uint32 pos + in + let idx' = map idx in + if idx <> idx' + then ( + flush' pos pos'; + let p = Buffer.length buf in + output_uint buf idx'; + let p' = Buffer.length buf in + let dp = p' - p in + let dpos = pos' - pos in + if dp <> dpos then report pos' (dp - dpos)); + pos' + in + let rewrite_signed map pos = + let pos', idx = + let i = get pos in + if i < 64 then pos + 1, i else if i < 128 then pos + 1, i - 128 else sint32 pos + in + let idx' = map idx in + if idx <> idx' + then ( + flush' pos pos'; + let p = Buffer.length buf in + output_sint buf idx'; + let p' = Buffer.length buf in + let dp = p' - p in + let dpos = pos' - pos in + if dp <> dpos then report pos (dp - dpos)); + pos' + in + let typ_map idx = maps.typ.(idx) in + let typeidx pos = rewrite typ_map pos in + let signed_typeidx pos = rewrite_signed typ_map pos in + let func_map idx = maps.func.(idx) in + let funcidx pos = rewrite func_map pos in + let table_map idx = maps.table.(idx) in + let tableidx pos = rewrite table_map pos in + let mem_map idx = maps.mem.(idx) in + let memidx pos = rewrite mem_map pos in + let global_map idx = maps.global.(idx) in + let globalidx pos = rewrite global_map pos in + let elem_map idx = maps.elem.(idx) in + let elemidx pos = rewrite elem_map pos in + let data_map idx = maps.data.(idx) in + let dataidx pos = rewrite data_map pos in + let tag_map idx = maps.tag.(idx) in + let tagidx pos = rewrite tag_map pos in + let labelidx = int in + let localidx = int in + let laneidx pos = pos + 1 in + let heaptype pos = + let c = get pos in + if c >= 64 && c < 128 then (* absheaptype *) pos + 1 else signed_typeidx pos + in + let absheaptype pos = + match get pos with + | 0X73 (* nofunc *) + | 0x72 (* noextern *) + | 0x71 (* none *) + | 0x70 (* func *) + | 0x6F (* extern *) + | 0x6E (* any *) + | 0x6D (* eq *) + | 0x6C (* i31 *) + | 0x6B (* struct *) + | 0x6A (* array *) -> pos + 1 + | c -> failwith (Printf.sprintf "Bad heap type 0x%02X@." c) + in + let reftype pos = + match get pos with + | 0x63 | 0x64 -> pos + 1 |> heaptype + | _ -> pos |> absheaptype + in + let valtype pos = + let c = get pos in + match c with + | 0x63 (* ref null ht *) | 0x64 (* ref ht *) -> pos + 1 |> heaptype + | _ -> pos + 1 + in + let blocktype pos = + let c = get pos in + if c >= 64 && c < 128 then pos |> valtype else pos |> signed_typeidx + in + let memarg pos = + let pos', c = uint32 pos in + if c < 64 + then ( + if mem_map 0 <> 0 + then ( + flush' pos pos'; + let p = Buffer.length buf in + output_uint buf (c + 64); + output_uint buf (mem_map 0); + let p' = Buffer.length buf in + let dp = p' - p in + let dpos = pos' - pos in + if dp <> dpos then report pos (dp - dpos)); + pos' |> int) + else pos' |> memidx |> int + in + let rec instructions pos = + if debug then Format.eprintf "0x%02X (@%d)@." (get pos) pos; + match get pos with + (* Control instruction *) + | 0x00 (* unreachable *) | 0x01 (* nop *) | 0x0F (* return *) -> + pos + 1 |> instructions + | 0x02 (* block *) | 0x03 (* loop *) -> + pos + 1 |> blocktype |> instructions |> block_end |> instructions + | 0x04 (* if *) -> pos + 1 |> blocktype |> instructions |> opt_else |> instructions + | 0x0C (* br *) + | 0x0D (* br_if *) + | 0xD5 (* br_on_null *) + | 0xD6 (* br_on_non_null *) -> pos + 1 |> labelidx |> instructions + | 0x0E (* br_table *) -> pos + 1 |> vector labelidx |> labelidx |> instructions + | 0x10 (* call *) | 0x12 (* return_call *) -> pos + 1 |> funcidx |> instructions + | 0x11 (* call_indirect *) | 0x13 (* return_call_indirect *) -> + pos + 1 |> typeidx |> tableidx |> instructions + | 0x14 (* call_ref *) | 0x15 (* return_call_ref *) -> + pos + 1 |> typeidx |> instructions + (* Exceptions *) + | 0x06 (* try *) -> pos + 1 |> blocktype |> instructions |> opt_catch + | 0x08 (* throw *) -> pos + 1 |> tagidx |> instructions + | 0x09 (* rethrow *) -> pos + 1 |> int |> instructions + | 0x0A (* throw_ref *) -> pos + 1 |> instructions + (* Parametric instructions *) + | 0x1A (* drop *) | 0x1B (* select *) -> pos + 1 |> instructions + | 0x1C (* select *) -> pos + 1 |> vector valtype |> instructions + | 0x1F (* try_table *) -> + pos + 1 + |> blocktype + |> vector catch + |> instructions + |> block_end + |> instructions + (* Variable instructions *) + | 0x20 (* local.get *) | 0x21 (* local.set *) | 0x22 (* local.tee *) -> + pos + 1 |> localidx |> instructions + | 0x23 (* global.get *) | 0x24 (* global.set *) -> + pos + 1 |> globalidx |> instructions + (* Table instructions *) + | 0x25 (* table.get *) | 0x26 (* table.set *) -> pos + 1 |> tableidx |> instructions + (* Memory instructions *) + | 0x28 + | 0x29 + | 0x2A + | 0x2B + | 0x2C + | 0x2D + | 0x2E + | 0x2F + | 0x30 + | 0x31 + | 0x32 + | 0x33 + | 0x34 + | 0x35 (* load *) + | 0x36 | 0x37 | 0x38 | 0x39 | 0x3A | 0x3B | 0x3C | 0x3D | 0x3E (* store *) -> + pos + 1 |> memarg |> instructions + | 0x3F | 0x40 -> pos + 1 |> memidx |> instructions + (* Numeric instructions *) + | 0x41 (* i32.const *) | 0x42 (* i64.const *) -> pos + 1 |> int |> instructions + | 0x43 (* f32.const *) -> pos + 5 |> instructions + | 0x44 (* f64.const *) -> pos + 9 |> instructions + | 0x45 + | 0x46 + | 0x47 + | 0x48 + | 0x49 + | 0x4A + | 0x4B + | 0x4C + | 0x4D + | 0x4E + | 0x4F + | 0x50 + | 0x51 + | 0x52 + | 0x53 + | 0x54 + | 0x55 + | 0x56 + | 0x57 + | 0x58 + | 0x59 + | 0x5A + | 0x5B + | 0x5C + | 0x5D + | 0x5E + | 0x5F + | 0x60 + | 0x61 + | 0x62 + | 0x63 + | 0x64 + | 0x65 + | 0x66 + | 0x67 + | 0x68 + | 0x69 + | 0x6A + | 0x6B + | 0x6C + | 0x6D + | 0x6E + | 0x6F + | 0x70 + | 0x71 + | 0x72 + | 0x73 + | 0x74 + | 0x75 + | 0x76 + | 0x77 + | 0x78 + | 0x79 + | 0x7A + | 0x7B + | 0x7C + | 0x7D + | 0x7E + | 0x7F + | 0x80 + | 0x81 + | 0x82 + | 0x83 + | 0x84 + | 0x85 + | 0x86 + | 0x87 + | 0x88 + | 0x89 + | 0x8A + | 0x8B + | 0x8C + | 0x8D + | 0x8E + | 0x8F + | 0x90 + | 0x91 + | 0x92 + | 0x93 + | 0x94 + | 0x95 + | 0x96 + | 0x97 + | 0x98 + | 0x99 + | 0x9A + | 0x9B + | 0x9C + | 0x9D + | 0x9E + | 0x9F + | 0xA0 + | 0xA1 + | 0xA2 + | 0xA3 + | 0xA4 + | 0xA5 + | 0xA6 + | 0xA7 + | 0xA8 + | 0xA9 + | 0xAA + | 0xAB + | 0xAC + | 0xAD + | 0xAE + | 0xAF + | 0xB0 + | 0xB1 + | 0xB2 + | 0xB3 + | 0xB4 + | 0xB5 + | 0xB6 + | 0xB7 + | 0xB8 + | 0xB9 + | 0xBA + | 0xBB + | 0xBC + | 0xBD + | 0xBE + | 0xBF + | 0xC0 + | 0xC1 + | 0xC2 + | 0xC3 + | 0xC4 -> pos + 1 |> instructions + (* Reference instructions *) + | 0xD0 (* ref.null *) -> pos + 1 |> heaptype |> instructions + | 0xD1 (* ref.is_null *) | 0xD3 (* ref.eq *) | 0xD4 (* ref.as_non_null *) -> + pos + 1 |> instructions + | 0xD2 (* ref.func *) -> pos + 1 |> funcidx |> instructions + | 0xFB -> pos + 1 |> gc_instruction + | 0xFC -> ( + if debug then Format.eprintf " %d@." (get (pos + 1)); + match get (pos + 1) with + | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 (* xx.trunc_sat_xxx_x *) -> + pos + 2 |> instructions + | 8 (* memory.init *) -> pos + 2 |> dataidx |> memidx |> instructions + | 9 (* data.drop *) -> pos + 2 |> dataidx |> instructions + | 10 (* memory.copy *) -> pos + 2 |> memidx |> memidx |> instructions + | 11 (* memory.fill *) -> pos + 2 |> memidx |> instructions + | 12 (* table.init *) -> pos + 2 |> elemidx |> tableidx |> instructions + | 13 (* elem.drop *) -> pos + 2 |> elemidx |> instructions + | 14 (* table.copy *) -> pos + 2 |> tableidx |> tableidx |> instructions + | 15 (* table.grow *) | 16 (* table.size *) | 17 (* table.fill *) -> + pos + 2 |> tableidx |> instructions + | c -> failwith (Printf.sprintf "Bad instruction 0xFC 0x%02X" c)) + | 0xFD -> pos + 1 |> vector_instruction + | 0xFE -> pos + 1 |> atomic_instruction + | _ -> pos + and gc_instruction pos = + if debug then Format.eprintf " %d@." (get pos); + match get pos with + | 0 (* struct.new *) + | 1 (* struct.new_default *) + | 6 (* array.new *) + | 7 (* array.new_default *) + | 11 (* array.get *) + | 12 (* array.get_s *) + | 13 (* array.get_u *) + | 14 (* array.set *) + | 16 (* array.fill *) -> pos + 1 |> typeidx |> instructions + | 2 (* struct.get *) + | 3 (* struct.get_s *) + | 4 (* struct.get_u *) + | 5 (* struct.set *) + | 8 (* array.new_fixed *) -> pos + 1 |> typeidx |> int |> instructions + | 9 (* array.new_data *) | 18 (* array.init_data *) -> + pos + 1 |> typeidx |> dataidx |> instructions + | 10 (* array.new_elem *) | 19 (* array.init_elem *) -> + pos + 1 |> typeidx |> elemidx |> instructions + | 15 (* array.len *) + | 26 (* any.convert_extern *) + | 27 (* extern.convert_any *) + | 28 (* ref.i31 *) + | 29 (* i31.get_s *) + | 30 (* i31.get_u *) -> pos + 1 |> instructions + | 17 (* array.copy *) -> pos + 1 |> typeidx |> typeidx |> instructions + | 20 | 21 (* ref_test *) | 22 | 23 (* ref.cast*) -> + pos + 1 |> heaptype |> instructions + | 24 (* br_on_cast *) | 25 (* br_on_cast_fail *) -> + pos + 2 |> labelidx |> heaptype |> heaptype |> instructions + | c -> failwith (Printf.sprintf "Bad instruction 0xFB 0x%02X" c) + and vector_instruction pos = + if debug then Format.eprintf " %d@." (get pos); + let pos, i = uint32 pos in + match i with + | 0 | 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 92 | 93 (* v128.load / store *) + -> pos + 1 |> memarg |> instructions + | 84 | 85 | 86 | 87 | 88 | 89 | 90 | 91 (* v128.load/store_lane *) -> + pos + 1 |> memarg |> laneidx |> instructions + | 12 (* v128.const *) | 13 (* v128.shuffle *) -> pos + 17 |> instructions + | 21 + | 22 + | 23 + | 24 + | 25 + | 26 + | 27 + | 28 + | 29 + | 30 + | 31 + | 32 + | 33 + | 34 (* xx.extract/replace_lane *) -> pos + 1 |> laneidx |> instructions + | ( 162 + | 165 + | 166 + | 175 + | 176 + | 178 + | 179 + | 180 + | 187 + | 194 + | 197 + | 198 + | 207 + | 208 + | 210 + | 211 + | 212 + | 226 + | 238 ) as c -> failwith (Printf.sprintf "Bad instruction 0xFD 0x%02X" c) + | c -> + if c <= 275 + then pos + 1 |> instructions + else failwith (Printf.sprintf "Bad instruction 0xFD 0x%02X" c) + and atomic_instruction pos = + if debug then Format.eprintf " %d@." (get pos); + match get pos with + | 0 (* memory.atomic.notify *) + | 1 | 2 (* memory.atomic.waitxx *) + | 16 | 17 | 18 | 19 | 20 | 21 | 22 (* xx.atomic.load *) + | 23 | 24 | 25 | 26 | 27 | 28 | 29 (* xx.atomic.store *) + | 30 | 31 | 32 | 33 | 34 | 35 | 36 (* xx.atomic.rmw.add *) + | 37 | 38 | 39 | 40 | 41 | 42 | 43 (* xx.atomic.rmw.sub *) + | 44 | 45 | 46 | 47 | 48 | 49 | 50 (* xx.atomic.rmw.and *) + | 51 | 52 | 53 | 54 | 55 | 56 | 57 (* xx.atomic.rmw.or *) + | 58 | 59 | 60 | 61 | 62 | 63 | 64 (* xx.atomic.rmw.xor *) + | 65 | 66 | 67 | 68 | 69 | 70 | 71 (* xx.atomic.rmw.xchg *) + | 72 | 73 | 74 | 75 | 76 | 77 | 78 (* xx.atomic.rmw.cmpxchg *) -> + pos + 1 |> memarg |> instructions + | 3 (* memory.fence *) -> + let c = get pos + 1 in + assert (c = 0); + pos + 2 |> instructions + | c -> failwith (Printf.sprintf "Bad instruction 0xFE 0x%02X" c) + and opt_else pos = + if debug then Format.eprintf "0x%02X (@%d) else@." (get pos) pos; + match get pos with + | 0x05 (* else *) -> pos + 1 |> instructions |> block_end |> instructions + | _ -> pos |> block_end |> instructions + and opt_catch pos = + if debug then Format.eprintf "0x%02X (@%d) catch@." (get pos) pos; + match get pos with + | 0x07 (* catch *) -> pos + 1 |> tagidx |> instructions |> opt_catch + | 0x05 (* catch_all *) -> pos + 1 |> instructions |> block_end |> instructions + | _ -> pos |> block_end |> instructions + and catch pos = + match get pos with + | 0 (* catch *) | 1 (* catch_ref *) -> pos + 1 |> tagidx |> labelidx + | 2 (* catch_all *) | 3 (* catch_all_ref *) -> pos + 1 |> labelidx + | c -> failwith (Printf.sprintf "bad catch 0x02%d@." c) + and block_end pos = + if debug then Format.eprintf "0x%02X (@%d) block end@." (get pos) pos; + match get pos with + | 0x0B -> pos + 1 + | c -> failwith (Printf.sprintf "Bad instruction 0x%02X" c) + in + let locals pos = pos |> int |> valtype in + let expr pos = pos |> instructions |> block_end in + let func pos = + start := pos; + pos |> vector locals |> expr |> flush + in + let mut pos = pos + 1 in + let limits pos = + let c = get pos in + assert (c < 8); + if c land 1 = 0 then pos |> int else pos |> int |> int + in + let tabletype pos = + mark pos; + pos |> reftype |> limits + in + let table pos = + match get pos with + | 0x40 -> + assert (get (pos + 1) = 0); + pos + 2 |> tabletype |> expr + | _ -> pos |> tabletype + in + let table_section ~count pos = + start := pos; + pos |> repeat count table |> flush + in + let globaltype pos = + mark pos; + pos |> valtype |> mut + in + let global pos = pos |> globaltype |> expr in + let global_section ~count pos = + start := pos; + pos |> repeat count global |> flush + in + let elemkind pos = + assert (get pos = 0); + pos + 1 + in + let elem pos = + match get pos with + | 0 -> pos + 1 |> expr |> vector funcidx + | 1 -> pos + 1 |> elemkind |> vector funcidx + | 2 -> pos + 1 |> tableidx |> expr |> elemkind |> vector funcidx + | 3 -> pos + 1 |> elemkind |> vector funcidx + | 4 -> pos + 1 |> expr |> vector expr + | 5 -> pos + 1 |> reftype |> vector expr + | 6 -> pos + 1 |> tableidx |> expr |> reftype |> vector expr + | 7 -> pos + 1 |> reftype |> vector expr + | c -> failwith (Printf.sprintf "Bad element 0x%02X" c) + in + let bytes pos = + let pos, len = uint32 pos in + pos + len + in + let data pos = + match get pos with + | 0 -> pos + 1 |> expr |> bytes + | 1 -> pos + 1 |> bytes + | 2 -> pos + 1 |> memidx |> expr |> bytes + | c -> failwith (Printf.sprintf "Bad data segment 0x%02X" c) + in + let elem_section ~count pos = + start := pos; + !start |> repeat count elem |> flush + in + let data_section ~count pos = + start := pos; + !start |> repeat count data |> flush + in + let local_nameassoc pos = pos |> localidx |> name in + let local_namemap pos = + start := pos; + pos |> vector local_nameassoc |> flush + in + table_section, global_section, elem_section, data_section, func, local_namemap + + let table_section positions maps buf s = + let table_section, _, _, _, _, _ = + scanner (fun _ _ -> ()) (fun pos -> push_position positions pos) maps buf s + in + table_section + + let global_section positions maps buf s = + let _, global_section, _, _, _, _ = + scanner (fun _ _ -> ()) (fun pos -> push_position positions pos) maps buf s + in + global_section + + let elem_section maps buf s = + let _, _, elem_section, _, _, _ = scanner (fun _ _ -> ()) (fun _ -> ()) maps buf s in + elem_section + + let data_section maps buf s = + let _, _, _, data_section, _, _ = scanner (fun _ _ -> ()) (fun _ -> ()) maps buf s in + data_section + + let func resize_data maps buf s = + let _, _, _, _, func, _ = + scanner + (fun pos delta -> push_resize resize_data pos delta) + (fun _ -> ()) + maps + buf + s + in + func + + let local_namemap buf s = + let _, _, _, _, _, local_namemap = + scanner (fun _ _ -> ()) (fun _ -> ()) default_maps buf s + in + local_namemap +end + +let interface types contents = + Read.type_section types contents; + Read.interface contents + +type t = + { module_name : string + ; file : string + ; contents : Read.t + ; source_map_contents : Source_map.Standard.t option + } + +type import_status = + | Resolved of int * int + | Unresolved of int + +let check_limits export import = + export.min >= import.min + && + match export.max, import.max with + | _, None -> true + | None, Some _ -> false + | Some e, Some i -> e <= i + +let rec subtype subtyping_info (i : int) i' = + i = i' + || + match subtyping_info.(i).supertype with + | None -> false + | Some s -> subtype subtyping_info s i' + +let heap_subtype (subtyping_info : subtype array) (ty : heaptype) (ty' : heaptype) = + match ty, ty' with + | (Func | Nofunc), Func + | Nofunc, Nofunc + | (Extern | Noextern), Extern + | (Any | Eq | I31 | Struct | Array | None_ | Type _), Any + | (Eq | I31 | Struct | Array | None_ | Type _), Eq + | (I31 | None_), I31 + | (Struct | None_), Struct + | (Array | None_), Array + | None_, None_ -> true + | Type i, Struct -> ( + match subtyping_info.(i).typ with + | Struct _ -> true + | Array _ | Func _ -> false) + | Type i, Array -> ( + match subtyping_info.(i).typ with + | Array _ -> true + | Struct _ | Func _ -> false) + | Type i, Func -> ( + match subtyping_info.(i).typ with + | Func _ -> true + | Struct _ | Array _ -> false) + | Type i, Type i' -> subtype subtyping_info i i' + | _ -> false + +let ref_subtype subtyping_info { nullable; typ } { nullable = nullable'; typ = typ' } = + ((not nullable) || nullable') && heap_subtype subtyping_info typ typ' + +let val_subtype subtyping_info ty ty' = + match ty, ty' with + | Ref t, Ref t' -> ref_subtype subtyping_info t t' + | _ -> Stdlib.phys_equal ty ty' + +let check_export_import_types ~subtyping_info ~files i (desc : importdesc) i' import = + let ok = + match desc, import.desc with + | Func t, Func t' -> subtype subtyping_info t t' + | Table { limits; typ }, Table { limits = limits'; typ = typ' } -> + check_limits limits limits' && Poly.(typ = typ') + | Mem limits, Mem limits' -> check_limits limits limits' + | Global { mut; typ }, Global { mut = mut'; typ = typ' } -> + Bool.(mut = mut') + && if mut then Poly.(typ = typ') else val_subtype subtyping_info typ typ' + | Tag t, Tag t' -> t = t' + | _ -> false + in + if not ok + then + failwith + (Printf.sprintf + "In module %s, the import %s / %s refers to an export in module %s of an \ + incompatible type" + files.(i').file + import.module_ + import.name + files.(i).file) + +let build_mappings resolved_imports unresolved_imports kind counts = + let current_offset = ref (get_exportable_info unresolved_imports kind) in + let mappings = + Array.mapi + ~f:(fun i count -> + let imports = get_exportable_info resolved_imports.(i) kind in + let import_count = Array.length imports in + let offset = !current_offset - import_count in + current_offset := !current_offset + count; + Array.init + (Array.length imports + count) + ~f:(fun i -> + if i < import_count + then + match imports.(i) with + | Unresolved i -> i + | Resolved _ -> -1 + else i + offset)) + counts + in + Array.iteri + ~f:(fun i map -> + let imports = get_exportable_info resolved_imports.(i) kind in + for i = 0 to Array.length imports - 1 do + match imports.(i) with + | Unresolved _ -> () + | Resolved (j, k) -> map.(i) <- mappings.(j).(k) + done) + mappings; + mappings + +let build_simple_mappings ~counts = + let current_offset = ref 0 in + Array.map + ~f:(fun count -> + let offset = !current_offset in + current_offset := !current_offset + count; + Array.init count ~f:(fun j -> j + offset)) + counts + +let add_section out_ch ~id ?count buf = + match count with + | Some 0 -> Buffer.clear buf + | _ -> + let buf' = Buffer.create 5 in + Option.iter ~f:(fun c -> Write.uint buf' c) count; + output_byte out_ch id; + output_uint out_ch (Buffer.length buf' + Buffer.length buf); + Buffer.output_buffer out_ch buf'; + Buffer.output_buffer out_ch buf; + Buffer.clear buf + +let add_subsection buf ~id ?count buf' = + match count with + | Some 0 -> Buffer.clear buf' + | _ -> + let buf'' = Buffer.create 5 in + Option.iter ~f:(fun c -> Write.uint buf'' c) count; + Buffer.add_char buf (Char.chr id); + Write.uint buf (Buffer.length buf'' + Buffer.length buf'); + Buffer.add_buffer buf buf''; + Buffer.add_buffer buf buf'; + Buffer.clear buf' + +let check_exports_against_imports + ~intfs + ~subtyping_info + ~resolved_imports + ~files + ~kind + ~to_desc = + Array.iteri + ~f:(fun i intf -> + let imports = get_exportable_info intf.Read.imports kind in + let statuses = get_exportable_info resolved_imports.(i) kind in + Array.iter2 + ~f:(fun import status -> + match status with + | Unresolved _ -> () + | Resolved (i', idx') -> ( + match to_desc i' idx' with + | None -> () + | Some desc -> + check_export_import_types ~subtyping_info ~files i' desc i import)) + imports + statuses) + intfs + +let read_desc_from_file ~intfs ~files ~positions ~read i j = + let offset = Array.length (get_exportable_info intfs.(i).Read.imports Table) in + if j < offset + then None + else + let { contents; _ } = files.(i) in + Read.seek_in contents.ch positions.(i).Scan.pos.(j - offset); + Some (read contents) + +let index_in_output ~unresolved_imports ~mappings ~kind ~get i' idx' = + let offset = get_exportable_info unresolved_imports kind in + let idx'' = mappings.(i').(idx') - offset in + if idx'' >= 0 then Some (get idx'') else None + +let write_simple_section + ~intfs + ~subtyping_info + ~resolved_imports + ~unresolved_imports + ~files + ~out_ch + ~buf + ~kind + ~id + ~read + ~to_type + ~write = + let data = Array.map ~f:(fun f -> read f.contents) files in + let entries = Array.concat (Array.to_list data) in + if Array.length entries <> 0 + then ( + write buf entries; + add_section out_ch ~id buf); + let counts = Array.map ~f:Array.length data in + let mappings = build_mappings resolved_imports unresolved_imports kind counts in + check_exports_against_imports + ~intfs + ~subtyping_info + ~resolved_imports + ~files + ~kind + ~to_desc: + (index_in_output ~unresolved_imports ~mappings ~kind ~get:(fun idx -> + to_type entries.(idx))); + mappings + +let write_section_with_scan ~files ~out_ch ~buf ~id ~scan = + let counts = + Array.mapi + ~f:(fun i { contents; _ } -> + if Read.find_section contents id + then ( + let count = Read.uint contents.ch in + scan + i + { Scan.default_maps with typ = contents.type_mapping } + buf + contents.ch.buf + ~count + contents.ch.pos; + count) + else 0) + files + in + add_section out_ch ~id ~count:(Array.fold_left ~f:( + ) ~init:0 counts) buf; + counts + +let write_simple_namemap ~name_sections ~name_section_buffer ~buf ~section_id ~mappings = + let count = ref 0 in + Array.iter2 + ~f:(fun name_section mapping -> + if Read.find_section name_section section_id + then ( + let map = Read.namemap name_section in + Array.iter ~f:(fun (idx, name) -> Write.nameassoc buf mapping.(idx) name) map; + count := !count + Array.length map)) + name_sections + mappings; + add_subsection name_section_buffer ~id:section_id ~count:!count buf + +let write_namemap + ~resolved_imports + ~unresolved_imports + ~name_sections + ~name_section_buffer + ~buf + ~kind + ~section_id + ~mappings = + let import_names = Array.make (get_exportable_info unresolved_imports kind) None in + Array.iteri + ~f:(fun i name_section -> + if Read.find_section name_section section_id + then + let imports = get_exportable_info resolved_imports.(i) kind in + let import_count = Array.length imports in + let n = Read.uint name_section.ch in + let rec loop j = + if j < n + then + let idx = Read.uint name_section.ch in + let name = Read.name name_section.ch in + if idx < import_count + then ( + let idx' = + match imports.(idx) with + | Unresolved idx' -> idx' + | Resolved (i', idx') -> mappings.(i').(idx') + in + if idx' < Array.length import_names && Option.is_none import_names.(idx') + then import_names.(idx') <- Some name; + loop (j + 1)) + in + loop 0) + name_sections; + let count = ref 0 in + Array.iteri + ~f:(fun idx name -> + match name with + | None -> () + | Some name -> + incr count; + Write.nameassoc buf idx name) + import_names; + Array.iteri + ~f:(fun i name_section -> + if Read.find_section name_section section_id + then + let mapping = mappings.(i) in + let imports = get_exportable_info resolved_imports.(i) kind in + let import_count = Array.length imports in + let n = Read.uint name_section.ch in + let ch = name_section.ch in + for _ = 1 to n do + let idx = Read.uint ch in + let len = Read.uint ch in + if idx >= import_count + then ( + incr count; + Write.uint buf mapping.(idx); + Write.uint buf len; + Buffer.add_substring buf ch.buf ch.pos len); + ch.pos <- ch.pos + len + done) + name_sections; + add_subsection name_section_buffer ~id:section_id ~count:!count buf + +let write_indirectnamemap ~name_sections ~name_section_buffer ~buf ~section_id ~mappings = + let count = ref 0 in + Array.iter2 + ~f:(fun name_section mapping -> + if Read.find_section name_section section_id + then ( + let n = Read.uint name_section.ch in + let scan_map = Scan.local_namemap buf name_section.ch.buf in + for _ = 1 to n do + let idx = mapping.(Read.uint name_section.ch) in + Write.uint buf idx; + let p = Buffer.length buf in + scan_map name_section.ch.pos; + name_section.ch.pos <- name_section.ch.pos + Buffer.length buf - p + done; + count := !count + n)) + name_sections + mappings; + add_subsection name_section_buffer ~id:section_id ~count:!count buf + +let rec resolve + depth + ~files + ~intfs + ~subtyping_info + ~exports + ~kind + i + ({ module_; name; _ } as import) = + let i', index = Hashtbl.find exports (module_, name) in + let imports = get_exportable_info intfs.(i').Read.imports kind in + if index < Array.length imports + then ( + if depth > 100 then failwith (Printf.sprintf "Import loop on %s %s" module_ name); + let entry = imports.(index) in + check_export_import_types ~subtyping_info ~files i' entry.desc i import; + try resolve (depth + 1) ~files ~intfs ~subtyping_info ~exports ~kind i' entry + with Not_found -> i', index) + else i', index + +type input = + { module_name : string + ; file : string + ; code : string option + ; opt_source_map : Source_map.Standard.t option + } + +let f files ~output_file = + let files = + Array.map + ~f:(fun { module_name; file; code; opt_source_map } -> + let data = + match code with + | None -> Fs.read_file file + | Some data -> data + in + let contents = Read.open_in file data in + { module_name; file; contents; source_map_contents = opt_source_map }) + (Array.of_list files) + in + + let out_ch = open_out_bin output_file in + output_string out_ch Read.header; + let buf = Buffer.create 100000 in + + (* 1: type *) + let types = Read.create_types () in + let intfs = Array.map ~f:(fun f -> interface types f.contents) files in + let type_list = List.rev types.rev_list in + let subtyping_info = Array.concat type_list in + let st = Write.types buf (Array.of_list type_list) in + add_section out_ch ~id:1 buf; + + (* 2: import *) + let exports = init_exportable_info (fun _ -> Hashtbl.create 128) in + Array.iteri + ~f:(fun i intf -> + iter_exportable_info + (fun kind lst -> + let h = get_exportable_info exports kind in + List.iter + ~f:(fun (name, index) -> + Hashtbl.add h (files.(i).module_name, name) (i, index)) + lst) + intf.Read.exports) + intfs; + let import_list = ref [] in + let unresolved_imports = make_exportable_info 0 in + let resolved_imports = + let tbl = Hashtbl.create 128 in + Array.mapi + ~f:(fun i intf -> + map_exportable_info + (fun kind imports -> + let exports = get_exportable_info exports kind in + Array.map + ~f:(fun (import : import) -> + match resolve 0 ~files ~intfs ~subtyping_info ~exports ~kind i import with + | i', idx -> Resolved (i', idx) + | exception Not_found -> ( + match Hashtbl.find tbl import with + | status -> status + | exception Not_found -> + let idx = get_exportable_info unresolved_imports kind in + let status = Unresolved idx in + Hashtbl.replace tbl import status; + set_exportable_info unresolved_imports kind (1 + idx); + import_list := import :: !import_list; + status)) + imports) + intf.Read.imports) + intfs + in + Write.imports st buf (Array.of_list (List.rev !import_list)); + add_section out_ch ~id:2 buf; + + let start_count = + Array.fold_left + ~f:(fun count f -> + match Read.start f.contents with + | None -> count + | Some _ -> count + 1) + ~init:0 + files + in + + (* 3: function *) + let functions = Array.map ~f:(fun f -> Read.functions f.contents) files in + let func_types = + let l = Array.to_list functions in + let l = + if start_count > 1 + then + let ty = + let typ : comptype = Func { params = [||]; results = [||] } in + Read.add_rectype types [| { final = true; supertype = None; typ } |] + in + l @ [ [| ty |] ] + else l + in + Array.concat l + in + Write.functions buf func_types; + add_section out_ch ~id:3 buf; + let func_counts = Array.map ~f:Array.length functions in + let func_mappings = + build_mappings resolved_imports unresolved_imports Func func_counts + in + let func_count = + Array.fold_left ~f:( + ) ~init:(if start_count > 1 then 1 else 0) func_counts + in + check_exports_against_imports + ~intfs + ~subtyping_info + ~resolved_imports + ~files + ~kind:Func + ~to_desc: + (index_in_output + ~unresolved_imports + ~mappings:func_mappings + ~kind:Func + ~get:(fun idx : importdesc -> Func func_types.(idx))); + + (* 4: table *) + let positions = + Array.init (Array.length files) ~f:(fun _ -> Scan.create_position_data ()) + in + let table_counts = + write_section_with_scan ~files ~out_ch ~buf ~id:4 ~scan:(fun i maps -> + Scan.table_section positions.(i) { maps with func = func_mappings.(i) }) + in + let table_mappings = + build_mappings resolved_imports unresolved_imports Table table_counts + in + check_exports_against_imports + ~intfs + ~subtyping_info + ~resolved_imports + ~files + ~kind:Table + ~to_desc: + (read_desc_from_file ~intfs ~files ~positions ~read:(fun contents : importdesc -> + Table (Read.tabletype contents contents.ch))); + Array.iter ~f:Scan.clear_position_data positions; + + (* 5: memory *) + let mem_mappings = + write_simple_section + ~intfs + ~subtyping_info + ~resolved_imports + ~unresolved_imports + ~out_ch + ~buf + ~kind:Mem + ~id:5 + ~read:Read.memories + ~to_type:(fun limits -> Mem limits) + ~write:Write.memories + ~files + in + + (* 13: tag *) + let tag_mappings = + write_simple_section + ~intfs + ~subtyping_info + ~resolved_imports + ~unresolved_imports + ~out_ch + ~buf + ~kind:Tag + ~id:13 + ~read:Read.tags + ~to_type:(fun ty -> Tag ty) + ~write:Write.tags + ~files + in + + (* 6: global *) + let global_mappings = Array.make (Array.length files) [||] in + let global_counts = + let current_offset = ref (get_exportable_info unresolved_imports Global) in + Array.mapi + ~f:(fun i { file; contents; _ } -> + let imports = get_exportable_info resolved_imports.(i) Global in + let import_count = Array.length imports in + let offset = !current_offset - import_count in + let build_map count = + let map = + Array.init + (Array.length imports + count) + ~f:(fun j -> + if j < import_count + then ( + match imports.(j) with + | Unresolved j' -> j' + | Resolved (i', j') -> + (if i' > i + then + let import = + (get_exportable_info intfs.(i).imports Global).(j) + in + failwith + (Printf.sprintf + "In module %s, the import %s / %s refers to an export in a \ + later module %s" + file + import.module_ + import.name + files.(i').file)); + global_mappings.(i').(j')) + else j + offset) + in + global_mappings.(i) <- map; + map + in + let count = + if Read.find_section contents 6 + then ( + let count = Read.uint contents.ch in + let map = build_map count in + Scan.global_section + positions.(i) + { Scan.default_maps with + typ = contents.type_mapping + ; func = func_mappings.(i) + ; global = map + } + buf + contents.ch.buf + contents.ch.pos + ~count; + count) + else ( + ignore (build_map 0); + 0) + in + current_offset := !current_offset + count; + count) + files + in + add_section out_ch ~id:6 ~count:(Array.fold_left ~f:( + ) ~init:0 global_counts) buf; + check_exports_against_imports + ~intfs + ~subtyping_info + ~resolved_imports + ~files + ~kind:Global + ~to_desc:(fun i j : importdesc option -> + let offset = Array.length (get_exportable_info intfs.(i).imports Global) in + if j < offset + then None + else + let { contents; _ } = files.(i) in + Read.seek_in contents.ch positions.(i).pos.(j - offset); + Some (Global (Read.globaltype contents contents.ch))); + Array.iter ~f:Scan.clear_position_data positions; + + (* 7: export *) + let export_count = + Array.fold_left + ~f:(fun count intf -> + fold_exportable_info + (fun _ exports count -> List.length exports + count) + count + intf.Read.exports) + ~init:0 + intfs + in + Write.uint buf export_count; + let exports = Hashtbl.create 128 in + Array.iteri + ~f:(fun i intf -> + iter_exportable_info + (fun kind lst -> + let map = + match kind with + | Func -> func_mappings.(i) + | Table -> table_mappings.(i) + | Mem -> mem_mappings.(i) + | Global -> global_mappings.(i) + | Tag -> tag_mappings.(i) + in + List.iter + ~f:(fun (name, idx) -> + match Hashtbl.find exports name with + | i' -> + failwith + (Printf.sprintf + "Duplicated export %s from %s and %s" + name + files.(i').file + files.(i).file) + | exception Not_found -> + Hashtbl.add exports name i; + Write.export buf kind name map.(idx)) + lst) + intf.Read.exports) + intfs; + add_section out_ch ~id:7 buf; + + (* 8: start *) + let starts = + Array.mapi + ~f:(fun i f -> + Read.start f.contents |> Option.map ~f:(fun idx -> func_mappings.(i).(idx))) + files + |> Array.to_list + |> List.filter_map ~f:(fun x -> x) + in + (match starts with + | [] -> () + | [ start ] -> + Write.start buf start; + add_section out_ch ~id:8 buf + | _ :: _ :: _ -> + Write.start buf (func_count - 1); + add_section out_ch ~id:8 buf); + + (* 9: elements *) + let elem_counts = + write_section_with_scan ~files ~out_ch ~buf ~id:9 ~scan:(fun i maps -> + Scan.elem_section + { maps with func = func_mappings.(i); global = global_mappings.(i) }) + in + let elem_mappings = build_simple_mappings ~counts:elem_counts in + + (* 12: data count *) + let data_mappings, data_count = + let data_counts = Array.map ~f:(fun f -> Read.data_count f.contents) files in + let data_count = Array.fold_left ~f:( + ) ~init:0 data_counts in + let data_mappings = build_simple_mappings ~counts:data_counts in + data_mappings, data_count + in + if data_count > 0 + then ( + Write.data_count buf data_count; + add_section out_ch ~id:12 buf); + + (* 10: code *) + let code_pieces = Buffer.create 100000 in + let resize_data = Scan.create_resize_data () in + let source_maps = ref [] in + Write.uint code_pieces func_count; + Array.iteri + ~f:(fun i { contents; source_map_contents; _ } -> + if Read.find_section contents 10 + then ( + let pos = Buffer.length code_pieces in + let scan_func = + Scan.func + resize_data + { typ = contents.type_mapping + ; func = func_mappings.(i) + ; table = table_mappings.(i) + ; mem = mem_mappings.(i) + ; global = global_mappings.(i) + ; elem = elem_mappings.(i) + ; data = data_mappings.(i) + ; tag = tag_mappings.(i) + } + buf + contents.ch.buf + in + let code (ch : Read.ch) = + let pos = ch.pos in + let i = resize_data.i in + let size = Read.uint ch in + let pos' = ch.pos in + Scan.push_resize resize_data pos' 0; + scan_func ch.pos; + ch.pos <- ch.pos + size; + let p = Buffer.length code_pieces in + Write.uint code_pieces (Buffer.length buf); + let p' = Buffer.length code_pieces in + let delta = p' - p - pos' + pos in + resize_data.delta.(i) <- delta; + Buffer.add_buffer code_pieces buf; + Buffer.clear buf + in + let count = Read.uint contents.ch in + Scan.clear_resize_data resize_data; + Scan.push_resize resize_data 0 (-Read.pos_in contents.ch); + Read.repeat' count code contents.ch; + Option.iter + ~f:(fun sm -> + if not (Wasm_source_map.is_empty sm) + then + source_maps := (pos, Wasm_source_map.resize resize_data sm) :: !source_maps) + source_map_contents)) + files; + if start_count > 1 + then ( + (* no local *) + Buffer.add_char buf (Char.chr 0); + List.iter + ~f:(fun idx -> + (* call idx *) + Buffer.add_char buf (Char.chr 0x10); + Write.uint buf idx) + starts; + Buffer.add_buffer code_pieces buf; + Buffer.clear buf); + let code_section_offset = + let b = Buffer.create 5 in + Write.uint b (Buffer.length code_pieces); + pos_out out_ch + 1 + Buffer.length b + in + add_section out_ch ~id:10 code_pieces; + let source_map = + Wasm_source_map.concatenate + (List.map + ~f:(fun (pos, sm) -> pos + code_section_offset, sm) + (List.rev !source_maps)) + in + + (* 11: data *) + ignore + (write_section_with_scan ~files ~out_ch ~buf ~id:11 ~scan:(fun i maps -> + Scan.data_section { maps with global = global_mappings.(i) })); + + (* Custom section: name *) + let name_sections = + Array.map + ~f:(fun { contents; _ } -> Read.focus_on_custom_section contents "name") + files + in + let name_section_buffer = Buffer.create 100000 in + Write.name name_section_buffer "name"; + + (* 1: functions *) + write_namemap + ~resolved_imports + ~unresolved_imports + ~name_sections + ~name_section_buffer + ~buf + ~kind:Func + ~section_id:1 + ~mappings:func_mappings; + (* 2: locals *) + write_indirectnamemap + ~name_sections + ~name_section_buffer + ~buf + ~section_id:2 + ~mappings:func_mappings; + (* 3: labels *) + write_indirectnamemap + ~name_sections + ~name_section_buffer + ~buf + ~section_id:3 + ~mappings:func_mappings; + + (* 4: types *) + let type_names = Array.make types.last_index None in + Array.iter2 + ~f:(fun { contents; _ } name_section -> + if Read.find_section name_section 4 + then + let map = Read.namemap name_section in + Array.iter + ~f:(fun (idx, name) -> + let idx = contents.type_mapping.(idx) in + if Option.is_none type_names.(idx) then type_names.(idx) <- Some (idx, name)) + map) + files + name_sections; + Write.namemap + buf + (Array.of_list (List.filter_map ~f:(fun x -> x) (Array.to_list type_names))); + add_subsection name_section_buffer ~id:4 buf; + + (* 5: tables *) + write_namemap + ~resolved_imports + ~unresolved_imports + ~name_sections + ~name_section_buffer + ~buf + ~kind:Table + ~section_id:5 + ~mappings:table_mappings; + (* 6: memories *) + write_namemap + ~resolved_imports + ~unresolved_imports + ~name_sections + ~name_section_buffer + ~buf + ~kind:Mem + ~section_id:6 + ~mappings:mem_mappings; + (* 7: globals *) + write_namemap + ~resolved_imports + ~unresolved_imports + ~name_sections + ~name_section_buffer + ~buf + ~kind:Global + ~section_id:7 + ~mappings:global_mappings; + (* 8: elems *) + write_simple_namemap + ~name_sections + ~name_section_buffer + ~buf + ~section_id:8 + ~mappings:elem_mappings; + (* 9: data segments *) + write_simple_namemap + ~name_sections + ~name_section_buffer + ~buf + ~section_id:9 + ~mappings:data_mappings; + + (* 10: field names *) + let type_field_names = Array.make types.last_index None in + Array.iter2 + ~f:(fun { contents; _ } name_section -> + if Read.find_section name_section 10 + then + let n = Read.uint name_section.ch in + let scan_map = Scan.local_namemap buf name_section.ch.buf in + for _ = 1 to n do + let idx = contents.type_mapping.(Read.uint name_section.ch) in + scan_map name_section.ch.pos; + name_section.ch.pos <- name_section.ch.pos + Buffer.length buf; + if Option.is_none type_field_names.(idx) + then type_field_names.(idx) <- Some (idx, Buffer.contents buf); + Buffer.clear buf + done) + files + name_sections; + let type_field_names = + Array.of_list (List.filter_map ~f:(fun x -> x) (Array.to_list type_field_names)) + in + Write.uint buf (Array.length type_field_names); + for i = 0 to Array.length type_field_names - 1 do + let idx, map = type_field_names.(i) in + Write.uint buf idx; + Buffer.add_string buf map + done; + add_subsection name_section_buffer ~id:10 buf; + + (* 11: tags *) + write_namemap + ~resolved_imports + ~unresolved_imports + ~name_sections + ~name_section_buffer + ~buf + ~kind:Tag + ~section_id:11 + ~mappings:tag_mappings; + + add_section out_ch ~id:0 name_section_buffer; + + close_out out_ch; + + source_map + +(* +LATER +- testsuite : import/export matching, source maps, multiple start functions, ... +- missing instructions ==> typed continuations (?) +- check features? + +MAYBE +- topologic sort of globals? + => easy: just look at the import/export dependencies between modules +- reorder types/globals/functions to generate a smaller binary +*) diff --git a/compiler/lib-wasm/wasm_link.mli b/compiler/lib-wasm/wasm_link.mli new file mode 100644 index 0000000000..0c0ed0a582 --- /dev/null +++ b/compiler/lib-wasm/wasm_link.mli @@ -0,0 +1,26 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +type input = + { module_name : string + ; file : string + ; code : string option + ; opt_source_map : Source_map.Standard.t option + } + +val f : input list -> output_file:string -> Source_map.t diff --git a/compiler/lib-wasm/wasm_output.ml b/compiler/lib-wasm/wasm_output.ml new file mode 100644 index 0000000000..febd2c650e --- /dev/null +++ b/compiler/lib-wasm/wasm_output.ml @@ -0,0 +1,1164 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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! Stdlib +open Wasm_ast + +module Feature : sig + type set + + val make : unit -> set + + val get : set -> string list + + type t + + val register : set -> string -> t + + val require : t -> unit + + val test : t -> bool +end = struct + type t = string * bool ref + + type set = t list ref + + let make () = ref [] + + let get l = !l |> List.filter ~f:(fun (_, b) -> !b) |> List.map ~f:fst + + let register l name = + let f = name, ref false in + l := f :: !l; + f + + let require (_, b) = b := true + + let test (_, b) = !b +end + +module Make (Output : sig + type t + + val position : t -> int + + val seek : t -> int -> unit + + val byte : t -> int -> unit + + val string : t -> string -> unit +end) : sig + val output_module : Output.t -> module_field list -> unit +end = struct + let features = Feature.make () + + let mutable_globals = Feature.register features "mutable-globals" + + let nontrapping_fptoint = Feature.register features "nontrapping-fptoint" + + let multivalue = Feature.register features "multivalue" + + let exception_handling = Feature.register features "exception-handling" + + let tail_call = Feature.register features "tail-call" + + let bulk_memory = Feature.register features "bulk-memory" + + let gc = Feature.register features "gc" + + let reference_types = Feature.register features "reference-types" + + let position = Output.position + + let seek = Output.seek + + let output_byte = Output.byte + + let output_string = Output.string + + let rec output_uint ch i = + if i < 128 + then output_byte ch i + else ( + output_byte ch (128 + (i land 127)); + output_uint ch (i lsr 7)) + + let rec output_sint ch i = + if i >= -64 && i < 64 + then output_byte ch (i land 127) + else ( + output_byte ch (128 + (i land 127)); + output_sint ch (i asr 7)) + + let output_sint32 ch i = + if Poly.(i >= -64l && i < 64l) + then + let i = Int32.to_int i in + if i >= 0 then output_byte ch i else output_byte ch (i + 128) + else ( + output_byte ch (128 + (Int32.to_int i land 127)); + output_sint ch (Int32.to_int (Int32.shift_right i 7))) + + let rec output_sint64 ch i = + if Poly.(i >= -64L && i < 64L) + then + let i = Int64.to_int i in + if i >= 0 then output_byte ch i else output_byte ch (i + 128) + else ( + output_byte ch (128 + (Int64.to_int i land 127)); + output_sint64 ch (Int64.shift_right i 7)) + + let output_bytes32 ch v = + let v = ref v in + for _ = 0 to 3 do + output_byte ch (Int32.to_int !v land 255); + v := Int32.shift_right !v 8 + done + + let output_bytes64 ch v = + let v = ref v in + for _ = 0 to 7 do + output_byte ch (Int64.to_int !v land 255); + v := Int64.shift_right !v 8 + done + + let output_f32 ch f = output_bytes32 ch (Int32.bits_of_float f) + + let output_f64 ch f = output_bytes64 ch (Int64.bits_of_float f) + + let output_name ch name = + output_uint ch (String.length name); + output_string ch name + + let output_vec f ch l = + output_uint ch (List.length l); + List.iter ~f:(fun x -> f ch x) l + + let output_uint32_placeholder ch = + let pos = position ch in + output_string ch "\x80\x80\x80\x80\x00"; + pos + + let output_uint32_fixed ch ~pos v = + let pos' = position ch in + seek ch pos; + let v = ref v in + for _ = 0 to 3 do + output_byte ch ((!v land 0x7f) + 128); + v := !v lsr 7 + done; + output_byte ch !v; + seek ch pos' + + let with_size f ch x = + let pos = output_uint32_placeholder ch in + let res = f ch x in + output_uint32_fixed ch ~pos (position ch - pos - 5); + res + + (****) + let output_heaptype type_names ch typ = + match (typ : heap_type) with + | Func -> output_byte ch 0x70 + | Extern -> output_byte ch 0x6F + | Any -> output_byte ch 0x6E + | Eq -> output_byte ch 0x6D + | I31 -> output_byte ch 0x6C + | Type nm -> output_sint ch (Hashtbl.find type_names nm) + + let output_valtype type_names ch (typ : value_type) = + match typ with + | I32 -> output_byte ch 0x7F + | I64 -> output_byte ch 0x7E + | F32 -> output_byte ch 0x7D + | F64 -> output_byte ch 0x7C + | Ref { nullable; typ } -> + output_byte ch (if nullable then 0x63 else 0x64); + output_heaptype type_names ch typ + + let output_mut ch mut = output_byte ch (if mut then 0x01 else 0x00) + + let output_fieldtype type_names ch { mut; typ } = + (match typ with + | Value typ -> output_valtype type_names ch typ + | Packed typ -> ( + match typ with + | I8 -> output_byte ch 0x78 + | I16 -> output_byte ch 0x77)); + output_mut ch mut + + let output_functype type_names ch { params; result } = + if List.length result > 1 then Feature.require multivalue; + output_byte ch 0x60; + output_vec (output_valtype type_names) ch params; + output_vec (output_valtype type_names) ch result + + let output_globaltype type_names ch { typ; mut } = + output_valtype type_names ch typ; + output_mut ch mut + + let fold_types func_type explicit_definition acc fields = + List.fold_left + ~f:(fun acc field -> + match field with + | Function { typ; _ } | Import { desc = Fun typ; _ } -> func_type acc typ + | Import { desc = Tag typ; _ } -> func_type acc { params = [ typ ]; result = [] } + | Type l -> explicit_definition acc l + | Import { desc = Global _; _ } | Data _ | Global _ | Tag _ -> acc) + ~init:acc + fields + + let output_types ch fields = + let count = + let func_types = Hashtbl.create 16 in + fold_types + (fun count typ -> + if Hashtbl.mem func_types typ + then count + else ( + Hashtbl.add func_types typ (); + count + 1)) + (fun count _ -> count + 1) + 0 + fields + in + output_uint ch count; + let func_types = Hashtbl.create 16 in + let type_names = Hashtbl.create 16 in + let _idx = + fold_types + (fun idx typ -> + if Hashtbl.mem func_types typ + then idx + else ( + Hashtbl.add func_types typ idx; + output_functype type_names ch typ; + idx + 1)) + (fun idx l -> + let len = List.length l in + if List.length l > 1 + then ( + output_byte ch 0x4E; + output_uint ch len); + List.fold_left + ~f:(fun idx { name; typ; supertype; final } -> + Hashtbl.add type_names name idx; + (match supertype, final with + | None, true -> () + | None, false -> + output_byte ch 0x50; + output_byte ch 0 + | Some supertype, _ -> + output_byte ch (if final then 0X4F else 0x50); + output_byte ch 1; + output_uint ch (Hashtbl.find type_names supertype)); + (match typ with + | Array field_type -> + output_byte ch 0x5E; + output_fieldtype type_names ch field_type + | Struct l -> + output_byte ch 0x5F; + output_vec (output_fieldtype type_names) ch l + | Func typ -> output_functype type_names ch typ); + idx + 1) + ~init:idx + l) + 0 + fields + in + func_types, type_names + + let output_imports ch (func_types, type_names, fields) = + let count = + List.fold_left + ~f:(fun count field -> + match field with + | Import _ -> count + 1 + | Function _ | Type _ | Data _ | Global _ | Tag _ -> count) + ~init:0 + fields + in + output_uint ch count; + let func_idx = ref 0 in + let func_names = Hashtbl.create 16 in + let global_idx = ref 0 in + let global_names = Hashtbl.create 16 in + let tag_idx = ref 0 in + let tag_names = Hashtbl.create 16 in + List.iter + ~f:(fun field -> + match field with + | Function _ | Type _ | Data _ | Global _ | Tag _ -> () + | Import { import_module; import_name; name; desc } -> ( + output_name ch import_module; + output_name ch import_name; + match desc with + | Fun typ -> + output_byte ch 0x00; + output_uint ch (Hashtbl.find func_types typ); + Hashtbl.add func_names name !func_idx; + incr func_idx + | Global typ -> + if typ.mut then Feature.require mutable_globals; + output_byte ch 0x03; + output_globaltype type_names ch typ; + Hashtbl.add global_names name !global_idx; + incr global_idx + | Tag typ -> + Feature.require exception_handling; + output_byte ch 0x04; + output_byte ch 0x00; + output_uint ch (Hashtbl.find func_types { params = [ typ ]; result = [] }); + Hashtbl.add tag_names name !tag_idx; + incr tag_idx)) + fields; + !func_idx, func_names, !global_idx, global_names, !tag_idx, tag_names + + let output_functions ch (func_idx, func_names, func_types, fields) = + let l = + List.fold_left + ~f:(fun acc field -> + match field with + | Function { typ; _ } -> typ :: acc + | Type _ | Import _ | Data _ | Global _ | Tag _ -> acc) + ~init:[] + fields + in + let _ = + List.fold_left + ~f:(fun idx field -> + match field with + | Function { name; _ } -> + Hashtbl.add func_names name idx; + idx + 1 + | Type _ | Import _ | Data _ | Global _ | Tag _ -> idx) + ~init:func_idx + fields + in + output_vec + (fun ch typ -> output_uint ch (Hashtbl.find func_types typ)) + ch + (List.rev l) + + let int_un_op (arith, comp, trunc, reinterpret) ch op = + match op with + | Clz -> output_byte ch arith + | Ctz -> output_byte ch (arith + 1) + | Popcnt -> output_byte ch (arith + 2) + | Eqz -> output_byte ch comp + | TruncSatF64 signage -> + Feature.require nontrapping_fptoint; + output_byte ch 0xFC; + output_byte + ch + (trunc + + + match signage with + | S -> 0 + | U -> 1) + | ReinterpretF -> output_byte ch reinterpret + + let int_bin_op (arith, comp) op = + match (op : int_bin_op) with + | Add -> arith + 3 + | Sub -> arith + 4 + | Mul -> arith + 5 + | Div S -> arith + 6 + | Div U -> arith + 7 + | Rem S -> arith + 8 + | Rem U -> arith + 9 + | And -> arith + 10 + | Or -> arith + 11 + | Xor -> arith + 12 + | Shl -> arith + 13 + | Shr S -> arith + 14 + | Shr U -> arith + 15 + | Rotl -> arith + 16 + | Rotr -> arith + 17 + | Eq -> comp + 1 + | Ne -> comp + 2 + | Lt S -> comp + 3 + | Lt U -> comp + 4 + | Gt S -> comp + 5 + | Gt U -> comp + 6 + | Le S -> comp + 7 + | Le U -> comp + 8 + | Ge S -> comp + 9 + | Ge U -> comp + 10 + + let float_un_op (arith, convert, reinterpret) op = + match op with + | Abs -> arith + | Neg -> arith + 1 + | Ceil -> arith + 2 + | Floor -> arith + 3 + | Trunc -> arith + 4 + | Nearest -> arith + 5 + | Sqrt -> arith + 6 + | Convert (size, signage) -> ( + convert + + (match size with + | `I32 -> 0 + | `I64 -> 2) + + + match signage with + | S -> 0 + | U -> 1) + | ReinterpretI -> reinterpret + + let float_bin_op (arith, comp) op = + match op with + | Add -> arith + 7 + | Sub -> arith + 8 + | Mul -> arith + 9 + | Div -> arith + 10 + | Min -> arith + 11 + | Max -> arith + 12 + | CopySign -> arith + 13 + | Eq -> comp + | Ne -> comp + 1 + | Lt -> comp + 2 + | Gt -> comp + 3 + | Le -> comp + 4 + | Ge -> comp + 5 + + let output_blocktype type_names ch typ = + match typ with + | { params = []; result = [] } -> output_byte ch 0x40 + | { params = []; result = [ typ ] } -> output_valtype type_names ch typ + | _ -> assert false + + type st = + { type_names : (var, int) Hashtbl.t + ; func_names : (var, int) Hashtbl.t + ; global_names : (var, int) Hashtbl.t + ; data_names : (var, int) Hashtbl.t + ; tag_names : (var, int) Hashtbl.t + ; local_names : (var, (var, int) Hashtbl.t) Hashtbl.t + ; current_local_names : (var, int) Hashtbl.t + } + + let rec output_expression st ch e = + match e with + | Const c -> ( + match c with + | I32 d -> + output_byte ch 0x41; + output_sint32 ch d + | I64 d -> + output_byte ch 0x42; + output_sint64 ch d + | F32 d -> + output_byte ch 0x43; + output_f32 ch d + | F64 d -> + output_byte ch 0x44; + output_f64 ch d) + | UnOp (op, e') -> ( + output_expression st ch e'; + match op with + | I32 op -> int_un_op (0x67, 0x45, 2, 0xBC) ch op + | I64 op -> int_un_op (0x79, 0x50, 6, 0xBD) ch op + | F32 op -> output_byte ch (float_un_op (0x8B, 0xB2, 0xBE) op) + | F64 op -> output_byte ch (float_un_op (0x99, 0xB7, 0xBF) op)) + | BinOp (op, e', e'') -> ( + output_expression st ch e'; + output_expression st ch e''; + match op with + | I32 op -> output_byte ch (int_bin_op (0x67, 0x45) op) + | I64 op -> output_byte ch (int_bin_op (0x79, 0x50) op) + | F32 op -> output_byte ch (float_bin_op (0x8B, 0x5B) op) + | F64 op -> output_byte ch (float_bin_op (0x99, 0x61) op)) + | I32WrapI64 e' -> + output_expression st ch e'; + output_byte ch 0xA7 + | I64ExtendI32 (S, e') -> + output_expression st ch e'; + output_byte ch 0xAC + | I64ExtendI32 (U, e') -> + output_expression st ch e'; + output_byte ch 0xAD + | F32DemoteF64 e' -> + output_expression st ch e'; + output_byte ch 0xB6 + | F64PromoteF32 e' -> + output_expression st ch e'; + output_byte ch 0xBB + | LocalGet i -> + output_byte ch 0x20; + output_uint ch (Hashtbl.find st.current_local_names i) + | LocalTee (i, e') -> + output_expression st ch e'; + output_byte ch 0x22; + output_uint ch (Hashtbl.find st.current_local_names i) + | GlobalGet g -> + output_byte ch 0x23; + output_uint ch (Hashtbl.find st.global_names g) + | BlockExpr (typ, l) -> + output_byte ch 0x02; + output_blocktype st.type_names ch typ; + List.iter ~f:(fun i' -> output_instruction st ch i') l; + output_byte ch 0x0B + | Call (f, l) -> + List.iter ~f:(fun e' -> output_expression st ch e') l; + output_byte ch 0x10; + output_uint ch (Hashtbl.find st.func_names f) + | Seq _ -> assert false + | Pop _ -> () + | RefFunc f -> + Feature.require reference_types; + output_byte ch 0xD2; + output_uint ch (Hashtbl.find st.func_names f) + | Call_ref (typ, e', l) -> + Feature.require gc; + List.iter ~f:(fun e' -> output_expression st ch e') l; + output_expression st ch e'; + output_byte ch 0x14; + output_uint ch (Hashtbl.find st.type_names typ) + | RefI31 e' -> + Feature.require gc; + output_expression st ch e'; + output_byte ch 0xFB; + output_byte ch 0x1C + | I31Get (s, e') -> ( + Feature.require gc; + output_expression st ch e'; + output_byte ch 0xFB; + match s with + | S -> output_byte ch 0x1D + | U -> output_byte ch 0x1E) + | ArrayNew (typ, e', e'') -> + Feature.require gc; + output_expression st ch e'; + output_expression st ch e''; + output_byte ch 0xFB; + output_byte ch 6; + output_uint ch (Hashtbl.find st.type_names typ) + | ArrayNewFixed (typ, l) -> + Feature.require gc; + List.iter ~f:(fun e' -> output_expression st ch e') l; + output_byte ch 0xFB; + output_byte ch 8; + output_uint ch (Hashtbl.find st.type_names typ); + output_uint ch (List.length l) + | ArrayNewData (typ, data, e', e'') -> + Feature.require gc; + output_expression st ch e'; + output_expression st ch e''; + output_byte ch 0xFB; + output_byte ch 9; + output_uint ch (Hashtbl.find st.type_names typ); + output_uint ch (Hashtbl.find st.data_names data) + | ArrayGet (signage, typ, e', e'') -> + Feature.require gc; + output_expression st ch e'; + output_expression st ch e''; + output_byte ch 0xFB; + output_byte + ch + (match signage with + | None -> 0x0B + | Some S -> 0x0C + | Some U -> 0x0D); + output_uint ch (Hashtbl.find st.type_names typ) + | ArrayLen e' -> + Feature.require gc; + output_expression st ch e'; + output_byte ch 0xFB; + output_byte ch 0x0F + | StructNew (typ, l) -> + Feature.require gc; + List.iter ~f:(fun e' -> output_expression st ch e') l; + output_byte ch 0xFB; + output_byte ch 0; + output_uint ch (Hashtbl.find st.type_names typ) + | StructGet (signage, typ, idx, e') -> + Feature.require gc; + output_expression st ch e'; + output_byte ch 0xFB; + output_byte + ch + (match signage with + | None -> 0x02 + | Some S -> 0x03 + | Some U -> 0x04); + output_uint ch (Hashtbl.find st.type_names typ); + output_uint ch idx + | RefCast ({ typ; nullable }, e') -> + Feature.require gc; + output_expression st ch e'; + output_byte ch 0xFB; + output_byte ch (if nullable then 0x17 else 0x16); + output_heaptype st.type_names ch typ + | RefTest ({ typ; nullable }, e') -> + Feature.require gc; + output_expression st ch e'; + output_byte ch 0xFB; + output_byte ch (if nullable then 0x15 else 0x14); + output_heaptype st.type_names ch typ + | RefEq (e', e'') -> + Feature.require gc; + output_expression st ch e'; + output_expression st ch e''; + output_byte ch 0xD3 + | RefNull typ -> + Feature.require reference_types; + output_byte ch 0xD0; + output_heaptype st.type_names ch typ + | Br_on_cast (i, typ1, typ2, e') -> + Feature.require gc; + output_expression st ch e'; + output_byte ch 0xFB; + output_byte ch 0x18; + output_byte ch ((if typ1.nullable then 1 else 0) + if typ2.nullable then 2 else 0); + output_uint ch i; + output_heaptype st.type_names ch typ1.typ; + output_heaptype st.type_names ch typ2.typ + | Br_on_cast_fail (i, typ1, typ2, e') -> + Feature.require gc; + output_expression st ch e'; + output_byte ch 0xFB; + output_byte ch 0x19; + output_byte ch ((if typ1.nullable then 1 else 0) + if typ2.nullable then 2 else 0); + output_uint ch i; + output_heaptype st.type_names ch typ1.typ; + output_heaptype st.type_names ch typ2.typ + | IfExpr (typ, e1, e2, e3) -> + output_expression st ch e1; + output_byte ch 0x04; + output_valtype st.type_names ch typ; + output_expression st ch e2; + output_byte ch 0x05; + output_expression st ch e3; + output_byte ch 0x0B + | Try (typ, l, catches) -> + Feature.require exception_handling; + output_byte ch 0x06; + output_blocktype st.type_names ch typ; + List.iter ~f:(fun i' -> output_instruction st ch i') l; + List.iter + ~f:(fun (tag, l, ty) -> + output_byte ch 0x07; + output_uint ch (Hashtbl.find st.tag_names tag); + output_instruction st ch (Br (l + 1, Some (Pop ty)))) + catches; + output_byte ch 0X0B + + and output_instruction st ch i = + match i with + | Drop e -> + output_expression st ch e; + output_byte ch 0x1A + | LocalSet (i, e) -> + output_expression st ch e; + output_byte ch 0x21; + output_uint ch (Hashtbl.find st.current_local_names i) + | GlobalSet (g, e) -> + output_expression st ch e; + output_byte ch 0x24; + output_uint ch (Hashtbl.find st.global_names g) + | Loop (typ, l) -> + output_byte ch 0x03; + output_blocktype st.type_names ch typ; + List.iter ~f:(fun i' -> output_instruction st ch i') l; + output_byte ch 0x0B + | Block (typ, l) -> + output_byte ch 0x02; + output_blocktype st.type_names ch typ; + List.iter ~f:(fun i' -> output_instruction st ch i') l; + output_byte ch 0x0B + | If (typ, e, l1, l2) -> + output_expression st ch e; + output_byte ch 0x04; + output_blocktype st.type_names ch typ; + List.iter ~f:(fun i' -> output_instruction st ch i') l1; + if not (List.is_empty l2) + then ( + output_byte ch 0x05; + List.iter ~f:(fun i' -> output_instruction st ch i') l2); + output_byte ch 0x0B + | Br_table (e, l, i) -> + output_expression st ch e; + output_byte ch 0x0E; + output_vec output_uint ch l; + output_uint ch i + | Br (i, None) -> + output_byte ch 0x0C; + output_uint ch i + | Br (i, Some e) -> + output_expression st ch e; + output_byte ch 0x0C; + output_uint ch i + | Br_if (i, e) -> + output_expression st ch e; + output_byte ch 0x0D; + output_uint ch i + | Return None -> output_byte ch 0x0F + | Return (Some e) -> + output_expression st ch e; + output_byte ch 0x0F + | CallInstr (f, l) -> + List.iter ~f:(fun e -> output_expression st ch e) l; + output_byte ch 0x10; + output_uint ch (Hashtbl.find st.func_names f) + | Nop -> () + | Push e -> output_expression st ch e + | Throw (tag, e) -> + Feature.require exception_handling; + output_expression st ch e; + output_byte ch 0x08; + output_uint ch (Hashtbl.find st.tag_names tag) + | Rethrow i -> + Feature.require exception_handling; + output_byte ch 0x09; + output_uint ch i + | ArraySet (typ, e1, e2, e3) -> + Feature.require gc; + output_expression st ch e1; + output_expression st ch e2; + output_expression st ch e3; + output_byte ch 0xFB; + output_byte ch 0x0E; + output_uint ch (Hashtbl.find st.type_names typ) + | StructSet (typ, idx, e1, e2) -> + Feature.require gc; + output_expression st ch e1; + output_expression st ch e2; + output_byte ch 0xFB; + output_byte ch 0x05; + output_uint ch (Hashtbl.find st.type_names typ); + output_uint ch idx + | Return_call (f, l) -> + Feature.require tail_call; + List.iter ~f:(fun e -> output_expression st ch e) l; + output_byte ch 0x12; + output_uint ch (Hashtbl.find st.func_names f) + | Return_call_ref (typ, e', l) -> + Feature.require tail_call; + List.iter ~f:(fun e' -> output_expression st ch e') l; + output_expression st ch e'; + output_byte ch 0x15; + output_uint ch (Hashtbl.find st.type_names typ) + | Event _ -> () + + let output_globals ch (st, global_idx, fields) = + let count = + List.fold_left + ~f:(fun count field -> + match field with + | Global _ -> count + 1 + | Function _ | Type _ | Import _ | Data _ | Tag _ -> count) + ~init:0 + fields + in + output_uint ch count; + let _idx = + List.fold_left + ~f:(fun idx field -> + match field with + | Global { name; typ; init; _ } -> + Hashtbl.add st.global_names name idx; + output_globaltype st.type_names ch typ; + output_expression st ch init; + output_byte ch 0x0B; + idx + 1 + | Function _ | Type _ | Import _ | Data _ | Tag _ -> idx) + ~init:global_idx + fields + in + () + + let output_exports ch (func_names, global_names, fields) = + let count = + List.fold_left + ~f:(fun count field -> + match field with + | Function { exported_name = Some _; _ } | Global { exported_name = Some _; _ } + -> count + 1 + | Function { exported_name = None; _ } + | Global { exported_name = None; _ } + | Import _ | Type _ | Data _ | Tag _ -> count) + ~init:0 + fields + in + output_uint ch count; + List.iter + ~f:(fun field -> + match field with + | Function { exported_name = None; _ } + | Type _ | Data _ + | Global { exported_name = None; _ } + | Tag _ | Import _ -> () + | Function { name; exported_name = Some exported_name; _ } -> + output_name ch exported_name; + output_byte ch 0x00; + output_uint ch (Hashtbl.find func_names name) + | Global { name; exported_name = Some exported_name; typ; _ } -> + if typ.mut then Feature.require mutable_globals; + output_name ch exported_name; + output_byte ch 0x03; + output_uint ch (Hashtbl.find global_names name)) + fields + + let compute_data_names fields = + let data_count = + List.fold_left + ~f:(fun count field -> + match field with + | Data _ -> count + 1 + | Function _ | Type _ | Import _ | Global _ | Tag _ -> count) + ~init:0 + fields + in + let data_names = Hashtbl.create 16 in + let _idx = + List.fold_left + ~f:(fun idx field -> + match field with + | Data { name; _ } -> + Hashtbl.add data_names name idx; + idx + 1 + | Function _ | Type _ | Import _ | Global _ | Tag _ -> idx) + ~init:0 + fields + in + data_count, data_names + + let output_data_count ch data_count = output_uint ch data_count + + let output_data ch (data_count, fields) = + output_uint ch data_count; + ignore + (List.fold_left + ~f:(fun idx field -> + match field with + | Data { contents; _ } -> + output_byte ch 1; + output_name ch contents; + idx + 1 + | Function _ | Type _ | Import _ | Global _ | Tag _ -> idx) + ~init:0 + fields) + + let rec expr_function_references e set = + match e with + | Const _ | LocalGet _ | GlobalGet _ | Pop _ | RefNull _ -> set + | UnOp (_, e') + | I32WrapI64 e' + | I64ExtendI32 (_, e') + | F32DemoteF64 e' + | F64PromoteF32 e' + | LocalTee (_, e') + | RefI31 e' + | I31Get (_, e') + | ArrayLen e' + | StructGet (_, _, _, e') + | RefCast (_, e') + | RefTest (_, e') + | Br_on_cast (_, _, _, e') + | Br_on_cast_fail (_, _, _, e') -> expr_function_references e' set + | BinOp (_, e', e'') + | ArrayNew (_, e', e'') + | ArrayNewData (_, _, e', e'') + | ArrayGet (_, _, e', e'') + | RefEq (e', e'') -> + set |> expr_function_references e' |> expr_function_references e'' + | IfExpr (_, e1, e2, e3) -> + set + |> expr_function_references e1 + |> expr_function_references e2 + |> expr_function_references e3 + | BlockExpr (_, l) -> + List.fold_left ~f:(fun set i -> instr_function_references i set) ~init:set l + | Call (_, l) | ArrayNewFixed (_, l) | StructNew (_, l) -> + List.fold_left ~f:(fun set i -> expr_function_references i set) ~init:set l + | Seq _ -> assert false + | RefFunc f -> Code.Var.Set.add f set + | Call_ref (_, e', l) -> + List.fold_left + ~f:(fun set i -> expr_function_references i set) + ~init:(expr_function_references e' set) + l + | Try (_, l, _) -> + List.fold_left ~f:(fun set i -> instr_function_references i set) ~init:set l + + and instr_function_references i set = + match i with + | Drop e + | LocalSet (_, e) + | GlobalSet (_, e) + | Br (_, Some e) + | Br_table (e, _, _) + | Br_if (_, e) + | Return (Some e) + | Push e + | Throw (_, e) -> expr_function_references e set + | Loop (_, l) | Block (_, l) -> + List.fold_left ~f:(fun set i -> instr_function_references i set) ~init:set l + | If (_, e, l1, l2) -> + set + |> expr_function_references e + |> (fun init -> + List.fold_left ~f:(fun set i -> instr_function_references i set) ~init l1) + |> fun init -> + List.fold_left ~f:(fun set i -> instr_function_references i set) ~init l2 + | Br (_, None) | Return None | Nop | Rethrow _ -> set + | CallInstr (_, l) -> + List.fold_left ~f:(fun set i -> expr_function_references i set) ~init:set l + | ArraySet (_, e1, e2, e3) -> + set + |> expr_function_references e1 + |> expr_function_references e2 + |> expr_function_references e3 + | StructSet (_, _, e1, e2) -> + set |> expr_function_references e1 |> expr_function_references e2 + | Return_call (_, l) -> + List.fold_left ~f:(fun set i -> expr_function_references i set) ~init:set l + | Return_call_ref (_, e', l) -> + List.fold_left + ~f:(fun set i -> expr_function_references i set) + ~init:(expr_function_references e' set) + l + | Event _ -> set + + let function_references fields set = + List.fold_left + ~f:(fun set field -> + match field with + | Function { body; _ } -> + List.fold_left + ~f:(fun set i -> instr_function_references i set) + ~init:set + body + | Global _ | Import _ | Type _ | Data _ | Tag _ -> set) + ~init:set + fields + + let output_elem ch (st, refs) = + output_byte ch (* declare *) 1; + output_byte ch (* func *) 3; + output_byte ch 0x00; + let refs = Code.Var.Set.elements refs in + output_vec (fun ch f -> output_uint ch (Hashtbl.find st.func_names f)) ch refs + + let coalesce_locals l = + let rec loop acc n t l = + match l with + | [] -> List.rev ((n, t) :: acc) + | (_, t') :: r -> + if Poly.equal t t' then loop acc (n + 1) t r else loop ((n, t) :: acc) 1 t' r + in + match l with + | [] -> [] + | (_, t) :: rem -> loop [] 1 t rem + + let output_code ch (st, fields) = + let l = + List.fold_left + ~f:(fun acc field -> + match field with + | Function { name; param_names; locals; body; _ } -> + (name, param_names, locals, body) :: acc + | Type _ | Import _ | Data _ | Global _ | Tag _ -> acc) + ~init:[] + fields + in + output_vec + (with_size (fun ch (name, param_names, locals, body) -> + let current_local_names = Hashtbl.create 8 in + let idx = + List.fold_left + ~f:(fun idx x -> + Hashtbl.add current_local_names x idx; + idx + 1) + ~init:0 + param_names + in + let _ = + List.fold_left + ~f:(fun idx (x, _) -> + Hashtbl.add current_local_names x idx; + idx + 1) + ~init:idx + locals + in + Hashtbl.add st.local_names name current_local_names; + let st = { st with current_local_names } in + output_vec + (fun ch (n, typ) -> + output_uint ch n; + output_valtype st.type_names ch typ) + ch + (coalesce_locals locals); + (try List.iter ~f:(fun i -> output_instruction st ch i) body + with e -> + let backtrace = Printexc.get_backtrace () in + prerr_endline (Printexc.to_string e); + prerr_endline backtrace; + assert false); + output_byte ch 0x0B)) + ch + (List.rev l) + + let output_section id f ch x = + output_byte ch id; + with_size f ch x + + let assign_names f tbl = + let names = Hashtbl.fold (fun name idx rem -> (idx, name) :: rem) tbl [] in + let names = List.sort ~cmp:(fun (idx, _) (idx', _) -> compare idx idx') names in + let used = ref StringSet.empty in + let counts = Hashtbl.create 101 in + let rec find_available_name used name = + let i = + try Hashtbl.find counts name + with Not_found -> + let i = ref 0 in + Hashtbl.replace counts name i; + i + in + incr i; + let nm = Printf.sprintf "%s$%d" name !i in + if StringSet.mem nm used then find_available_name used name else nm + in + let names = + List.map + ~f:(fun (idx, x) -> + match f x with + | None -> idx, None + | Some nm -> + let nm = + if StringSet.mem nm !used then find_available_name !used nm else nm + in + used := StringSet.add nm !used; + idx, Some nm) + names + in + let printer = Var_printer.create Var_printer.Alphabet.javascript in + let i = ref 0 in + let rec first_available_name () = + let nm = Var_printer.to_string printer !i in + incr i; + if StringSet.mem nm !used then first_available_name () else nm + in + List.map + ~f:(fun (idx, nm) -> + match nm with + | Some nm -> idx, nm + | None -> idx, first_available_name ()) + names + + let output_names ch st = + output_name ch "name"; + let index = Code.Var.get_name in + let out id f tbl = + let names = assign_names f tbl in + if not (List.is_empty names) + then + output_section + id + (output_vec (fun ch (idx, name) -> + output_uint ch idx; + output_name ch name)) + ch + names + in + let locals = + Hashtbl.fold + (fun name tbl rem -> (Hashtbl.find st.func_names name, tbl) :: rem) + st.local_names + [] + |> List.sort ~cmp:(fun (idx, _) (idx', _) -> compare idx idx') + in + out 1 index st.func_names; + output_section + 2 + (output_vec (fun ch (idx, tbl) -> + output_uint ch idx; + let locals = assign_names index tbl in + output_vec + (fun ch (idx, name) -> + output_uint ch idx; + output_name ch name) + ch + locals)) + ch + locals; + out 4 index st.type_names; + out 7 index st.global_names; + out 9 index st.data_names; + out 11 index st.tag_names + + let output_features ch () = + output_name ch "target_features"; + output_vec + (fun ch f -> + output_byte ch 0x2b; + output_name ch f) + ch + (Feature.get features) + + let output_module ch fields = + output_string ch "\x00\x61\x73\x6D\x01\x00\x00\x00"; + let func_types, type_names = output_section 1 output_types ch fields in + let func_idx, func_names, global_idx, global_names, _, tag_names = + output_section 2 output_imports ch (func_types, type_names, fields) + in + output_section 3 output_functions ch (func_idx, func_names, func_types, fields); + let st = + { type_names + ; func_names + ; global_names + ; data_names = Hashtbl.create 1 + ; tag_names + ; local_names = Hashtbl.create 8 + ; current_local_names = Hashtbl.create 8 + } + in + output_section 6 output_globals ch (st, global_idx, fields); + output_section 7 output_exports ch (func_names, global_names, fields); + let refs = function_references fields Code.Var.Set.empty in + output_section 9 output_elem ch (st, refs); + let data_count, data_names = compute_data_names fields in + if data_count > 0 + then ( + Feature.require bulk_memory; + output_section 12 output_data_count ch data_count); + let st = { st with data_names } in + output_section 10 output_code ch (st, fields); + output_section 11 output_data ch (data_count, fields); + if Config.Flag.pretty () then output_section 0 output_names ch st; + if Feature.test gc then Feature.require reference_types; + output_section 0 output_features ch () +end + +let f ch fields = + let module O = Make (struct + type t = out_channel + + let position = pos_out + + let seek = seek_out + + let byte = output_byte + + let string = output_string + end) in + Code.Var.set_pretty true; + Code.Var.set_stable (Config.Flag.stable_var ()); + O.output_module ch fields diff --git a/compiler/lib-wasm/wasm_output.mli b/compiler/lib-wasm/wasm_output.mli new file mode 100644 index 0000000000..9e01eb96a6 --- /dev/null +++ b/compiler/lib-wasm/wasm_output.mli @@ -0,0 +1,19 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 f : out_channel -> Wasm_ast.module_field list -> unit diff --git a/compiler/lib-wasm/wasm_source_map.ml b/compiler/lib-wasm/wasm_source_map.ml new file mode 100644 index 0000000000..0d59a6927e --- /dev/null +++ b/compiler/lib-wasm/wasm_source_map.ml @@ -0,0 +1,182 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 Stdlib + +type resize_data = + { mutable i : int + ; mutable pos : int array + ; mutable delta : int array + } + +type t = Yojson.Raw.t + +type input = Vlq64.input = + { string : string + ; mutable pos : int + ; len : int + } + +let rec next' src mappings pos len = + pos < len + && + match mappings.[pos] with + | ',' -> + src.pos <- pos + 1; + true + | _ -> next' src mappings (pos + 1) len + +let next src = next' src src.string src.pos src.len + +let flush buf src start pos = + if start < pos then Buffer.add_substring buf src.string start (pos - start) + +let rec resize_rec buf start src resize_data i col0 delta0 col = + let pos = src.pos in + let delta = Vlq64.decode src in + let col = col + delta in + if col < col0 + then + if next src + then resize_rec buf start src resize_data i col0 delta0 col + else flush buf src start src.len + else + let delta = delta + delta0 in + adjust buf start src resize_data i col delta pos + +and adjust buf start src (resize_data : resize_data) i col delta pos = + assert (delta > 0); + if i < resize_data.i + then + let col0 = resize_data.pos.(i) in + let delta0 = resize_data.delta.(i) in + if col < col0 + then ( + flush buf src start pos; + Vlq64.encode buf delta; + let start = src.pos in + if next src + then resize_rec buf start src resize_data (i + 1) col0 delta0 col + else flush buf src start src.len) + else + let delta = delta + delta0 in + adjust buf start src resize_data (i + 1) col delta pos + else ( + flush buf src start pos; + Vlq64.encode buf delta; + let start = src.pos in + flush buf src start src.len) + +let resize_mappings (resize_data : resize_data) mappings = + if String.equal mappings "" || resize_data.i = 0 + then mappings + else + let col0 = resize_data.pos.(0) in + let delta0 = resize_data.delta.(0) in + let buf = Buffer.create (String.length mappings) in + resize_rec + buf + 0 + { Vlq64.string = mappings; pos = 0; len = String.length mappings } + resize_data + 1 + col0 + delta0 + 0; + Buffer.contents buf + +let resize resize_data (sm : Source_map.Standard.t) = + let mappings = Source_map.Mappings.to_string sm.mappings in + let mappings = resize_mappings resize_data mappings in + { sm with mappings = Source_map.Mappings.of_string_unsafe mappings } + +let is_empty { Source_map.Standard.mappings; _ } = Source_map.Mappings.is_empty mappings + +let concatenate l = + Source_map.Index + { version = 3 + ; file = None + ; sections = + List.map + ~f:(fun (ofs, map) -> + { Source_map.Index.offset = { gen_line = 0; gen_column = ofs }; map }) + l + } + +let iter_sources' (sm : Source_map.Standard.t) i f = + let l = sm.sources in + let single = List.length l = 1 in + List.iteri ~f:(fun j nm -> f i (if single then None else Some j) nm) l + +let iter_sources sm f = + match sm with + | Source_map.Standard sm -> iter_sources' sm None f + | Index { sections; _ } -> + let single_map = List.length sections = 1 in + List.iteri + ~f:(fun i entry -> + iter_sources' entry.Source_map.Index.map (if single_map then None else Some i) f) + sections + +let blackbox_filename = "/builtin/blackbox.ml" + +let blackbox_contents = "(* generated code *)" + +let insert_source_contents' ~rewrite_path (sm : Source_map.Standard.t) i f = + let l = sm.sources in + let single = List.length l = 1 in + let contents = + List.mapi + ~f:(fun j name -> + if String.equal name blackbox_filename + then Some (Source_map.Source_content.create blackbox_contents) + else + match f i (if single then None else Some j) name with + | Some c -> Some (Source_map.Source_content.of_stringlit (`Stringlit c)) + | None -> None) + l + in + let sm = { sm with sources_content = Some contents } in + let sm = + if List.mem blackbox_filename ~set:sm.sources + then { sm with ignore_list = [ blackbox_filename ] } + else sm + in + let sm = { sm with sources = List.map ~f:rewrite_path sm.sources } in + sm + +let insert_source_contents ~rewrite_path sm f = + match sm with + | Source_map.Standard sm -> + Source_map.Standard (insert_source_contents' ~rewrite_path sm None f) + | Index ({ sections; _ } as sm) -> + let single_map = List.length sections = 1 in + let sections = + List.mapi + ~f:(fun i entry -> + { entry with + Source_map.Index.map = + insert_source_contents' + ~rewrite_path + entry.Source_map.Index.map + (if single_map then None else Some i) + f + }) + sections + in + Index { sm with sections } diff --git a/compiler/lib-wasm/wasm_source_map.mli b/compiler/lib-wasm/wasm_source_map.mli new file mode 100644 index 0000000000..2ca1bec72c --- /dev/null +++ b/compiler/lib-wasm/wasm_source_map.mli @@ -0,0 +1,43 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +type t + +val is_empty : Source_map.Standard.t -> bool + +type resize_data = + { mutable i : int + ; mutable pos : int array + ; mutable delta : int array + } + +val resize : resize_data -> Source_map.Standard.t -> Source_map.Standard.t + +val concatenate : (int * Source_map.Standard.t) list -> Source_map.t + +val iter_sources : Source_map.t -> (int option -> int option -> string -> unit) -> unit + +val insert_source_contents : + rewrite_path:(string -> string) + -> Source_map.t + -> (int option -> int option -> string -> string option) + -> Source_map.t + +val blackbox_filename : string + +val blackbox_contents : string diff --git a/compiler/lib-wasm/wat_output.ml b/compiler/lib-wasm/wat_output.ml new file mode 100644 index 0000000000..27c2307801 --- /dev/null +++ b/compiler/lib-wasm/wat_output.ml @@ -0,0 +1,665 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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! Stdlib +open Wasm_ast + +let assign_names ?(reversed = true) f names = + let used = ref StringSet.empty in + let counts = Hashtbl.create 101 in + let rec find_available_name used name = + let i = + try Hashtbl.find counts name + with Not_found -> + let i = ref 0 in + Hashtbl.replace counts name i; + i + in + incr i; + let nm = Printf.sprintf "%s$%d" name !i in + if StringSet.mem nm used then find_available_name used name else nm + in + let names = if reversed then List.rev names else names in + let names = + List.map + ~f:(fun x -> + match f x with + | None -> x, None + | Some nm -> + let nm = + if StringSet.mem nm !used then find_available_name !used nm else nm + in + used := StringSet.add nm !used; + x, Some nm) + names + in + let printer = Var_printer.create Var_printer.Alphabet.javascript in + let i = ref 0 in + let rec first_available_name () = + let nm = Var_printer.to_string printer !i in + incr i; + if StringSet.mem nm !used then first_available_name () else nm + in + let tbl = Hashtbl.create 16 in + List.iter + ~f:(fun (x, nm) -> + Hashtbl.add + tbl + x + (match nm with + | Some nm -> nm + | None -> first_available_name ())) + names; + tbl + +type st = + { type_names : (var, string) Hashtbl.t + ; func_names : (var, string) Hashtbl.t + ; global_names : (var, string) Hashtbl.t + ; data_names : (var, string) Hashtbl.t + ; tag_names : (var, string) Hashtbl.t + ; local_names : (var, string) Hashtbl.t + } + +let build_name_tables fields = + let type_names = ref [] in + let func_names = ref [] in + let data_names = ref [] in + let global_names = ref [] in + let tag_names = ref [] in + let push l v = l := v :: !l in + List.iter + ~f:(fun field -> + match field with + | Function { name; _ } -> push func_names name + | Type l -> List.iter ~f:(fun { name; _ } -> push type_names name) l + | Data { name; _ } -> push data_names name + | Global { name; _ } -> push global_names name + | Tag { name; _ } -> push tag_names name + | Import { name; desc; _ } -> ( + match desc with + | Fun _ -> push func_names name + | Global _ -> push global_names name + | Tag _ -> push tag_names name)) + fields; + let index = Code.Var.get_name in + { type_names = assign_names index !type_names + ; func_names = assign_names index !func_names + ; global_names = assign_names index !global_names + ; data_names = assign_names index !data_names + ; tag_names = assign_names index !tag_names + ; local_names = Hashtbl.create 1 + } + +type sexp = + | Atom of string + | List of sexp list + | Comment of string + (** Line comment. String [s] is rendered as [;;s], on its own line, + without space after the double semicolon. *) + +let rec format_sexp f s = + match s with + | Atom s -> Format.fprintf f "%s" s + | List l -> + let has_comment = + List.exists l ~f:(function + | Comment _ -> true + | _ -> false) + in + if has_comment + then (* Ensure comments are on their own line *) + Format.fprintf f "@[(" + else Format.fprintf f "@[<2>("; + Format.pp_print_list ~pp_sep:(fun f () -> Format.fprintf f "@ ") format_sexp f l; + if + has_comment + && List.fold_left + ~f:(fun _ i -> + match i with + | Comment _ -> true + | _ -> false) + ~init:false + l + then + (* Make sure there is a newline when a comment is at the very end. *) + Format.fprintf f "@ "; + Format.fprintf f ")@]" + | Comment s -> Format.fprintf f ";;%s" s + +let index tbl x = Atom ("$" ^ Hashtbl.find tbl x) + +let heap_type st (ty : heap_type) = + match ty with + | Func -> Atom "func" + | Extern -> Atom "extern" + | Any -> Atom "any" + | Eq -> Atom "eq" + | I31 -> Atom "i31" + | Type t -> index st.type_names t + +let ref_type st { nullable; typ } = + let r = [ heap_type st typ ] in + List (Atom "ref" :: (if nullable then Atom "null" :: r else r)) + +let value_type st (t : value_type) = + match t with + | I32 -> Atom "i32" + | I64 -> Atom "i64" + | F32 -> Atom "f32" + | F64 -> Atom "f64" + | Ref ty -> ref_type st ty + +let packed_type t = + match t with + | I8 -> Atom "i8" + | I16 -> Atom "i16" + +let list ?(always = false) name f l = + if (not always) && List.is_empty l then [] else [ List (Atom name :: f l) ] + +let value_type_list st name tl = + list name (fun tl -> List.map ~f:(fun t -> value_type st t) tl) tl + +let func_type st ?param_names { params; result } = + (match param_names with + | None -> value_type_list st "param" params + | Some names -> + List.map2 + ~f:(fun i typ -> List [ Atom "param"; index st.local_names i; value_type st typ ]) + names + params) + @ value_type_list st "result" result + +let storage_type st typ = + match typ with + | Value typ -> value_type st typ + | Packed typ -> packed_type typ + +let mut_type f { mut; typ } = if mut then List [ Atom "mut"; f typ ] else f typ + +let field_type st typ = mut_type (fun t -> storage_type st t) typ + +let global_type st typ = mut_type (fun t -> value_type st t) typ + +let str_type st typ = + match typ with + | Func ty -> List (Atom "func" :: func_type st ty) + | Struct l -> + List + (Atom "struct" :: List.map ~f:(fun f -> List [ Atom "field"; field_type st f ]) l) + | Array ty -> List [ Atom "array"; field_type st ty ] + +let block_type = func_type + +let quoted_name name = Atom ("\"" ^ name ^ "\"") + +let export name = + match name with + | None -> [] + | Some name -> [ List [ Atom "export"; quoted_name name ] ] + +let type_prefix op nm = + (match op with + | I32 _ -> "i32." + | I64 _ -> "i64." + | F32 _ -> "f32." + | F64 _ -> "f64.") + ^ nm + +let signage op (s : Wasm_ast.signage) = + op + ^ + match s with + | S -> "_s" + | U -> "_u" + +let int_un_op sz op = + match op with + | Clz -> "clz" + | Ctz -> "ctz" + | Popcnt -> "popcnt" + | Eqz -> "eqz" + | TruncSatF64 s -> signage "trunc_sat_f64" s + | ReinterpretF -> "reinterpret_f" ^ sz + +let int_bin_op _ (op : int_bin_op) = + match op with + | Add -> "add" + | Sub -> "sub" + | Mul -> "mul" + | Div s -> signage "div" s + | Rem s -> signage "rem" s + | And -> "and" + | Or -> "or" + | Xor -> "xor" + | Shl -> "shl" + | Shr s -> signage "shr" s + | Rotl -> "rotl" + | Rotr -> "rotr" + | Eq -> "eq" + | Ne -> "ne" + | Lt s -> signage "lt" s + | Gt s -> signage "gt" s + | Le s -> signage "le" s + | Ge s -> signage "ge" s + +let float_un_op sz op = + match op with + | Neg -> "neg" + | Abs -> "abs" + | Ceil -> "ceil" + | Floor -> "floor" + | Trunc -> "trunc" + | Nearest -> "nearest" + | Sqrt -> "sqrt" + | Convert (`I32, s) -> signage "convert_i32" s + | Convert (`I64, s) -> signage "convert_i64" s + | ReinterpretI -> "reinterpret_i" ^ sz + +let float_bin_op _ op = + match op with + | Add -> "add" + | Sub -> "sub" + | Mul -> "mul" + | Div -> "div" + | Min -> "min" + | Max -> "max" + | CopySign -> "copysign" + | Eq -> "eq" + | Ne -> "ne" + | Lt -> "lt" + | Gt -> "gt" + | Le -> "le" + | Ge -> "ge" + +let select i32 i64 f32 f64 op = + match op with + | I32 x -> i32 "32" x + | I64 x -> i64 "64" x + | F32 x -> f32 "32" x + | F64 x -> f64 "64" x + +type ctx = { mutable function_refs : Code.Var.Set.t } + +let reference_function ctx f = ctx.function_refs <- Code.Var.Set.add f ctx.function_refs + +let remove_nops l = List.filter ~f:(fun i -> not (Poly.equal i Nop)) l + +let float64 _ f = + match classify_float f with + | FP_normal | FP_subnormal | FP_zero | FP_nan -> Printf.sprintf "%h" f + | FP_infinite -> if Float.(f > 0.) then "inf" else "-inf" + +let float32 _ f = + match classify_float f with + | FP_normal | FP_subnormal | FP_zero | FP_nan -> Printf.sprintf "%h" f + | FP_infinite -> if Float.(f > 0.) then "inf" else "-inf" + +let expression_or_instructions ctx st in_function = + let rec expression e = + match e with + | Const op -> + [ List + [ Atom (type_prefix op "const") + ; Atom + (select + (fun _ i -> Int32.to_string i) + (fun _ i -> Int64.to_string i) + float32 + float64 + op) + ] + ] + | UnOp (op, e') -> + [ List + (Atom (type_prefix op (select int_un_op int_un_op float_un_op float_un_op op)) + :: expression e') + ] + | BinOp (op, e1, e2) -> + [ List + (Atom + (type_prefix + op + (select int_bin_op int_bin_op float_bin_op float_bin_op op)) + :: (expression e1 @ expression e2)) + ] + | I32WrapI64 e -> [ List (Atom "i32.wrap_i64" :: expression e) ] + | I64ExtendI32 (s, e) -> [ List (Atom (signage "i64.extend_i32" s) :: expression e) ] + | F32DemoteF64 e -> [ List (Atom "f32.demote_f64" :: expression e) ] + | F64PromoteF32 e -> [ List (Atom "f64.promote_f32" :: expression e) ] + | LocalGet i -> [ List [ Atom "local.get"; index st.local_names i ] ] + | LocalTee (i, e') -> + [ List (Atom "local.tee" :: index st.local_names i :: expression e') ] + | GlobalGet nm -> [ List [ Atom "global.get"; index st.global_names nm ] ] + | BlockExpr (ty, l) -> [ List (Atom "block" :: (block_type st ty @ instructions l)) ] + | Call (f, l) -> + [ List + (Atom "call" + :: index st.func_names f + :: List.concat (List.map ~f:expression l)) + ] + | Seq (l, e) -> instructions l @ expression e + | Pop _ -> [] + | RefFunc symb -> + if in_function then reference_function ctx symb; + [ List [ Atom "ref.func"; index st.func_names symb ] ] + | Call_ref (f, e, l) -> + [ List + (Atom "call_ref" + :: index st.type_names f + :: List.concat (List.map ~f:expression (l @ [ e ]))) + ] + | RefI31 e -> [ List (Atom "ref.i31" :: expression e) ] + | I31Get (s, e) -> [ List (Atom (signage "i31.get" s) :: expression e) ] + | ArrayNew (typ, e, e') -> + [ List + (Atom "array.new" :: index st.type_names typ :: (expression e @ expression e')) + ] + | ArrayNewFixed (typ, l) -> + [ List + (Atom "array.new_fixed" + :: index st.type_names typ + :: Atom (string_of_int (List.length l)) + :: List.concat (List.map ~f:expression l)) + ] + | ArrayNewData (typ, data, e, e') -> + [ List + (Atom "array.new_data" + :: index st.type_names typ + :: index st.data_names data + :: (expression e @ expression e')) + ] + | ArrayGet (None, typ, e, e') -> + [ List + (Atom "array.get" :: index st.type_names typ :: (expression e @ expression e')) + ] + | ArrayGet (Some s, typ, e, e') -> + [ List + (Atom (signage "array.get" s) + :: index st.type_names typ + :: (expression e @ expression e')) + ] + | ArrayLen e -> [ List (Atom "array.len" :: expression e) ] + | StructNew (typ, l) -> + [ List + (Atom "struct.new" + :: index st.type_names typ + :: List.concat (List.map ~f:expression l)) + ] + | StructGet (None, typ, i, e) -> + [ List + (Atom "struct.get" + :: index st.type_names typ + :: Atom (string_of_int i) + :: expression e) + ] + | StructGet (Some s, typ, i, e) -> + [ List + (Atom (signage "struct.get" s) + :: index st.type_names typ + :: Atom (string_of_int i) + :: expression e) + ] + | RefCast (ty, e) -> [ List (Atom "ref.cast" :: ref_type st ty :: expression e) ] + | RefTest (ty, e) -> [ List (Atom "ref.test" :: ref_type st ty :: expression e) ] + | RefEq (e, e') -> [ List (Atom "ref.eq" :: (expression e @ expression e')) ] + | RefNull ty -> [ List [ Atom "ref.null"; heap_type st ty ] ] + | Br_on_cast (i, ty, ty', e) -> + [ List + (Atom "br_on_cast" + :: Atom (string_of_int i) + :: ref_type st ty + :: ref_type st ty' + :: expression e) + ] + | Br_on_cast_fail (i, ty, ty', e) -> + [ List + (Atom "br_on_cast_fail" + :: Atom (string_of_int i) + :: ref_type st ty + :: ref_type st ty' + :: expression e) + ] + | IfExpr (ty, cond, ift, iff) -> + [ List + ((Atom "if" :: block_type st { params = []; result = [ ty ] }) + @ expression cond + @ [ List (Atom "then" :: expression ift) ] + @ [ List (Atom "else" :: expression iff) ]) + ] + | Try (ty, body, catches) -> + [ List + (Atom "try" + :: (block_type st ty + @ List (Atom "do" :: instructions body) + :: List.map + ~f:(fun (tag, i, ty) -> + List + (Atom "catch" + :: index st.tag_names tag + :: (instruction (Wasm_ast.Event Code_generation.hidden_location) + @ instruction (Wasm_ast.Br (i + 1, Some (Pop ty)))))) + catches)) + ] + and instruction i = + match i with + | Drop e -> [ List (Atom "drop" :: expression e) ] + | LocalSet (i, Seq (l, e)) -> instructions (l @ [ LocalSet (i, e) ]) + | LocalSet (i, e) -> + [ List (Atom "local.set" :: index st.local_names i :: expression e) ] + | GlobalSet (nm, e) -> + [ List (Atom "global.set" :: index st.global_names nm :: expression e) ] + | Loop (ty, l) -> [ List (Atom "loop" :: (block_type st ty @ instructions l)) ] + | Block (ty, l) -> [ List (Atom "block" :: (block_type st ty @ instructions l)) ] + | If (ty, e, l1, l2) -> + [ List + (Atom "if" + :: (block_type st ty + @ expression e + @ list ~always:true "then" instructions (remove_nops l1) + @ list "else" instructions (remove_nops l2))) + ] + | Br_table (e, l, i) -> + [ List + (Atom "br_table" + :: (List.map ~f:(fun i -> Atom (string_of_int i)) (l @ [ i ]) @ expression e) + ) + ] + | Br (i, e) -> + [ List + (Atom "br" + :: Atom (string_of_int i) + :: + (match e with + | None -> [] + | Some e -> expression e)) + ] + | Br_if (i, e) -> [ List (Atom "br_if" :: Atom (string_of_int i) :: expression e) ] + | Return e -> + [ List + (Atom "return" + :: + (match e with + | None -> [] + | Some e -> expression e)) + ] + | Throw (tag, e) -> [ List (Atom "throw" :: index st.tag_names tag :: expression e) ] + | Rethrow i -> [ List [ Atom "rethrow"; Atom (string_of_int i) ] ] + | CallInstr (f, l) -> + [ List + (Atom "call" + :: index st.func_names f + :: List.concat (List.map ~f:expression l)) + ] + | Nop -> [] + | Push e -> expression e + | ArraySet (typ, e, e', e'') -> + [ List + (Atom "array.set" + :: index st.type_names typ + :: (expression e @ expression e' @ expression e'')) + ] + | StructSet (typ, i, e, e') -> + [ List + (Atom "struct.set" + :: index st.type_names typ + :: Atom (string_of_int i) + :: (expression e @ expression e')) + ] + | Return_call (f, l) -> + [ List + (Atom "return_call" + :: index st.func_names f + :: List.concat (List.map ~f:expression l)) + ] + | Return_call_ref (typ, e, l) -> + [ List + (Atom "return_call_ref" + :: index st.type_names typ + :: List.concat (List.map ~f:expression (l @ [ e ]))) + ] + | Event Parse_info.{ src = None | Some ""; _ } -> [ Comment "@" ] + | Event Parse_info.{ src = Some src; col; line; _ } -> + let loc = Format.sprintf "%s:%d:%d" src line col in + [ Comment ("@ " ^ loc) ] + and instructions l = List.concat (List.map ~f:instruction l) in + expression, instructions + +let expression ctx st = fst (expression_or_instructions ctx st false) + +let instructions ctx st = snd (expression_or_instructions ctx st true) + +let funct ctx st name exported_name typ param_names locals body = + let st = + { st with + local_names = + assign_names + ~reversed:false + Code.Var.get_name + (param_names @ List.map ~f:fst locals) + } + in + List + ((Atom "func" :: index st.func_names name :: export exported_name) + @ func_type st ~param_names typ + @ List.map + ~f:(fun (i, t) -> List [ Atom "local"; index st.local_names i; value_type st t ]) + locals + @ instructions ctx st body) + +let import st f = + match f with + | Function _ | Global _ | Data _ | Tag _ | Type _ -> [] + | Import { import_module; import_name; name; desc } -> + [ List + [ Atom "import" + ; quoted_name import_module + ; quoted_name import_name + ; List + (match desc with + | Fun typ -> Atom "func" :: index st.func_names name :: func_type st typ + | Global ty -> + [ Atom "global"; index st.global_names name; global_type st ty ] + | Tag ty -> + [ Atom "tag" + ; index st.tag_names name + ; List [ Atom "param"; value_type st ty ] + ]) + ] + ] + +let escape_string s = + let b = Buffer.create (String.length s + 2) in + for i = 0 to String.length s - 1 do + let c = s.[i] in + if Poly.(c >= ' ' && c <= '~' && c <> '"' && c <> '\\') + then Buffer.add_char b c + else Printf.bprintf b "\\%02x" (Char.code c) + done; + Buffer.contents b + +let type_field st { name; typ; supertype; final } = + if final && Option.is_none supertype + then List [ Atom "type"; index st.type_names name; str_type st typ ] + else + List + [ Atom "type" + ; index st.type_names name + ; List + (Atom "sub" + :: ((if final then [ Atom "final" ] else []) + @ (match supertype with + | Some supertype -> [ index st.type_names supertype ] + | None -> []) + @ [ str_type st typ ])) + ] + +let field ctx st f = + match f with + | Function { name; exported_name; typ; param_names; locals; body } -> + [ funct ctx st name exported_name typ param_names locals body ] + | Global { name; exported_name; typ; init } -> + [ List + (Atom "global" + :: index st.global_names name + :: (export exported_name @ (global_type st typ :: expression ctx st init))) + ] + | Tag { name; typ } -> + [ List + [ Atom "tag" + ; index st.tag_names name + ; List [ Atom "param"; value_type st typ ] + ] + ] + | Import _ -> [] + | Data { name; contents } -> + [ List + [ Atom "data" + ; index st.data_names name + ; Atom ("\"" ^ escape_string contents ^ "\"") + ] + ] + | Type [ t ] -> [ type_field st t ] + | Type l -> [ List (Atom "rec" :: List.map ~f:(type_field st) l) ] + +let f ch fields = + let st = build_name_tables fields in + let ctx = { function_refs = Code.Var.Set.empty } in + let other_fields = List.concat (List.map ~f:(fun f -> field ctx st f) fields) in + let funct_decl = + let functions = Code.Var.Set.elements ctx.function_refs in + if List.is_empty functions + then [] + else + [ List + (Atom "elem" + :: Atom "declare" + :: Atom "func" + :: List.map ~f:(index st.func_names) functions) + ] + in + Format.fprintf + (Format.formatter_of_out_channel ch) + "%a@." + format_sexp + (List + (Atom "module" + :: (List.concat (List.map ~f:(fun i -> import st i) fields) + @ funct_decl + @ other_fields))) diff --git a/compiler/lib-wasm/wat_output.mli b/compiler/lib-wasm/wat_output.mli new file mode 100644 index 0000000000..9e01eb96a6 --- /dev/null +++ b/compiler/lib-wasm/wat_output.mli @@ -0,0 +1,19 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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 f : out_channel -> Wasm_ast.module_field list -> unit diff --git a/compiler/lib-wasm/zip.ml b/compiler/lib-wasm/zip.ml new file mode 100644 index 0000000000..916ca7ef3b --- /dev/null +++ b/compiler/lib-wasm/zip.ml @@ -0,0 +1,469 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +let stdlib_close_out = close_out + +open Stdlib + +module type CRC = sig + type t + + val start : t + + val update_from_bytes : bytes -> int -> int -> t -> t + + val update_from_string : string -> int -> int -> t -> t + + val finish : t -> int32 +end + +module CRC32 : CRC = struct + let compute_table () = + let open Int32 in + let tbl = Array.make 256 zero in + let poly = 0xedb88320l in + for i = 0 to 255 do + let n = ref (of_int i) in + for _ = 0 to 7 do + if logand !n one = one + then n := logxor (shift_right_logical !n 1) poly + else n := shift_right_logical !n 1 + done; + tbl.(i) <- !n + done; + tbl + + module CRC32 : CRC with type t = int32 = struct + type t = int32 + + let table = lazy (compute_table ()) + + let start = 0xffffffffl + + let update_from_bytes s pos len crc = + assert (pos >= 0 && len >= 0 && pos <= Bytes.length s - len); + let open Int32 in + let tbl = Lazy.force table in + let crc = ref crc in + for i = pos to pos + len - 1 do + crc := + logxor + (shift_right_logical !crc 8) + (Array.unsafe_get + tbl + (to_int !crc land 0xff lxor Char.code (Bytes.unsafe_get s i))) + done; + !crc + + let update_from_string s pos len crc = + assert (pos >= 0 && len >= 0 && pos <= String.length s - len); + let open Int32 in + let tbl = Lazy.force table in + let crc = ref crc in + for i = pos to pos + len - 1 do + crc := + logxor + (shift_right_logical !crc 8) + (Array.unsafe_get tbl (to_int !crc land 0xff lxor Char.code s.[i])) + done; + !crc + + let finish crc = Int32.(logxor crc start) + end + + module CRC64 : CRC with type t = int = struct + type t = int + + let start = (1 lsl 32) - 1 + + let next_table tbl tbl' = + lazy + (let tbl = Lazy.force tbl in + let tbl' = Lazy.force tbl' in + Array.init 256 ~f:(fun i -> (tbl'.(i) lsr 8) lxor tbl.(tbl'.(i) land 0xFF))) + + let table1 = + lazy (Array.map ~f:(fun i -> Int32.to_int i land start) (compute_table ())) + + let table2 = next_table table1 table1 + + let table3 = next_table table1 table2 + + let table4 = next_table table1 table3 + + let table5 = next_table table1 table4 + + let table6 = next_table table1 table5 + + let table7 = next_table table1 table6 + + let table8 = next_table table1 table7 + + let update_from_bytes s pos len crc = + assert (pos >= 0 && len >= 0 && pos <= Bytes.length s - len); + let tbl1 = Lazy.force table1 in + let tbl2 = Lazy.force table2 in + let tbl3 = Lazy.force table3 in + let tbl4 = Lazy.force table4 in + let tbl5 = Lazy.force table5 in + let tbl6 = Lazy.force table6 in + let tbl7 = Lazy.force table7 in + let tbl8 = Lazy.force table8 in + let crc = ref crc in + for i = 0 to (len / 8) - 1 do + let pos = pos + (i lsl 3) in + crc := + let crc = !crc in + Array.unsafe_get tbl8 (crc lxor Char.code (Bytes.unsafe_get s pos) land 0xff) + lxor Array.unsafe_get + tbl7 + ((crc lsr 8) lxor Char.code (Bytes.unsafe_get s (pos + 1)) land 0xff) + lxor (Array.unsafe_get + tbl6 + ((crc lsr 16) lxor Char.code (Bytes.unsafe_get s (pos + 2)) land 0xff) + lxor Array.unsafe_get + tbl5 + ((crc lsr 24) lxor Char.code (Bytes.unsafe_get s (pos + 3)))) + lxor (Array.unsafe_get tbl4 (Char.code (Bytes.unsafe_get s (pos + 4))) + lxor Array.unsafe_get tbl3 (Char.code (Bytes.unsafe_get s (pos + 5))) + lxor Array.unsafe_get tbl2 (Char.code (Bytes.unsafe_get s (pos + 6))) + lxor Array.unsafe_get tbl1 (Char.code (Bytes.unsafe_get s (pos + 7)))) + done; + for i = pos + (len land -8) to pos + len - 1 do + crc := + (!crc lsr 8) + lxor Array.unsafe_get tbl1 (!crc land 0xff lxor Char.code (Bytes.unsafe_get s i)) + done; + !crc + + let update_from_string s pos len crc = + assert (pos >= 0 && len >= 0 && pos <= String.length s - len); + let tbl = Lazy.force table1 in + let crc = ref crc in + for i = pos to pos + len - 1 do + crc := (!crc lsr 8) lxor Array.unsafe_get tbl (!crc land 0xff lxor Char.code s.[i]) + done; + !crc + + let finish crc = Int32.of_int (crc lxor start) + end + + module Repr = Sys.Immediate64.Make (Int) (Int32) + + include + (val match Repr.repr with + | Immediate -> (module CRC64 : CRC) + | Non_immediate -> (module CRC32 : CRC) + : CRC) +end + +let buffer = lazy (Bytes.create 65536) + +let copy in_ch out_ch ?(iter = fun _ _ _ -> ()) len = + let buffer = Lazy.force buffer in + let buffer_len = Bytes.length buffer in + let rec copy rem = + if rem > 0 + then ( + let n = input in_ch buffer 0 (min buffer_len rem) in + if n = 0 then raise End_of_file; + iter buffer 0 n; + output out_ch buffer 0 n; + copy (rem - n)) + in + copy len + +type file = + { name : string + ; pos : int + ; len : int + ; mutable crc : int32 + } + +type output = + { ch : out_channel + ; mutable files : file list + } + +let open_out name = { ch = open_out_bin name; files = [] } + +let output_16 ch c = + output_byte ch c; + output_byte ch (c lsr 8) + +let output_32 ch c = + output_16 ch c; + output_16 ch (c lsr 16) + +let output_crc ch crc = + output_16 ch (Int32.to_int crc); + output_16 ch (Int32.to_int (Int32.shift_right_logical crc 16)) + +let output_local_file_header ch ?(crc = 0l) { name; len; _ } = + output_32 ch 0x04034b50; + (* version needed to extract *) + output_16 ch 10; + (* general purpose but flag *) + output_16 ch 0x0; + (* compression method *) + output_16 ch 0x0; + (* time / date *) + output_16 ch 0x0; + output_16 ch 0x5821; + (* CRC *) + let crc_pos = pos_out ch in + output_crc ch crc; + (* compressed / uncompressed size *) + output_32 ch len; + output_32 ch len; + (* file name length *) + output_16 ch (String.length name); + (* extra field length *) + output_16 ch 0; + (* file name *) + output_string ch name; + crc_pos + +let add_file z ~name ~file = + let ch = open_in_bin file in + let pos = pos_out z.ch in + let len = in_channel_length ch in + let file = { name; pos; len; crc = 0l } in + z.files <- file :: z.files; + let crc_pos = output_local_file_header z.ch file in + let crc = ref CRC32.start in + copy ch z.ch ~iter:(fun b pos len -> crc := CRC32.update_from_bytes b pos len !crc) len; + let crc = CRC32.finish !crc in + file.crc <- crc; + let pos = pos_out z.ch in + seek_out z.ch crc_pos; + output_crc z.ch crc; + seek_out z.ch pos + +let add_entry z ~name ~contents = + let pos = pos_out z.ch in + let len = String.length contents in + let crc = CRC32.start |> CRC32.update_from_string contents 0 len |> CRC32.finish in + let file = { name; pos; len; crc } in + z.files <- file :: z.files; + let _crc_pos = output_local_file_header z.ch ~crc file in + output_string z.ch contents + +let output_file_header ch { name; pos; len; crc } = + output_32 ch 0x02014b50; + (* versions: made by / needed to extract *) + output_16 ch 10; + output_16 ch 10; + (* general purpose but flag *) + output_16 ch 0x0; + (* compression method *) + output_16 ch 0x0; + (* time / date *) + output_16 ch 0x0; + output_16 ch 0x5821; + (* CRC *) + output_crc ch crc; + (* compressed / uncompressed size *) + output_32 ch len; + output_32 ch len; + (* file name length *) + output_16 ch (String.length name); + (* extra field length *) + output_16 ch 0; + (* file comment length *) + output_16 ch 0; + (* disk number start *) + output_16 ch 0; + (* file attributes *) + output_16 ch 0; + output_32 ch 0; + (* relative offset of local header *) + output_32 ch pos; + (* file name *) + output_string ch name + +let output_end_of_directory z pos len = + let ch = z.ch in + output_32 ch 0x06054b50; + (* disk numbers *) + output_16 ch 0; + output_16 ch 0; + (* number of entries *) + let n = List.length z.files in + output_16 ch n; + output_16 ch n; + (* size of the central directory *) + output_32 ch len; + (* offset of the central directory *) + output_32 ch pos; + (* comment length *) + output_16 ch 0 + +let output_directory z = + let pos = pos_out z.ch in + List.iter ~f:(output_file_header z.ch) (List.rev z.files); + let pos' = pos_out z.ch in + output_end_of_directory z pos (pos' - pos) + +let close_out z = + output_directory z; + close_out z.ch + +(****) + +type entry = + { pos : int + ; len : int + ; crc : int32 + } + +let input_16 ch = + let c = input_byte ch in + c lor (input_byte ch lsl 8) + +let input_32 ch = + let c = input_16 ch in + c lor (input_16 ch lsl 16) + +let input_32' ch = + let c = input_16 ch in + Int32.(logor (of_int c) (shift_left (of_int (input_16 ch)) 16)) + +let read_local_file_header ch pos = + let pos = pos + 14 in + seek_in ch pos; + let crc = input_32' ch in + let _ = input_32 ch in + let len = input_32 ch in + let name_len = input_16 ch in + let extra_len = input_16 ch in + { pos = pos + 16 + name_len + extra_len; len; crc } + +let read_file_header ch = + let signature = input_32' ch in + if not (Int32.equal signature 0x02014b50l) then failwith "bad signature"; + (* versions: made by / needed to extract *) + ignore (input_16 ch); + let v = input_16 ch in + if v > 10 then failwith "unsupported file format"; + (* general purpose but flag *) + ignore (input_16 ch); + (* compression method *) + ignore (input_16 ch); + (* time / date *) + ignore (input_32 ch); + (* CRC *) + ignore (input_32' ch); + (* compressed / uncompressed size *) + ignore (input_32 ch); + ignore (input_32 ch); + (* file name length *) + let name_len = input_16 ch in + (* extra field length *) + let extra_len = input_16 ch in + (* file comment length *) + let comment_len = input_16 ch in + (* disk number start *) + ignore (input_16 ch); + (* file attributes *) + ignore (input_16 ch); + ignore (input_32 ch); + (* relative offset of local header *) + let pos = input_32 ch in + (* file name *) + let name = really_input_string ch name_len in + ignore (really_input_string ch extra_len); + ignore (really_input_string ch comment_len); + name, pos + +type input = + { ch : in_channel + ; files : int StringMap.t + } + +let open_in name = + let ch = open_in_bin name in + let len = in_channel_length ch in + let find_directory_end offset = + seek_in ch (len - 22 - offset); + let c = ref 0l in + let p = ref (-1) in + for i = 0 to offset + 3 do + (c := Int32.(add (shift_left !c 8) (of_int (input_byte ch)))); + if Int32.equal !c 0x504b0506l then p := 22 + 3 + offset - i + done; + !p + in + let p = find_directory_end 0 in + let p = if p = -1 then find_directory_end 65535 else p in + if p = -1 then failwith "not a ZIP file"; + seek_in ch (len - p + 10); + (* number of entries *) + let n = input_16 ch in + (* size of the directory *) + ignore (input_32 ch); + (* offset of the directory *) + let offset = input_32 ch in + seek_in ch offset; + let m = ref StringMap.empty in + for _ = 0 to n - 1 do + let name, entry = read_file_header ch in + m := StringMap.add name entry !m + done; + { ch; files = !m } + +let with_open_in name f = + let z = open_in name in + Fun.protect ~finally:(fun () -> close_in_noerr z.ch) (fun () -> f z) + +let get_pos z ~name = + try StringMap.find name z.files + with Not_found -> failwith (Printf.sprintf "File %s not found in archive" name) + +let has_entry z ~name = StringMap.mem name z.files + +let read_entry z ~name = + let pos = get_pos z ~name in + let { pos; len; _ } = read_local_file_header z.ch pos in + seek_in z.ch pos; + really_input_string z.ch len + +let get_entry z ~name = + let pos = get_pos z ~name in + let { pos; len; crc } = read_local_file_header z.ch pos in + z.ch, pos, len, crc + +let extract_file z ~name ~file = + let pos = get_pos z ~name in + let { pos; len; _ } = read_local_file_header z.ch pos in + seek_in z.ch pos; + let ch = open_out_bin file in + copy z.ch ch len; + stdlib_close_out ch + +let close_in z = close_in z.ch + +let copy_file z (z' : output) ~src_name ~dst_name = + let pos = StringMap.find src_name z.files in + let { pos; len; crc } = read_local_file_header z.ch pos in + seek_in z.ch pos; + let pos' = pos_out z'.ch in + let file = { name = dst_name; pos = pos'; len; crc } in + z'.files <- file :: z'.files; + let _ = output_local_file_header z'.ch ~crc file in + copy z.ch z'.ch len diff --git a/compiler/lib-wasm/zip.mli b/compiler/lib-wasm/zip.mli new file mode 100644 index 0000000000..111bb42a4f --- /dev/null +++ b/compiler/lib-wasm/zip.mli @@ -0,0 +1,46 @@ +(* Wasm_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * 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. + *) + +type output + +val open_out : string -> output + +val add_entry : output -> name:string -> contents:string -> unit + +val add_file : output -> name:string -> file:string -> unit + +val close_out : output -> unit + +type input + +val open_in : string -> input + +val with_open_in : string -> (input -> 'a) -> 'a + +val has_entry : input -> name:string -> bool + +val read_entry : input -> name:string -> string + +val get_entry : + input -> name:string -> in_channel * int (* pos *) * int (* len *) * int32 (* crc *) + +val extract_file : input -> name:string -> file:string -> unit + +val copy_file : input -> output -> src_name:string -> dst_name:string -> unit + +val close_in : input -> unit diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 21712fd03e..0a3f8ea295 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -198,6 +198,9 @@ let rec block_escape st x = | Immutable -> () | Maybe_mutable -> Code.Var.ISet.add st.possibly_mutable y); Array.iter l ~f:(fun z -> block_escape st z) + | Expr + (Prim (Extern ("caml_make_array" | "caml_array_of_uniform_array"), [ Pv y ])) + -> block_escape st y | _ -> Code.Var.ISet.add st.possibly_mutable y)) (Var.Tbl.get st.known_origins x) @@ -207,6 +210,7 @@ let expr_escape st _x e = | Apply { args; _ } -> List.iter args ~f:(fun x -> block_escape st x) | Prim (Array_get, [ Pv x; _ ]) -> block_escape st x | Prim ((Vectlength | Array_get | Not | IsInt | Eq | Neq | Lt | Le | Ult), _) -> () + | Prim (Extern ("caml_make_array" | "caml_array_of_uniform_array"), [ Pv _ ]) -> () | Prim (Extern name, l) -> let ka = match Primitive.kind_args name with @@ -231,6 +235,14 @@ let expr_escape st _x e = | Expr (Constant (Tuple _)) -> () | Expr (Block (_, a, _, _)) -> Array.iter a ~f:(fun x -> block_escape st x) + | Expr + (Prim + ( Extern ("caml_make_array" | "caml_array_of_uniform_array") + , [ Pv y ] )) -> ( + match st.defs.(Var.idx y) with + | Expr (Block (_, a, _, _)) -> + Array.iter a ~f:(fun x -> block_escape st x) + | _ -> assert false) | _ -> block_escape st v) | Pv v, `Object_literal -> ( match st.defs.(Var.idx v) with @@ -403,6 +415,20 @@ let the_string_of ~target info x = let the_native_string_of ~target info x = match the_const_of ~target info x with | Some (NativeString i) -> Some i + | Some (String i) -> + (* This function is used to optimize the primitives that access + object properties. These primitives are expected to work with + OCaml string as well, considered as byte strings. *) + Some (Native_string.of_bytestring i) + | _ -> None + +let the_block_contents_of info x = + match the_def_of info x with + | Some (Block (_, a, _, _)) -> Some a + | Some (Prim (Extern ("caml_make_array" | "caml_array_of_uniform_array"), [ x ])) -> ( + match the_def_of info x with + | Some (Block (_, a, _, _)) -> Some a + | _ -> None) | _ -> None (*XXX Maybe we could iterate? *) diff --git a/compiler/lib/flow.mli b/compiler/lib/flow.mli index 20271a4e3f..32801ac301 100644 --- a/compiler/lib/flow.mli +++ b/compiler/lib/flow.mli @@ -61,6 +61,8 @@ val the_string_of : val the_native_string_of : target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Code.Native_string.t option +val the_block_contents_of : Info.t -> Code.prim_arg -> Code.Var.t array option + val the_int : target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Targetint.t option diff --git a/compiler/lib/source_map.ml b/compiler/lib/source_map.ml index bd0002f544..806054bab7 100644 --- a/compiler/lib/source_map.ml +++ b/compiler/lib/source_map.ml @@ -71,6 +71,8 @@ module Mappings = struct let empty = Uninterpreted "" + let is_empty (Uninterpreted s) = String.equal s "" + let of_string_unsafe : string -> t = fun s -> Uninterpreted s let to_string : t -> string = fun (Uninterpreted s) -> s @@ -291,8 +293,8 @@ let rewrite_path path = let invalid () = invalid_arg "Source_map.of_json" -let string_of_stringlit (`Stringlit s) = - match Yojson.Safe.from_string s with +let string_of_stringlit ?tmp_buf (`Stringlit s) = + match Yojson.Safe.from_string ?buf:tmp_buf s with | `String s -> s | _ -> invalid () @@ -509,11 +511,13 @@ module Standard = struct t.sources))) ) ]) - let of_json (json : Yojson.Raw.t) = + let of_json ?tmp_buf (json : Yojson.Raw.t) = match json with | `Assoc (("version", `Intlit version) :: rest) when version_is_valid (int_of_string version) -> - let string name json = Option.map ~f:string_of_stringlit (stringlit name json) in + let string name json = + Option.map ~f:(fun s -> string_of_stringlit ?tmp_buf s) (stringlit name json) + in let file = string "file" rest in let sourceroot = string "sourceRoot" rest in let names = @@ -562,6 +566,10 @@ module Standard = struct } | _ -> invalid () + let of_string ?tmp_buf s = of_json ?tmp_buf (Yojson.Raw.from_string ?buf:tmp_buf s) + + let of_file ?tmp_buf f = of_json ?tmp_buf (Yojson.Raw.from_file ?buf:tmp_buf f) + let to_string m = Yojson.Raw.to_string (json m) let to_file m file = Yojson.Raw.to_file file (json m) @@ -643,7 +651,7 @@ module Index = struct | _ -> invalid_arg errmsg | exception Not_found -> invalid_arg errmsg - let section_of_json : Yojson.Raw.t -> section = function + let section_of_json ?tmp_buf : Yojson.Raw.t -> section = function | `Assoc json -> let offset = match List.assoc "offset" json with @@ -673,7 +681,7 @@ module Index = struct "Source_map.Index.of_json: URLs in index maps are not currently supported" | exception Not_found -> ()); let map = - try Standard.of_json (List.assoc "map" json) with + try Standard.of_json ?tmp_buf (List.assoc "map" json) with | Not_found -> invalid_arg "Source_map.Index.of_json: field 'map' absent" | Invalid_argument _ -> invalid_arg "Source_map.Index.of_json: invalid sub-map object" @@ -681,14 +689,14 @@ module Index = struct { offset; map } | _ -> invalid_arg "Source_map.Index.of_json: section of unexpected type" - let of_json = function + let of_json ?tmp_buf = function | `Assoc (("version", `Intlit version) :: fields) when version_is_valid (int_of_string version) -> ( let string name json = Option.map ~f:string_of_stringlit (stringlit name json) in let file = string "file" fields in match List.assoc "sections" fields with | `List sections -> - let sections = List.map ~f:section_of_json sections in + let sections = List.map ~f:(section_of_json ?tmp_buf) sections in { version = int_of_string version; file; sections } | _ -> invalid_arg "Source_map.Index.of_json: `sections` is not an array" | exception Not_found -> @@ -723,16 +731,16 @@ type t = | Standard of Standard.t | Index of Index.t -let of_json = function +let of_json ?tmp_buf = function | `Assoc fields as json -> ( match List.assoc "sections" fields with - | _ -> Index (Index.of_json json) - | exception Not_found -> Standard (Standard.of_json json)) + | _ -> Index (Index.of_json ?tmp_buf json) + | exception Not_found -> Standard (Standard.of_json ?tmp_buf json)) | _ -> invalid_arg "Source_map.of_json: map is not an object" -let of_string s = of_json (Yojson.Raw.from_string s) +let of_string ?tmp_buf s = of_json ?tmp_buf (Yojson.Raw.from_string ?buf:tmp_buf s) -let of_file f = of_json (Yojson.Raw.from_file f) +let of_file ?tmp_buf f = of_json ?tmp_buf (Yojson.Raw.from_file ?buf:tmp_buf f) let to_string = function | Standard m -> Standard.to_string m diff --git a/compiler/lib/source_map.mli b/compiler/lib/source_map.mli index 64954d0fd5..217e437e09 100644 --- a/compiler/lib/source_map.mli +++ b/compiler/lib/source_map.mli @@ -21,6 +21,8 @@ module Source_content : sig type t val create : string -> t + + val of_stringlit : [ `Stringlit of string ] -> t end type map = @@ -60,6 +62,9 @@ module Mappings : sig val empty : t (** The empty mapping. *) + val is_empty : t -> bool + (** Test whether the mapping is empty. *) + val of_string_unsafe : string -> t (** [of_string_unsafe] does not perform any validation of its argument, unlike {!val:decode}. It is guaranteed that @@ -111,6 +116,10 @@ module Standard : sig linear in function of the size of the input mappings. *) val empty : inline_source_content:bool -> t + + val of_string : ?tmp_buf:Buffer.t -> string -> t + + val of_file : ?tmp_buf:Buffer.t -> string -> t end module Index : sig @@ -134,9 +143,9 @@ val to_string : t -> string val to_file : t -> string -> unit -val of_string : string -> t +val of_string : ?tmp_buf:Buffer.t -> string -> t -val of_file : string -> t +val of_file : ?tmp_buf:Buffer.t -> string -> t val invariant : t -> unit diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 4fa7c7776c..f1a28ef6a3 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -55,22 +55,22 @@ let specialize_instr ~target info i = | Some _ -> Let (x, Constant (Int Targetint.zero)) | None -> i) | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])), _ -> ( - match the_def_of info a with - | Some (Block (_, a, _, _)) -> + match the_block_contents_of info a with + | Some a -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_call", f :: o :: Array.to_list a)) | _ -> i) | Let (x, Prim (Extern "caml_js_fun_call", [ f; a ])), _ -> ( - match the_def_of info a with - | Some (Block (_, a, _, _)) -> + match the_block_contents_of info a with + | Some a -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_fun_call", f :: Array.to_list a)) | _ -> i) | Let (x, Prim (Extern "caml_js_meth_call", [ o; m; a ])), _ -> ( match the_string_of ~target info m with | Some m when Javascript.is_ident m -> ( - match the_def_of info a with - | Some (Block (_, a, _, _)) -> + match the_block_contents_of info a with + | Some a -> let a = Array.map a ~f:(fun x -> Pv x) in Let ( x @@ -79,11 +79,11 @@ let specialize_instr ~target info i = , o :: Pc (NativeString (Native_string.of_string m)) :: Array.to_list a ) ) - | _ -> i) + | None -> i) | _ -> i) | Let (x, Prim (Extern "caml_js_new", [ c; a ])), _ -> ( - match the_def_of info a with - | Some (Block (_, a, _, _)) -> + match the_block_contents_of info a with + | Some a -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_new", c :: Array.to_list a)) | _ -> i) diff --git a/compiler/lib/structure.ml b/compiler/lib/structure.ml index 679d5dcf9b..4f6f3b5708 100644 --- a/compiler/lib/structure.ml +++ b/compiler/lib/structure.ml @@ -157,6 +157,8 @@ let is_loop_header g pc = let sort_in_post_order t l = List.sort ~cmp:(fun a b -> compare (block_order t b) (block_order t a)) l +let blocks_in_reverse_post_order g = g.reverse_post_order + (* (* pc dominates pc' *) diff --git a/compiler/lib/structure.mli b/compiler/lib/structure.mli index 6278174c6f..1aa1a10940 100644 --- a/compiler/lib/structure.mli +++ b/compiler/lib/structure.mli @@ -21,4 +21,6 @@ val is_loop_header : t -> Addr.t -> bool val sort_in_post_order : t -> Addr.t list -> Addr.t list +val blocks_in_reverse_post_order : t -> Code.Addr.t list + val get_nodes : t -> Addr.Set.t diff --git a/compiler/lib/targetint.ml b/compiler/lib/targetint.ml index 098e7f2fe3..441a686802 100644 --- a/compiler/lib/targetint.ml +++ b/compiler/lib/targetint.ml @@ -108,6 +108,8 @@ let of_int32_exn (x : int32) = let offset = offset () in if min_int_ offset <= x && x <= max_int_ offset then x else failwith "of_int32_exn" +let of_int32_truncate = wrap_modulo + let of_string_exn x = try let offset = offset () in diff --git a/compiler/lib/targetint.mli b/compiler/lib/targetint.mli index 15fd1846ff..c51b500735 100644 --- a/compiler/lib/targetint.mli +++ b/compiler/lib/targetint.mli @@ -24,6 +24,8 @@ val of_int_exn : int -> t val of_int32_exn : int32 -> t +val of_int32_truncate : int32 -> t + val of_int32_warning_on_overflow : int32 -> t val of_nativeint_warning_on_overflow : nativeint -> t diff --git a/compiler/lib/vlq64.ml b/compiler/lib/vlq64.ml index 3c147ec263..f32fa6f58e 100644 --- a/compiler/lib/vlq64.ml +++ b/compiler/lib/vlq64.ml @@ -99,3 +99,22 @@ let decode_l s ~pos ~len = aux i (d :: acc) len in aux pos [] len + +type input = + { string : string + ; mutable pos : int + ; len : int + } + +let rec decode' src s pos len offset i = + if pos = len then invalid_arg "Vql64.decode'"; + let digit = Array.unsafe_get code_rev (Char.code s.[pos]) in + if digit = -1 then invalid_arg "Vql64.decode'"; + let i = i + ((digit land vlq_base_mask) lsl offset) in + if digit >= vlq_continuation_bit + then decode' src s (pos + 1) len (offset + vlq_base_shift) i + else ( + src.pos <- pos + 1; + i) + +let decode src = fromVLQSigned (decode' src src.string src.pos src.len 0 0) diff --git a/compiler/lib/vlq64.mli b/compiler/lib/vlq64.mli index c3accf5215..fb4d19f1fb 100644 --- a/compiler/lib/vlq64.mli +++ b/compiler/lib/vlq64.mli @@ -19,6 +19,16 @@ val in_alphabet : char -> bool +type input = + { string : string + ; mutable pos : int + ; len : int + } + +val encode : Buffer.t -> int -> unit + val encode_l : Buffer.t -> int list -> unit +val decode : input -> int + val decode_l : string -> pos:int -> len:int -> int list diff --git a/compiler/tests-compiler/dune.inc b/compiler/tests-compiler/dune.inc index 27e0cd65fb..4a4f76bf43 100644 --- a/compiler/tests-compiler/dune.inc +++ b/compiler/tests-compiler/dune.inc @@ -2,7 +2,7 @@ (library ;; compiler/tests-compiler/array_access.ml (name array_access_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules array_access) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -17,7 +17,7 @@ (library ;; compiler/tests-compiler/build_path_prefix_map.ml (name build_path_prefix_map_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules build_path_prefix_map) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -32,7 +32,7 @@ (library ;; compiler/tests-compiler/call_gen.ml (name call_gen_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules call_gen) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -47,7 +47,7 @@ (library ;; compiler/tests-compiler/compact.ml (name compact_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules compact) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -62,7 +62,7 @@ (library ;; compiler/tests-compiler/cond.ml (name cond_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules cond) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -77,7 +77,7 @@ (library ;; compiler/tests-compiler/direct_calls.ml (name direct_calls_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules direct_calls) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -92,7 +92,7 @@ (library ;; compiler/tests-compiler/effects.ml (name effects_15) - (enabled_if (>= %{ocaml_version} 5)) + (enabled_if (and (>= %{ocaml_version} 5) %{env:js-enabled=})) (modules effects) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -107,7 +107,7 @@ (library ;; compiler/tests-compiler/effects_continuations.ml (name effects_continuations_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules effects_continuations) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -122,7 +122,7 @@ (library ;; compiler/tests-compiler/effects_exceptions.ml (name effects_exceptions_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules effects_exceptions) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -137,7 +137,7 @@ (library ;; compiler/tests-compiler/effects_toplevel.ml (name effects_toplevel_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules effects_toplevel) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -152,7 +152,7 @@ (library ;; compiler/tests-compiler/eliminate_exception_handler.ml (name eliminate_exception_handler_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules eliminate_exception_handler) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -167,7 +167,7 @@ (library ;; compiler/tests-compiler/empty_cma.ml (name empty_cma_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules empty_cma) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -182,7 +182,7 @@ (library ;; compiler/tests-compiler/end_to_end.ml (name end_to_end_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules end_to_end) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -197,7 +197,7 @@ (library ;; compiler/tests-compiler/error.ml (name error_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules error) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -212,7 +212,7 @@ (library ;; compiler/tests-compiler/es6.ml (name es6_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules es6) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -227,7 +227,7 @@ (library ;; compiler/tests-compiler/exceptions.ml (name exceptions_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules exceptions) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -242,7 +242,7 @@ (library ;; compiler/tests-compiler/exports.ml (name exports_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules exports) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -257,7 +257,7 @@ (library ;; compiler/tests-compiler/getenv.ml (name getenv_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules getenv) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -272,7 +272,7 @@ (library ;; compiler/tests-compiler/gh1007.ml (name gh1007_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh1007) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -287,7 +287,7 @@ (library ;; compiler/tests-compiler/gh1051.ml (name gh1051_15) - (enabled_if %{arch_sixtyfour}) + (enabled_if (and %{arch_sixtyfour} %{env:js-enabled=})) (modules gh1051) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -302,7 +302,7 @@ (library ;; compiler/tests-compiler/gh1320.ml (name gh1320_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh1320) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -317,7 +317,7 @@ (library ;; compiler/tests-compiler/gh1349.ml (name gh1349_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh1349) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -332,7 +332,7 @@ (library ;; compiler/tests-compiler/gh1354.ml (name gh1354_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh1354) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -347,7 +347,7 @@ (library ;; compiler/tests-compiler/gh1390.ml (name gh1390_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh1390) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -362,7 +362,7 @@ (library ;; compiler/tests-compiler/gh1481.ml (name gh1481_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh1481) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -377,7 +377,7 @@ (library ;; compiler/tests-compiler/gh1494.ml (name gh1494_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh1494) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -392,7 +392,7 @@ (library ;; compiler/tests-compiler/gh1559.ml (name gh1559_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh1559) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -407,7 +407,7 @@ (library ;; compiler/tests-compiler/gh1599.ml (name gh1599_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh1599) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -422,7 +422,7 @@ (library ;; compiler/tests-compiler/gh1659.ml (name gh1659_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh1659) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -437,7 +437,7 @@ (library ;; compiler/tests-compiler/gh747.ml (name gh747_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gh747) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -452,7 +452,7 @@ (library ;; compiler/tests-compiler/gl507.ml (name gl507_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules gl507) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -467,7 +467,7 @@ (library ;; compiler/tests-compiler/global_deadcode.ml (name global_deadcode_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules global_deadcode) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -482,7 +482,7 @@ (library ;; compiler/tests-compiler/inlining.ml (name inlining_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules inlining) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -497,7 +497,7 @@ (library ;; compiler/tests-compiler/js_parser_printer.ml (name js_parser_printer_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules js_parser_printer) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -512,7 +512,7 @@ (library ;; compiler/tests-compiler/jsopt.ml (name jsopt_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules jsopt) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -527,7 +527,7 @@ (library ;; compiler/tests-compiler/lambda_lifting.ml (name lambda_lifting_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules lambda_lifting) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -542,7 +542,7 @@ (library ;; compiler/tests-compiler/lazy.ml (name lazy_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules lazy) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -557,7 +557,7 @@ (library ;; compiler/tests-compiler/loops.ml (name loops_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules loops) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -572,7 +572,7 @@ (library ;; compiler/tests-compiler/macro.ml (name macro_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules macro) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -587,7 +587,7 @@ (library ;; compiler/tests-compiler/match_with_exn.ml (name match_with_exn_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules match_with_exn) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -602,7 +602,7 @@ (library ;; compiler/tests-compiler/minify.ml (name minify_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules minify) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -617,7 +617,7 @@ (library ;; compiler/tests-compiler/mutable_closure.ml (name mutable_closure_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules mutable_closure) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -632,7 +632,7 @@ (library ;; compiler/tests-compiler/obj.ml (name obj_15) - (enabled_if (>= %{ocaml_version} 5)) + (enabled_if (and (>= %{ocaml_version} 5) %{env:js-enabled=})) (modules obj) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -647,7 +647,7 @@ (library ;; compiler/tests-compiler/obj_dup.ml (name obj_dup_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules obj_dup) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -662,7 +662,7 @@ (library ;; compiler/tests-compiler/rec.ml (name rec_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules rec) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -677,7 +677,7 @@ (library ;; compiler/tests-compiler/rec52.ml (name rec52_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules rec52) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -692,7 +692,7 @@ (library ;; compiler/tests-compiler/scopes.ml (name scopes_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules scopes) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -707,7 +707,7 @@ (library ;; compiler/tests-compiler/side_effect.ml (name side_effect_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules side_effect) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -722,7 +722,7 @@ (library ;; compiler/tests-compiler/sourcemap.ml (name sourcemap_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules sourcemap) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -737,7 +737,7 @@ (library ;; compiler/tests-compiler/static_eval.ml (name static_eval_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules static_eval) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -752,7 +752,7 @@ (library ;; compiler/tests-compiler/sys_command.ml (name sys_command_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules sys_command) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -767,7 +767,7 @@ (library ;; compiler/tests-compiler/sys_fs.ml (name sys_fs_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules sys_fs) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -782,7 +782,7 @@ (library ;; compiler/tests-compiler/tailcall.ml (name tailcall_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules tailcall) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -797,7 +797,7 @@ (library ;; compiler/tests-compiler/target_env.ml (name target_env_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules target_env) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -812,7 +812,7 @@ (library ;; compiler/tests-compiler/test_string.ml (name test_string_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules test_string) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -827,7 +827,7 @@ (library ;; compiler/tests-compiler/unix_fs.ml (name unix_fs_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules unix_fs) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests @@ -842,7 +842,7 @@ (library ;; compiler/tests-compiler/variable_declaration_output.ml (name variable_declaration_output_15) - (enabled_if true) + (enabled_if %{env:js-enabled=}) (modules variable_declaration_output) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests diff --git a/compiler/tests-compiler/gen-rules/gen.ml b/compiler/tests-compiler/gen-rules/gen.ml index 2595d3adac..4781edde62 100644 --- a/compiler/tests-compiler/gen-rules/gen.ml +++ b/compiler/tests-compiler/gen-rules/gen.ml @@ -72,6 +72,10 @@ let enabled_if = function | LT52 -> "(< %{ocaml_version} 5.2)" | B64 -> "%{arch_sixtyfour}" +let js_enabled = function + | "true" -> "%{env:js-enabled=}" + | x -> Printf.sprintf "(and %s %%{env:js-enabled=})" x + let () = Array.to_list (Sys.readdir ".") |> List.filter ~f:is_implem @@ -99,6 +103,6 @@ let () = basename basename (Hashtbl.hash prefix mod 100) - (enabled_if (lib_enabled_if basename)) + (js_enabled (enabled_if (lib_enabled_if basename))) basename (enabled_if (test_enabled_if basename))) diff --git a/compiler/tests-dynlink-js/dune b/compiler/tests-dynlink-js/dune index 22dbfab923..52df5f5de0 100644 --- a/compiler/tests-dynlink-js/dune +++ b/compiler/tests-dynlink-js/dune @@ -1,5 +1,6 @@ (executable (name main) + (enabled_if %{env:js-enabled=}) (modules main) (libraries js_of_ocaml) (link_flags @@ -34,6 +35,7 @@ (rule (target main.js) + (enabled_if %{env:js-enabled=}) (action (run %{bin:js_of_ocaml} @@ -77,6 +79,7 @@ (rule (target main.out) + (enabled_if %{env:js-enabled=}) (deps plugin.js plugin2.js) (action (with-outputs-to @@ -85,6 +88,7 @@ (rule (target main.out2) + (enabled_if %{env:js-enabled=}) (deps plugin.js plugin2.js) (action (with-outputs-to @@ -93,10 +97,12 @@ (rule (alias runtest) + (enabled_if %{env:js-enabled=}) (action (diff main.out.expected main.out))) (rule (alias runtest) + (enabled_if %{env:js-enabled=}) (action (diff main.out.expected main.out2))) diff --git a/compiler/tests-dynlink/dune b/compiler/tests-dynlink/dune index 07e8b4e9e3..37de0cb1cc 100644 --- a/compiler/tests-dynlink/dune +++ b/compiler/tests-dynlink/dune @@ -1,11 +1,13 @@ (executable (name main) + (enabled_if %{env:js-enabled=}) (modules main) (libraries dynlink js_of_ocaml-compiler.dynlink) (modes byte)) (rule (target main.js) + (enabled_if %{env:js-enabled=}) (deps plugin.cmo export) (action (run @@ -25,6 +27,7 @@ (rule (target main.out) + (enabled_if %{env:js-enabled=}) (deps plugin.cmo) (action (with-outputs-to @@ -33,5 +36,6 @@ (rule (alias runtest) + (enabled_if %{env:js-enabled=}) (action (diff main.out.expected main.out))) diff --git a/compiler/tests-env/dune b/compiler/tests-env/dune index 1a392b7b9b..0ec8080c7c 100644 --- a/compiler/tests-env/dune +++ b/compiler/tests-env/dune @@ -1,5 +1,5 @@ (test - (modes js) + (modes js) ; No env support in wasm_of_ocaml yet (js_of_ocaml (javascript_files setup.js) (flags :standard --setenv JSOO_C=from-jsoo-args)) diff --git a/compiler/tests-io/dune b/compiler/tests-io/dune index a2dcef1a3f..184846813e 100644 --- a/compiler/tests-io/dune +++ b/compiler/tests-io/dune @@ -2,6 +2,7 @@ (names cat md5) (modes js + wasm (best exe))) (rule @@ -27,6 +28,12 @@ (action (diff cat-js.stdout cat-native.stdout))) +(rule + (action + (copy cat.bc.wasm.js cat.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) + (rule (target md5-native.stdout) (action @@ -69,3 +76,9 @@ (alias runtest) (action (diff md5-js.stdout md5-native.stdout))) + +(rule + (action + (copy md5.bc.wasm.js md5.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) diff --git a/compiler/tests-jsoo/bin/dune b/compiler/tests-jsoo/bin/dune index 3cadcdb3ed..ed7615c013 100644 --- a/compiler/tests-jsoo/bin/dune +++ b/compiler/tests-jsoo/bin/dune @@ -1,6 +1,6 @@ (executables (names error1 error2) - (modes exe js) + (modes exe js wasm) (foreign_stubs (language c) (names named_value_stubs)) @@ -55,6 +55,12 @@ (action (diff %{dep:error1-unregister.expected} %{dep:error1-unregister.js.actual}))) +(rule + (action + (copy error1.bc.wasm.js error1.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) + (rule (target error2.js.actual) (deps error2.html) @@ -105,3 +111,9 @@ (alias runtest) (action (diff %{dep:error2-unregister.expected} %{dep:error2-unregister.js.actual}))) + +(rule + (action + (copy error2.bc.wasm.js error2.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) diff --git a/compiler/tests-jsoo/dune b/compiler/tests-jsoo/dune index ca6f45862f..26f79c9284 100644 --- a/compiler/tests-jsoo/dune +++ b/compiler/tests-jsoo/dune @@ -5,7 +5,7 @@ (enabled_if (>= %{ocaml_version} 4.14)) (inline_tests - (modes js best)) + (modes js wasm best)) (preprocess (pps ppx_expect))) @@ -16,7 +16,7 @@ (enabled_if (>= %{ocaml_version} 5.1.1)) (inline_tests - (modes js best)) + (modes js wasm best)) (preprocess (pps ppx_expect))) @@ -27,7 +27,7 @@ (enabled_if (>= %{ocaml_version} 5.1.1)) (inline_tests - (modes js best)) + (modes js wasm best)) (preprocess (pps ppx_expect))) @@ -47,7 +47,7 @@ (language c) (names bigarray_stubs)) (inline_tests - (modes js best)) + (modes js wasm best)) (preprocess (pps ppx_expect))) diff --git a/compiler/tests-jsoo/lib-effects/dune b/compiler/tests-jsoo/lib-effects/dune index 42475386b2..1e61456db8 100644 --- a/compiler/tests-jsoo/lib-effects/dune +++ b/compiler/tests-jsoo/lib-effects/dune @@ -12,6 +12,6 @@ (enabled_if (>= %{ocaml_version} 5)) (inline_tests - (modes js best)) + (modes js wasm best)) (preprocess (pps ppx_expect))) diff --git a/compiler/tests-linkall/dune b/compiler/tests-linkall/dune index 4b1df9f693..5d1fd7d45f 100644 --- a/compiler/tests-linkall/dune +++ b/compiler/tests-linkall/dune @@ -3,11 +3,13 @@ (env (_ (js_of_ocaml + (compilation_mode separate)) + (wasm_of_ocaml (compilation_mode separate)))) (test (name test) - (modes byte js) + (modes byte js wasm) (libraries dynlink) ;; It doesn't seem possible to create a pack-ed module with dune. ;; However, dynlink uses pack to embed a copy diff --git a/compiler/tests-num/dune b/compiler/tests-num/dune index 38ac98ecbf..5b48d2af79 100644 --- a/compiler/tests-num/dune +++ b/compiler/tests-num/dune @@ -2,6 +2,7 @@ (name main) (modules main test_nats test test_big_ints test_ratios test_nums test_io) (libraries num) + (enabled_if %{env:js-enabled=}) (modes js (best exe)) diff --git a/compiler/tests-ocaml/basic-modules/dune b/compiler/tests-ocaml/basic-modules/dune index d5bfb9f8a9..f0add07495 100644 --- a/compiler/tests-ocaml/basic-modules/dune +++ b/compiler/tests-ocaml/basic-modules/dune @@ -1,4 +1,4 @@ (tests (names recursive_module_init) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-atomic/dune b/compiler/tests-ocaml/lib-atomic/dune index ca4c49b456..2976592d37 100644 --- a/compiler/tests-ocaml/lib-atomic/dune +++ b/compiler/tests-ocaml/lib-atomic/dune @@ -1,3 +1,3 @@ (test (name test_atomic) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-bigarray/dune b/compiler/tests-ocaml/lib-bigarray/dune index 38ac683d5e..559c82ecd1 100644 --- a/compiler/tests-ocaml/lib-bigarray/dune +++ b/compiler/tests-ocaml/lib-bigarray/dune @@ -1,4 +1,4 @@ (tests (names bigarrays change_layout fftba pr5115 weak_bigarray) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-bool/dune b/compiler/tests-ocaml/lib-bool/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-bool/dune +++ b/compiler/tests-ocaml/lib-bool/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-buffer/dune b/compiler/tests-ocaml/lib-buffer/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-buffer/dune +++ b/compiler/tests-ocaml/lib-buffer/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-bytes-utf/dune b/compiler/tests-ocaml/lib-bytes-utf/dune index 9b2db1c33a..717f83e0e5 100644 --- a/compiler/tests-ocaml/lib-bytes-utf/dune +++ b/compiler/tests-ocaml/lib-bytes-utf/dune @@ -5,4 +5,5 @@ (:standard \ -strict-sequence)) (modes js + wasm (best exe))) diff --git a/compiler/tests-ocaml/lib-bytes/dune b/compiler/tests-ocaml/lib-bytes/dune index 10725957d6..4af2ae612c 100644 --- a/compiler/tests-ocaml/lib-bytes/dune +++ b/compiler/tests-ocaml/lib-bytes/dune @@ -1,4 +1,4 @@ (tests (names test_bytes binary) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-digest/dune b/compiler/tests-ocaml/lib-digest/dune index efd881b016..550ca10463 100644 --- a/compiler/tests-ocaml/lib-digest/dune +++ b/compiler/tests-ocaml/lib-digest/dune @@ -2,7 +2,7 @@ (names md5) (libraries) (modules md5) - (modes js)) + (modes js wasm)) (tests (names digests) @@ -10,4 +10,5 @@ (build_if (>= %{ocaml_version} 5.2)) (modules digests) + ; blake2b not supported by wasm_of_ocaml yet (modes js)) diff --git a/compiler/tests-ocaml/lib-effects/dune b/compiler/tests-ocaml/lib-effects/dune index d73836514e..1025666336 100644 --- a/compiler/tests-ocaml/lib-effects/dune +++ b/compiler/tests-ocaml/lib-effects/dune @@ -2,6 +2,12 @@ (using-effects (flags (:standard -w -38))) + (wasm + (flags + (:standard -w -38))) + (wasm-effects + (flags + (:standard -w -38))) (_ (flags (:standard -w -38)) @@ -36,7 +42,7 @@ used_cont) (modules (:standard \ unhandled_unlinked)) - (modes js)) + (modes js wasm)) (tests (build_if @@ -49,4 +55,4 @@ 2 (run node %{test})) (run cat))) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-effects/evenodd.expected b/compiler/tests-ocaml/lib-effects/evenodd.expected index 8682371075..00b9bd6f70 100644 --- a/compiler/tests-ocaml/lib-effects/evenodd.expected +++ b/compiler/tests-ocaml/lib-effects/evenodd.expected @@ -1 +1 @@ -even 100000 is true +even 10000 is true diff --git a/compiler/tests-ocaml/lib-effects/evenodd.ml b/compiler/tests-ocaml/lib-effects/evenodd.ml index 035308b58f..b7bdd86463 100644 --- a/compiler/tests-ocaml/lib-effects/evenodd.ml +++ b/compiler/tests-ocaml/lib-effects/evenodd.ml @@ -18,5 +18,5 @@ and odd n = else even (n-1) let _ = - let n = 100_000 in + let n = 10_000 in Printf.printf "even %d is %B\n%!" n (even n) diff --git a/compiler/tests-ocaml/lib-filename/dune b/compiler/tests-ocaml/lib-filename/dune index 407a53e557..1f8a908a98 100644 --- a/compiler/tests-ocaml/lib-filename/dune +++ b/compiler/tests-ocaml/lib-filename/dune @@ -1,4 +1,4 @@ (tests (names suffix extension) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-float/dune b/compiler/tests-ocaml/lib-float/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-float/dune +++ b/compiler/tests-ocaml/lib-float/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-floatarray/dune b/compiler/tests-ocaml/lib-floatarray/dune index b3af4c6d57..de31de0d28 100644 --- a/compiler/tests-ocaml/lib-floatarray/dune +++ b/compiler/tests-ocaml/lib-floatarray/dune @@ -1,4 +1,4 @@ (tests (names floatarray) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-format/dune b/compiler/tests-ocaml/lib-format/dune index 94c4cfe76f..a5860c3846 100644 --- a/compiler/tests-ocaml/lib-format/dune +++ b/compiler/tests-ocaml/lib-format/dune @@ -3,4 +3,4 @@ (libraries) (flags (:standard -no-strict-formats \ -strict-formats)) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-fun/dune b/compiler/tests-ocaml/lib-fun/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-fun/dune +++ b/compiler/tests-ocaml/lib-fun/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-gc/dune b/compiler/tests-ocaml/lib-gc/dune index 13e636f3e2..0237c30eb0 100644 --- a/compiler/tests-ocaml/lib-gc/dune +++ b/compiler/tests-ocaml/lib-gc/dune @@ -2,4 +2,4 @@ (names test_gc) (libraries) (flags -w -69) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-hashtbl/dune b/compiler/tests-ocaml/lib-hashtbl/dune index 91ffd3fe48..9ef71618dc 100644 --- a/compiler/tests-ocaml/lib-hashtbl/dune +++ b/compiler/tests-ocaml/lib-hashtbl/dune @@ -3,7 +3,7 @@ (deps ../../../LICENSE) (modules hfun) (libraries) - (modes js)) + (modes js wasm)) (tests (names htbl) @@ -12,4 +12,15 @@ (build_if (>= %{ocaml_version} 5)) (libraries) - (modes js)) + (modes js wasm)) + +(rule + (action + (copy hfun.expected-js hfun.expected)) + (enabled_if %{env:js-enabled=})) + +(rule + (action + (copy hfun.expected-wasm hfun.expected)) + (enabled_if + (not %{env:js-enabled=}))) diff --git a/compiler/tests-ocaml/lib-hashtbl/hfun.expected b/compiler/tests-ocaml/lib-hashtbl/hfun.expected-js similarity index 100% rename from compiler/tests-ocaml/lib-hashtbl/hfun.expected rename to compiler/tests-ocaml/lib-hashtbl/hfun.expected-js diff --git a/compiler/tests-ocaml/lib-hashtbl/hfun.expected-wasm b/compiler/tests-ocaml/lib-hashtbl/hfun.expected-wasm new file mode 100644 index 0000000000..2e92cf439d --- /dev/null +++ b/compiler/tests-ocaml/lib-hashtbl/hfun.expected-wasm @@ -0,0 +1,27 @@ +-- Strings: +"" 00000000 +"Hello world" 364b8272 +-- Integers: +0 07be548a +-1 3653e015 +42 1792870b +2^30-1 23c392d0 +-2^30 0c66fde3 +-- Floats: ++0.0 0f478b8c +-0.0 0f478b8c ++infty 23ea56fb +-infty 059f7872 +NaN 3228858d +NaN#2 3228858d +NaN#3 3228858d +-- Native integers: +0 3f19274a +-1 3653e015 +42 3e33aef8 +2^30-1 3711bf46 +-2^30 2e71f39c +-- Lists: +[0..10] 0ade0fc9 +[0..12] 0ade0fc9 +[10..0] 0cd6259d diff --git a/compiler/tests-ocaml/lib-int/dune b/compiler/tests-ocaml/lib-int/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-int/dune +++ b/compiler/tests-ocaml/lib-int/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-int64/dune b/compiler/tests-ocaml/lib-int64/dune index 4ff01bc02f..6987384f87 100644 --- a/compiler/tests-ocaml/lib-int64/dune +++ b/compiler/tests-ocaml/lib-int64/dune @@ -1,4 +1,4 @@ (tests (names test issue9460) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-list/dune b/compiler/tests-ocaml/lib-list/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-list/dune +++ b/compiler/tests-ocaml/lib-list/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-option/dune b/compiler/tests-ocaml/lib-option/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-option/dune +++ b/compiler/tests-ocaml/lib-option/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-printf/dune b/compiler/tests-ocaml/lib-printf/dune index 69defbd4e8..2a15a0ace3 100644 --- a/compiler/tests-ocaml/lib-printf/dune +++ b/compiler/tests-ocaml/lib-printf/dune @@ -5,4 +5,5 @@ (:standard -no-strict-formats \ -strict-formats)) (modes js + wasm (best exe))) diff --git a/compiler/tests-ocaml/lib-queue/dune b/compiler/tests-ocaml/lib-queue/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-queue/dune +++ b/compiler/tests-ocaml/lib-queue/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-random/dune b/compiler/tests-ocaml/lib-random/dune index 840bec2a7f..6c1c5e29e1 100644 --- a/compiler/tests-ocaml/lib-random/dune +++ b/compiler/tests-ocaml/lib-random/dune @@ -5,4 +5,5 @@ (libraries) (modes js + wasm (best exe))) diff --git a/compiler/tests-ocaml/lib-result/dune b/compiler/tests-ocaml/lib-result/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-result/dune +++ b/compiler/tests-ocaml/lib-result/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-seq/dune b/compiler/tests-ocaml/lib-seq/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-seq/dune +++ b/compiler/tests-ocaml/lib-seq/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-set/dune b/compiler/tests-ocaml/lib-set/dune index 9e8fed86d5..c0602be25e 100644 --- a/compiler/tests-ocaml/lib-set/dune +++ b/compiler/tests-ocaml/lib-set/dune @@ -1,4 +1,4 @@ (tests (names testmap testset) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-stack/dune b/compiler/tests-ocaml/lib-stack/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-stack/dune +++ b/compiler/tests-ocaml/lib-stack/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-str/dune b/compiler/tests-ocaml/lib-str/dune index 18b732190a..fe1e7b18c4 100644 --- a/compiler/tests-ocaml/lib-str/dune +++ b/compiler/tests-ocaml/lib-str/dune @@ -1,4 +1,4 @@ (tests (names t01) (libraries str) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-string/dune b/compiler/tests-ocaml/lib-string/dune index f1b08d6ad0..e3f41537b8 100644 --- a/compiler/tests-ocaml/lib-string/dune +++ b/compiler/tests-ocaml/lib-string/dune @@ -3,4 +3,4 @@ (build_if (>= %{ocaml_version} 5)) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-uchar/dune b/compiler/tests-ocaml/lib-uchar/dune index 9047167ba4..16342d6417 100644 --- a/compiler/tests-ocaml/lib-uchar/dune +++ b/compiler/tests-ocaml/lib-uchar/dune @@ -1,4 +1,4 @@ (tests (names test) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/prim-bigstring/dune b/compiler/tests-ocaml/prim-bigstring/dune index 2e162bd45a..880fb9cd70 100644 --- a/compiler/tests-ocaml/prim-bigstring/dune +++ b/compiler/tests-ocaml/prim-bigstring/dune @@ -1,4 +1,4 @@ (tests (names bigstring_access string_access) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/prim-bswap/dune b/compiler/tests-ocaml/prim-bswap/dune index 36c5b217b1..a0328d664c 100644 --- a/compiler/tests-ocaml/prim-bswap/dune +++ b/compiler/tests-ocaml/prim-bswap/dune @@ -1,4 +1,4 @@ (tests (names bswap) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-ocaml/prim-revapply/dune b/compiler/tests-ocaml/prim-revapply/dune index bf4e90bb65..017e60f37c 100644 --- a/compiler/tests-ocaml/prim-revapply/dune +++ b/compiler/tests-ocaml/prim-revapply/dune @@ -1,4 +1,4 @@ (tests (names apply revapply) (libraries) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-re/dune b/compiler/tests-re/dune index 10c45d2c5b..e86d9c9347 100644 --- a/compiler/tests-re/dune +++ b/compiler/tests-re/dune @@ -6,4 +6,4 @@ (tests (names test_str) (libraries str re) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-runtime-events/dune b/compiler/tests-runtime-events/dune index f387de95eb..a8a208145f 100644 --- a/compiler/tests-runtime-events/dune +++ b/compiler/tests-runtime-events/dune @@ -8,4 +8,4 @@ (build_if (>= %{ocaml_version} 5.1.0)) (libraries runtime_events) - (modes js)) + (modes js wasm)) diff --git a/compiler/tests-toplevel/dune b/compiler/tests-toplevel/dune index abd0a7828a..650ac90c16 100644 --- a/compiler/tests-toplevel/dune +++ b/compiler/tests-toplevel/dune @@ -1,5 +1,6 @@ (executables (names test_toplevel) + (enabled_if %{env:js-enabled=}) (libraries js_of_ocaml-compiler.dynlink compiler-libs.toplevel) (flags (:standard -linkall)) @@ -9,13 +10,16 @@ (rule (targets test_toplevel.js) + (enabled_if %{env:js-enabled=}) (action (run %{bin:js_of_ocaml} --toplevel %{dep:test_toplevel.bc} -o %{targets}))) (rule (target test_toplevel.bc.js.actual) (enabled_if - (>= %{ocaml_version} 5.2)) + (and + (>= %{ocaml_version} 5.2) + %{env:js-enabled=})) (action (with-stdout-to %{target} @@ -24,7 +28,9 @@ (rule (target test_toplevel.js.actual) (enabled_if - (>= %{ocaml_version} 5.2)) + (and + (>= %{ocaml_version} 5.2) + %{env:js-enabled=})) (action (with-stdout-to %{target} @@ -33,7 +39,9 @@ (rule (alias runtest) (enabled_if - (>= %{ocaml_version} 5.2)) + (and + (>= %{ocaml_version} 5.2) + %{env:js-enabled=})) (action (progn (diff test_toplevel.expected test_toplevel.bc.js.actual) diff --git a/compiler/tests-wasm_of_ocaml/dune b/compiler/tests-wasm_of_ocaml/dune new file mode 100644 index 0000000000..0ae81f7992 --- /dev/null +++ b/compiler/tests-wasm_of_ocaml/dune @@ -0,0 +1,7 @@ +(tests + (names gh38 gh46 gh107 gh112) + (modes js wasm) + (js_of_ocaml + (flags :standard --disable optcall --no-inline)) + (wasm_of_ocaml + (flags :standard --disable optcall --no-inline))) diff --git a/compiler/tests-wasm_of_ocaml/gh107.expected b/compiler/tests-wasm_of_ocaml/gh107.expected new file mode 100644 index 0000000000..cf2650d57b --- /dev/null +++ b/compiler/tests-wasm_of_ocaml/gh107.expected @@ -0,0 +1 @@ +2.000000 diff --git a/compiler/tests-wasm_of_ocaml/gh107.ml b/compiler/tests-wasm_of_ocaml/gh107.ml new file mode 100644 index 0000000000..ca4202d7f8 --- /dev/null +++ b/compiler/tests-wasm_of_ocaml/gh107.ml @@ -0,0 +1,11 @@ +[@@@warning "-69"] + +type t = + { x : float + ; y : float + } + +let () = + let f x = { x; y = 2. } in + let x = f 1. in + Format.printf "%f@." x.y diff --git a/compiler/tests-wasm_of_ocaml/gh112.ml b/compiler/tests-wasm_of_ocaml/gh112.ml new file mode 100644 index 0000000000..d2fc1d2b8f --- /dev/null +++ b/compiler/tests-wasm_of_ocaml/gh112.ml @@ -0,0 +1,49 @@ +let construct x = [| x |] + +let get (x : float array) = x.(0) + +let get_ (x : _ array) = x.(0) + +let set (x : float array) e = x.(0) <- e + +let set_ (x : _ array) e = x.(0) <- e + +let a = construct 1.0 + +let _ = set a 2.0 + +let _ = assert (Float.equal (get a) 2.0) + +let _ = assert (Float.equal (get_ a) 2.0) + +let _ = set_ a 3.0 + +let _ = assert (Float.equal (get a) 3.0) + +let _ = assert (Float.equal (get_ a) 3.0) + +let b = [| 1.0 |] + +let _ = set b 2.0 + +let _ = assert (Float.equal (get b) 2.0) + +let _ = assert (Float.equal (get_ b) 2.0) + +let _ = set_ b 3.0 + +let _ = assert (Float.equal (get b) 3.0) + +let _ = assert (Float.equal (get_ b) 3.0) + +let construct2 x = [| x; x |] + +let c = construct2 1. + +let _ = assert (Float.equal c.(0) 1. && Float.equal c.(1) 1.) + +let _ = c.(1) <- 2. + +let _ = assert (Array.length c = 2) + +let _ = assert (Float.equal c.(0) 1. && Float.equal c.(1) 2.) diff --git a/compiler/tests-wasm_of_ocaml/gh38.ml b/compiler/tests-wasm_of_ocaml/gh38.ml new file mode 100644 index 0000000000..5fec74de67 --- /dev/null +++ b/compiler/tests-wasm_of_ocaml/gh38.ml @@ -0,0 +1,3 @@ +let f () () = () + +let (_ : _ -> _) = f () diff --git a/compiler/tests-wasm_of_ocaml/gh46.ml b/compiler/tests-wasm_of_ocaml/gh46.ml new file mode 100644 index 0000000000..4fcf866402 --- /dev/null +++ b/compiler/tests-wasm_of_ocaml/gh46.ml @@ -0,0 +1,7 @@ +type lst = + | Cons of lst * int + | Nil + +let rec make n = if n = 0 then Nil else Cons (make (n - 1), n) + +let () = assert (make 10 = make 10) diff --git a/dune b/dune index 38e369ffce..1bd709e8a8 100644 --- a/dune +++ b/dune @@ -1,21 +1,54 @@ (env (dev + (wasm_of_ocaml + (enabled_if false)) (flags - (:standard -w +a-4-40-41-42-44-48-58-66-70))) + (:standard -w +a-4-40-41-42-44-48-58-66-70)) + (env-vars + (js-enabled true))) (using-effects + (wasm_of_ocaml + (enabled_if false)) (js_of_ocaml (compilation_mode separate) (flags (:standard --enable effects)) (build_runtime_flags - (:standard --enable effects)))) + (:standard --enable effects))) + (env-vars + (js-enabled true))) + (wasm + (binaries + (tools/node_wrapper.sh as node)) + (js_of_ocaml + (enabled_if false)) + (wasm_of_ocaml + (compilation_mode separate)) + (env-vars + (js-enabled false))) + (wasm-effects + (binaries + (tools/node_wrapper.sh as node)) + (js_of_ocaml + (enabled_if false)) + (wasm_of_ocaml + (compilation_mode separate) + (flags + (:standard --enable effects))) + (env-vars + (js-enabled false))) (bench_no_debug (flags (:standard \ -g)) (ocamlc_flags (:standard \ -g)) (link_flags - (:standard \ -g)))) + (:standard \ -g)) + (env-vars + (js-enabled true))) + (_ + (env-vars + (js-enabled true)))) (rule (targets version.ml.in) diff --git a/dune-project b/dune-project index c821bbe45b..8bfe676983 100644 --- a/dune-project +++ b/dune-project @@ -132,3 +132,29 @@ (ppx_expect (and (>= v0.14.2) :with-test)) (re (and (>= 1.9.0) :with-test)) )) + +(package + (name wasm_of_ocaml-compiler) + (synopsis "Compiler from OCaml bytecode to WebAssembly") + (description + "Wasm_of_ocaml is a compiler from OCaml bytecode to WebAssembly. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") + (depends + (ocaml (>= 4.14)) + (js_of_ocaml (= :version)) + (num :with-test) + (ppx_expect (and (>= v0.14.2) :with-test)) + (ppxlib (>= 0.15.0)) + (re :with-test) + (cmdliner (>= 1.1.0)) + (sedlex (>= 2.3)) + menhir + menhirLib + menhirSdk + (yojson (>= 2.1)) + binaryen-bin) + (depopts + ocamlfind) + (conflicts + (ocamlfind (< 1.5.1)) + (js_of_ocaml (< 3.0)) +)) diff --git a/examples/README.md b/examples/README.md index 8742565178..842b7ba6b4 100644 --- a/examples/README.md +++ b/examples/README.md @@ -10,4 +10,17 @@ Or a single one: $> dune build @examples//default ``` +Add the `--profile wasm` option to compile to Wasm: +``` +$> dune build @examples/boulderdash/default --profile wasm +``` + Compilation artifacts can be found in `${REPO_ROOT}/_build/default/examples/`. + +When generating JavaScript code, you can directly open the +`index.html` files in a browser. When generating Wasm code, you need +to serve the files, for instance with the following command: +``` +python -m http.server -d _build/default/examples/boulderdash/ +``` +and then open `http://localhost:8000` in a browser. diff --git a/examples/boulderdash/boulderdash.ml b/examples/boulderdash/boulderdash.ml index ac4b0c4e7c..90cf35f6d0 100644 --- a/examples/boulderdash/boulderdash.ml +++ b/examples/boulderdash/boulderdash.ml @@ -329,7 +329,7 @@ let http_get url = let msg = r.XmlHttpRequest.content in if cod = 0 || cod = 200 then Lwt.return msg else fst (Lwt.wait ()) -let getfile f = try Lwt.return (Sys_js.read_file ~name:f) with Not_found -> http_get f +let getfile f = try Lwt.return (Sys_js.read_file ~name:f) with Sys_error _ -> http_get f exception Eos @@ -510,8 +510,4 @@ let start _ = Dom.appendChild body div; Lwt.return () -let _ = - Html.window##.onload := - Html.handler (fun _ -> - ignore (start ()); - Js._false) +let () = Lwt.async start diff --git a/examples/boulderdash/dune b/examples/boulderdash/dune index 952ee49396..3f26cd2f5a 100644 --- a/examples/boulderdash/dune +++ b/examples/boulderdash/dune @@ -1,30 +1,25 @@ (executables (names boulderdash) (libraries js_of_ocaml-lwt) - (modes byte) + (modes js wasm) + (js_of_ocaml + (flags :standard --file %{dep:maps.txt} --file maps)) + (link_deps + (glob_files maps/*.map)) (preprocess (pps js_of_ocaml-ppx))) (rule - (targets boulderdash.js) - (deps - (glob_files maps/*.map)) (action - (run - %{bin:js_of_ocaml} - --source-map - %{dep:boulderdash.bc} - -o - %{targets} - --pretty - --file - %{dep:maps.txt} - --file - maps))) + (copy boulderdash.bc.wasm.js boulderdash.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) (alias (name default) (deps - boulderdash.js + boulderdash.bc.js index.html + maps.txt + (glob_files maps/*.map) (glob_files sprites/*.{png,svg}))) diff --git a/examples/boulderdash/index.html b/examples/boulderdash/index.html index 1ccdf3e964..fcd89ea7d8 100644 --- a/examples/boulderdash/index.html +++ b/examples/boulderdash/index.html @@ -5,7 +5,7 @@ Boulder Dash - + diff --git a/examples/cubes/cubes.ml b/examples/cubes/cubes.ml index 0314554e66..08f11c1266 100644 --- a/examples/cubes/cubes.ml +++ b/examples/cubes/cubes.ml @@ -201,7 +201,7 @@ let rec loop c c' a = if !need_redraw then redraw c c' a; loop c c' a -let start _ = +let () = let c = create_canvas () in let c' = create_canvas () in Dom.appendChild Html.window##.document##.body c; @@ -209,7 +209,4 @@ let start _ = c##.globalCompositeOperation := Js.string "copy"; let a = create_cubes true in redraw c c' a; - ignore (loop c c' a); - Js._false - -let _ = Html.window##.onload := Html.handler start + ignore (loop c c' a) diff --git a/examples/cubes/dune b/examples/cubes/dune index 56d43c509d..f945ab2f69 100644 --- a/examples/cubes/dune +++ b/examples/cubes/dune @@ -1,21 +1,16 @@ (executables (names cubes) (libraries js_of_ocaml-lwt) - (modes byte) + (modes js wasm) (preprocess (pps js_of_ocaml-ppx))) (rule - (targets cubes.js) (action - (run - %{bin:js_of_ocaml} - --source-map - %{dep:cubes.bc} - -o - %{targets} - --pretty))) + (copy cubes.bc.wasm.js cubes.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) (alias (name default) - (deps cubes.js index.html)) + (deps cubes.bc.js index.html)) diff --git a/examples/cubes/index.html b/examples/cubes/index.html index c48a46e7bd..09508370d2 100644 --- a/examples/cubes/index.html +++ b/examples/cubes/index.html @@ -4,7 +4,7 @@ Cubes - + diff --git a/examples/graph_viewer/dune b/examples/graph_viewer/dune index b22b3d62c2..e67a55a769 100644 --- a/examples/graph_viewer/dune +++ b/examples/graph_viewer/dune @@ -1,7 +1,7 @@ (executables (names viewer_js) ;; add converter & viewer (libraries js_of_ocaml-lwt) - (modes byte) + (modes js wasm) (modules (:standard \ @@ -13,24 +13,19 @@ dot_lexer dot_graph dot_render)) + (js_of_ocaml + (flags :standard --file %{dep:scene.json})) (preprocess - (pps js_of_ocaml-ppx))) + (pps js_of_ocaml-ppx js_of_ocaml-ppx_deriving_json))) (ocamllex dot_lexer) (rule - (targets viewer_js.js) (action - (run - %{bin:js_of_ocaml} - --source-map - %{dep:viewer_js.bc} - -o - %{targets} - --pretty - --file - %{dep:scene.json}))) + (copy viewer_js.bc.wasm.js viewer_js.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) (alias (name default) - (deps viewer_js.js index.html)) + (deps viewer_js.bc.js scene.json index.html)) diff --git a/examples/graph_viewer/index.html b/examples/graph_viewer/index.html index 857bf5eaff..b4c6d482bd 100644 --- a/examples/graph_viewer/index.html +++ b/examples/graph_viewer/index.html @@ -4,7 +4,7 @@ Graph viewer - + diff --git a/examples/graph_viewer/scene.ml b/examples/graph_viewer/scene.ml index 8185bb8d9f..9a917e21e6 100644 --- a/examples/graph_viewer/scene.ml +++ b/examples/graph_viewer/scene.ml @@ -17,9 +17,12 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) +[@@@warning "-39"] + type command = | Move_to of float * float | Curve_to of float * float * float * float * float * float +[@@deriving json] type color = float * float * float @@ -28,6 +31,7 @@ type ('color, 'font, 'text) element = | Polygon of (float * float) array * 'color option * 'color option | Ellipse of float * float * float * float * 'color option * 'color option | Text of float * float * 'text * 'font * 'color option * 'color option +[@@deriving json] (****) diff --git a/examples/graph_viewer/scene.mli b/examples/graph_viewer/scene.mli index 685a9584b2..935ee5168a 100644 --- a/examples/graph_viewer/scene.mli +++ b/examples/graph_viewer/scene.mli @@ -20,6 +20,7 @@ type command = | Move_to of float * float | Curve_to of float * float * float * float * float * float +[@@deriving json] type color = float * float * float @@ -28,6 +29,7 @@ type ('color, 'font, 'text) element = | Polygon of (float * float) array * 'color option * 'color option | Ellipse of float * float * float * float * 'color option * 'color option | Text of float * float * 'text * 'font * 'color option * 'color option +[@@deriving json] (****) diff --git a/examples/graph_viewer/viewer_js.ml b/examples/graph_viewer/viewer_js.ml index 3140f1d06d..2820bd543e 100644 --- a/examples/graph_viewer/viewer_js.ml +++ b/examples/graph_viewer/viewer_js.ml @@ -166,15 +166,8 @@ open Common let redraw st s h v (canvas : Html.canvasElement Js.t) = let width = canvas##.width in let height = canvas##.height in - (*Firebug.console##time (Js.string "draw");*) redraw st s h v canvas { x = 0; y = 0; width; height } 0 0 width height -(* -;Firebug.console##timeEnd (Js.string "draw") -;Firebug.console##log_2 (Js.string "draw", Js.date##now()) -*) -let json : < parse : Js.js_string Js.t -> 'a > Js.t = Js.Unsafe.pure_js_expr "JSON" - let ( >>= ) = Lwt.bind let http_get url = @@ -182,7 +175,7 @@ let http_get url = >>= fun { XmlHttpRequest.code = cod; content = msg; _ } -> if cod = 0 || cod = 200 then Lwt.return msg else fst (Lwt.wait ()) -let getfile f = try Lwt.return (Sys_js.read_file ~name:f) with Not_found -> http_get f +let getfile f = try Lwt.return (Sys_js.read_file ~name:f) with Sys_error _ -> http_get f class adjustment ?(value = 0.) @@ -275,6 +268,25 @@ let handle_drag element f = in this example. *) Js._true) +let of_json ~typ v = + match Sys.backend_type with + | Other "js_of_ocaml" -> Js._JSON##parse (Js.string v) + | _ -> Deriving_Json.from_string typ v + +type js_string = Js.js_string Js.t + +let js_string_to_json _ _ : unit = assert false + +let js_string_of_json buf = Js.bytestring (Deriving_Json.Json_string.read buf) + +[@@@warning "-20-39"] + +type scene = + (float * float * float * float) + * (float * float * float * float) array + * (js_string, js_string, js_string) Scene.element array +[@@deriving json] + let start () = let doc = Html.document in let page = doc##.documentElement in @@ -300,7 +312,7 @@ let start () = Firebug.console##timeEnd(Js.string "loading"); Firebug.console##time(Js.string "parsing"); *) - let (x1, y1, x2, y2), bboxes, scene = json##parse (Js.string s) in + let (x1, y1, x2, y2), bboxes, scene = of_json ~typ:[%json: scene] s in (* Firebug.console##timeEnd(Js.string "parsing"); Firebug.console##time(Js.string "init"); @@ -561,8 +573,4 @@ Firebug.console##timeEnd(Js.string "init"); *) Lwt.return () -let _ = - Html.window##.onload := - Html.handler (fun _ -> - ignore (start ()); - Js._false) +let () = Lwt.async start diff --git a/examples/graphics/dune b/examples/graphics/dune index a563ee7739..da1fd0f113 100644 --- a/examples/graphics/dune +++ b/examples/graphics/dune @@ -1,10 +1,16 @@ (executable (name main) - (modes js) + (modes js wasm) (libraries js_of_ocaml-lwt.graphics) (preprocess (pps js_of_ocaml-ppx))) +(rule + (action + (copy main.bc.wasm.js main.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) + (alias (name default) (deps main.bc.js index.html)) diff --git a/examples/hyperbolic/dune b/examples/hyperbolic/dune index f1fb55f990..7a6788b708 100644 --- a/examples/hyperbolic/dune +++ b/examples/hyperbolic/dune @@ -1,31 +1,32 @@ (executables (names hypertree) (libraries js_of_ocaml-lwt) - (modes byte) - (preprocess - (pps js_of_ocaml-ppx))) - -(rule - (targets hypertree.js) - (action - (run - %{bin:js_of_ocaml} - --source-map - %{dep:hypertree.bc} - -o - %{targets} - --pretty + (modes js wasm) + (js_of_ocaml + (flags + :standard --file %{dep:image_info.json} --file %{dep:messages.json} --file - %{dep:tree.json}))) + %{dep:tree.json})) + (preprocess + (pps js_of_ocaml-ppx js_of_ocaml-ppx_deriving_json))) + +(rule + (action + (copy hypertree.bc.wasm.js hypertree.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) (alias (name default) (deps - hypertree.js + hypertree.bc.js index.html + image_info.json + messages.json + tree.json (glob_files icons/*.{png,jpg}) (glob_files thumbnails/*.{png,jpg}))) diff --git a/examples/hyperbolic/hypertree.ml b/examples/hyperbolic/hypertree.ml index 2bf304e4d5..6c05a964f1 100644 --- a/examples/hyperbolic/hypertree.ml +++ b/examples/hyperbolic/hypertree.ml @@ -248,8 +248,6 @@ let lwt_wrap f = module Html = Dom_html -let json : < parse : Js.js_string Js.t -> 'a > Js.t = Js.Unsafe.pure_js_expr "JSON" - let http_get url = XmlHttpRequest.get url >>= fun r -> @@ -257,7 +255,7 @@ let http_get url = let msg = r.XmlHttpRequest.content in if cod = 0 || cod = 200 then Lwt.return msg else fst (Lwt.wait ()) -let getfile f = try Lwt.return (Sys_js.read_file ~name:f) with Not_found -> http_get f +let getfile f = try Lwt.return (Sys_js.read_file ~name:f) with Sys_error _ -> http_get f let load_image src = let img = Html.createImg Html.document in @@ -531,6 +529,13 @@ let text_size font txt = (******) +let of_json ~typ v = + match Sys.backend_type with + | Other "js_of_ocaml" -> Js._JSON##parse (Js.string v) + | _ -> Deriving_Json.from_string typ v + +(******) + let default_language () = (Js.Optdef.get Dom_html.window##.navigator##.language @@ -553,7 +558,7 @@ let set_language lang = language := lang let load_messages () = - getfile "messages.json" >>= fun s -> Lwt.return (json##parse (Js.string s)) + getfile "messages.json" >>= fun s -> Lwt.return (Js._JSON##parse (Js.string s)) let local_messages msgs : messages Js.t = option (Js.Unsafe.get msgs !language) @@ -801,7 +806,7 @@ let tree_url = "tree.json" let ( >> ) x f = f x -type 'a tree = Node of 'a * 'a tree array +type 'a tree = Node of 'a * 'a tree array [@@deriving json] let rec tree_vertice_count n = let (Node (_, l)) = n in @@ -1074,17 +1079,22 @@ let tree_layout node_names root = compute_text_nodes node_names nodes; vertices, edges, nodes, boxes +type js_string = Js.js_string Js.t + +let js_string_to_json _ _ : unit = assert false + +let js_string_of_json buf = Js.bytestring (Deriving_Json.Json_string.read buf) + +[@@@warning "-20-39"] + +type tree_info = + js_string tree * (js_string * (js_string * js_string) array * js_string) array +[@@deriving json] + let load_tree () = getfile tree_url >>= fun s -> - let info : - Js.js_string Js.t tree - * (Js.js_string Js.t - * (Js.js_string Js.t * Js.js_string Js.t) array - * Js.js_string Js.t) - array = - json##parse (Js.string s) - in + let info : tree_info = of_json ~typ:[%json: tree_info] s in let tree, node_names = info in randomize_tree tree; let node_names = @@ -1098,17 +1108,18 @@ let load_tree () = Lwt.return (tree_layout node_names tree, node_names) type info = - { name : Js.js_string Js.t - ; url : Js.js_string Js.t - ; attribution : Js.js_string Js.t + { name : js_string + ; url : js_string + ; attribution : js_string ; width : int ; height : int - ; links : (Js.js_string Js.t * Js.js_string Js.t * Js.js_string Js.t) array - ; img_url : Js.js_string Js.t option + ; links : (js_string * js_string * js_string) array + ; img_url : js_string option } +[@@deriving json] let load_image_info () : info array Lwt.t = - getfile "image_info.json" >>= fun s -> Lwt.return (json##parse (Js.string s)) + getfile "image_info.json" >>= fun s -> Lwt.return (of_json ~typ:[%json: info array] s) let close_button over = let color = opt_style style##.buttonColor (Js.string "#888888") in @@ -1851,6 +1862,7 @@ debug_msg (Format.sprintf "Resize %d %d" w h); prev_buttons := Some buttons in make_buttons (); + (* let img = Html.createImg doc in img##.src := icon "ocsigen-powered.png"; let a = Html.createA doc in @@ -1863,15 +1875,11 @@ debug_msg (Format.sprintf "Resize %d %d" w h); logo##.style##.bottom := Js.string "0"; Dom.appendChild logo a; Dom.appendChild doc##.body logo; - Lwt.return ()); - Js._false +*) + Lwt.return ()) -let start _ = +let () = try ignore (Html.createCanvas Html.window##.document); start () - with Html.Canvas_not_available -> - unsupported_messages (); - Js._false - -let _ = Html.window##.onload := Html.handler start + with Html.Canvas_not_available -> unsupported_messages () diff --git a/examples/hyperbolic/index.html b/examples/hyperbolic/index.html index 6d29554d60..6b9f6e1c49 100644 --- a/examples/hyperbolic/index.html +++ b/examples/hyperbolic/index.html @@ -78,6 +78,6 @@ - + diff --git a/examples/minesweeper/dune b/examples/minesweeper/dune index f393dd49ca..12a574195b 100644 --- a/examples/minesweeper/dune +++ b/examples/minesweeper/dune @@ -1,18 +1,19 @@ (executables (names main) (libraries js_of_ocaml-lwt) - (modes byte) + (modes js wasm) (preprocess (pps js_of_ocaml-ppx))) (rule - (targets main.js) (action - (run %{bin:js_of_ocaml} --source-map %{dep:main.bc} -o %{targets} --pretty))) + (copy main.bc.wasm.js main.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) (alias (name default) (deps - main.js + main.bc.js index.html (glob_files sprites/*.{png,svg}))) diff --git a/examples/minesweeper/index.html b/examples/minesweeper/index.html index 43eef95f15..f4243fca7a 100644 --- a/examples/minesweeper/index.html +++ b/examples/minesweeper/index.html @@ -5,7 +5,7 @@ Minesweeper - +
diff --git a/examples/minesweeper/main.ml b/examples/minesweeper/main.ml index 32bd38b5ae..0851c819f3 100644 --- a/examples/minesweeper/main.ml +++ b/examples/minesweeper/main.ml @@ -35,7 +35,7 @@ let button name callback = Dom.appendChild res input; res -let onload _ = +let () = let main = Js.Opt.get (document##getElementById (js "main")) (fun () -> assert false) in let nbr, nbc, nbm = ref 10, ref 12, ref 15 in Dom.appendChild main (int_input "Number of columns" nbr); @@ -50,7 +50,4 @@ let onload _ = let div = Html.createDiv document in Dom.appendChild main div; Minesweeper.run div !nbc !nbr !nbm; - Js._false)); - Js._false - -let () = Html.window##.onload := Html.handler onload + Js._false)) diff --git a/examples/namespace/dune b/examples/namespace/dune index 9e18547e5c..f616007252 100644 --- a/examples/namespace/dune +++ b/examples/namespace/dune @@ -59,5 +59,6 @@ (rule (alias runtest) + (enabled_if %{env:js-enabled=}) (action (diff %{dep:for-node.expected} %{dep:for-node.actual}))) diff --git a/examples/planet/dune b/examples/planet/dune index 30e0388841..c1c9db4ec8 100644 --- a/examples/planet/dune +++ b/examples/planet/dune @@ -1,21 +1,16 @@ (executables (names planet) (libraries js_of_ocaml-lwt) - (modes byte) + (modes js wasm) (preprocess (pps js_of_ocaml-ppx))) (rule - (targets planet.js) (action - (run - %{bin:js_of_ocaml} - --source-map - %{dep:planet.bc} - -o - %{targets} - --pretty))) + (copy planet.bc.wasm.js planet.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) (alias (name default) - (deps planet.js index.html texture.jpg)) + (deps planet.bc.js index.html texture.jpg)) diff --git a/examples/planet/index.html b/examples/planet/index.html index eeeae461f1..aba6071fd8 100644 --- a/examples/planet/index.html +++ b/examples/planet/index.html @@ -13,7 +13,7 @@ p {clear:left;} --> - + diff --git a/examples/planet/planet.ml b/examples/planet/planet.ml index c4c4b8b9e2..d9ae889702 100644 --- a/examples/planet/planet.ml +++ b/examples/planet/planet.ml @@ -593,9 +593,9 @@ let _texture = Js.string "black.jpg" let _texture = Js.string "../planet/land_ocean_ice_cloud_2048.jpg" -let texture = Js.string "../planet/texture.jpg" +let texture = Js.string "texture.jpg" -let start _ = +let () = Lwt.ignore_result (load_image texture >>= fun texture -> @@ -777,7 +777,4 @@ if true then Lwt.return () else if (not !paused) && !follow then phi_rot := !phi_rot +. angle; loop t' (if !paused then phi else phi +. angle) in - loop (Js.to_float (new%js Js.date_now)##getTime) 0.); - Js._false - -let _ = Html.window##.onload := Html.handler start + loop (Js.to_float (new%js Js.date_now)##getTime) 0.) diff --git a/examples/separate_compilation/dune b/examples/separate_compilation/dune index 17d9055b21..8f0cc22b6e 100644 --- a/examples/separate_compilation/dune +++ b/examples/separate_compilation/dune @@ -110,11 +110,13 @@ (rule (alias runtest) + (enabled_if %{env:js-enabled=}) (action (diff bin.expected bin.actual))) (alias (name default) + (enabled_if %{env:js-enabled=}) (deps myruntime.js stdlib.cma.js diff --git a/examples/test_wheel/dune b/examples/test_wheel/dune index cd729978bc..09de8f259d 100644 --- a/examples/test_wheel/dune +++ b/examples/test_wheel/dune @@ -1,6 +1,12 @@ (executables (names test_wheel) (libraries js_of_ocaml) - (modes js) + (modes js wasm) (preprocess (pps js_of_ocaml-ppx))) + +(rule + (action + (copy test_wheel.bc.wasm.js test_wheel.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) diff --git a/examples/webgl/dune b/examples/webgl/dune index 8025ac85fb..dd0cbcdd3e 100644 --- a/examples/webgl/dune +++ b/examples/webgl/dune @@ -1,23 +1,18 @@ (executables (names webgldemo) (libraries js_of_ocaml-lwt) - (modes byte) + (modes js wasm) + (js_of_ocaml + (flags :standard --file %{dep:monkey.model})) (preprocess (pps js_of_ocaml-ppx))) (rule - (targets webgldemo.js) (action - (run - %{bin:js_of_ocaml} - --source-map - %{dep:webgldemo.bc} - -o - %{targets} - --pretty - --file - %{dep:monkey.model}))) + (copy webgldemo.bc.wasm.js webgldemo.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) (alias (name default) - (deps webgldemo.js index.html)) + (deps webgldemo.bc.js monkey.model index.html)) diff --git a/examples/webgl/index.html b/examples/webgl/index.html index 3110e5b81c..da0ce73cf8 100644 --- a/examples/webgl/index.html +++ b/examples/webgl/index.html @@ -42,7 +42,7 @@ gl_FragColor = vec4( col * lighting + u_ambientLight, 1); } - + diff --git a/examples/webgl/webgldemo.ml b/examples/webgl/webgldemo.ml index c071713e7a..082b6be798 100644 --- a/examples/webgl/webgldemo.ml +++ b/examples/webgl/webgldemo.ml @@ -220,7 +220,8 @@ let http_get url = if cod = 0 || cod = 200 then Lwt.return msg else fst (Lwt.wait ()) let getfile f = - try Lwt.return (Sys_js.read_file ~name:f) with Not_found -> http_get f >|= fun s -> s + try Lwt.return (Sys_js.read_file ~name:f) + with Sys_error _ -> http_get f >|= fun s -> s let fetch_model s = getfile s @@ -298,12 +299,9 @@ let start (pos, norm) = in f () -let go _ = +let () = ignore (debug "fetching model"; catch (fun () -> fetch_model "monkey.model" >>= start) - (fun exn -> error "uncaught exception: %s" (Printexc.to_string exn))); - _true - -let _ = Dom_html.window##.onload := Dom_html.handler go + (fun exn -> error "uncaught exception: %s" (Printexc.to_string exn))) diff --git a/examples/wiki/dune b/examples/wiki/dune index 93735a2832..ee357ad4a6 100644 --- a/examples/wiki/dune +++ b/examples/wiki/dune @@ -1,17 +1,18 @@ (executables (names main) (libraries js_of_ocaml-lwt) - (modes byte) + (modes js wasm) (preprocess (pps js_of_ocaml-ppx))) (ocamllex wikicreole) (rule - (targets main.js) (action - (run %{bin:js_of_ocaml} --source-map %{dep:main.bc} -o %{targets} --pretty))) + (copy main.bc.wasm.js main.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) (alias (name default) - (deps main.js index.html)) + (deps main.bc.js index.html)) diff --git a/examples/wiki/index.html b/examples/wiki/index.html index aa4519299e..8d8ff3fb68 100644 --- a/examples/wiki/index.html +++ b/examples/wiki/index.html @@ -5,7 +5,7 @@ Realtime wiki syntax parsing - + diff --git a/examples/wiki/main.ml b/examples/wiki/main.ml index d7f8ea48c2..c9359e5705 100644 --- a/examples/wiki/main.ml +++ b/examples/wiki/main.ml @@ -27,7 +27,7 @@ let replace_child p n = Js.Opt.iter p##.firstChild (fun c -> Dom.removeChild p c); Dom.appendChild p n -let onload _ = +let () = let d = Html.document in let body = Js.Opt.get (d##getElementById (Js.string "wiki_demo")) (fun () -> assert false) @@ -56,7 +56,4 @@ let onload _ = in Lwt_js.sleep (if n = 0 then 0.5 else 0.1) >>= fun () -> dyn_preview text n in - ignore (dyn_preview "" 0); - Js._false - -let _ = Html.window##.onload := Html.handler onload + ignore (dyn_preview "" 0) diff --git a/examples/wysiwyg/dune b/examples/wysiwyg/dune index 45c74c83cd..ef6b073cbe 100644 --- a/examples/wysiwyg/dune +++ b/examples/wysiwyg/dune @@ -1,15 +1,16 @@ (executables (names main) (libraries js_of_ocaml-lwt) - (modes byte) + (modes js wasm) (preprocess (pps js_of_ocaml-ppx))) (rule - (targets main.js) (action - (run %{bin:js_of_ocaml} --source-map %{dep:main.bc} -o %{targets} --pretty))) + (copy main.bc.wasm.js main.bc.js)) + (enabled_if + (not %{env:js-enabled=}))) (alias (name default) - (deps main.js index.html)) + (deps main.bc.js index.html)) diff --git a/examples/wysiwyg/index.html b/examples/wysiwyg/index.html index 57a2a92390..1631d03c66 100644 --- a/examples/wysiwyg/index.html +++ b/examples/wysiwyg/index.html @@ -5,7 +5,7 @@ Kakadu's WYSIWYG wiki editor - + diff --git a/examples/wysiwyg/main.ml b/examples/wysiwyg/main.ml index 43341cecdf..d28b5f5863 100644 --- a/examples/wysiwyg/main.ml +++ b/examples/wysiwyg/main.ml @@ -102,7 +102,7 @@ let rec html2wiki body = done; Buffer.contents ans -let onload _ = +let () = let d = Html.document in let body = Js.Opt.get (d##getElementById (Js.string "wiki_demo")) (fun () -> assert false) @@ -212,7 +212,4 @@ let onload _ = in Lwt_js.sleep (if n = 0 then 0.5 else 0.1) >>= fun () -> dyn_preview text n in - ignore (dyn_preview "" 0)); - Js._false - -let _ = Html.window##.onload := Html.handler onload + ignore (dyn_preview "" 0)) diff --git a/lib/deriving_json/tests/dune b/lib/deriving_json/tests/dune index 8834c59137..c1e0147b3d 100644 --- a/lib/deriving_json/tests/dune +++ b/lib/deriving_json/tests/dune @@ -2,6 +2,6 @@ (name deriving_expect_tests) (libraries unix js_of_ocaml js_of_ocaml.deriving) (inline_tests - (modes js)) + (modes js wasm)) (preprocess (pps ppx_expect ppx_deriving_json))) diff --git a/lib/deriving_json/tests/json_convert.ml b/lib/deriving_json/tests/json_convert.ml index 0e5bbd3b1c..45e0640b10 100644 --- a/lib/deriving_json/tests/json_convert.ml +++ b/lib/deriving_json/tests/json_convert.ml @@ -33,12 +33,17 @@ let str = type t = int list * float option * string [@@deriving json] +let wasm = + match Sys.backend_type with + | Other "wasm_of_ocaml" -> true + | _ -> false + let test t v = - if v = Json.unsafe_input (Json.output v) then () else print_endline "Not equal"; - if v = Deriving_Json.from_string t (Js.to_string (Json.output v)) + if wasm || v = Json.unsafe_input (Json.output v) then () else print_endline "Not equal"; + if wasm || v = Deriving_Json.from_string t (Js.to_string (Json.output v)) then () else print_endline "Not equal"; - if v = Json.unsafe_input (Js.string (Deriving_Json.to_string t v)) + if wasm || v = Json.unsafe_input (Js.string (Deriving_Json.to_string t v)) then () else print_endline "Not equal"; if v = Deriving_Json.from_string t (Deriving_Json.to_string t v) diff --git a/lib/js_of_ocaml/js.ml b/lib/js_of_ocaml/js.ml index 252b51088a..9caa734de4 100644 --- a/lib/js_of_ocaml/js.ml +++ b/lib/js_of_ocaml/js.ml @@ -246,8 +246,6 @@ module Js = struct type string_array - type number_t = float - class type number = object method toString : js_string t meth @@ -271,7 +269,7 @@ module Js = struct method charAt : int -> js_string t meth - method charCodeAt : int -> number_t meth + method charCodeAt : int -> number t meth (* This may return NaN... *) method concat : js_string t -> js_string t meth @@ -291,7 +289,7 @@ module Js = struct method lastIndexOf_from : js_string t -> int -> int meth - method localeCompare : js_string t -> number_t meth + method localeCompare : js_string t -> number t meth method _match : regExp t -> match_result_handle t opt meth @@ -354,6 +352,8 @@ module Js = struct and normalization = js_string + type number_t = number t + (* string is used by ppx_js, it needs to come before any use of the new syntax in this file *) external string : string -> js_string t = "caml_jsstring_of_string" diff --git a/lib/js_of_ocaml/js.mli b/lib/js_of_ocaml/js.mli index 47013b7c95..cdaf7ad8f4 100644 --- a/lib/js_of_ocaml/js.mli +++ b/lib/js_of_ocaml/js.mli @@ -219,8 +219,6 @@ val nfkc : normalization t (** Specification of Javascript number objects. *) -type number_t = float - class type number = object method toString : js_string t meth @@ -245,7 +243,7 @@ and js_string = object method charAt : int -> js_string t meth - method charCodeAt : int -> number_t meth + method charCodeAt : int -> number t meth (* This may return NaN... *) method concat : js_string t -> js_string t meth @@ -265,7 +263,7 @@ and js_string = object method lastIndexOf_from : js_string t -> int -> int meth - method localeCompare : js_string t -> number_t meth + method localeCompare : js_string t -> number t meth method _match : regExp t -> match_result_handle t opt meth @@ -328,6 +326,8 @@ and regExp = object method lastIndex : int prop end +type number_t = number t + (** Specification of the string constructor, considered as an object. *) class type string_constr = object method fromCharCode : int -> js_string t meth diff --git a/lib/tests/dune.inc b/lib/tests/dune.inc index 57c773ffc3..b7f107eb24 100644 --- a/lib/tests/dune.inc +++ b/lib/tests/dune.inc @@ -5,7 +5,7 @@ (enabled_if true) (modules test_css_angle) (libraries js_of_ocaml unix) - (inline_tests (modes js)) + (inline_tests (modes js wasm)) (preprocess (pps ppx_js_internal ppx_expect))) @@ -15,7 +15,7 @@ (enabled_if true) (modules test_css_color) (libraries js_of_ocaml unix) - (inline_tests (modes js)) + (inline_tests (modes js wasm)) (preprocess (pps ppx_js_internal ppx_expect))) @@ -25,7 +25,7 @@ (enabled_if true) (modules test_css_length) (libraries js_of_ocaml unix) - (inline_tests (modes js)) + (inline_tests (modes js wasm)) (preprocess (pps ppx_js_internal ppx_expect))) @@ -39,6 +39,16 @@ (preprocess (pps ppx_js_internal ppx_expect))) +(library + ;; lib/tests/test_fun_call_2.ml + (name test_fun_call_2_75) + (enabled_if true) + (modules test_fun_call_2) + (libraries js_of_ocaml unix) + (inline_tests (modes js wasm)) + (preprocess + (pps ppx_js_internal ppx_expect))) + (library ;; lib/tests/test_json.ml (name test_json_75) @@ -55,7 +65,7 @@ (enabled_if true) (modules test_nodejs_filesystem_errors) (libraries js_of_ocaml unix) - (inline_tests (modes js)) + (inline_tests (modes js wasm)) (preprocess (pps ppx_js_internal ppx_expect))) @@ -69,13 +79,23 @@ (preprocess (pps ppx_js_internal ppx_expect))) +(library + ;; lib/tests/test_poly_equal.ml + (name test_poly_equal_75) + (enabled_if true) + (modules test_poly_equal) + (libraries js_of_ocaml unix) + (inline_tests (modes js wasm)) + (preprocess + (pps ppx_js_internal ppx_expect))) + (library ;; lib/tests/test_regexp.ml (name test_regexp_75) (enabled_if true) (modules test_regexp) (libraries js_of_ocaml unix) - (inline_tests (modes js)) + (inline_tests (modes js wasm)) (preprocess (pps ppx_js_internal ppx_expect))) @@ -95,7 +115,7 @@ (enabled_if true) (modules test_typed_array) (libraries js_of_ocaml unix) - (inline_tests (modes js)) + (inline_tests (modes js wasm)) (preprocess (pps ppx_js_internal ppx_expect))) @@ -105,7 +125,7 @@ (enabled_if true) (modules test_unsafe_set_get) (libraries js_of_ocaml unix) - (inline_tests (modes js)) + (inline_tests (modes js wasm)) (preprocess (pps ppx_js_internal ppx_expect))) @@ -115,6 +135,6 @@ (enabled_if true) (modules test_url) (libraries js_of_ocaml unix) - (inline_tests (modes js)) + (inline_tests (modes js wasm)) (preprocess (pps ppx_js_internal ppx_expect))) diff --git a/lib/tests/gen-rules/gen.ml b/lib/tests/gen-rules/gen.ml index f29ac95feb..56eb329f6f 100644 --- a/lib/tests/gen-rules/gen.ml +++ b/lib/tests/gen-rules/gen.ml @@ -48,12 +48,14 @@ let prefix : string = type enabled_if = | GE5 - | No_effects + | Not_wasm + | No_effects_not_wasm | Any let enabled_if = function | "test_sys" -> GE5 - | "test_fun_call" -> No_effects + | "test_fun_call" -> No_effects_not_wasm + | "test_json" | "test_poly_compare" -> Not_wasm | _ -> Any let () = @@ -70,7 +72,7 @@ let () = (enabled_if %s) (modules %s) (libraries js_of_ocaml unix) - (inline_tests (modes js)) + (inline_tests (modes js%s)) (preprocess (pps ppx_js_internal ppx_expect))) |} @@ -79,7 +81,11 @@ let () = basename (Hashtbl.hash prefix mod 100) (match enabled_if basename with - | Any -> "true" + | Any | Not_wasm -> "true" | GE5 -> "(>= %{ocaml_version} 5)" - | No_effects -> "(<> %{profile} using-effects)") - basename) + | No_effects_not_wasm -> "(<> %{profile} using-effects)") + basename + (match enabled_if basename with + | Any -> " wasm" + | GE5 -> "" (* ZZZ /static not yet implemented *) + | Not_wasm | No_effects_not_wasm -> "")) diff --git a/lib/tests/test_fun_call_2.ml b/lib/tests/test_fun_call_2.ml new file mode 100644 index 0000000000..00a48af3b9 --- /dev/null +++ b/lib/tests/test_fun_call_2.ml @@ -0,0 +1,420 @@ +(* Js_of_ocaml tests + * 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 + +let s x = + let to_string = + Js.Unsafe.eval_string + {| +(function(x){ + if(x === null) + return "null" + if(x === undefined) + return "undefined" + if (!(typeof x == 'function') && x.toString) return x.toString(); + return "other" +}) +|} + in + Js.to_string (Js.Unsafe.fun_call to_string [| Js.Unsafe.inject x |]) + +let call_and_log f ?(cont = (Obj.magic Fun.id : _ -> _)) str = + let call = Js.Unsafe.eval_string str in + let r = Js.Unsafe.fun_call call [| Js.Unsafe.inject f |] in + Printf.printf "Result: %s" (s (cont r)) + +let cb1 a = Printf.printf "got %s, done\n" (s a) + +let cb2 a b = Printf.printf "got %s, %s, done\n" (s a) (s b) + +let cb3 a b c = Printf.printf "got %s, %s, %s, done\n" (s a) (s b) (s c) + +let cb4 a b c d = Printf.printf "got %s, %s, %s, %s, done\n" (s a) (s b) (s c) (s d) + +let cb5 a b c d e = + Printf.printf "got %s, %s, %s, %s, %s, done\n" (s a) (s b) (s c) (s d) (s e) + +(* Wrap callback *) + +let%expect_test "over application, extra arguments are dropped" = + call_and_log (Js.wrap_callback cb3) {| (function(f){ return f(1,2,3,4) }) |}; + [%expect {| + got 1, 2, 3, done + Result: 0 |}] + +let%expect_test "over application, extra arguments are dropped" = + call_and_log (Js.wrap_callback cb3) {| (function(f){ return f(1,2)(3,4) }) |}; + [%expect {| + got 1, 2, 3, done + Result: 0 |}] + +let%expect_test "partial application 1 + 2" = + call_and_log (Js.wrap_callback cb3) {| (function(f){ return f(1)(2,3) }) |}; + [%expect {| + got 1, 2, 3, done + Result: 0 |}] + +let%expect_test "partial application 2 + 1" = + call_and_log (Js.wrap_callback cb3) {| (function(f){ return f(1,2)(3) }) |}; + [%expect {| + got 1, 2, 3, done + Result: 0 |}] + +let%expect_test "partial application, callback is called when all arguments are available" + = + call_and_log (Js.wrap_callback cb5) {| (function(f){ return f(1)(2)(3)(4)(5) }) |}; + [%expect {| + got 1, 2, 3, 4, 5, done + Result: 0 |}] + +let%expect_test + "partial application, 0 argument call is treated like 1 argument (undefined)" = + call_and_log (Js.wrap_callback cb5) {| (function(f){ return f(1)()(3)()(5) }) |}; + [%expect {| + got 1, undefined, 3, undefined, 5, done + Result: 0 |}] + +let%expect_test _ = + let plus = Js.wrap_callback (fun a b -> a + b) in + call_and_log plus {| (function(f){ return f(1) }) |}; + [%expect {| Result: other |}]; + call_and_log plus {| (function(f){ return f(1)(2) }) |}; + [%expect {| Result: 3 |}]; + call_and_log plus {| (function(f){ return f(1,2) }) |}; + [%expect {| Result: 3 |}]; + call_and_log plus {| (function(f){ return f(1,2,3) }) |}; + [%expect {| Result: 3 |}] + +(* Wrap callback with argument *) + +let%expect_test "wrap_callback_arguments" = + call_and_log + (Js.Unsafe.callback_with_arguments (Obj.magic cb1)) + {| (function(f){ return f(1,2,3,4,5) }) |}; + [%expect {| + got 1,2,3,4,5, done + Result: 0 |}] + +let%expect_test "wrap_callback_arguments" = + call_and_log + (Js.Unsafe.callback_with_arguments (Obj.magic cb1)) + {| (function(f){ return f() }) |}; + [%expect {| + got , done + Result: 0 |}] + +(* Wrap with arity *) + +let%expect_test "wrap_callback_strict" = + call_and_log + (Js.Unsafe.callback_with_arity 3 cb3) + {| (function(f){ return f(1,2,3) }) |}; + [%expect {| + got 1, 2, 3, done + Result: 0 |}]; + call_and_log + (Js.Unsafe.callback_with_arity 3 cb3) + {| (function(f){ return f(1,2,3,4) }) |}; + [%expect {| + got 1, 2, 3, done + Result: 0 |}]; + call_and_log (Js.Unsafe.callback_with_arity 3 cb3) {| (function(f){ return f(1,2) }) |}; + [%expect {| + got 1, 2, undefined, done + Result: 0 |}] + +let%expect_test "wrap_callback_strict" = + call_and_log + (Js.Unsafe.callback_with_arity 2 cb3) + {| (function(f){ return f(1,2,3) }) |}; + [%expect {| + Result: other |}]; + call_and_log + (Js.Unsafe.callback_with_arity 2 cb3) + ~cont:(fun g -> g 4) + {| (function(f){ return f(1,2,3) }) |}; + [%expect {| + got 1, 2, 4, done + Result: 0 |}]; + call_and_log + (Js.Unsafe.callback_with_arity 2 cb3) + ~cont:(fun g -> g 3) + {| (function(f){ return f(1,2) }) |}; + [%expect {| + got 1, 2, 3, done + Result: 0 |}]; + call_and_log (Js.Unsafe.callback_with_arity 2 cb3) {| (function(f){ return f(1,2) }) |}; + [%expect {| + Result: other |}] + +let%expect_test "wrap_callback_strict" = + call_and_log + (Js.Unsafe.callback_with_arity 4 cb3) + {| (function(f){ return f(1,2,3) }) |}; + [%expect {| + got 1, 2, 3, done + Result: 0 |}]; + call_and_log + (Js.Unsafe.callback_with_arity 4 cb3) + {| (function(f){ return f(1,2,3,4) }) |}; + [%expect {| + got 1, 2, 3, done + Result: 0 |}]; + call_and_log (Js.Unsafe.callback_with_arity 4 cb3) {| (function(f){ return f(1,2) }) |}; + [%expect {| + got 1, 2, undefined, done + Result: 0 |}] + +(* Wrap meth callback *) + +let%expect_test "over application, extra arguments are dropped" = + call_and_log + (Js.wrap_meth_callback cb4) + {| (function(f){ return f.apply("this",[1,2,3,4]) }) |}; + [%expect {| + got this, 1, 2, 3, done + Result: 0 |}] + +let%expect_test "over application, extra arguments are dropped" = + call_and_log + (Js.wrap_meth_callback cb4) + {| (function(f){ return f.apply("this",[1,2])(3,4) }) |}; + [%expect {| + got this, 1, 2, 3, done + Result: 0 |}] + +let%expect_test "partial application 1 + 2" = + call_and_log + (Js.wrap_meth_callback cb4) + {| (function(f){ return f.apply("this", [1])(2,3) }) |}; + [%expect {| + got this, 1, 2, 3, done + Result: 0 |}] + +let%expect_test "partial application 2 + 1" = + call_and_log + (Js.wrap_meth_callback cb4) + {| (function(f){ return f.apply("this",[1,2])(3) }) |}; + [%expect {| + got this, 1, 2, 3, done + Result: 0 |}] + +let%expect_test "partial application, callback is called when all arguments are available" + = + call_and_log + (Js.wrap_meth_callback cb5) + {| (function(f){ return f.apply("this",[])(1)(2)(3)(4) }) |}; + [%expect {| + got this, 1, 2, 3, 4, done + Result: 0 |}] + +let%expect_test "partial application, 0 argument call is treated 1 argument (undefined)" = + call_and_log + (Js.wrap_meth_callback cb5) + {| (function(f){ return f.apply("this",[])(1)()(3)() }) |}; + [%expect {| + got this, 1, undefined, 3, undefined, done + Result: 0 |}] + +let%expect_test _ = + let plus = Js.wrap_meth_callback (fun _ a b -> a + b) in + call_and_log plus {| (function(f){ return f(1) }) |}; + [%expect {| Result: other |}]; + call_and_log plus {| (function(f){ return f(1)(2) }) |}; + [%expect {| Result: 3 |}]; + call_and_log plus {| (function(f){ return f(1,2) }) |}; + [%expect {| Result: 3 |}]; + call_and_log plus {| (function(f){ return f(1,2,3) }) |}; + [%expect {| Result: 3 |}] + +(* Wrap callback with argument *) + +let%expect_test "wrap_meth_callback_arguments" = + call_and_log + (Js.Unsafe.meth_callback_with_arguments (Obj.magic cb2)) + {| (function(f){ return f.apply("this",[1,2,3,4,5]) }) |}; + [%expect {| + got this, 1,2,3,4,5, done + Result: 0 |}] + +let%expect_test "wrap_meth_callback_arguments" = + call_and_log + (Js.Unsafe.meth_callback_with_arguments (Obj.magic cb2)) + {| (function(f){ return f.apply("this", []) }) |}; + [%expect {| + got this, , done + Result: 0 |}] + +(* Wrap with arity *) + +let%expect_test "wrap_meth_callback_strict" = + call_and_log + (Js.Unsafe.meth_callback_with_arity 3 cb4) + {| (function(f){ return f.apply("this",[1,2,3]) }) |}; + [%expect {| + got this, 1, 2, 3, done + Result: 0 |}]; + call_and_log + (Js.Unsafe.meth_callback_with_arity 3 cb4) + {| (function(f){ return f.apply("this",[1,2,3,4]) }) |}; + [%expect {| + got this, 1, 2, 3, done + Result: 0 |}]; + call_and_log + (Js.Unsafe.meth_callback_with_arity 3 cb4) + {| (function(f){ return f.apply("this",[1,2]) }) |}; + [%expect {| + got this, 1, 2, undefined, done + Result: 0 |}] + +let%expect_test "wrap_meth_callback_strict" = + call_and_log + (Js.Unsafe.meth_callback_with_arity 2 cb4) + {| (function(f){ return f.apply("this",[1,2,3]) }) |}; + [%expect {| + Result: other |}]; + call_and_log + (Js.Unsafe.meth_callback_with_arity 2 cb4) + ~cont:(fun g -> g 4) + {| (function(f){ return f.apply("this",[1,2,3]) }) |}; + [%expect {| + got this, 1, 2, 4, done + Result: 0 |}]; + call_and_log + (Js.Unsafe.meth_callback_with_arity 2 cb4) + ~cont:(fun g -> g 3) + {| (function(f){ return f.apply("this",[1,2]) }) |}; + [%expect {| + got this, 1, 2, 3, done + Result: 0 |}]; + call_and_log + (Js.Unsafe.meth_callback_with_arity 2 cb4) + {| (function(f){ return f.apply("this",[1,2]) }) |}; + [%expect {| Result: other |}] + +let%expect_test "wrap_meth_callback_strict" = + call_and_log + (Js.Unsafe.meth_callback_with_arity 4 cb4) + {| (function(f){ return f.apply("this",[1,2,3]) }) |}; + [%expect {| + got this, 1, 2, 3, done + Result: 0 |}]; + call_and_log + (Js.Unsafe.meth_callback_with_arity 4 cb4) + {| (function(f){ return f.apply("this",[1,2,3,4]) }) |}; + (* Should not return a function *) + [%expect {| + got this, 1, 2, 3, done + Result: 0 |}]; + call_and_log + (Js.Unsafe.meth_callback_with_arity 4 cb4) + {| (function(f){ return f.apply("this",[1,2]) }) |}; + [%expect {| + got this, 1, 2, undefined, done + Result: 0 |}] + +(* Wrap meth callback unsafe *) +let%expect_test "over application, extra arguments are dropped" = + call_and_log + (Js.Unsafe.meth_callback cb4) + {| (function(f){ return f.apply("this",[1,2,3,4]) }) |}; + [%expect {| + got this, 1, 2, 3, done + Result: 0 |}] + +let%expect_test "partial application, extra arguments set to undefined" = + call_and_log + (Js.Unsafe.meth_callback cb4) + {| (function(f){ return f.apply("this",[1,2]) }) |}; + [%expect {| + got this, 1, 2, undefined, done + Result: 0 |}] + +(* caml_call_gen *) + +let%expect_test _ = + call_and_log cb3 ~cont:(fun g -> g 1) {| (function(f){ return f }) |}; + [%expect {| + Result: other |}] + +(* +let%expect_test _ = + call_and_log cb3 ~cont:(fun g -> g 1 2 3 4) {| (function(f){ return f }) |}; + [%expect {| + got 1, 2, 3, done + Result: 0 |}] +*) + +let%expect_test _ = + let f cb = + try call_and_log (cb 1) ~cont:(fun g -> g 1 2 3) {| (function(f){ return f }) |} with + | Invalid_argument s | Failure s -> Printf.printf "Error: %s" s + | _ -> Printf.printf "Error: unknown" + in + f cb5; + [%expect {| Result: other |}]; + f cb4; + [%expect {| + got 1, 1, 2, 3, done + Result: 0 |}]; + () +(* f cb3; + [%expect {| + got 1, 1, 2, done + Result: 0 |}] +*) + +let%expect_test _ = + let f cb = + try call_and_log (cb 1 2 3) {| (function(f){ return f }) |} with + | Invalid_argument s | Failure s -> Printf.printf "Error: %s" s + | _ -> Printf.printf "Error: unknown" + in + (* + f (Obj.magic cb1); + [%expect {| + got 1, done + Result: 0 |}]; + f (Obj.magic cb2); + [%expect {| + got 1, 2, done + Result: 0 |}]; +*) + f (Obj.magic cb3); + [%expect {| + got 1, 2, 3, done + Result: 0 |}]; + f (Obj.magic cb4); + [%expect {| + Result: other |}]; + f (Obj.magic cb5); + [%expect {| + Result: other |}] + +let%expect_test _ = + let open Js_of_ocaml in + let f = Js.wrap_callback (fun s -> print_endline (Js.to_string s)) in + Js.export "f" f; + let () = + Js.Unsafe.fun_call + (Js.Unsafe.pure_js_expr "jsoo_exports")##.f + [| Js.Unsafe.coerce (Js.string "hello") |] + in + (); + [%expect {| hello |}] diff --git a/lib/tests/test_poly_equal.ml b/lib/tests/test_poly_equal.ml new file mode 100644 index 0000000000..0f6cf095ea --- /dev/null +++ b/lib/tests/test_poly_equal.ml @@ -0,0 +1,66 @@ +(* Js_of_ocaml tests + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU General Public License as published by + * the Free Software Foundation; either version 2 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 + +let%expect_test "poly equal" = + let obj1 = Js.Unsafe.obj [||] in + let obj2 = Js.Unsafe.obj [||] in + assert (obj1 = obj2); + assert (not (obj1 = obj2)); + () +[@@expect.uncaught_exn {| "Assert_failure lib/tests/test_poly_equal.ml:24:2" |}] + +let%expect_test "poly equal neg" = + let obj1 = Js.Unsafe.obj [||] in + let obj2 = Js.Unsafe.obj [||] in + assert (obj1 <> obj2); + assert (not (obj1 <> obj1)); + () + +type pack = Pack : 'a -> pack + +let%expect_test "number comparison" = + assert (Pack 2 = Pack 2); + assert (Pack 2 <> Pack 2.1); + assert (Pack (Js.float 2.1) = Pack (Js.float 2.1)); + assert (Pack (Js.Unsafe.js_expr "Number(2.1)") <> Pack 2.); + assert (Pack (Js.Unsafe.js_expr "new Number(2.1)") <> Pack 2.); + assert (Pack (Js.Unsafe.js_expr "Number(2.1)") = Pack (Js.Unsafe.js_expr "Number(2.1)")) + +let%expect_test "string comparison" = + assert (Pack (Js.Unsafe.js_expr "String(2)") = Pack (Js.string "2")); + assert (Pack (Js.Unsafe.js_expr "String('abc')") = Pack (Js.string "abc")); + assert (Pack (Js.Unsafe.js_expr "new String('abcሴ')") = Pack (Js.string "abcሴ")); + assert (Pack (Js.Unsafe.js_expr "String(1)") <> Pack (Js.string "2")); + assert (Pack (Js.Unsafe.js_expr "String('abcd')") <> Pack (Js.string "abc")); + assert (Pack (Js.Unsafe.js_expr "new String('abcd')") <> Pack (Js.string "abc")); + assert ( + Pack (Js.Unsafe.js_expr "String('abcd')") = Pack (Js.Unsafe.js_expr "String('abcd')")) + +let%expect_test "symbol comparison" = + let s1 = Pack (Js.Unsafe.js_expr "Symbol('2')") in + let s2 = Pack (Js.Unsafe.js_expr "Symbol('2')") in + assert (s1 <> s2); + assert (s1 = s1) + +let%expect_test "object comparison" = + let s1 = Pack (Js.Unsafe.js_expr "{}") in + let s2 = Pack (Js.Unsafe.js_expr "{}") in + assert (s1 <> s2); + assert (s1 = s1) diff --git a/ppx/ppx_deriving_json/tests/dune b/ppx/ppx_deriving_json/tests/dune index d2607ddee2..2e9ac54928 100644 --- a/ppx/ppx_deriving_json/tests/dune +++ b/ppx/ppx_deriving_json/tests/dune @@ -27,7 +27,9 @@ (rule (alias runtest) (enabled_if - (>= %{ocaml_version} 5.1)) + (and + (>= %{ocaml_version} 5.1) + %{env:js-enabled=})) ;; (package js_of_ocaml-ppx) (action (diff ppx.mlt ppx.mlt.corrected))) @@ -35,7 +37,9 @@ (rule (alias runtest) (enabled_if - (>= %{ocaml_version} 5.1)) + (and + (>= %{ocaml_version} 5.1) + %{env:js-enabled=})) ;; (package js_of_ocaml-ppx) (action (diff gen.mlt gen.mlt.corrected))) diff --git a/ppx/ppx_js/tests/dune b/ppx/ppx_js/tests/dune index 6cc1f54563..2820801e71 100644 --- a/ppx/ppx_js/tests/dune +++ b/ppx/ppx_js/tests/dune @@ -7,7 +7,9 @@ (rule (targets ppx.mlt.corrected) (enabled_if - (>= %{ocaml_version} 5.2)) + (and + (>= %{ocaml_version} 5.2) + (< %{ocaml_version} 5.3))) (action (run %{exe:main.bc} %{dep:ppx.mlt}))) @@ -15,6 +17,8 @@ (alias runtest) (package js_of_ocaml-ppx) (enabled_if - (>= %{ocaml_version} 5.2)) + (and + (>= %{ocaml_version} 5.2) + (< %{ocaml_version} 5.3))) (action (diff ppx.mlt ppx.mlt.corrected))) diff --git a/runtime/wasm/args.ml b/runtime/wasm/args.ml new file mode 100644 index 0000000000..16cd0418a5 --- /dev/null +++ b/runtime/wasm/args.ml @@ -0,0 +1,4 @@ +let () = + for i = 1 to Array.length Sys.argv - 1 do + Format.printf "%s@.%s@." Sys.argv.(i) (Filename.chop_suffix Sys.argv.(i) ".wat") + done diff --git a/runtime/wasm/array.wat b/runtime/wasm/array.wat new file mode 100644 index 0000000000..00d01e8082 --- /dev/null +++ b/runtime/wasm/array.wat @@ -0,0 +1,407 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $float (struct (field f64))) + (type $float_array (array (mut f64))) + + (data $Array_make "Array.make") + + (global $empty_array (ref eq) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (func $caml_make_vect (export "caml_make_vect") (export "caml_array_make") + (param $n (ref eq)) (param $v (ref eq)) (result (ref eq)) + (local $sz i32) (local $b (ref $block)) (local $f f64) + (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n)))) + (if (i32.lt_s (local.get $sz) (i32.const 0)) + (then + (call $caml_invalid_argument + (array.new_data $string $Array_make + (i32.const 0) (i32.const 10))))) + (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array)))) + (drop (block $not_float (result (ref eq)) + (local.set $f + (struct.get $float 0 + (br_on_cast_fail $not_float (ref eq) (ref $float) + (local.get $v)))) + (return (array.new $float_array (local.get $f) (local.get $sz))))) + (local.set $b + (array.new $block (local.get $v) + (i32.add (local.get $sz) (i32.const 1)))) + (array.set $block (local.get $b) (i32.const 0) (ref.i31 (i32.const 0))) + (local.get $b)) + + (func (export "caml_floatarray_make") + (param $n (ref eq)) (param $v (ref eq)) (result (ref eq)) + (local $sz i32) (local $f f64) + (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n)))) + (if (i32.lt_s (local.get $sz) (i32.const 0)) + (then + (call $caml_invalid_argument + (array.new_data $string $Array_make + (i32.const 0) (i32.const 10))))) + (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array)))) + (local.set $f + (struct.get $float 0 + (ref.cast (ref $float) (local.get $v)))) + (array.new $float_array (local.get $f) (local.get $sz))) + + (func $caml_floatarray_create + (export "caml_make_float_vect") (export "caml_floatarray_create") + (export "caml_array_create_float") + (param $n (ref eq)) (result (ref eq)) + (local $sz i32) + (local.set $sz (i31.get_s (ref.cast (ref i31) (local.get $n)))) + (if (i32.lt_s (local.get $sz) (i32.const 0)) + (then + (call $caml_invalid_argument + (array.new_data $string $Array_make + (i32.const 0) (i32.const 10))))) + (if (i32.eqz (local.get $sz)) (then (return (global.get $empty_array)))) + (array.new $float_array (f64.const 0) (local.get $sz))) + + (func (export "caml_array_of_uniform_array") + (param $vinit (ref eq)) (result (ref eq)) + (local $init (ref $block)) (local $res (ref $float_array)) + (local $size i32) (local $i i32) + (local.set $init (ref.cast (ref $block) (local.get $vinit))) + (local.set $size (array.len (local.get $init))) + (if (i32.ne (local.get $size) (i32.const 1)) + (then + (if (ref.test (ref $float) + (array.get $block (local.get $init) (i32.const 1))) + (then + (local.set $size (i32.sub (local.get $size) (i32.const 1))) + (local.set $res + (array.new $float_array (f64.const 0) (local.get $size))) + (loop $loop + (array.set $float_array (local.get $res) (local.get $i) + (struct.get $float 0 + (ref.cast (ref $float) + (array.get $block (local.get $init) + (i32.add (local.get $i) (i32.const 1)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (local.get $size)))) + (return (local.get $res)))))) + (return (local.get $init))) + + (func (export "caml_floatarray_unsafe_get") + (param $a (ref eq)) (param $i (ref eq)) (result (ref eq)) + (struct.new $float + (array.get $float_array (ref.cast (ref $float_array) (local.get $a)) + (i31.get_s (ref.cast (ref i31) (local.get $i)))))) + + (func (export "caml_floatarray_unsafe_set") + (param $a (ref eq)) (param $i (ref eq)) (param $v (ref eq)) + (result (ref eq)) + (array.set $float_array (ref.cast (ref $float_array) (local.get $a)) + (i31.get_s (ref.cast (ref i31) (local.get $i))) + (struct.get $float 0 (ref.cast (ref $float) (local.get $v)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_array_sub") + (param $a (ref eq)) (param $i (ref eq)) (param $vlen (ref eq)) + (result (ref eq)) + (local $a1 (ref $block)) (local $a2 (ref $block)) (local $len i32) + (local $fa1 (ref $float_array)) (local $fa2 (ref $float_array)) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (if (i32.eqz (local.get $len)) (then (return (global.get $empty_array)))) + (drop (block $not_block (result (ref eq)) + (local.set $a1 + (br_on_cast_fail $not_block (ref eq) (ref $block) (local.get $a))) + (local.set $a2 (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $len) (i32.const 1)))) + (array.set $block (local.get $a2) (i32.const 0) + (array.get $block (local.get $a1) (i32.const 0))) + (array.copy $block $block + (local.get $a2) (i32.const 1) (local.get $a1) + (i32.add (i31.get_u (ref.cast (ref i31) (local.get $i))) + (i32.const 1)) + (local.get $len)) + (return (local.get $a2)))) + (local.set $fa1 (ref.cast (ref $float_array) (local.get $a))) + (local.set $fa2 (array.new $float_array (f64.const 0) (local.get $len))) + (array.copy $float_array $float_array + (local.get $fa2) (i32.const 0) (local.get $fa1) + (i31.get_u (ref.cast (ref i31) (local.get $i))) + (local.get $len)) + (local.get $fa2)) + + (func (export "caml_floatarray_sub") + (param $a (ref eq)) (param $i (ref eq)) (param $vlen (ref eq)) + (result (ref eq)) + (local $len i32) + (local $fa1 (ref $float_array)) (local $fa2 (ref $float_array)) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (if (i32.eqz (local.get $len)) (then (return (global.get $empty_array)))) + (local.set $fa1 (ref.cast (ref $float_array) (local.get $a))) + (local.set $fa2 (array.new $float_array (f64.const 0) (local.get $len))) + (array.copy $float_array $float_array + (local.get $fa2) (i32.const 0) (local.get $fa1) + (i31.get_u (ref.cast (ref i31) (local.get $i))) + (local.get $len)) + (local.get $fa2)) + + (func $caml_floatarray_dup (param $a (ref $float_array)) (result (ref eq)) + (local $a' (ref $float_array)) + (local $len i32) + (local.set $len (array.len (local.get $a))) + (local.set $a' (array.new $float_array (f64.const 0) (local.get $len))) + (array.copy $float_array $float_array + (local.get $a') (i32.const 0) (local.get $a) (i32.const 0) + (local.get $len)) + (local.get $a')) + + (func (export "caml_array_append") + (param $va1 (ref eq)) (param $va2 (ref eq)) (result (ref eq)) + (local $a1 (ref $block)) (local $a2 (ref $block)) (local $a (ref $block)) + (local $fa1 (ref $float_array)) (local $fa2 (ref $float_array)) + (local $fa (ref $float_array)) + (local $l1 i32) (local $l2 i32) + (drop (block $a1_not_block (result (ref eq)) + (local.set $a1 + (br_on_cast_fail $a1_not_block (ref eq) (ref $block) + (local.get $va1))) + (drop (block $a2_not_block (result (ref eq)) + (local.set $a2 + (br_on_cast_fail $a2_not_block (ref eq) (ref $block) + (local.get $va2))) + (local.set $l1 (array.len (local.get $a1))) + (local.set $l2 (array.len (local.get $a2))) + (local.set $a + (array.new $block (ref.i31 (i32.const 0)) + (i32.sub (i32.add (local.get $l1) (local.get $l2)) + (i32.const 1)))) + (array.copy $block $block + (local.get $a) (i32.const 1) (local.get $a1) (i32.const 1) + (i32.sub (local.get $l1) (i32.const 1))) + (array.copy $block $block + (local.get $a) (local.get $l1) (local.get $a2) (i32.const 1) + (i32.sub (local.get $l2) (i32.const 1))) + (return (local.get $a)))) + (return_call $caml_floatarray_dup + (ref.cast (ref $float_array) (local.get $va2))))) + (local.set $fa1 (ref.cast (ref $float_array) (local.get $va1))) + (drop (block $a2_not_float_array (result (ref eq)) + (local.set $fa2 + (br_on_cast_fail $a2_not_float_array (ref eq) (ref $float_array) + (local.get $va2))) + (local.set $l1 (array.len (local.get $fa1))) + (local.set $l2 (array.len (local.get $fa2))) + (local.set $fa + (array.new $float_array (f64.const 0) + (i32.add (local.get $l1) (local.get $l2)))) + (array.copy $float_array $float_array + (local.get $fa) (i32.const 0) (local.get $fa1) (i32.const 0) + (local.get $l1)) + (array.copy $float_array $float_array + (local.get $fa) (local.get $l1) (local.get $fa2) (i32.const 0) + (local.get $l2)) + (return (local.get $fa)))) + (return_call $caml_floatarray_dup (local.get $fa1))) + + (func (export "caml_floatarray_append") + (param $va1 (ref eq)) (param $va2 (ref eq)) (result (ref eq)) + (local $fa1 (ref $float_array)) (local $fa2 (ref $float_array)) + (local $fa (ref $float_array)) + (local $l1 i32) (local $l2 i32) + (local.set $fa1 (ref.cast (ref $float_array) (local.get $va1))) + (drop (block $a2_not_float_array (result (ref eq)) + (local.set $fa2 + (br_on_cast_fail $a2_not_float_array (ref eq) (ref $float_array) + (local.get $va2))) + (local.set $l1 (array.len (local.get $fa1))) + (local.set $l2 (array.len (local.get $fa2))) + (local.set $fa + (array.new $float_array (f64.const 0) + (i32.add (local.get $l1) (local.get $l2)))) + (array.copy $float_array $float_array + (local.get $fa) (i32.const 0) (local.get $fa1) (i32.const 0) + (local.get $l1)) + (array.copy $float_array $float_array + (local.get $fa) (local.get $l1) (local.get $fa2) (i32.const 0) + (local.get $l2)) + (return (local.get $fa)))) + (return_call $caml_floatarray_dup (local.get $fa1))) + + (func (export "caml_array_concat") (param (ref eq)) (result (ref eq)) + (local $i i32) (local $len i32) + (local $l (ref eq)) (local $v (ref eq)) + (local $isfloat i32) + (local $b (ref $block)) + (local $a (ref $block)) (local $a' (ref $block)) + (local $fa (ref $float_array)) (local $fa' (ref $float_array)) + (local.set $l (local.get 0)) + (local.set $len (i32.const 0)) + (loop $compute_length + (drop (block $exit (result (ref eq)) + (local.set $b + (br_on_cast_fail $exit (ref eq) (ref $block) (local.get $l))) + (local.set $v (array.get $block (local.get $b) (i32.const 1))) + (block $continue + (drop (block $not_block (result (ref eq)) + (local.set $len + (i32.add (local.get $len) + (i32.sub + (array.len + (br_on_cast_fail $not_block (ref eq) (ref $block) + (local.get $v))) + (i32.const 1)))) + (br $continue))) + (local.set $len + (i32.add (local.get $len) + (array.len (ref.cast (ref $float_array) (local.get $v))))) + (local.set $isfloat (i32.const 1))) + (local.set $l (array.get $block (local.get $b) (i32.const 2))) + (br $compute_length)))) + (if (result (ref eq)) (local.get $isfloat) + (then + (local.set $fa + (array.new $float_array (f64.const 0) (local.get $len))) + (local.set $l (local.get 0)) + (local.set $i (i32.const 0)) + (loop $fill + (drop (block $exit (result (ref eq)) + (local.set $b + (br_on_cast_fail $exit (ref eq) (ref $block) + (local.get $l))) + (local.set $l (array.get $block (local.get $b) (i32.const 2))) + (drop (block $not_float (result (ref eq)) + (local.set $fa' + (br_on_cast_fail $not_float (ref eq) (ref $float_array) + (array.get $block (local.get $b) (i32.const 1)))) + (local.set $len (array.len (local.get $fa'))) + (array.copy $float_array $float_array + (local.get $fa) (local.get $i) + (local.get $fa') (i32.const 0) + (local.get $len)) + (local.set $i (i32.add (local.get $i) (local.get $len))) + (br $fill))) + (br $fill)))) + (local.get $fa)) + (else + (local.set $a + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $len) (i32.const 1)))) + (local.set $l (local.get 0)) + (local.set $i (i32.const 1)) + (loop $fill + (drop (block $exit (result (ref eq)) + (local.set $b + (br_on_cast_fail $exit (ref eq) (ref $block) + (local.get $l))) + (local.set $a' + (ref.cast (ref $block) + (array.get $block (local.get $b) (i32.const 1)))) + (local.set $len + (i32.sub (array.len (local.get $a')) (i32.const 1))) + (array.copy $block $block + (local.get $a) (local.get $i) + (local.get $a') (i32.const 1) + (local.get $len)) + (local.set $i (i32.add (local.get $i) (local.get $len))) + (local.set $l (array.get $block (local.get $b) (i32.const 2))) + (br $fill)))) + (local.get $a)))) + + (func $caml_floatarray_blit (export "caml_floatarray_blit") + (param $a1 (ref eq)) (param $i1 (ref eq)) + (param $a2 (ref eq)) (param $i2 (ref eq)) + (param $vlen (ref eq)) + (result (ref eq)) + (local $len i32) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (if (local.get $len) + (then + (array.copy $float_array $float_array + (ref.cast (ref $float_array) (local.get $a2)) + (i31.get_s (ref.cast (ref i31) (local.get $i2))) + (ref.cast (ref $float_array) (local.get $a1)) + (i31.get_s (ref.cast (ref i31) (local.get $i1))) + (local.get $len)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_array_blit") + (param $a1 (ref eq)) (param $i1 (ref eq)) + (param $a2 (ref eq)) (param $i2 (ref eq)) + (param $vlen (ref eq)) + (result (ref eq)) + (local $len i32) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (if (local.get $len) + (then + (if (ref.test (ref $float_array) (local.get $a1)) + (then + (return_call $caml_floatarray_blit + (local.get $a1) (local.get $i1) + (local.get $a2) (local.get $i2) (local.get $vlen))) + (else + (array.copy $block $block + (ref.cast (ref $block) (local.get $a2)) + (i32.add + (i31.get_s + (ref.cast (ref i31) (local.get $i2))) (i32.const 1)) + (ref.cast (ref $block) (local.get $a1)) + (i32.add + (i31.get_s + (ref.cast (ref i31) (local.get $i1))) (i32.const 1)) + (local.get $len)))))) + (ref.i31 (i32.const 0))) + + (func (export "caml_array_fill") + (param $a (ref eq)) (param $i (ref eq)) (param $vlen (ref eq)) + (param $v (ref eq)) (result (ref eq)) + (local $len i32) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (if $done (local.get $len) + (then + (drop (block $not_block (result (ref eq)) + (array.fill $block + (br_on_cast_fail $not_block (ref eq) (ref $block) + (local.get $a)) + (i32.add (i31.get_u (ref.cast (ref i31) (local.get $i))) + (i32.const 1)) + (local.get $v) + (local.get $len)) + (br $done))) + (array.fill $float_array + (ref.cast (ref $float_array) (local.get $a)) + (i31.get_u (ref.cast (ref i31) (local.get $i))) + (struct.get $float 0 (ref.cast (ref $float) (local.get $v))) + (local.get $len)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_floatarray_fill") + (param $a (ref eq)) (param $i (ref eq)) (param $vlen (ref eq)) + (param $v (ref eq)) (result (ref eq)) + (local $len i32) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (if (local.get $len) + (then + (array.fill $float_array + (ref.cast (ref $float_array) (local.get $a)) + (i31.get_u (ref.cast (ref i31) (local.get $i))) + (struct.get $float 0 (ref.cast (ref $float) (local.get $v))) + (local.get $len)))) + (ref.i31 (i32.const 0))) +) diff --git a/runtime/wasm/backtrace.wat b/runtime/wasm/backtrace.wat new file mode 100644 index 0000000000..ea4d0e46aa --- /dev/null +++ b/runtime/wasm/backtrace.wat @@ -0,0 +1,69 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + + (func (export "caml_get_exception_raw_backtrace") + (param (ref eq)) (result (ref eq)) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (func (export "caml_backtrace_status") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_convert_raw_backtrace") + (param (ref eq)) (result (ref eq)) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (func (export "caml_raw_backtrace_next_slot") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (data $raw_backtrace_slot_err + "Printexc.get_raw_backtrace_slot: index out of bounds") + + (func (export "caml_raw_backtrace_slot") + (param (ref eq) (ref eq)) (result (ref eq)) + (call $caml_invalid_argument + (array.new_data $string $raw_backtrace_slot_err + (i32.const 0) (i32.const 52))) + (ref.i31 (i32.const 0))) + + (func (export "caml_convert_raw_backtrace_slot") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_restore_raw_backtrace") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_get_current_callstack") + (param (ref eq)) (result (ref eq)) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (func (export "caml_ml_debug_info_status") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_record_backtrace") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) diff --git a/runtime/wasm/bigarray.wat b/runtime/wasm/bigarray.wat new file mode 100644 index 0000000000..812055eca7 --- /dev/null +++ b/runtime/wasm/bigarray.wat @@ -0,0 +1,2095 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "bindings" "ta_create" + (func $ta_create (param i32) (param i32) (result (ref extern)))) + (import "bindings" "ta_normalize" + (func $ta_normalize (param (ref extern)) (result (ref extern)))) + (import "bindings" "ta_kind" + (func $ta_kind (param (ref extern)) (result i32))) + (import "bindings" "ta_length" + (func $ta_length (param (ref extern)) (result i32))) + (import "bindings" "ta_get_f64" + (func $ta_get_f64 (param (ref extern)) (param i32) (result f64))) + (import "bindings" "ta_get_f32" + (func $ta_get_f32 (param (ref extern)) (param i32) (result f64))) + (import "bindings" "ta_get_i32" + (func $ta_get_i32 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_get_i16" + (func $ta_get_i16 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_get_ui16" + (func $ta_get_ui16 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_get_i8" + (func $ta_get_i8 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_get_ui8" + (func $ta_get_ui8 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_get32_ui8" + (func $ta_get32_ui8 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_get16_ui8" + (func $ta_get16_ui8 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_set_f64" + (func $ta_set_f64 (param (ref extern)) (param i32) (param f64))) + (import "bindings" "ta_set_f32" + (func $ta_set_f32 (param (ref extern)) (param i32) (param f64))) + (import "bindings" "ta_set_i32" + (func $ta_set_i32 (param (ref extern)) (param i32) (param i32))) + (import "bindings" "ta_set_i16" + (func $ta_set_i16 (param (ref extern)) (param i32) (param (ref i31)))) + (import "bindings" "ta_set_ui16" + (func $ta_set_ui16 (param (ref extern)) (param i32) (param (ref i31)))) + (import "bindings" "ta_set_i8" + (func $ta_set_i8 (param (ref extern)) (param i32) (param (ref i31)))) + (import "bindings" "ta_set_ui8" + (func $ta_set_ui8 (param (ref extern)) (param i32) (param (ref i31)))) + (import "bindings" "ta_set16_ui8" + (func $ta_set16_ui8 (param (ref extern)) (param i32) (param (ref i31)))) + (import "bindings" "ta_set32_ui8" + (func $ta_set32_ui8 (param (ref extern)) (param i32) (param i32))) + (import "bindings" "ta_fill" + (func $ta_fill_int (param (ref extern)) (param i32))) + (import "bindings" "ta_fill" + (func $ta_fill_float (param (ref extern)) (param f64))) + (import "bindings" "ta_blit" + (func $ta_blit (param (ref extern)) (param (ref extern)))) + (import "bindings" "ta_subarray" + (func $ta_subarray + (param (ref extern)) (param i32) (param i32) (result (ref extern)))) + (import "bindings" "ta_blit_from_string" + (func $ta_blit_from_string + (param (ref $string)) (param i32) (param (ref extern)) (param i32) + (param i32))) + (import "bindings" "ta_blit_to_string" + (func $ta_blit_to_string + (param (ref extern)) (param i32) (param (ref $string)) (param i32) + (param i32))) + (import "fail" "caml_bound_error" (func $caml_bound_error)) + (import "fail" "caml_raise_out_of_memory" (func $caml_raise_out_of_memory)) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "int32" "caml_copy_int32" + (func $caml_copy_int32 (param i32) (result (ref eq)))) + (import "int32" "Int32_val" + (func $Int32_val (param (ref eq)) (result i32))) + (import "int32" "caml_copy_nativeint" + (func $caml_copy_nativeint (param i32) (result (ref eq)))) + (import "int64" "caml_copy_int64" + (func $caml_copy_int64 (param i64) (result (ref eq)))) + (import "int64" "Int64_val" + (func $Int64_val (param (ref eq)) (result i64))) + (import "obj" "double_array_tag" (global $double_array_tag i32)) + (import "compare" "unordered" (global $unordered i32)) + (import "hash" "caml_hash_mix_int" + (func $caml_hash_mix_int (param i32) (param i32) (result i32))) + (import "hash" "caml_hash_mix_int64" + (func $caml_hash_mix_int64 (param i32) (param i64) (result i32))) + (import "hash" "caml_hash_mix_double" + (func $caml_hash_mix_double (param i32) (param f64) (result i32))) + (import "hash" "caml_hash_mix_float" + (func $caml_hash_mix_float (param i32) (param f32) (result i32))) + (import "marshal" "caml_serialize_int_1" + (func $caml_serialize_int_1 (param (ref eq)) (param i32))) + (import "marshal" "caml_serialize_int_2" + (func $caml_serialize_int_2 (param (ref eq)) (param i32))) + (import "marshal" "caml_serialize_int_4" + (func $caml_serialize_int_4 (param (ref eq)) (param i32))) + (import "marshal" "caml_serialize_int_8" + (func $caml_serialize_int_8 (param (ref eq)) (param i64))) + (import "marshal" "caml_deserialize_uint_1" + (func $caml_deserialize_uint_1 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_sint_1" + (func $caml_deserialize_sint_1 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_uint_2" + (func $caml_deserialize_uint_2 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_sint_2" + (func $caml_deserialize_sint_2 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_int_4" + (func $caml_deserialize_int_4 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_int_8" + (func $caml_deserialize_int_8 (param (ref eq)) (result i64))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $float (struct (field f64))) + (type $float_array (array (mut f64))) + + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $dup (func (param (ref eq)) (result (ref eq)))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)) + (field $dup (ref null $dup)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + + (global $bigarray_ops (export "bigarray_ops") (ref $custom_operations) + (struct.new $custom_operations + (array.new_fixed $string 9 ;; "_bigarr02" + (i32.const 95) (i32.const 98) (i32.const 105) (i32.const 103) + (i32.const 97) (i32.const 114) (i32.const 114) (i32.const 48) + (i32.const 50)) + (ref.func $caml_ba_compare) + (ref.null $compare) + (ref.func $bigarray_hash) + (ref.null $fixed_length) + (ref.func $bigarray_serialize) + (ref.func $bigarray_deserialize) + (ref.null $dup))) + + (type $int_array (array (mut i32))) + + (type $bigarray + (sub final $custom + (struct + (field (ref $custom_operations)) + (field $ba_data (mut (ref extern))) ;; data + (field $ba_dim (ref $int_array)) ;; size in each dimension + (field $ba_num_dims i8) ;; number of dimensions + (field $ba_kind i8) ;; kind + (field $ba_layout i8)))) ;; layout + + (func $bigarray_hash (param (ref eq)) (result i32) + (local $b (ref $bigarray)) + (local $h i32) (local $len i32) (local $i i32) (local $w i32) + (local $data (ref extern)) + (local.set $b (ref.cast (ref $bigarray) (local.get 0))) + (local.set $data (struct.get $bigarray $ba_data (local.get $b))) + (local.set $len (call $ta_length (local.get $data))) + (block $float64 + (block $float32 + (block $int8 + (block $uint8 + (block $int16 + (block $uint16 + (block $int32 + (block $int64 + (br_table $float32 $float64 $int8 $uint8 $int16 $uint16 + $int32 $int64 $int32 $int32 + $float32 $float64 $uint8 + (struct.get $bigarray $ba_kind (local.get $b)))) + ;; int64 + (if (i32.gt_u (local.get $len) (i32.const 32)) + (then (local.set $len (i32.const 32)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $h + (call $caml_hash_mix_int64 (local.get $h) + (i64.or + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) + (local.get $i))) + (i64.shl + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) + (i32.add (local.get $i) (i32.const 1)))) + (i64.const 32))))) + (local.set $i (i32.add (local.get $i) (i32.const 2))) + (br $loop)))) + (return (local.get $h))) + ;; int32 + (if (i32.gt_u (local.get $len) (i32.const 64)) + (then (local.set $len (i32.const 64)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $h + (call $caml_hash_mix_int (local.get $h) + (call $ta_get_i32 (local.get $data) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (local.get $h))) + ;; uint16 + (if (i32.gt_u (local.get $len) (i32.const 128)) + (then (local.set $len (i32.const 128)))) + (loop $loop + (if (i32.le_u (i32.add (local.get $i) (i32.const 2)) + (local.get $len)) + (then + (local.set $h + (call $caml_hash_mix_int + (local.get $h) + (i32.or + (call $ta_get_ui16 (local.get $data) (local.get $i)) + (i32.shl (call $ta_get_ui16 (local.get $data) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 16))))) + (local.set $i (i32.add (local.get $i) (i32.const 2))) + (br $loop)))) + (if (i32.and (local.get $len) (i32.const 1)) + (then + (local.set $h + (call $caml_hash_mix_int (local.get $h) + (call $ta_get_ui16 (local.get $data) (local.get $i)))))) + (return (local.get $h))) + ;; int16 + (if (i32.gt_u (local.get $len) (i32.const 128)) + (then (local.set $len (i32.const 128)))) + (loop $loop + (if (i32.le_u (i32.add (local.get $i) (i32.const 2)) + (local.get $len)) + (then + (local.set $h + (call $caml_hash_mix_int + (local.get $h) + (i32.or + (call $ta_get_i16 (local.get $data) (local.get $i)) + (i32.shl (call $ta_get_i16 (local.get $data) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 16))))) + (local.set $i (i32.add (local.get $i) (i32.const 2))) + (br $loop)))) + (if (i32.and (local.get $len) (i32.const 1)) + (then + (local.set $h + (call $caml_hash_mix_int (local.get $h) + (call $ta_get_i16 (local.get $data) (local.get $i)))))) + (return (local.get $h))) + ;; uint8 + (if (i32.gt_u (local.get $len) (i32.const 256)) + (then (local.set $len (i32.const 256)))) + (loop $loop + (if (i32.le_u (i32.add (local.get $i) (i32.const 4)) + (local.get $len)) + (then + (local.set $h + (call $caml_hash_mix_int + (local.get $h) + (call $ta_get32_ui8 (local.get $data) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 4))) + (br $loop)))) + (local.set $w (i32.const 0)) + (block $0_bytes + (block $1_byte + (block $2_bytes + (block $3_bytes + (br_table $0_bytes $1_byte $2_bytes $3_bytes + (i32.and (local.get $len) (i32.const 3)))) + (local.set $w + (i32.shl (call $ta_get_ui8 (local.get $data) + (i32.add (local.get $i) (i32.const 2))) + (i32.const 16)))) + (local.set $w + (i32.or (local.get $w) + (i32.shl (call $ta_get_ui8 (local.get $data) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8))))) + (local.set $w + (i32.or (local.get $w) + (call $ta_get_ui8 (local.get $data) (local.get $i)))) + (local.set $h + (call $caml_hash_mix_int (local.get $h) (local.get $w)))) + (return (local.get $h))) + ;; int8 + (if (i32.gt_u (local.get $len) (i32.const 256)) + (then (local.set $len (i32.const 256)))) + (loop $loop + (if (i32.le_u (i32.add (local.get $i) (i32.const 4)) (local.get $len)) + (then + (local.set $h + (call $caml_hash_mix_int + (local.get $h) + (i32.or + (i32.or + (call $ta_get_i8 (local.get $data) (local.get $i)) + (i32.shl (call $ta_get_i8 (local.get $data) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8))) + (i32.or + (i32.shl (call $ta_get_i8 (local.get $data) + (i32.add (local.get $i) (i32.const 2))) + (i32.const 16)) + (i32.shl (call $ta_get_i8 (local.get $data) + (i32.add (local.get $i) (i32.const 3))) + (i32.const 24)))))) + (local.set $i (i32.add (local.get $i) (i32.const 4))) + (br $loop)))) + (local.set $w (i32.const 0)) + (block $0_bytes + (block $1_byte + (block $2_bytes + (block $3_bytes + (br_table $0_bytes $1_byte $2_bytes $3_bytes + (i32.and (local.get $len) (i32.const 3)))) + (local.set $w + (i32.shl (call $ta_get_i8 (local.get $data) + (i32.add (local.get $i) (i32.const 2))) + (i32.const 16)))) + (local.set $w + (i32.or (local.get $w) + (i32.shl (call $ta_get_i8 (local.get $data) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8))))) + (local.set $w + (i32.or (local.get $w) + (call $ta_get_i8 (local.get $data) (local.get $i)))) + (local.set $h + (call $caml_hash_mix_int (local.get $h) (local.get $w)))) + (return (local.get $h))) + ;; float32 + (if (i32.gt_u (local.get $len) (i32.const 64)) + (then (local.set $len (i32.const 64)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $h + (call $caml_hash_mix_float (local.get $h) + (f32.demote_f64 + (call $ta_get_f32 (local.get $data) (local.get $i))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (local.get $h))) + ;; float64 + (if (i32.gt_u (local.get $len) (i32.const 32)) + (then (local.set $len (i32.const 32)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $h + (call $caml_hash_mix_double (local.get $h) + (call $ta_get_f64 (local.get $data) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (local.get $h))) + + (func $bigarray_serialize + (param $s (ref eq)) (param $v (ref eq)) (result i32) (result i32) + (local $b (ref $bigarray)) + (local $num_dims i32) (local $dim (ref $int_array)) + (local $data (ref extern)) + (local $i i32) (local $len i32) + (local.set $b (ref.cast (ref $bigarray) (local.get $v))) + (local.set $num_dims (struct.get $bigarray $ba_num_dims (local.get $b))) + (local.set $dim (struct.get $bigarray $ba_dim (local.get $b))) + (call $caml_serialize_int_4 (local.get $s) (local.get $num_dims)) + (call $caml_serialize_int_4 (local.get $s) + (i32.or (struct.get $bigarray $ba_kind (local.get $b)) + (i32.shl (struct.get $bigarray $ba_layout (local.get $b)) + (i32.const 8)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $num_dims)) + (then + (local.set $len + (array.get $int_array (local.get $dim) (local.get $i))) + (if (i32.lt_u (local.get $len) (i32.const 0xffff)) + (then + (call $caml_serialize_int_2 (local.get $s) + (local.get $len))) + (else + (call $caml_serialize_int_2 (local.get $s) + (i32.const 0xffff)) + (call $caml_serialize_int_8 (local.get $s) + (i64.extend_i32_u (local.get $len))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (block $done + (local.set $data (struct.get $bigarray $ba_data (local.get $b))) + (local.set $len (call $ta_length (local.get $data))) + (local.set $i (i32.const 0)) + (block $float64 + (block $float32 + (block $int8 + (block $uint8 + (block $int16 + (block $uint16 + (block $int32 + (block $int + (block $int64 + (br_table $float32 $float64 $int8 $uint8 $int16 $uint16 + $int32 $int64 $int $int + $float32 $float64 $uint8 + (struct.get $bigarray $ba_kind (local.get $b)))) + ;; int64 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $caml_serialize_int_8 (local.get $s) + (i64.or + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) + (local.get $i))) + (i64.shl + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) + (i32.add (local.get $i) (i32.const 1)))) + (i64.const 32)))) + (local.set $i (i32.add (local.get $i) (i32.const 2))) + (br $loop)))) + (br $done)) + ;; int + (call $caml_serialize_int_1 (local.get $s) (i32.const 0))) + ;; int32 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $caml_serialize_int_4 (local.get $s) + (call $ta_get_i32 (local.get $data) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; uint16 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $caml_serialize_int_2 (local.get $s) + (call $ta_get_ui16 (local.get $data) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; int16 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $caml_serialize_int_2 (local.get $s) + (call $ta_get_i16 (local.get $data) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; uint8 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $caml_serialize_int_1 (local.get $s) + (call $ta_get_ui8 (local.get $data) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; int8 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $caml_serialize_int_1 (local.get $s) + (call $ta_get_i8 (local.get $data) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; float32 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $caml_serialize_int_4 (local.get $s) + (i32.reinterpret_f32 + (f32.demote_f64 + (call $ta_get_f32 (local.get $data) (local.get $i))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; float64 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $caml_serialize_int_8 (local.get $s) + (i64.reinterpret_f64 + (call $ta_get_f64 (local.get $data) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (tuple.make 2 + (i32.mul (i32.add (i32.const 4) (local.get $num_dims)) (i32.const 4)) + (i32.mul (i32.add (i32.const 4) (local.get $num_dims)) (i32.const 8)))) + + (data $intern_overflow + "input_value: cannot read bigarray with 64-bit OCaml ints") + + (func $bigarray_deserialize + (param $s (ref eq)) (result (ref eq)) (result i32) + (local $b (ref $bigarray)) + (local $num_dims i32) (local $dim (ref $int_array)) + (local $flags i32) (local $kind i32) + (local $data (ref extern)) + (local $i i32) (local $len i32) + (local $l i64) + (local.set $num_dims (call $caml_deserialize_int_4 (local.get $s))) + (local.set $flags (call $caml_deserialize_int_4 (local.get $s))) + (local.set $kind (i32.and (local.get $flags) (i32.const 0xff))) + (local.set $dim (array.new $int_array (i32.const 0) (local.get $num_dims))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $num_dims)) + (then + (local.set $len + (call $caml_deserialize_uint_2 (local.get $s))) + (if (i32.eq (local.get $len) (i32.const 0xffff)) + (then + ;; ZZZ overflows? + (local.set $len + (i32.wrap_i64 + (call $caml_deserialize_int_8 (local.get $s)))))) + (array.set $int_array (local.get $dim) (local.get $i) + (local.get $len)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.set $b + (struct.new $bigarray + (global.get $bigarray_ops) + (call $caml_ba_create_buffer (local.get $kind) + (call $caml_ba_get_size (local.get $dim))) + (local.get $dim) + (local.get $num_dims) + (local.get $kind) + (i32.shr_u (local.get $flags) (i32.const 8)))) + (block $done + (local.set $data (struct.get $bigarray $ba_data (local.get $b))) + (local.set $len (call $ta_length (local.get $data))) + (local.set $i (i32.const 0)) + (block $float64 + (block $float32 + (block $int8 + (block $uint8 + (block $int16 + (block $uint16 + (block $int32 + (block $int + (block $int64 + (br_table $float32 $float64 $int8 $uint8 $int16 $uint16 + $int32 $int64 $int $int + $float32 $float64 $uint8 + (struct.get $bigarray $ba_kind (local.get $b)))) + ;; int64 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $l + (call $caml_deserialize_int_8 (local.get $s))) + (call $ta_set_i32 (local.get $data) (local.get $i) + (i32.wrap_i64 (local.get $l))) + (call $ta_set_i32 (local.get $data) + (i32.add (local.get $i) (i32.const 1)) + (i32.wrap_i64 + (i64.shr_u (local.get $l) (i64.const 32)))) + (local.set $i (i32.add (local.get $i) (i32.const 2))) + (br $loop)))) + (br $done)) + ;; int + (if (call $caml_deserialize_uint_1 (local.get $s)) + (then + (call $caml_failwith + (array.new_data $string $intern_overflow + (i32.const 0) (i32.const 56)))))) + ;; int32 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $ta_set_i32 (local.get $data) (local.get $i) + (call $caml_deserialize_int_4 (local.get $s))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; uint16 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $ta_set_ui16 (local.get $data) (local.get $i) + (ref.i31 (call $caml_deserialize_uint_2 (local.get $s)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; int16 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $ta_set_i16 (local.get $data) (local.get $i) + (ref.i31 (call $caml_deserialize_sint_2 (local.get $s)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; uint8 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $ta_set_ui8 (local.get $data) (local.get $i) + (ref.i31 (call $caml_deserialize_uint_1 (local.get $s)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; int8 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $ta_set_i8 (local.get $data) (local.get $i) + (ref.i31 (call $caml_deserialize_sint_1 (local.get $s)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; float32 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $ta_set_f32 (local.get $data) (local.get $i) + (f64.promote_f32 + (f32.reinterpret_i32 + (call $caml_deserialize_int_4 (local.get $s))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $done)) + ;; float64 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $ta_set_f64 (local.get $data) (local.get $i) + (f64.reinterpret_i64 + (call $caml_deserialize_int_8 (local.get $s)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (tuple.make 2 + (local.get $b) + (i32.mul (i32.add (i32.const 4) (local.get $num_dims)) (i32.const 4)))) + + (func $caml_ba_get_size (param $dim (ref $int_array)) (result i32) + (local $i i32) (local $n i32) (local $sz i64) + (local.set $n (array.len (local.get $dim))) + (local.set $i (i32.const 0)) + (local.set $sz (i64.const 1)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $n)) + (then + (local.set $sz + (i64.mul (local.get $sz) + (i64.extend_i32_s + (array.get $int_array + (local.get $dim) (local.get $i))))) + (if (i64.ne (local.get $sz) + (i64.extend_i32_s (i32.wrap_i64 (local.get $sz)))) + (then (call $caml_raise_out_of_memory))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (i32.wrap_i64 (local.get $sz))) + + (func $caml_ba_size_per_element (param $kind i32) (result i32) + (select (i32.const 2) (i32.const 1) + (i32.or (i32.eq (local.get $kind) (i32.const 7)) + (i32.or (i32.eq (local.get $kind) (i32.const 10)) + (i32.eq (local.get $kind) (i32.const 11)))))) + + (func $caml_ba_create_buffer (export "caml_ba_create_buffer") + (param $kind i32) (param $sz i32) (result (ref extern)) + (local $l i64) + (local.set $l + (i64.mul (i64.extend_i32_s (local.get $sz)) + (i64.extend_i32_s + (call $caml_ba_size_per_element (local.get $kind))))) + (if (i64.ne (local.get $l) (i64.extend_i32_s (i32.wrap_i64 (local.get $l)))) + (then (call $caml_raise_out_of_memory))) + (return_call $ta_create (local.get $kind) (i32.wrap_i64 (local.get $l)))) + + (global $CAML_BA_MAX_NUM_DIMS i32 (i32.const 16)) + + (data $ba_create_bad_dims "Bigarray.create: bad number of dimensions") + (data $ba_create_negative_dim "Bigarray.create: negative dimension") + + (func (export "caml_ba_create") + (param $vkind (ref eq)) (param $layout (ref eq)) (param $d (ref eq)) + (result (ref eq)) + (local $vdim (ref $block)) + (local $dim (ref $int_array)) + (local $kind i32) (local $num_dims i32) (local $i i32) (local $n i32) + (local.set $kind (i31.get_s (ref.cast (ref i31) (local.get $vkind)))) + (local.set $vdim (ref.cast (ref $block) (local.get $d))) + (local.set $num_dims (i32.sub (array.len (local.get $vdim)) (i32.const 1))) + (if (i32.gt_u (local.get $num_dims) (global.get $CAML_BA_MAX_NUM_DIMS)) + (then + (call $caml_invalid_argument + (array.new_data $string $ba_create_bad_dims + (i32.const 0) (i32.const 41))))) + (local.set $dim + (array.new $int_array (i32.const 0) (local.get $num_dims))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $num_dims)) + (then + (local.set $n + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $vdim) + (i32.add (local.get $i) (i32.const 1)))))) + (if (i32.lt_s (local.get $n) (i32.const 0)) + (then + (call $caml_invalid_argument + (array.new_data $string $ba_create_negative_dim + (i32.const 0) (i32.const 35))))) + (array.set $int_array + (local.get $dim) (local.get $i) (local.get $n)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (struct.new $bigarray + (global.get $bigarray_ops) + (call $caml_ba_create_buffer (local.get $kind) + (call $caml_ba_get_size (local.get $dim))) + (local.get $dim) + (local.get $num_dims) + (local.get $kind) + (i31.get_s (ref.cast (ref i31) (local.get $layout))))) + + (data $ta_unsupported_kind "Typed_array.to_genarray: unsupported kind") + (data $ta_too_large "Typed_array.to_genarray: too large") + + (func (export "caml_ba_from_typed_array") (param (ref eq)) (result (ref eq)) + (local $data (ref extern)) + (local $kind i32) + (local $len i32) + (local.set $data + (call $ta_normalize + (ref.as_non_null (extern.convert_any (call $unwrap (local.get 0)))))) + (local.set $kind (call $ta_kind (local.get $data))) + (if (i32.lt_s (local.get $kind) (i32.const 0)) + (then + (call $caml_invalid_argument + (array.new_data $string $ta_unsupported_kind + (i32.const 0) (i32.const 41))))) + (if (i32.eq (local.get $kind) (i32.const 13)) ;; Uint8ClampedArray + (then (local.set $kind (i32.const 3)))) + (local.set $len (call $ta_length (local.get $data))) + (if (i32.lt_s (local.get $len) (i32.const 0)) + (then + (call $caml_invalid_argument + (array.new_data $string $ta_too_large + (i32.const 0) (i32.const 34))))) + (struct.new $bigarray + (global.get $bigarray_ops) + (local.get $data) + (array.new_fixed $int_array 1 (local.get $len)) + (i32.const 1) + (local.get $kind) + (i32.const 0))) + + (func (export "caml_ba_to_typed_array") (param (ref eq)) (result (ref eq)) + (call $wrap + (any.convert_extern + (struct.get $bigarray $ba_data + (ref.cast (ref $bigarray) (local.get 0)))))) + + (func $caml_ba_get_at_offset + (param $ba (ref $bigarray)) (param $i i32) (result (ref eq)) + (local $data (ref extern)) + (local.set $data (struct.get $bigarray $ba_data (local.get $ba))) + (block $float32 + (block $float64 + (block $int8 + (block $uint8 + (block $int16 + (block $uint16 + (block $int32 + (block $int64 + (block $int + (block $nativeint + (block $complex32 + (block $complex64 + (br_table $float32 $float64 $int8 $uint8 $int16 $uint16 + $int32 $int64 $int $nativeint + $complex32 $complex64 $uint8 + (struct.get $bigarray $ba_kind (local.get $ba)))) + ;; complex64 + (local.set $i (i32.shl (local.get $i) (i32.const 1))) + (return + (array.new_fixed $float_array 2 + (call $ta_get_f64 (local.get $data) (local.get $i)) + (call $ta_get_f64 (local.get $data) + (i32.add (local.get $i) (i32.const 1)))))) + ;; complex32 + (local.set $i (i32.shl (local.get $i) (i32.const 1))) + (return + (array.new_fixed $float_array 2 + (call $ta_get_f32 (local.get $data) (local.get $i)) + (call $ta_get_f32 (local.get $data) + (i32.add (local.get $i) (i32.const 1)))))) + ;; nativeint + (return_call $caml_copy_nativeint + (call $ta_get_i32 (local.get $data) (local.get $i)))) + ;; int + (return + (ref.i31 + (call $ta_get_i32 (local.get $data) (local.get $i))))) + ;; int64 + (local.set $i (i32.shl (local.get $i) (i32.const 1))) + (return_call $caml_copy_int64 + (i64.or + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) (local.get $i))) + (i64.shl + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) + (i32.add (local.get $i) (i32.const 1)))) + (i64.const 32))))) + ;; int32 + (return_call $caml_copy_int32 + (call $ta_get_i32 (local.get $data) (local.get $i)))) + ;; uint16 + (return (ref.i31 + (call $ta_get_ui16 (local.get $data) (local.get $i))))) + ;; int16 + (return (ref.i31 + (call $ta_get_i16 (local.get $data) (local.get $i))))) + ;; uint8 + (return (ref.i31 + (call $ta_get_ui8 (local.get $data) (local.get $i))))) + ;; int8 + (return (ref.i31 + (call $ta_get_i8 (local.get $data) (local.get $i))))) + ;; float64 + (return (struct.new $float + (call $ta_get_f64 (local.get $data) (local.get $i))))) + ;; float32 + (return (struct.new $float + (call $ta_get_f32 (local.get $data) (local.get $i))))) + + (func $caml_ba_set_at_offset + (param $ba (ref $bigarray)) (param $i i32) (param $v (ref eq)) + (local $data (ref extern)) + (local $b (ref $float_array)) (local $l i64) + (local.set $data (struct.get $bigarray $ba_data (local.get $ba))) + (block $float32 + (block $float64 + (block $int8 + (block $uint8 + (block $int16 + (block $uint16 + (block $int32 + (block $int64 + (block $int + (block $nativeint + (block $complex32 + (block $complex64 + (br_table $float32 $float64 $int8 $uint8 $int16 $uint16 + $int32 $int64 $int $nativeint + $complex32 $complex64 $uint8 + (struct.get $bigarray $ba_kind (local.get $ba)))) + ;; complex64 + (local.set $i (i32.shl (local.get $i) (i32.const 1))) + (local.set $b (ref.cast (ref $float_array) (local.get $v))) + (call $ta_set_f64 (local.get $data) (local.get $i) + (array.get $float_array (local.get $b) (i32.const 0))) + (call $ta_set_f64 (local.get $data) + (i32.add (local.get $i) (i32.const 1)) + (array.get $float_array (local.get $b) (i32.const 1))) + (return)) + ;; complex32 + (local.set $i (i32.shl (local.get $i) (i32.const 1))) + (local.set $b (ref.cast (ref $float_array) (local.get $v))) + (call $ta_set_f32 (local.get $data) (local.get $i) + (array.get $float_array (local.get $b) (i32.const 0))) + (call $ta_set_f32 (local.get $data) + (i32.add (local.get $i) (i32.const 1)) + (array.get $float_array (local.get $b) (i32.const 1))) + (return)) + ;; nativeint + (call $ta_set_i32 (local.get $data) (local.get $i) + (call $Int32_val (local.get $v))) + (return)) + ;; int + (call $ta_set_i32 (local.get $data) (local.get $i) + (i31.get_s (ref.cast (ref i31) (local.get $v)))) + (return)) + ;; int64 + (local.set $i (i32.shl (local.get $i) (i32.const 1))) + (local.set $l (call $Int64_val (local.get $v))) + (call $ta_set_i32 (local.get $data) (local.get $i) + (i32.wrap_i64 (local.get $l))) + (call $ta_set_i32 (local.get $data) + (i32.add (local.get $i) (i32.const 1)) + (i32.wrap_i64 (i64.shr_u (local.get $l) (i64.const 32)))) + (return)) + ;; int32 + (call $ta_set_i32 (local.get $data) (local.get $i) + (call $Int32_val (local.get $v))) + (return)) + ;; uint16 + (call $ta_set_ui16 (local.get $data) (local.get $i) + (ref.cast (ref i31) (local.get $v))) + (return)) + ;; int16 + (call $ta_set_i16 (local.get $data) (local.get $i) + (ref.cast (ref i31) (local.get $v))) + (return)) + ;; uint8 + (call $ta_set_ui8 (local.get $data) (local.get $i) + (ref.cast (ref i31) (local.get $v))) + (return)) + ;; int8 + (call $ta_set_i8 (local.get $data) (local.get $i) + (ref.cast (ref i31) (local.get $v))) + (return)) + ;; float64 + (call $ta_set_f64 (local.get $data) (local.get $i) + (struct.get $float 0 (ref.cast (ref $float) (local.get $v)))) + (return)) + ;; float32 + (call $ta_set_f32 (local.get $data) (local.get $i) + (struct.get $float 0 (ref.cast (ref $float) (local.get $v)))) + (return)) + + (data $Bigarray_dim "Bigarray.dim") + + (func $caml_ba_dim (export "caml_ba_dim") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local $dim (ref $int_array)) + (local $i i32) + (local.set $dim + (struct.get $bigarray $ba_dim + (ref.cast (ref $bigarray) (local.get 0)))) + (local.set $i (i31.get_s (ref.cast (ref i31) (local.get 1)))) + (if (i32.ge_u (local.get $i) (array.len (local.get $dim))) + (then (call $caml_invalid_argument + (array.new_data $string $Bigarray_dim + (i32.const 0) (i32.const 12))))) + (ref.i31 (array.get $int_array (local.get $dim) (local.get $i)))) + + (func (export "caml_ba_dim_1") (param (ref eq)) (result (ref eq)) + (return_call $caml_ba_dim (local.get 0) (ref.i31 (i32.const 0)))) + + (func (export "caml_ba_get_1") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local $ba (ref $bigarray)) + (local $i i32) + (local.set $ba (ref.cast (ref $bigarray) (local.get 0))) + (local.set $i (i31.get_u (ref.cast (ref i31) (local.get 1)))) + (if (struct.get $bigarray $ba_layout (local.get $ba)) + (then (local.set $i (i32.sub (local.get $i) (i32.const 1))))) + (if (i32.ge_u (local.get $i) + (array.get $int_array (struct.get $bigarray 2 (local.get $ba)) + (i32.const 0))) + (then (call $caml_bound_error))) + (return_call $caml_ba_get_at_offset (local.get $ba) (local.get $i))) + + (func (export "caml_ba_set_1") + (param (ref eq)) (param (ref eq)) (param $v (ref eq)) (result (ref eq)) + (local $ba (ref $bigarray)) + (local $i i32) + (local.set $ba (ref.cast (ref $bigarray) (local.get 0))) + (local.set $i (i31.get_u (ref.cast (ref i31) (local.get 1)))) + (if (struct.get $bigarray $ba_layout (local.get $ba)) + (then (local.set $i (i32.sub (local.get $i) (i32.const 1))))) + (if (i32.ge_u (local.get $i) + (array.get $int_array (struct.get $bigarray $ba_dim (local.get $ba)) + (i32.const 0))) + (then (call $caml_bound_error))) + (call $caml_ba_set_at_offset + (local.get $ba) (local.get $i) (local.get $v)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ba_get_2") + (param $vba (ref eq)) (param $vi (ref eq)) (param $vj (ref eq)) + (result (ref eq)) + (local $ba (ref $bigarray)) + (local $i i32) + (local $j i32) + (local $offset i32) + (local $dim (ref $int_array)) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $i (i31.get_u (ref.cast (ref i31) (local.get $vi)))) + (local.set $j (i31.get_u (ref.cast (ref i31) (local.get $vj)))) + (local.set $dim (struct.get $bigarray $ba_dim (local.get $ba))) + (if (struct.get $bigarray $ba_layout (local.get $ba)) + (then + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (local.set $j (i32.sub (local.get $j) (i32.const 1))) + (local.set $offset + (i32.add + (i32.mul (local.get $j) + (array.get $int_array (local.get $dim) (i32.const 0))) + (local.get $i)))) + (else + (local.set $offset + (i32.add + (i32.mul (local.get $i) + (array.get $int_array (local.get $dim) (i32.const 1))) + (local.get $j))))) + (if (i32.or + (i32.ge_u (local.get $i) + (array.get $int_array (local.get $dim) (i32.const 0))) + (i32.ge_u (local.get $j) + (array.get $int_array (local.get $dim) (i32.const 1)))) + (then + (call $caml_bound_error))) + (return_call $caml_ba_get_at_offset (local.get $ba) (local.get $offset))) + + (func (export "caml_ba_set_2") + (param $vba (ref eq)) (param $vi (ref eq)) (param $vj (ref eq)) + (param $v (ref eq)) (result (ref eq)) + (local $ba (ref $bigarray)) + (local $i i32) + (local $j i32) + (local $offset i32) + (local $dim (ref $int_array)) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $i (i31.get_u (ref.cast (ref i31) (local.get $vi)))) + (local.set $j (i31.get_u (ref.cast (ref i31) (local.get $vj)))) + (local.set $dim (struct.get $bigarray $ba_dim (local.get $ba))) + (if (struct.get $bigarray $ba_layout (local.get $ba)) + (then + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (local.set $j (i32.sub (local.get $j) (i32.const 1))) + (local.set $offset + (i32.add + (i32.mul (local.get $j) + (array.get $int_array (local.get $dim) (i32.const 0))) + (local.get $i)))) + (else + (local.set $offset + (i32.add + (i32.mul (local.get $i) + (array.get $int_array (local.get $dim) (i32.const 1))) + (local.get $j))))) + (if (i32.or + (i32.ge_u (local.get $i) + (array.get $int_array (local.get $dim) (i32.const 0))) + (i32.ge_u (local.get $j) + (array.get $int_array (local.get $dim) (i32.const 1)))) + (then + (call $caml_bound_error))) + (call $caml_ba_set_at_offset + (local.get $ba) (local.get $offset) (local.get $v)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ba_dim_2") (param (ref eq)) (result (ref eq)) + (return_call $caml_ba_dim (local.get 0) (ref.i31 (i32.const 1)))) + + (func (export "caml_ba_get_3") + (param $vba (ref eq)) (param $vi (ref eq)) (param $vj (ref eq)) + (param $vk (ref eq)) + (result (ref eq)) + (local $ba (ref $bigarray)) + (local $i i32) + (local $j i32) + (local $k i32) + (local $offset i32) + (local $dim (ref $int_array)) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $i (i31.get_u (ref.cast (ref i31) (local.get $vi)))) + (local.set $j (i31.get_u (ref.cast (ref i31) (local.get $vj)))) + (local.set $k (i31.get_u (ref.cast (ref i31) (local.get $vk)))) + (local.set $dim (struct.get $bigarray $ba_dim (local.get $ba))) + (if (struct.get $bigarray $ba_layout (local.get $ba)) + (then + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (local.set $j (i32.sub (local.get $j) (i32.const 1))) + (local.set $k (i32.sub (local.get $k) (i32.const 1))) + (local.set $offset + (i32.add + (i32.mul + (i32.add + (i32.mul + (local.get $k) + (array.get $int_array (local.get $dim) (i32.const 1))) + (local.get $j)) + (array.get $int_array (local.get $dim) (i32.const 0))) + (local.get $i)))) + (else + (local.set $offset + (i32.add + (i32.mul + (i32.add + (i32.mul + (local.get $i) + (array.get $int_array (local.get $dim) (i32.const 1))) + (local.get $j)) + (array.get $int_array (local.get $dim) (i32.const 2))) + (local.get $k))))) + (if (i32.or + (i32.ge_u (local.get $i) + (array.get $int_array (local.get $dim) (i32.const 0))) + (i32.or + (i32.ge_u (local.get $j) + (array.get $int_array (local.get $dim) (i32.const 1))) + (i32.ge_u (local.get $k) + (array.get $int_array (local.get $dim) (i32.const 2))))) + (then + (call $caml_bound_error))) + (return_call $caml_ba_get_at_offset (local.get $ba) (local.get $offset))) + + (func (export "caml_ba_set_3") + (param $vba (ref eq)) (param $vi (ref eq)) (param $vj (ref eq)) + (param $vk (ref eq)) (param $v (ref eq)) + (result (ref eq)) + (local $ba (ref $bigarray)) + (local $i i32) + (local $j i32) + (local $k i32) + (local $offset i32) + (local $dim (ref $int_array)) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $i (i31.get_u (ref.cast (ref i31) (local.get $vi)))) + (local.set $j (i31.get_u (ref.cast (ref i31) (local.get $vj)))) + (local.set $k (i31.get_u (ref.cast (ref i31) (local.get $vk)))) + (local.set $dim (struct.get $bigarray $ba_dim (local.get $ba))) + (if (struct.get $bigarray $ba_layout (local.get $ba)) + (then + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (local.set $j (i32.sub (local.get $j) (i32.const 1))) + (local.set $k (i32.sub (local.get $k) (i32.const 1))) + (local.set $offset + (i32.add + (i32.mul + (i32.add + (i32.mul + (local.get $k) + (array.get $int_array (local.get $dim) (i32.const 1))) + (local.get $j)) + (array.get $int_array (local.get $dim) (i32.const 0))) + (local.get $i)))) + (else + (local.set $offset + (i32.add + (i32.mul + (i32.add + (i32.mul + (local.get $i) + (array.get $int_array (local.get $dim) (i32.const 1))) + (local.get $j)) + (array.get $int_array (local.get $dim) (i32.const 2))) + (local.get $k))))) + (if (i32.or + (i32.ge_u (local.get $i) + (array.get $int_array (local.get $dim) (i32.const 0))) + (i32.or + (i32.ge_u (local.get $j) + (array.get $int_array (local.get $dim) (i32.const 1))) + (i32.ge_u (local.get $k) + (array.get $int_array (local.get $dim) (i32.const 2))))) + (then + (call $caml_bound_error))) + (call $caml_ba_set_at_offset + (local.get $ba) (local.get $offset) (local.get $v)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ba_dim_3") (param (ref eq)) (result (ref eq)) + (return_call $caml_ba_dim (local.get 0) (ref.i31 (i32.const 2)))) + + (func $caml_ba_offset + (param $b (ref $bigarray)) (param $index (ref $int_array)) (result i32) + (local $dim (ref $int_array)) + (local $num_dims i32) (local $idx i32) + (local $offset i32) (local $i i32) (local $l i32) + (local.set $dim (struct.get $bigarray $ba_dim (local.get $b))) + (if (struct.get $bigarray $ba_layout (local.get $b)) + (then + (local.set $i + (i32.sub (struct.get $bigarray $ba_num_dims (local.get $b)) + (i32.const 1))) + (loop $loop + (if (i32.ge_s (local.get $i) (i32.const 0)) + (then + (local.set $idx + (i32.sub + (array.get $int_array (local.get $index) + (local.get $i)) + (i32.const 1))) + (local.set $l + (array.get $int_array (local.get $dim) (local.get $i))) + (if (i32.ge_u (local.get $idx) (local.get $l)) + (then + (call $caml_bound_error))) + (local.set $offset + (i32.add (i32.mul (local.get $offset) (local.get $l)) + (local.get $idx))) + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (br $loop))))) + (else + (local.set $num_dims + (struct.get $bigarray $ba_num_dims (local.get $b))) + (loop $loop + (if (i32.lt_s (local.get $i) (local.get $num_dims)) + (then + (local.set $idx + (array.get $int_array (local.get $index) (local.get $i))) + (local.set $l + (array.get $int_array (local.get $dim) (local.get $i))) + (if (i32.ge_u (local.get $idx) (local.get $l)) + (then + (call $caml_bound_error))) + (local.set $offset + (i32.add (i32.mul (local.get $offset) (local.get $l)) + (local.get $idx))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (local.get $offset)) + + (func $caml_ba_offset' + (param $b (ref $bigarray)) (param $index (ref $block)) (result i32) + (local $dim (ref $int_array)) + (local $num_dims i32) (local $idx i32) + (local $offset i32) (local $i i32) (local $l i32) + (local.set $dim (struct.get $bigarray $ba_dim (local.get $b))) + (if (struct.get $bigarray $ba_layout (local.get $b)) + (then + (local.set $i + (i32.sub (struct.get $bigarray $ba_num_dims (local.get $b)) + (i32.const 1))) + (loop $loop + (if (i32.ge_s (local.get $i) (i32.const 0)) + (then + (local.set $idx + (i32.sub + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $index) + (i32.add (local.get $i) (i32.const 1))))) + (i32.const 1))) + (local.set $l + (array.get $int_array (local.get $dim) (local.get $i))) + (if (i32.ge_u (local.get $idx) (local.get $l)) + (then + (call $caml_bound_error))) + (local.set $offset + (i32.add (i32.mul (local.get $offset) (local.get $l)) + (local.get $idx))) + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (br $loop))))) + (else + (local.set $num_dims + (struct.get $bigarray $ba_num_dims (local.get $b))) + (loop $loop + (if (i32.lt_s (local.get $i) (local.get $num_dims)) + (then + (local.set $idx + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $index) + (i32.add (local.get $i) (i32.const 1)))))) + (local.set $l + (array.get $int_array (local.get $dim) (local.get $i))) + (if (i32.ge_u (local.get $idx) (local.get $l)) + (then + (call $caml_bound_error))) + (local.set $offset + (i32.add (i32.mul (local.get $offset) (local.get $l)) + (local.get $idx))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (local.get $offset)) + + (func (export "caml_ba_get_generic") + (param $vba (ref eq)) (param $index (ref eq)) (result (ref eq)) + (local $ba (ref $bigarray)) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (return_call $caml_ba_get_at_offset (local.get $ba) + (call $caml_ba_offset' (local.get $ba) + (ref.cast (ref $block) (local.get $index))))) + + (func (export "caml_ba_set_generic") + (param $vba (ref eq)) (param $index (ref eq)) (param $v (ref eq)) + (result (ref eq)) + (local $ba (ref $bigarray)) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (call $caml_ba_set_at_offset (local.get $ba) + (call $caml_ba_offset' (local.get $ba) + (ref.cast (ref $block) (local.get $index))) + (local.get $v)) + (ref.i31 (i32.const 0))) + + (data $too_many_indices "Bigarray.slice: too many indices") + + (func (export "caml_ba_slice") + (param $vb (ref eq)) (param $vind (ref eq)) (result (ref eq)) + (local $b (ref $bigarray)) + (local $ind (ref $block)) + (local $index (ref $int_array)) (local $sub_dim (ref $int_array)) + (local $num_inds i32) (local $num_dims i32) (local $i i32) + (local $idx i32) (local $mul i32) (local $offset i32) (local $size i32) + (local $sub_data (ref extern)) + (local.set $b (ref.cast (ref $bigarray) (local.get $vb))) + (local.set $ind (ref.cast (ref $block) (local.get $vind))) + (local.set $num_inds (i32.sub (array.len (local.get $ind)) (i32.const 1))) + (local.set $num_dims (struct.get $bigarray $ba_num_dims (local.get $b))) + (if (i32.gt_u (local.get $num_inds) + (struct.get $bigarray $ba_num_dims (local.get $b))) + (then + (call $caml_invalid_argument + (array.new_data $string $too_many_indices + (i32.const 0) (i32.const 32))))) + (local.set $sub_dim + (array.new $int_array (i32.const 0) + (i32.sub (local.get $num_dims) (local.get $num_inds)))) + (if (struct.get $bigarray $ba_layout (local.get $b)) + (then + (local.set $index + (array.new $int_array (i32.const 1) (local.get $num_dims))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $num_inds)) + (then + (array.set $int_array (local.get $index) + (i32.sub (i32.add (local.get $num_dims) (local.get $i)) + (local.get $num_inds)) + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $ind) + (i32.add (local.get $i) (i32.const 1)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.set $offset + (call $caml_ba_offset (local.get $b) (local.get $index))) + (array.copy $int_array $int_array + (local.get $sub_dim) (i32.const 0) + (struct.get $bigarray $ba_dim (local.get $b)) (i32.const 0) + (i32.sub (local.get $num_dims) (local.get $num_inds)))) + (else + (local.set $index + (array.new $int_array (i32.const 0) (local.get $num_dims))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $num_inds)) + (then + (array.set $int_array (local.get $index) + (local.get $i) + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $ind) + (i32.add (local.get $i) (i32.const 1)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.set $offset + (call $caml_ba_offset (local.get $b) (local.get $index))) + (array.copy $int_array $int_array + (local.get $sub_dim) (i32.const 0) + (struct.get $bigarray $ba_dim (local.get $b)) + (local.get $num_inds) + (i32.sub (local.get $num_dims) (local.get $num_inds))))) + (local.set $mul + (call $caml_ba_size_per_element + (struct.get $bigarray $ba_kind (local.get $b)))) + (local.set $size (call $caml_ba_get_size (local.get $sub_dim))) + (local.set $sub_data + (call $ta_subarray (struct.get $bigarray $ba_data (local.get $b)) + (i32.mul (local.get $offset) (local.get $mul)) + (i32.mul (i32.add (local.get $offset) (local.get $size)) + (local.get $mul)))) + (struct.new $bigarray + (global.get $bigarray_ops) + (local.get $sub_data) + (local.get $sub_dim) + (array.len (local.get $sub_dim)) + (struct.get $bigarray $ba_kind (local.get $b)) + (struct.get $bigarray $ba_layout (local.get $b)))) + + (data $bad_subarray "Bigarray.sub: bad sub-array") + + (func (export "caml_ba_sub") + (param $vba (ref eq)) (param $vofs (ref eq)) (param $vlen (ref eq)) + (result (ref eq)) + (local $ba (ref $bigarray)) + (local $ofs i32) (local $len i32) + (local $changed_dim i32) (local $mul i32) (local $i i32) + (local $num_dims i32) + (local $dim (ref $int_array)) (local $new_dim (ref $int_array)) + (local $new_data (ref extern)) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $ofs (i31.get_s (ref.cast (ref i31) (local.get $vofs)))) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (local.set $num_dims (struct.get $bigarray $ba_num_dims (local.get $ba))) + (local.set $dim (struct.get $bigarray $ba_dim (local.get $ba))) + (local.set $mul (i32.const 1)) + (if (struct.get $bigarray $ba_layout (local.get $ba)) + (then + (local.set $changed_dim + (i32.sub (local.get $num_dims) (i32.const 1))) + (local.set $ofs (i32.sub (local.get $ofs) (i32.const 1))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $changed_dim)) + (then + (local.set $mul + (i32.mul (local.get $mul) + (array.get $int_array + (local.get $dim) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (else + (local.set $changed_dim (i32.const 0)) + (local.set $i (i32.const 1)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $num_dims)) + (then + (local.set $mul + (i32.mul (local.get $mul) + (array.get $int_array + (local.get $dim) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (if (i32.or + (i32.or (i32.lt_s (local.get $ofs) (i32.const 0)) + (i32.lt_s (local.get $len) (i32.const 0))) + (i32.gt_s (i32.add (local.get $ofs) (local.get $len)) + (array.get $int_array (local.get $dim) + (local.get $changed_dim)))) + (then + (call $caml_invalid_argument + (array.new_data $string $bad_subarray + (i32.const 0) (i32.const 27))))) + (local.set $new_dim + (array.new $int_array (i32.const 0) (local.get $num_dims))) + (array.copy $int_array $int_array + (local.get $new_dim) (i32.const 0) + (local.get $dim) (i32.const 0) + (local.get $num_dims)) + (array.set $int_array (local.get $new_dim) (local.get $changed_dim) + (local.get $len)) + (local.set $mul (i32.mul (local.get $mul) + (call $caml_ba_size_per_element + (struct.get $bigarray $ba_kind (local.get $ba))))) + (local.set $new_data + (call $ta_subarray (struct.get $bigarray $ba_data (local.get $ba)) + (i32.mul (local.get $ofs) (local.get $mul)) + (i32.mul (i32.add (local.get $ofs) (local.get $len)) + (local.get $mul)))) + (struct.new $bigarray + (global.get $bigarray_ops) + (local.get $new_data) + (local.get $new_dim) + (local.get $num_dims) + (struct.get $bigarray $ba_kind (local.get $ba)) + (struct.get $bigarray $ba_layout (local.get $ba)))) + + (func (export "caml_ba_fill") + (param $vba (ref eq)) (param $v (ref eq)) (result (ref eq)) + (local $ba (ref $bigarray)) + (local $data (ref extern)) + (local $l i64) + (local $i i32) (local $len i32) (local $i1 i32) (local $i2 i32) + (local $f1 f64) (local $f2 f64) + (local $b (ref $float_array)) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $data (struct.get $bigarray $ba_data (local.get $ba))) + (block $float + (block $int + (block $int32 + (block $int64 + (block $complex32 + (block $complex64 + (br_table $float $float $int $int $int $int $int32 $int64 $int + $int32 $complex32 $complex64 $int + (struct.get $bigarray $ba_kind (local.get $ba)))) + ;; complex64 + (local.set $len (call $ta_length (local.get $data))) + (local.set $b (ref.cast (ref $float_array) (local.get $v))) + (local.set $f1 + (array.get $float_array (local.get $b) (i32.const 0))) + (local.set $f2 + (array.get $float_array (local.get $b) (i32.const 1))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $ta_set_f64 (local.get $data) (local.get $i) + (local.get $f1)) + (call $ta_set_f64 (local.get $data) + (i32.add (local.get $i) (i32.const 1)) + (local.get $f2)) + (local.set $i (i32.add (local.get $i) (i32.const 2))) + (br $loop)))) + (return (ref.i31 (i32.const 0)))) + ;; complex32 + (local.set $len (call $ta_length (local.get $data))) + (local.set $b (ref.cast (ref $float_array) (local.get $v))) + (local.set $f1 (array.get $float_array (local.get $b) (i32.const 0))) + (local.set $f2 (array.get $float_array (local.get $b) (i32.const 1))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $ta_set_f32 (local.get $data) (local.get $i) + (local.get $f1)) + (call $ta_set_f32 (local.get $data) + (i32.add (local.get $i) (i32.const 1)) + (local.get $f2)) + (local.set $i (i32.add (local.get $i) (i32.const 2))) + (br $loop)))) + (return (ref.i31 (i32.const 0)))) + ;; int64 + (local.set $len (call $ta_length (local.get $data))) + (local.set $l (call $Int64_val (local.get $v))) + (local.set $i1 (i32.wrap_i64 (local.get $l))) + (local.set $i2 + (i32.wrap_i64 (i64.shr_u (local.get $l) (i64.const 32)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $ta_set_i32 (local.get $data) (local.get $i) + (local.get $i1)) + (call $ta_set_i32 (local.get $data) + (i32.add (local.get $i) (i32.const 1)) + (local.get $i2)) + (local.set $i (i32.add (local.get $i) (i32.const 2))) + (br $loop)))) + (return (ref.i31 (i32.const 0)))) + ;; int32 + (call $ta_fill_int (local.get $data) (call $Int32_val (local.get $v))) + (return (ref.i31 (i32.const 0)))) + ;; int + (call $ta_fill_int (local.get $data) + (i31.get_s (ref.cast (ref i31) (local.get $v)))) + (return (ref.i31 (i32.const 0)))) + ;; float + (call $ta_fill_float (local.get $data) + (struct.get $float 0 (ref.cast (ref $float) (local.get $v)))) + (return (ref.i31 (i32.const 0)))) + + (data $dim_mismatch "Bigarray.blit: dimension mismatch") + + (func (export "caml_ba_blit") + (param $vsrc (ref eq)) (param $vdst (ref eq)) (result (ref eq)) + (local $src (ref $bigarray)) + (local $dst (ref $bigarray)) + (local $sdim (ref $int_array)) + (local $ddim (ref $int_array)) + (local $i i32) (local $len i32) + (local.set $src (ref.cast (ref $bigarray) (local.get $vsrc))) + (local.set $dst (ref.cast (ref $bigarray) (local.get $vdst))) + (local.set $len (struct.get $bigarray $ba_num_dims (local.get $dst))) + (if (i32.ne (local.get $len) + (struct.get $bigarray $ba_num_dims (local.get $src))) + (then + (call $caml_invalid_argument + (array.new_data $string $dim_mismatch + (i32.const 0) (i32.const 33))))) + (local.set $sdim (struct.get $bigarray $ba_dim (local.get $src))) + (local.set $ddim (struct.get $bigarray $ba_dim (local.get $dst))) + (loop $loop + (if (i32.lt_s (local.get $i) (local.get $len)) + (then + (if (i32.ne + (array.get $int_array (local.get $sdim) (local.get $i)) + (array.get $int_array (local.get $ddim) (local.get $i))) + (then + (call $caml_invalid_argument + (array.new_data $string $dim_mismatch + (i32.const 0) (i32.const 33))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (call $ta_blit + (struct.get $bigarray $ba_data (local.get $src)) + (struct.get $bigarray $ba_data (local.get $dst))) + (ref.i31 (i32.const 0))) + + (data $bad_number_dim "Bigarray.reshape: bad number of dimensions") + (data $negative_dim "Bigarray.reshape: negative dimension") + (data $size_mismatch "Bigarray.reshape: size mismatch") + + (func (export "caml_ba_reshape") + (param $vb (ref eq)) (param $vd (ref eq)) (result (ref eq)) + (local $vdim (ref $block)) + (local $num_dims i32) (local $num_elts i64) (local $i i32) (local $d i32) + (local $b (ref $bigarray)) + (local $dim (ref $int_array)) + (local.set $vdim (ref.cast (ref $block) (local.get $vd))) + (local.set $num_dims (i32.sub (array.len (local.get $vdim)) (i32.const 1))) + (local.set $b (ref.cast (ref $bigarray) (local.get $vb))) + (if (i32.gt_u (local.get $num_dims) (global.get $CAML_BA_MAX_NUM_DIMS)) + (then + (call $caml_invalid_argument + (array.new_data $string $bad_number_dim + (i32.const 0) (i32.const 42))))) + (local.set $num_elts (i64.const 1)) + (local.set $dim (array.new $int_array (i32.const 0) (local.get $num_dims))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $num_dims)) + (then + (local.set $d + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $vdim) + (i32.add (local.get $i) (i32.const 1)))))) + (if (i32.lt_s (local.get $d) (i32.const 0)) + (then + (call $caml_invalid_argument + (array.new_data $string $negative_dim + (i32.const 0) (i32.const 36))))) + (array.set $int_array (local.get $dim) (local.get $i) + (local.get $d)) + (local.set $num_elts + (i64.mul (local.get $num_elts) + (i64.extend_i32_s (local.get $d)))) + (if (i64.ne (local.get $num_elts) + (i64.extend_i32_s (i32.wrap_i64 (local.get $num_elts)))) + (then (call $caml_raise_out_of_memory))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (if (i32.ne (i32.wrap_i64 (local.get $num_elts)) + (call $caml_ba_get_size + (struct.get $bigarray $ba_dim (local.get $b)))) + (then + (call $caml_invalid_argument + (array.new_data $string $size_mismatch + (i32.const 0) (i32.const 31))))) + (struct.new $bigarray + (global.get $bigarray_ops) + (struct.get $bigarray $ba_data (local.get $b)) + (local.get $dim) + (local.get $num_dims) + (struct.get $bigarray $ba_kind (local.get $b)) + (struct.get $bigarray $ba_layout (local.get $b)))) + + (func (export "caml_ba_change_layout") + (param $vb (ref eq)) (param $vlayout (ref eq)) (result (ref eq)) + (local $b (ref $bigarray)) + (local $layout i32) (local $num_dims i32) (local $i i32) + (local $dim (ref $int_array)) (local $new_dim (ref $int_array)) + (local.set $b (ref.cast (ref $bigarray) (local.get $vb))) + (local.set $layout (i31.get_s (ref.cast (ref i31) (local.get $vlayout)))) + (if (result (ref eq)) + (i32.ne (struct.get $bigarray $ba_layout (local.get $b)) + (local.get $layout)) + (then + (local.set $num_dims + (struct.get $bigarray $ba_num_dims (local.get $b))) + (local.set $dim + (struct.get $bigarray $ba_dim (local.get $b))) + (local.set $new_dim + (array.new $int_array (i32.const 0) (local.get $num_dims))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $num_dims)) + (then + (array.set $int_array (local.get $new_dim) (local.get $i) + (array.get $int_array (local.get $dim) + (i32.sub + (i32.sub (local.get $num_dims) (local.get $i)) + (i32.const 1)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (struct.new $bigarray + (global.get $bigarray_ops) + (struct.get $bigarray $ba_data (local.get $b)) + (local.get $new_dim) + (local.get $num_dims) + (struct.get $bigarray $ba_kind (local.get $b)) + (local.get $layout))) + (else + (local.get $vb)))) + + (func (export "caml_ba_num_dims") (param (ref eq)) (result (ref eq)) + (ref.i31 + (struct.get $bigarray $ba_num_dims + (ref.cast (ref $bigarray) (local.get 0))))) + + (func (export "caml_ba_kind") (param (ref eq)) (result (ref eq)) + (ref.i31 + (struct.get $bigarray $ba_kind + (ref.cast (ref $bigarray) (local.get 0))))) + + (func (export "caml_ba_layout") (param (ref eq)) (result (ref eq)) + (ref.i31 + (struct.get $bigarray $ba_layout + (ref.cast (ref $bigarray) (local.get 0))))) + + (func $caml_ba_compare + (param $v1 (ref eq)) (param $v2 (ref eq)) (param $total i32) (result i32) + (local $b1 (ref $bigarray)) (local $b2 (ref $bigarray)) + (local $i1 i32) (local $i2 i32) (local $i i32) (local $len i32) + (local $f1 f64) (local $f2 f64) + (local $d1 (ref extern)) (local $d2 (ref extern)) + (local.set $b1 (ref.cast (ref $bigarray) (local.get $v1))) + (local.set $b2 (ref.cast (ref $bigarray) (local.get $v2))) + (if (i32.ne (struct.get $bigarray $ba_layout (local.get $b2)) + (struct.get $bigarray $ba_layout (local.get $b1))) + (then + (return + (i32.sub (struct.get $bigarray $ba_layout (local.get $b2)) + (struct.get $bigarray $ba_layout (local.get $b1)))))) + (if (i32.ne (struct.get $bigarray $ba_kind (local.get $b2)) + (struct.get $bigarray $ba_kind (local.get $b1))) + (then + (return + (i32.sub (struct.get $bigarray $ba_kind (local.get $b2)) + (struct.get $bigarray $ba_kind (local.get $b1)))))) + (if (i32.ne (struct.get $bigarray $ba_num_dims (local.get $b2)) + (struct.get $bigarray $ba_num_dims (local.get $b1))) + (then + (return + (i32.sub (struct.get $bigarray $ba_num_dims (local.get $b2)) + (struct.get $bigarray $ba_num_dims (local.get $b1)))))) + (local.set $len (struct.get $bigarray $ba_num_dims (local.get $b2))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $i1 + (array.get $int_array + (struct.get $bigarray $ba_dim (local.get $b1)) + (local.get $i))) + (local.set $i2 + (array.get $int_array + (struct.get $bigarray $ba_dim (local.get $b2)) + (local.get $i))) + (if (i32.ne (local.get $i1) (local.get $i2)) + (then + (return + (select (i32.const -1) (i32.const 1) + (i32.lt_u (local.get $i1) (local.get $i2)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.set $d1 (struct.get $bigarray $ba_data (local.get $b1))) + (local.set $d2 (struct.get $bigarray $ba_data (local.get $b2))) + (local.set $len (call $ta_length (local.get $d1))) + (local.set $i (i32.const 0)) + (block $float32 + (block $float64 + (block $int8 + (block $uint8 + (block $int16 + (block $uint16 + (block $int32 + (block $int64 + (br_table $float32 $float64 $int8 $uint8 $int16 $uint16 + $int32 $int64 $int32 $int32 + $float32 $float64 $uint8 + (struct.get $bigarray $ba_kind (local.get $b1)))) + ;; int64 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $i1 + (call $ta_get_i32 (local.get $d1) + (i32.add (local.get $i) (i32.const 1)))) + (local.set $i2 + (call $ta_get_i32 (local.get $d2) + (i32.add (local.get $i) (i32.const 1)))) + (if (i32.lt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const -1)))) + (if (i32.gt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const 1)))) + (local.set $i1 + (call $ta_get_i32 (local.get $d1) (local.get $i))) + (local.set $i2 + (call $ta_get_i32 (local.get $d2) (local.get $i))) + (if (i32.lt_u (local.get $i1) (local.get $i2)) + (then (return (i32.const -1)))) + (if (i32.gt_u (local.get $i1) (local.get $i2)) + (then (return (i32.const 1)))) + (local.set $i (i32.add (local.get $i) (i32.const 2))) + (br $loop)))) + (return (i32.const 0))) + ;; int32 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $i1 + (call $ta_get_i32 (local.get $d1) (local.get $i))) + (local.set $i2 + (call $ta_get_i32 (local.get $d2) (local.get $i))) + (if (i32.lt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const -1)))) + (if (i32.gt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const 1)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (i32.const 0))) + ;; uint16 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $i1 + (call $ta_get_ui16 (local.get $d1) (local.get $i))) + (local.set $i2 + (call $ta_get_ui16 (local.get $d2) (local.get $i))) + (if (i32.lt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const -1)))) + (if (i32.gt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const 1)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (i32.const 0))) + ;; int16 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $i1 + (call $ta_get_i16 (local.get $d1) (local.get $i))) + (local.set $i2 + (call $ta_get_i16 (local.get $d2) (local.get $i))) + (if (i32.lt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const -1)))) + (if (i32.gt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const 1)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (i32.const 0))) + ;; uint8 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $i1 + (call $ta_get_ui8 (local.get $d1) (local.get $i))) + (local.set $i2 + (call $ta_get_ui8 (local.get $d2) (local.get $i))) + (if (i32.lt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const -1)))) + (if (i32.gt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const 1)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (i32.const 0))) + ;; int8 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $i1 + (call $ta_get_i8 (local.get $d1) (local.get $i))) + (local.set $i2 + (call $ta_get_i8 (local.get $d2) (local.get $i))) + (if (i32.lt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const -1)))) + (if (i32.gt_s (local.get $i1) (local.get $i2)) + (then (return (i32.const 1)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (i32.const 0))) + ;; float64 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $f1 + (call $ta_get_f64 (local.get $d1) (local.get $i))) + (local.set $f2 + (call $ta_get_f64 (local.get $d2) (local.get $i))) + (if (f64.lt (local.get $f1) (local.get $f2)) + (then (return (i32.const -1)))) + (if (f64.gt (local.get $f1) (local.get $f2)) + (then (return (i32.const 1)))) + (if (f64.ne (local.get $f1) (local.get $f2)) + (then + (if (i32.eqz (local.get $total)) + (then (return (global.get $unordered)))) + (if (f64.eq (local.get $f1) (local.get $f1)) + (then (return (i32.const 1)))) + (if (f64.eq (local.get $f2) (local.get $f2)) + (then (return (i32.const -1)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (i32.const 0))) + ;; float32 + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $f1 + (call $ta_get_f32 (local.get $d1) (local.get $i))) + (local.set $f2 + (call $ta_get_f32 (local.get $d2) (local.get $i))) + (if (f64.lt (local.get $f1) (local.get $f2)) + (then (return (i32.const -1)))) + (if (f64.gt (local.get $f1) (local.get $f2)) + (then (return (i32.const 1)))) + (if (f64.ne (local.get $f1) (local.get $f2)) + (then + (if (i32.eqz (local.get $total)) + (then (return (global.get $unordered)))) + (if (f64.eq (local.get $f1) (local.get $f1)) + (then (return (i32.const 1)))) + (if (f64.eq (local.get $f2) (local.get $f2)) + (then (return (i32.const -1)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (i32.const 0))) + + (func (export "caml_ba_uint8_get16") + (param $vba (ref eq)) (param $i (ref eq)) (result (ref eq)) + (local $ba (ref $bigarray)) + (local $data (ref extern)) + (local $p i32) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $data (struct.get $bigarray $ba_data (local.get $ba))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 1)) + (array.get $int_array + (struct.get $bigarray $ba_dim (local.get $ba)) + (i32.const 0))) + (then (call $caml_bound_error))) + (ref.i31 (call $ta_get16_ui8 (local.get $data) (local.get $p)))) + + (func (export "caml_ba_uint8_get32") + (param $vba (ref eq)) (param $i (ref eq)) (result i32) + (local $ba (ref $bigarray)) + (local $data (ref extern)) + (local $p i32) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $data (struct.get $bigarray $ba_data (local.get $ba))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 3)) + (array.get $int_array + (struct.get $bigarray $ba_dim (local.get $ba)) + (i32.const 0))) + (then (call $caml_bound_error))) + (return_call $ta_get32_ui8 (local.get $data) (local.get $p))) + + (func (export "caml_ba_uint8_get64") + (param $vba (ref eq)) (param $i (ref eq)) (result i64) + (local $ba (ref $bigarray)) + (local $data (ref extern)) + (local $p i32) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $data (struct.get $bigarray $ba_data (local.get $ba))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 7)) + (array.get $int_array + (struct.get $bigarray $ba_dim (local.get $ba)) + (i32.const 0))) + (then (call $caml_bound_error))) + (i64.or + (i64.extend_i32_u + (call $ta_get32_ui8 (local.get $data) (local.get $p))) + (i64.shl (i64.extend_i32_u + (call $ta_get32_ui8 (local.get $data) + (i32.add (local.get $p) (i32.const 4)))) + (i64.const 32)))) + + (func (export "caml_ba_uint8_set16") + (param $vba (ref eq)) (param $i (ref eq)) (param $v (ref eq)) + (result (ref eq)) + (local $ba (ref $bigarray)) + (local $data (ref extern)) + (local $p i32) (local $d (ref i31)) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $data (struct.get $bigarray $ba_data (local.get $ba))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (local.set $d (ref.cast (ref i31) (local.get $v))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 1)) + (array.get $int_array + (struct.get $bigarray $ba_dim (local.get $ba)) + (i32.const 0))) + (then (call $caml_bound_error))) + (call $ta_set16_ui8 (local.get $data) (local.get $p) (local.get $d)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ba_uint8_set32") + (param $vba (ref eq)) (param $i (ref eq)) (param $d i32) + (result (ref eq)) + (local $ba (ref $bigarray)) + (local $data (ref extern)) + (local $p i32) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $data (struct.get $bigarray $ba_data (local.get $ba))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 3)) + (array.get $int_array + (struct.get $bigarray $ba_dim (local.get $ba)) + (i32.const 0))) + (then (call $caml_bound_error))) + (call $ta_set32_ui8 (local.get $data) (local.get $p) (local.get $d)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ba_uint8_set64") + (param $vba (ref eq)) (param $i (ref eq)) (param $d i64) + (result (ref eq)) + (local $ba (ref $bigarray)) + (local $data (ref extern)) + (local $p i32) + (local.set $ba (ref.cast (ref $bigarray) (local.get $vba))) + (local.set $data (struct.get $bigarray $ba_data (local.get $ba))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 7)) + (array.get $int_array + (struct.get $bigarray $ba_dim (local.get $ba)) + (i32.const 0))) + (then (call $caml_bound_error))) + (call $ta_set32_ui8 (local.get $data) (local.get $p) + (i32.wrap_i64 (local.get $d))) + (call $ta_set32_ui8 (local.get $data) + (i32.add (local.get $p) (i32.const 4)) + (i32.wrap_i64 (i64.shr_u (local.get $d) (i64.const 32)))) + (ref.i31 (i32.const 0))) + + (export "caml_bytes_of_array" (func $caml_string_of_array)) + (func $caml_string_of_array (export "caml_string_of_array") + (param (ref eq)) (result (ref eq)) + ;; used to convert a typed array to a string + (local $a (ref extern)) (local $len i32) + (local $s (ref $string)) + (local.set $a + (ref.as_non_null (extern.convert_any (call $unwrap (local.get 0))))) + (local.set $len (call $ta_length (local.get $a))) + (local.set $s (array.new $string (i32.const 0) (local.get $len))) + (call $ta_blit_to_string + (local.get $a) (i32.const 0) (local.get $s) (i32.const 0) + (local.get $len)) + (local.get $s)) + + (export "caml_uint8_array_of_bytes" (func $caml_uint8_array_of_string)) + (func $caml_uint8_array_of_string (export "caml_uint8_array_of_string") + (param (ref eq)) (result (ref eq)) + ;; Convert a string to a typed array + (local $ta (ref extern)) (local $len i32) + (local $s (ref $string)) + (local.set $s (ref.cast (ref $string) (local.get 0))) + (local.set $len (array.len (local.get $s))) + (local.set $ta + (call $ta_create + (i32.const 3) ;; Uint8Array + (local.get $len))) + (call $ta_blit_from_string + (local.get $s) (i32.const 0) (local.get $ta) (i32.const 0) + (local.get $len)) + (call $wrap (any.convert_extern (local.get $ta)))) + + (func (export "caml_ba_get_kind") (param (ref eq)) (result i32) + (struct.get $bigarray $ba_kind (ref.cast (ref $bigarray) (local.get 0)))) + + (func (export "caml_ba_get_layout") (param (ref eq)) (result i32) + (struct.get $bigarray $ba_layout + (ref.cast (ref $bigarray) (local.get 0)))) + + (func (export "caml_ba_get_data") (param (ref eq)) (result (ref extern)) + (struct.get $bigarray $ba_data (ref.cast (ref $bigarray) (local.get 0)))) + + (func (export "caml_ba_set_data") (param (ref eq)) (param (ref extern)) + (struct.set $bigarray $ba_data (ref.cast (ref $bigarray) (local.get 0)) + (local.get 1))) + + (func (export "caml_ba_get_dim") (param (ref eq)) (result (ref $int_array)) + (struct.get $bigarray $ba_dim (ref.cast (ref $bigarray) (local.get 0)))) + + (func (export "caml_ba_alloc") + (param $kind i32) (param $layout i32) (param $num_dims i32) + (param $data (ref extern)) (param $dim (ref $int_array)) + (result (ref eq)) + (struct.new $bigarray + (global.get $bigarray_ops) + (local.get $data) + (local.get $dim) + (local.get $num_dims) + (local.get $kind) + (local.get $layout))) + + (func (export "string_set") + (param $s externref) (param $i i32) (param $v i32) + (array.set $string + (ref.cast (ref null $string) (any.convert_extern (local.get $s))) + (local.get $i) (local.get $v))) + + (func (export "string_get") + (param $s externref) (param $i i32) (result i32) + (array.get $string + (ref.cast (ref null $string) (any.convert_extern (local.get $s))) + (local.get $i))) +) diff --git a/runtime/wasm/bigstring.wat b/runtime/wasm/bigstring.wat new file mode 100644 index 0000000000..94a9621743 --- /dev/null +++ b/runtime/wasm/bigstring.wat @@ -0,0 +1,262 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "jslib" "caml_js_get" + (func $caml_js_get (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "bigarray" "caml_ba_to_typed_array" + (func $caml_ba_to_typed_array (param (ref eq)) (result (ref eq)))) + (import "bigarray" "caml_ba_from_typed_array" + (func $caml_ba_from_typed_array (param (ref eq)) (result (ref eq)))) + (import "bigarray" "caml_ba_sub" + (func $caml_ba_sub + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "bigarray" "caml_ba_fill" + (func $caml_ba_fill (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "bigarray" "caml_ba_get_data" + (func $caml_ba_get_data (param (ref eq)) (result (ref extern)))) + (import "bindings" "ta_create" + (func $ta_create (param i32) (param anyref) (result anyref))) + (import "bindings" "ta_get_ui8" + (func $ta_get_ui8 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_get32_ui8" + (func $ta_get32_ui8 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_set_ui8" + (func $ta_set_ui8 (param (ref extern)) (param i32) (param (ref i31)))) + (import "bindings" "ta_subarray" + (func $ta_subarray + (param (ref extern)) (param i32) (param i32) (result (ref extern)))) + (import "bindings" "ta_set" + (func $ta_set (param (ref extern)) (param (ref extern)) (param i32))) + (import "bindings" "ta_length" + (func $ta_length (param (ref extern)) (result i32))) + (import "bindings" "ta_bytes" + (func $ta_bytes (param anyref) (result anyref))) + (import "bindings" "ta_blit_from_string" + (func $ta_blit_from_string + (param (ref $string)) (param i32) (param (ref extern)) (param i32) + (param i32))) + (import "bindings" "ta_blit_to_string" + (func $ta_blit_to_string + (param (ref extern)) (param i32) (param (ref $string)) (param i32) + (param i32))) + (import "hash" "caml_hash_mix_int" + (func $caml_hash_mix_int (param i32) (param i32) (result i32))) + + (type $string (array (mut i8))) + + (func (export "caml_hash_mix_bigstring") + (param $h i32) (param $b (ref eq)) (result i32) + (local $data (ref extern)) + (local $len i32) (local $i i32) (local $w i32) + (local.set $data (call $caml_ba_get_data (local.get $b))) + (local.set $len (call $ta_length (local.get $data))) + (loop $loop + (if (i32.le_u (i32.add (local.get $i) (i32.const 4)) (local.get $len)) + (then + (local.set $h + (call $caml_hash_mix_int + (local.get $h) + (call $ta_get32_ui8 (local.get $data) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 4))) + (br $loop)))) + (local.set $w (i32.const 0)) + (block $0_bytes + (block $1_byte + (block $2_bytes + (block $3_bytes + (br_table $0_bytes $1_byte $2_bytes $3_bytes + (i32.and (local.get $len) (i32.const 3)))) + (local.set $w + (i32.shl (call $ta_get_ui8 (local.get $data) + (i32.add (local.get $i) (i32.const 2))) + (i32.const 16)))) + (local.set $w + (i32.or (local.get $w) + (i32.shl (call $ta_get_ui8 (local.get $data) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8))))) + (local.set $w + (i32.or (local.get $w) + (call $ta_get_ui8 (local.get $data) (local.get $i)))) + (local.set $h (call $caml_hash_mix_int (local.get $h) (local.get $w)))) + (i32.xor (local.get $h) (local.get $len))) + + (data $buffer "buffer") + + (func (export "bigstring_to_array_buffer") + (param $bs (ref eq)) (result (ref eq)) + (return_call $caml_js_get + (call $caml_ba_to_typed_array (local.get $bs)) + (array.new_data $string $buffer (i32.const 0) (i32.const 6)))) + + (export "bigstring_to_typed_array" (func $caml_ba_to_typed_array)) + + (func (export "bigstring_of_array_buffer") (param (ref eq)) (result (ref eq)) + (return_call $caml_ba_from_typed_array + (call $wrap + (call $ta_create (i32.const 12) (call $unwrap (local.get 0)))))) + + (func (export "bigstring_of_typed_array") (param (ref eq)) (result (ref eq)) + (return_call $caml_ba_from_typed_array + (call $wrap (call $ta_bytes (call $unwrap (local.get 0)))))) + + (func (export "caml_bigstring_memset") + (param $s (ref eq)) (param $pos (ref eq)) (param $len (ref eq)) + (param $v (ref eq)) (result (ref eq)) + (return_call $caml_ba_fill + (call $caml_ba_sub (local.get $s) (local.get $pos) (local.get $len)) + (local.get $v))) + + (func (export "caml_bigstring_memcmp") + (param $s1 (ref eq)) (param $vpos1 (ref eq)) + (param $s2 (ref eq)) (param $vpos2 (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $i i32) (local $pos1 i32) (local $pos2 i32) (local $len i32) + (local $c1 i32) (local $c2 i32) + (local $d1 (ref extern)) + (local $d2 (ref extern)) + (local.set $d1 (call $caml_ba_get_data (local.get $s1))) + (local.set $pos1 (i31.get_s (ref.cast (ref i31) (local.get $vpos1)))) + (local.set $d2 (call $caml_ba_get_data (local.get $s2))) + (local.set $pos2 (i31.get_s (ref.cast (ref i31) (local.get $vpos2)))) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $c1 + (call $ta_get_ui8 (local.get $d1) + (i32.add (local.get $pos1) (local.get $i)))) + (local.set $c2 + (call $ta_get_ui8 (local.get $d2) + (i32.add (local.get $pos2) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.eq (local.get $c1) (local.get $c2))) + (return + (select (ref.i31 (i32.const -1)) (ref.i31 (i32.const 1)) + (i32.lt_u (local.get $c1) (local.get $c2))))))) + (ref.i31 (i32.const 0))) + + (func (export "caml_bigstring_memcmp_string") + (param $s1 (ref eq)) (param $vpos1 (ref eq)) + (param $vs2 (ref eq)) (param $vpos2 (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $i i32) (local $pos1 i32) (local $pos2 i32) (local $len i32) + (local $c1 i32) (local $c2 i32) + (local $d1 (ref extern)) + (local $s2 (ref $string)) + (local.set $d1 (call $caml_ba_get_data (local.get $s1))) + (local.set $pos1 (i31.get_s (ref.cast (ref i31) (local.get $vpos1)))) + (local.set $s2 (ref.cast (ref $string) (local.get $vs2))) + (local.set $pos2 (i31.get_s (ref.cast (ref i31) (local.get $vpos2)))) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $c1 + (call $ta_get_ui8 (local.get $d1) + (i32.add (local.get $pos1) (local.get $i)))) + (local.set $c2 + (array.get_u $string (local.get $s2) + (i32.add (local.get $pos2) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.eq (local.get $c1) (local.get $c2))) + (return + (select (ref.i31 (i32.const -1)) (ref.i31 (i32.const 1)) + (i32.lt_u (local.get $c1) (local.get $c2))))))) + (ref.i31 (i32.const 0))) + + (func (export "caml_bigstring_memchr") + (param $s (ref eq)) (param $vc (ref eq)) + (param $vpos (ref eq)) (param $vlen (ref eq)) (result (ref eq)) + (local $pos i32) (local $len i32) (local $c i32) + (local $d (ref extern)) + (local.set $c (i31.get_s (ref.cast (ref i31) (local.get $vc)))) + (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (local.set $d (call $caml_ba_get_data (local.get $s))) + (loop $loop + (if (i32.gt_s (local.get $len) (i32.const 0)) + (then + (if (i32.eq (local.get $c) + (call $ta_get_ui8 (local.get $d) (local.get $pos))) + (then + (return (ref.i31 (local.get $pos))))) + (local.set $len (i32.sub (local.get $len) (i32.const 1))) + (local.set $pos (i32.add (local.get $pos) (i32.const 1))) + (br $loop)))) + (ref.i31 (i32.const -1))) + + (export "caml_bigstring_blit_string_to_ba" + (func $caml_bigstring_blit_bytes_to_ba)) + (func $caml_bigstring_blit_bytes_to_ba + (export "caml_bigstring_blit_bytes_to_ba") + (param $str1 (ref eq)) (param $vpos1 (ref eq)) + (param $ba2 (ref eq)) (param $vpos2 (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $pos1 i32) (local $pos2 i32) (local $len i32) + (local $s1 (ref $string)) + (local $d2 (ref extern)) + (local.set $s1 (ref.cast (ref $string) (local.get $str1))) + (local.set $pos1 (i31.get_s (ref.cast (ref i31) (local.get $vpos1)))) + (local.set $d2 (call $caml_ba_get_data (local.get $ba2))) + (local.set $pos2 (i31.get_s (ref.cast (ref i31) (local.get $vpos2)))) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (call $ta_blit_from_string + (local.get $s1) (local.get $pos1) + (local.get $d2) (local.get $pos2) + (local.get $len)) + (ref.i31 (i32.const 0))) + + (func (export "caml_bigstring_blit_ba_to_bytes") + (param $ba1 (ref eq)) (param $vpos1 (ref eq)) + (param $str2 (ref eq)) (param $vpos2 (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $pos1 i32) (local $pos2 i32) (local $len i32) + (local $d1 (ref extern)) + (local $s2 (ref $string)) + (local.set $d1 (call $caml_ba_get_data (local.get $ba1))) + (local.set $pos1 (i31.get_s (ref.cast (ref i31) (local.get $vpos1)))) + (local.set $s2 (ref.cast (ref $string) (local.get $str2))) + (local.set $pos2 (i31.get_s (ref.cast (ref i31) (local.get $vpos2)))) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (call $ta_blit_to_string + (local.get $d1) (local.get $pos1) + (local.get $s2) (local.get $pos2) + (local.get $len)) + (ref.i31 (i32.const 0))) + + (func (export "caml_bigstring_blit_ba_to_ba") + (param $ba1 (ref eq)) (param $vpos1 (ref eq)) + (param $ba2 (ref eq)) (param $vpos2 (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $pos1 i32) (local $pos2 i32) (local $len i32) + (local $d1 (ref extern)) + (local $d2 (ref extern)) + (local.set $d1 (call $caml_ba_get_data (local.get $ba1))) + (local.set $pos1 (i31.get_s (ref.cast (ref i31) (local.get $vpos1)))) + (local.set $d2 (call $caml_ba_get_data (local.get $ba2))) + (local.set $pos2 (i31.get_s (ref.cast (ref i31) (local.get $vpos2)))) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (call $ta_set (local.get $d2) + (call $ta_subarray (local.get $d1) + (local.get $pos1) (i32.add (local.get $pos1) (local.get $len))) + (local.get $pos2)) + (ref.i31 (i32.const 0))) +) diff --git a/runtime/wasm/compare.wat b/runtime/wasm/compare.wat new file mode 100644 index 0000000000..affa2a2765 --- /dev/null +++ b/runtime/wasm/compare.wat @@ -0,0 +1,614 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "bindings" "equals" + (func $equals (param anyref) (param anyref) (result i32))) + (import "obj" "forward_tag" (global $forward_tag i32)) + (import "obj" "object_tag" (global $object_tag i32)) + (import "obj" "double_array_tag" (global $double_array_tag i32)) + (import "obj" "caml_obj_tag" + (func $caml_obj_tag (param (ref eq)) (result (ref eq)))) + (import "obj" "caml_is_closure" + (func $caml_is_closure (param (ref eq)) (result i32))) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + (import "effect" "caml_is_continuation" + (func $caml_is_continuation (param (ref eq)) (result i32))) + (import "string" "caml_string_compare" + (func $caml_string_compare + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "jsstring" "jsstring_test" + (func $jsstring_test (param anyref) (result i32))) + (import "jsstring" "jsstring_compare" + (func $jsstring_compare (param anyref) (param anyref) (result i32))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $float (struct (field f64))) + (type $float_array (array (mut f64))) + (type $js (struct (field anyref))) + + (type $int_array (array (mut i32))) + (type $block_array (array (mut (ref $block)))) + (type $compare_stack + (struct (field (mut i32)) ;; position in stack + (field (ref $block_array)) ;; first value + (field (ref $block_array)) ;; second value + (field (ref $int_array)))) ;; position in value + + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $dup (func (param (ref eq)) (result (ref eq)))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)) + (field $dup (ref null $dup)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + + (global $dummy_block (ref $block) + (array.new $block (ref.i31 (i32.const 0)) (i32.const 0))) + + (global $default_compare_stack (ref $compare_stack) + (struct.new $compare_stack (i32.const -1) + (array.new $block_array (global.get $dummy_block) (i32.const 8)) + (array.new $block_array (global.get $dummy_block) (i32.const 8)) + (array.new $int_array (i32.const 0) (i32.const 8)))) + + (func $compare_stack_is_not_empty + (param $stack (ref $compare_stack)) (result i32) + (i32.ge_s (struct.get $compare_stack 0 (local.get $stack)) (i32.const 0))) + + (func $pop_compare_stack (param $stack (ref $compare_stack)) + (result (ref eq)) (result (ref eq)) + (local $i i32) (local $p i32) (local $p' i32) + (local $v1 (ref $block)) (local $v2 (ref $block)) + (local.set $i (struct.get $compare_stack 0 (local.get $stack))) + (local.set $p + (array.get $int_array (struct.get $compare_stack 3 (local.get $stack)) + (local.get $i))) + (local.set $p' (i32.add (local.get $p) (i32.const 1))) + (array.set $int_array (struct.get $compare_stack 3 (local.get $stack)) + (local.get $i) (local.get $p')) + (local.set $v1 + (array.get $block_array + (struct.get $compare_stack 1 (local.get $stack)) (local.get $i))) + (local.set $v2 + (array.get $block_array + (struct.get $compare_stack 2 (local.get $stack)) (local.get $i))) + (if (i32.eq (local.get $p') (array.len (local.get $v1))) + (then + (array.set $block_array + (struct.get $compare_stack 1 (local.get $stack)) + (local.get $i) (global.get $dummy_block)) + (array.set $block_array + (struct.get $compare_stack 2 (local.get $stack)) + (local.get $i) (global.get $dummy_block)) + (struct.set $compare_stack 0 (local.get $stack) + (i32.sub (local.get $i) (i32.const 1))))) + (tuple.make 2 + (array.get $block (local.get $v1) (local.get $p)) + (array.get $block (local.get $v2) (local.get $p)))) + + (func $push_compare_stack (param $stack (ref $compare_stack)) + (param $v1 (ref $block)) (param $v2 (ref $block)) (param $p i32) + (result (ref $compare_stack)) + (local $i i32) (local $len i32) (local $len' i32) + (local $stack' (ref $compare_stack)) + (local.set $i + (i32.add (struct.get $compare_stack 0 (local.get $stack)) + (i32.const 1))) + (local.set $len + (array.len (struct.get $compare_stack 1 (local.get $stack)))) + (if (i32.ge_u (local.get $i) (local.get $len)) + (then + (local.set $len' (i32.shl (local.get $len) (i32.const 1))) + (local.set $stack' + (struct.new $compare_stack (local.get $i) + (array.new $block_array + (global.get $dummy_block) (local.get $len')) + (array.new $block_array + (global.get $dummy_block) (local.get $len')) + (array.new $int_array (i32.const 0) (local.get $len')))) + (array.copy $block_array $block_array + (struct.get $compare_stack 1 (local.get $stack')) (i32.const 0) + (struct.get $compare_stack 1 (local.get $stack)) (i32.const 0) + (local.get $len)) + (array.copy $block_array $block_array + (struct.get $compare_stack 2 (local.get $stack')) (i32.const 0) + (struct.get $compare_stack 2 (local.get $stack)) (i32.const 0) + (local.get $len)) + (array.copy $int_array $int_array + (struct.get $compare_stack 3 (local.get $stack')) (i32.const 0) + (struct.get $compare_stack 3 (local.get $stack)) (i32.const 0) + (local.get $len)) + (local.set $stack (local.get $stack')))) + (struct.set $compare_stack 0 (local.get $stack) (local.get $i)) + (array.set $block_array (struct.get $compare_stack 1 (local.get $stack)) + (local.get $i) (local.get $v1)) + (array.set $block_array (struct.get $compare_stack 2 (local.get $stack)) + (local.get $i) (local.get $v2)) + (array.set $int_array (struct.get $compare_stack 3 (local.get $stack)) + (local.get $i) (local.get $p)) + (local.get $stack)) + + (global $unordered (export "unordered") i32 (i32.const 0x80000000)) + + (func $compare_strings + (param $s1 (ref $string)) (param $s2 (ref $string)) (result i32) + (local $l1 i32) (local $l2 i32) (local $len i32) (local $i i32) + (local $c1 i32) (local $c2 i32) + (if (ref.eq (local.get $s1) (local.get $s2)) + (then (return (i32.const 0)))) + (local.set $l1 (array.len (local.get $s1))) + (local.set $l2 (array.len (local.get $s2))) + (local.set $len (select (local.get $l1) (local.get $l2) + (i32.le_u (local.get $l1) (local.get $l2)))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_s (local.get $i) (local.get $len)) + (then + (local.set $c1 + (array.get_u $string (local.get $s1) (local.get $i))) + (local.set $c2 + (array.get_u $string (local.get $s2) (local.get $i))) + (if (i32.ne (local.get $c1) (local.get $c2)) + (then + (if (i32.le_u (local.get $c1) (local.get $c2)) + (then (return (i32.const -1))) + (else (return (i32.const 1)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (i32.sub (local.get $l1) (local.get $l2))) + + (func $clear_compare_stack + ;; clear stack (to avoid memory leaks) + (local $stack (ref $compare_stack)) (local $n i32) (local $res i32) + (local.set $stack (global.get $default_compare_stack)) + (local.set $n (struct.get $compare_stack 0 (local.get $stack))) + (if (i32.ge_s (local.get $n) (i32.const 0)) + (then + (local.set $n (i32.add (local.get $n) (i32.const 1))) + (array.fill $block_array + (struct.get $compare_stack 1 (local.get $stack)) + (i32.const 0) (global.get $dummy_block) (local.get $n)) + (array.fill $block_array + (struct.get $compare_stack 2 (local.get $stack)) + (i32.const 0) (global.get $dummy_block) (local.get $n))))) + + (func $compare_val + (param $v1 (ref eq)) (param $v2 (ref eq)) (param $total i32) + (result i32) + (local $stack (ref $compare_stack)) (local $n i32) (local $res i32) + (local.set $stack (global.get $default_compare_stack)) + (struct.set $compare_stack 0 (local.get $stack) (i32.const -1)) + (local.set $res + (call $do_compare_val + (local.get $stack) (local.get $v1) (local.get $v2) + (local.get $total))) + (call $clear_compare_stack) + (local.get $res)) + + (data $abstract_value "compare: abstract value") + (data $functional_value "compare: functional value") + (data $continuation_value "compare: continuation value") + + (func $do_compare_val + (param $stack (ref $compare_stack)) + (param $v1 (ref eq)) (param $v2 (ref eq)) (param $total i32) (result i32) + (local $i i32) (local $i1 (ref i31)) (local $i2 (ref i31)) + (local $b1 (ref $block)) (local $b2 (ref $block)) + (local $t1 i32) (local $t2 i32) + (local $s1 i32) (local $s2 i32) + (local $f1 f64) (local $f2 f64) + (local $fa1 (ref $float_array)) (local $fa2 (ref $float_array)) + (local $str1 (ref $string)) (local $str2 (ref $string)) + (local $c1 (ref $custom)) (local $c2 (ref $custom)) + (local $js1 anyref) (local $js2 anyref) + (local $tuple (tuple (ref eq) (ref eq))) + (local $res i32) + (loop $loop + (block $next_item + (if (local.get $total) + (then + (br_if $next_item (ref.eq (local.get $v1) (local.get $v2))))) + (drop (block $v1_is_not_int (result (ref eq)) + (local.set $i1 + (br_on_cast_fail $v1_is_not_int (ref eq) (ref i31) + (local.get $v1))) + (br_if $next_item (ref.eq (local.get $v1) (local.get $v2))) + (drop (block $v2_is_not_int (result (ref eq)) + (local.set $i2 + (br_on_cast_fail $v2_is_not_int (ref eq) (ref i31) + (local.get $v2))) + ;; v1 and v2 are both integers + (return (i32.sub (i31.get_s (local.get $i1)) + (i31.get_s (local.get $i2)))))) + ;; check for forward tag + (drop (block $v2_not_forward (result (ref eq)) + (local.set $b2 + (br_on_cast_fail $v2_not_forward (ref eq) (ref $block) + (local.get $v2))) + (local.set $t2 + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $b2) + (i32.const 0))))) + (if (i32.eq (local.get $t2) (global.get $forward_tag)) + (then + (local.set $v2 + (array.get $block (local.get $b2) (i32.const 1))) + (br $loop))) + (ref.i31 (i32.const 1)))) + (block $v2_not_comparable + (drop (block $v2_not_custom (result (ref eq)) + (local.set $c2 + (br_on_cast_fail $v2_not_custom (ref eq) (ref $custom) + (local.get $v2))) + (local.set $res + (call_ref $compare + (local.get $v1) (local.get $v2) (local.get $total) + (br_on_null $v2_not_comparable + (struct.get $custom_operations $compare_ext + (struct.get $custom 0 (local.get $c2)))))) + (br_if $next_item (i32.eqz (local.get $res))) + (return (local.get $res))))) + ;; v1 long < v2 block + (return (i32.const -1)))) + (if (ref.test (ref i31) (local.get $v2)) + (then + ;; check for forward tag + (drop (block $v1_not_forward (result (ref eq)) + (local.set $b1 + (br_on_cast_fail $v1_not_forward (ref eq) (ref $block) + (local.get $v1))) + (local.set $t1 + (i31.get_u (ref.cast (ref i31) + (array.get $block (local.get $b1) + (i32.const 0))))) + (if (i32.eq (local.get $t1) (global.get $forward_tag)) + (then + (local.set $v1 + (array.get $block (local.get $b1) (i32.const 1))) + (br $loop))) + (ref.i31 (i32.const 1)))) + (block $v1_not_comparable + (drop (block $v1_not_custom (result (ref eq)) + (local.set $c1 + (br_on_cast_fail + $v1_not_custom (ref eq) (ref $custom) + (local.get $v1))) + (local.set $res + (call_ref $compare + (local.get $v1) (local.get $v2) (local.get $total) + (br_on_null $v1_not_comparable + (struct.get $custom_operations $compare_ext + (struct.get $custom 0 (local.get $c1)))))) + (br_if $next_item (i32.eqz (local.get $res))) + (return (local.get $res))))) + ;; v1 block > v1 long + (return (i32.const 1)))) + (drop (block $heterogeneous (result (ref eq)) + (drop (block $v1_not_block (result (ref eq)) + (local.set $b1 + (br_on_cast_fail $v1_not_block (ref eq) (ref $block) + (local.get $v1))) + (local.set $t1 + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $b1) (i32.const 0))))) + (local.set $b2 + (br_on_cast_fail $heterogeneous (ref eq) (ref $block) + (local.get $v2))) + (local.set $t2 + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $b2) (i32.const 0))))) + (drop (br_if $heterogeneous (ref.i31 (i32.const 0)) + (i32.ne (local.get $t1) (local.get $t2)))) + ;; forward tag + (if (i32.eq (local.get $t1) (global.get $forward_tag)) + (then + (local.set $v1 + (array.get $block (local.get $b1) (i32.const 1))) + (local.set $v2 + (array.get $block (local.get $b2) (i32.const 1))) + (br $loop))) + (if (i32.eq (local.get $t1) (global.get $object_tag)) + (then + (local.set $v1 + (array.get $block (local.get $b1) (i32.const 2))) + (local.set $v2 + (array.get $block (local.get $b2) (i32.const 2))) + (br_if $next_item + (ref.eq (local.get $v1) (local.get $v2))) + (return + (i32.sub + (i31.get_s (ref.cast (ref i31) (local.get $v1))) + (i31.get_s + (ref.cast (ref i31) (local.get $v2))))))) + (local.set $s1 (array.len (local.get $b1))) + (local.set $s2 (array.len (local.get $b2))) + ;; compare size first + (if (i32.ne (local.get $s1) (local.get $s2)) + (then + (return (i32.sub (local.get $s1) (local.get $s2))))) + (br_if $next_item (i32.eq (local.get $s1) (i32.const 1))) + (if (i32.gt_u (local.get $s1) (i32.const 2)) + (then + (local.set $stack + (call $push_compare_stack (local.get $stack) + (local.get $b1) (local.get $b2) (i32.const 2))))) + (local.set $v1 + (array.get $block (local.get $b1) (i32.const 1))) + (local.set $v2 + (array.get $block (local.get $b2) (i32.const 1))) + (br $loop))) + (drop (block $v1_not_float (result (ref eq)) + (local.set $f1 + (struct.get $float 0 + (br_on_cast_fail $v1_not_float (ref eq) (ref $float) + (local.get $v1)))) + (local.set $f2 + (struct.get $float 0 + (br_on_cast_fail $heterogeneous (ref eq) (ref $float) + (local.get $v2)))) + (if (f64.lt (local.get $f1) (local.get $f2)) + (then (return (i32.const -1)))) + (if (f64.gt (local.get $f1) (local.get $f2)) + (then (return (i32.const 1)))) + (if (f64.ne (local.get $f1) (local.get $f2)) + (then + (if (i32.eqz (local.get $total)) + (then (return (global.get $unordered)))) + (if (f64.eq (local.get $f1) (local.get $f1)) + (then (return (i32.const 1)))) + (if (f64.eq (local.get $f2) (local.get $f2)) + (then (return (i32.const -1)))))) + (br $next_item))) + (drop (block $v1_not_string (result (ref eq)) + (local.set $str1 + (br_on_cast_fail $v1_not_string (ref eq) (ref $string) + (local.get $v1))) + (local.set $str2 + (br_on_cast_fail $heterogeneous (ref eq) (ref $string) + (local.get $v2))) + (local.set $res + (call $compare_strings (local.get $str1) (local.get $str2))) + (br_if $next_item (i32.eqz (local.get $res))) + (return (local.get $res)))) + (drop (block $v1_not_float_array (result (ref eq)) + (local.set $fa1 + (br_on_cast_fail $v1_not_float_array + (ref eq) (ref $float_array) + (local.get $v1))) + (local.set $fa2 + (br_on_cast_fail $heterogeneous + (ref eq) (ref $float_array) + (local.get $v2))) + (local.set $s1 (array.len (local.get $fa1))) + (local.set $s2 (array.len (local.get $fa2))) + (if (i32.ne (local.get $s1) (local.get $s2)) + (then + (return (i32.sub (local.get $s1) (local.get $s2))))) + (local.set $i (i32.const 0)) + (loop $float_array + (if (i32.lt_s (local.get $i) (local.get $s1)) + (then + (local.set $f1 + (array.get $float_array (local.get $fa1) + (local.get $i))) + (local.set $f2 + (array.get $float_array (local.get $fa2) + (local.get $i))) + (if (f64.lt (local.get $f1) (local.get $f2)) + (then (return (i32.const -1)))) + (if (f64.gt (local.get $f1) (local.get $f2)) + (then (return (i32.const 1)))) + (if (f64.ne (local.get $f1) (local.get $f2)) + (then + (if (i32.eqz (local.get $total)) + (then + (return (global.get $unordered)))) + (if (f64.eq (local.get $f1) + (local.get $f1)) + (then (return (i32.const 1)))) + (if (f64.eq (local.get $f2) + (local.get $f2)) + (then (return (i32.const -1)))))) + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (br $float_array)))) + (br $next_item))) + (drop (block $v1_not_custom (result (ref eq)) + (local.set $c1 + (br_on_cast_fail $v1_not_custom (ref eq) (ref $custom) + (local.get $v1))) + (local.set $c2 + (br_on_cast_fail $heterogeneous (ref eq) (ref $custom) + (local.get $v2))) + (if (i32.eqz + (ref.eq (struct.get $custom 0 (local.get $c1)) + (struct.get $custom 0 (local.get $c2)))) + (then + (return + (i31.get_s + (ref.cast (ref i31) + (call $caml_string_compare + (struct.get $custom_operations $id + (struct.get $custom 0 + (local.get $c1))) + (struct.get $custom_operations $id + (struct.get $custom 0 + (local.get $c2))))))))) + (block $not_comparable + (local.set $res + (call_ref $compare + (local.get $v1) (local.get $v2) (local.get $total) + (br_on_null $not_comparable + (struct.get $custom_operations $compare + (struct.get $custom 0 (local.get $c1)))))) + (br_if $next_item (i32.eqz (local.get $res))) + (return (local.get $res))) + (call $clear_compare_stack) + (call $caml_invalid_argument + (array.new_data $string $abstract_value + (i32.const 0) (i32.const 23))) + (ref.i31 (i32.const 0)))) + (drop (block $v1_not_js (result (ref eq)) + (local.set $js1 + (struct.get $js 0 + (br_on_cast_fail $v1_not_js (ref eq) (ref $js) + (local.get $v1)))) + (local.set $js2 + (struct.get $js 0 + (br_on_cast_fail $heterogeneous (ref eq) (ref $js) + (local.get $v2)))) + (block $not_jsstring + (br_if $not_jsstring + (i32.eqz (call $jsstring_test (local.get $js1)))) + (br_if $not_jsstring + (i32.eqz (call $jsstring_test (local.get $js2)))) + (local.set $res + (call $jsstring_compare + (local.get $js1) (local.get $js2))) + (br_if $next_item (i32.eqz (local.get $res))) + (return (local.get $res))) + ;; We cannot order two JavaScript objects, + ;; but we can tell whether they are equal or not + (if (i32.eqz (local.get $total)) + (then + (br_if $next_item + (call $equals (local.get $js1) (local.get $js2))) + (return (global.get $unordered)))) + (br $heterogeneous (ref.i31 (i32.const 0))))) + (if (call $caml_is_closure (local.get $v1)) + (then + (drop (br_if $heterogeneous (ref.i31 (i32.const 0)) + (i32.eqz (call $caml_is_closure (local.get $v2))))) + (call $clear_compare_stack) + (call $caml_invalid_argument + (array.new_data $string $functional_value + (i32.const 0) (i32.const 25))))) + (if (call $caml_is_continuation (local.get $v1)) + (then + (drop (br_if $heterogeneous(ref.i31 (i32.const 0)) + (i32.eqz + (call $caml_is_continuation (local.get $v2))))) + (call $clear_compare_stack) + (call $caml_invalid_argument + (array.new_data $string $continuation_value + (i32.const 0) (i32.const 27))))) + (ref.i31 (i32.const 0)))) ;; fall through + ;; heterogeneous comparison + (local.set $t1 + (i31.get_u + (ref.cast (ref i31) (call $caml_obj_tag (local.get $v1))))) + (local.set $t2 + (i31.get_u + (ref.cast (ref i31) (call $caml_obj_tag (local.get $v2))))) + (if (i32.eq (local.get $t1) (global.get $forward_tag)) + (then + (local.set $v1 + (array.get $block (ref.cast (ref $block) (local.get $v1)) + (i32.const 1))) + (br $loop))) + (if (i32.eq (local.get $t2) (global.get $forward_tag)) + (then + (local.set $v2 + (array.get $block (ref.cast (ref $block) (local.get $v2)) + (i32.const 1))) + (br $loop))) + (local.set $res (i32.sub (local.get $t1) (local.get $t2))) + (if (i32.eqz (local.get $res)) + (then + (call $clear_compare_stack) + (call $caml_invalid_argument + (array.new_data $string $abstract_value + (i32.const 0) (i32.const 23))))) + (return (local.get $res))) + (if (call $compare_stack_is_not_empty (local.get $stack)) + (then + (local.set $tuple (call $pop_compare_stack (local.get $stack))) + (local.set $v1 (tuple.extract 2 0 (local.get $tuple))) + (local.set $v2 (tuple.extract 2 1 (local.get $tuple))) + (br $loop)))) + (i32.const 0)) + + (func (export "caml_compare") + (param $v1 (ref eq)) (param $v2 (ref eq)) (result (ref eq)) + (local $res i32) + (local.set $res + (call $compare_val (local.get $v1) (local.get $v2) (i32.const 1))) + (if (i32.lt_s (local.get $res) (i32.const 0)) + (then (return (ref.i31 (i32.const -1))))) + (if (i32.gt_s (local.get $res) (i32.const 0)) + (then (return (ref.i31 (i32.const 1))))) + (ref.i31 (i32.const 0))) + + (func (export "caml_equal") + (param $v1 (ref eq)) (param $v2 (ref eq)) (result (ref eq)) + (ref.i31 + (i32.eqz + (call $compare_val (local.get $v1) (local.get $v2) (i32.const 0))))) + + (func (export "caml_notequal") + (param $v1 (ref eq)) (param $v2 (ref eq)) (result (ref eq)) + (ref.i31 + (i32.ne (i32.const 0) + (call $compare_val (local.get $v1) (local.get $v2) (i32.const 0))))) + + (func (export "caml_lessthan") + (param $v1 (ref eq)) (param $v2 (ref eq)) (result (ref eq)) + (local $res i32) + (local.set $res + (call $compare_val (local.get $v1) (local.get $v2) (i32.const 0))) + (ref.i31 + (i32.and (i32.lt_s (local.get $res) (i32.const 0)) + (i32.ne (local.get $res) (global.get $unordered))))) + + (func (export "caml_lessequal") + (param $v1 (ref eq)) (param $v2 (ref eq)) (result (ref eq)) + (local $res i32) + (local.set $res + (call $compare_val (local.get $v1) (local.get $v2) (i32.const 0))) + (ref.i31 + (i32.and (i32.le_s (local.get $res) (i32.const 0)) + (i32.ne (local.get $res) (global.get $unordered))))) + + (func (export "caml_greaterthan") + (param $v1 (ref eq)) (param $v2 (ref eq)) (result (ref eq)) + (ref.i31 (i32.lt_s (i32.const 0) + (call $compare_val (local.get $v1) (local.get $v2) (i32.const 0))))) + + (func (export "caml_greaterequal") + (param $v1 (ref eq)) (param $v2 (ref eq)) (result (ref eq)) + (ref.i31 (i32.le_s (i32.const 0) + (call $compare_val (local.get $v1) (local.get $v2) (i32.const 0))))) +) diff --git a/runtime/wasm/custom.wat b/runtime/wasm/custom.wat new file mode 100644 index 0000000000..4d48e9e075 --- /dev/null +++ b/runtime/wasm/custom.wat @@ -0,0 +1,145 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "int32" "int32_ops" (global $int32_ops (ref $custom_operations))) + (import "int32" "nativeint_ops" + (global $nativeint_ops (ref $custom_operations))) + (import "int64" "int64_ops" (global $int64_ops (ref $custom_operations))) + (import "bigarray" "bigarray_ops" + (global $bigarray_ops (ref $custom_operations))) + (import "string" "caml_string_equal" + (func $caml_string_equal + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + + (type $string (array (mut i8))) + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $dup (func (param (ref eq)) (result (ref eq)))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)) + (field $dup (ref null $dup)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + + (type $custom_with_id + (sub $custom + (struct + (field (ref $custom_operations)) + (field $id i64)))) + + (func (export "caml_is_custom") (param (ref eq)) (result i32) + (ref.test (ref $custom) (local.get 0))) + + (func (export "caml_dup_custom") (param $v (ref eq)) (result (ref eq)) + (call_ref $dup (local.get $v) + (ref.as_non_null + (struct.get $custom_operations $dup + (struct.get $custom 0 + (block $custom (result (ref $custom)) + (drop (br_on_cast $custom (ref eq) (ref $custom) + (local.get $v))) + (unreachable))))))) + + (func (export "custom_compare_id") + (param (ref eq)) (param (ref eq)) (param i32) (result i32) + (local $i1 i64) (local $i2 i64) + (local.set $i1 + (struct.get $custom_with_id $id + (ref.cast (ref $custom_with_id) (local.get 0)))) + (local.set $i2 + (struct.get $custom_with_id $id + (ref.cast (ref $custom_with_id) (local.get 1)))) + (i32.sub (i64.gt_s (local.get $i1) (local.get $i2)) + (i64.lt_s (local.get $i1) (local.get $i2)))) + + (func (export "custom_hash_id") (param (ref eq)) (result i32) + (i32.wrap_i64 + (struct.get $custom_with_id $id + (ref.cast (ref $custom_with_id) (local.get 0))))) + + (global $next_id (mut i64) (i64.const 0)) + + (func (export "custom_next_id") (result i64) + (local $id i64) + (local.set $id (global.get $next_id)) + (global.set $next_id (i64.add (local.get $id) (i64.const 1))) + (local.get $id)) + + (type $custom_operations_list + (struct + (field $ops (ref $custom_operations)) + (field $next (ref null $custom_operations_list)))) + + (global $custom_operations + (mut (ref null $custom_operations_list)) + (ref.null $custom_operations_list)) + + (func $caml_register_custom_operations + (export "caml_register_custom_operations") + (param $ops (ref $custom_operations)) + (global.set $custom_operations + (struct.new $custom_operations_list + (local.get $ops) (global.get $custom_operations)))) + + (func (export "caml_find_custom_operations") + (param $id (ref $string)) (result (ref null $custom_operations)) + (local $l (ref null $custom_operations_list)) + (block $not_found + (local.set $l (br_on_null $not_found (global.get $custom_operations))) + (loop $loop + (if (i31.get_u + (ref.cast (ref i31) + (call $caml_string_equal (local.get $id) + (struct.get $custom_operations $id + (struct.get $custom_operations_list $ops + (local.get $l)))))) + (then + (return + (struct.get $custom_operations_list $ops (local.get $l))))) + (local.set $l + (br_on_null $not_found + (struct.get $custom_operations_list $next (local.get $l)))) + (br $loop))) + (ref.null $custom_operations)) + + (global $initialized (mut i32) (i32.const 0)) + + (func (export "caml_init_custom_operations") + (if (global.get $initialized) (then (return))) + (call $caml_register_custom_operations (global.get $int32_ops)) + (call $caml_register_custom_operations (global.get $nativeint_ops)) + (call $caml_register_custom_operations (global.get $int64_ops)) + (call $caml_register_custom_operations (global.get $bigarray_ops)) + (global.set $initialized (i32.const 1))) + + (func (export "caml_custom_identifier") (param $v (ref eq)) (result (ref eq)) + (struct.get $custom_operations $id + (struct.get $custom 0 (ref.cast (ref $custom) (local.get $v))))) +) diff --git a/runtime/wasm/deps.json b/runtime/wasm/deps.json new file mode 100644 index 0000000000..c06b08f8aa --- /dev/null +++ b/runtime/wasm/deps.json @@ -0,0 +1,98 @@ +[ + { + "name": "root", + "reaches": ["init", "exn", "mem", "strings", "string_get", "string_set"], + "root": true + }, + { + "name": "init", + "export": "_initialize" + }, + { + "name": "exn", + "export": "caml_handle_uncaught_exception" + }, + { + "name": "mem", + "export": "caml_buffer" + }, + { + "name": "strings", + "export": "caml_extract_string" + }, + { + "name": "string_get", + "export": "string_get" + }, + { + "name": "string_set", + "export": "string_set" + }, + { + "name": "callback", + "export": "caml_callback" + }, + { + "name": "wrap_callback", + "import": ["bindings", "wrap_callback"], + "reaches": ["callback"] + }, + { + "name": "wrap_callback_args", + "import": ["bindings", "wrap_callback_args"], + "reaches": ["callback"] + }, + { + "name": "wrap_callback_strict", + "import": ["bindings", "wrap_callback_strict"], + "reaches": ["callback"] + }, + { + "name": "wrap_callback_unsafe", + "import": ["bindings", "wrap_callback_unsafe"], + "reaches": ["callback"] + }, + { + "name": "wrap_meth_callback", + "import": ["bindings", "wrap_meth_callback"], + "reaches": ["callback"] + }, + { + "name": "wrap_meth_callback_args", + "import": ["bindings", "wrap_meth_callback_args"], + "reaches": ["callback"] + }, + { + "name": "wrap_meth_callback_strict", + "import": ["bindings", "wrap_meth_callback_strict"], + "reaches": ["callback"] + }, + { + "name": "wrap_meth_callback_unsafe", + "import": ["bindings", "wrap_meth_callback_unsafe"], + "reaches": ["callback"] + }, + { + "name": "alloc_tm", + "export": "caml_alloc_tm" + }, + { + "name": "gmtime", + "import": ["bindings", "gmtime"], + "reaches": ["alloc_tm"] + }, + { + "name": "localtime", + "import": ["bindings", "localtime"], + "reaches": ["alloc_tm"] + }, + { + "name": "effects", + "export": "caml_start_fiber" + }, + { + "name": "start_fiber", + "import": ["bindings", "start_fiber"], + "reaches": ["effects"] + } +] diff --git a/runtime/wasm/domain.wat b/runtime/wasm/domain.wat new file mode 100644 index 0000000000..f5465bdf58 --- /dev/null +++ b/runtime/wasm/domain.wat @@ -0,0 +1,104 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (type $block (array (mut (ref eq)))) + (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) + (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) + + (func (export "caml_atomic_cas") + (param $ref (ref eq)) (param $o (ref eq)) (param $n (ref eq)) + (result (ref eq)) + (local $b (ref $block)) + (local.set $b (ref.cast (ref $block) (local.get $ref))) + (if (result (ref eq)) + (ref.eq (array.get $block (local.get $b) (i32.const 1)) + (local.get $o)) + (then + (array.set $block (local.get $b) (i32.const 1) (local.get $n)) + (ref.i31 (i32.const 1))) + (else + (ref.i31 (i32.const 0))))) + + (func (export "caml_atomic_load") (param (ref eq)) (result (ref eq)) + (array.get $block (ref.cast (ref $block) (local.get 0)) (i32.const 1))) + + (func (export "caml_atomic_fetch_add") + (param $ref (ref eq)) (param $i (ref eq)) (result (ref eq)) + (local $b (ref $block)) + (local $old (ref eq)) + (local.set $b (ref.cast (ref $block) (local.get $ref))) + (local.set $old (array.get $block (local.get $b) (i32.const 1))) + (array.set $block (local.get $b) (i32.const 1) + (ref.i31 (i32.add (i31.get_s (ref.cast (ref i31) (local.get $old))) + (i31.get_s (ref.cast (ref i31) (local.get $i)))))) + (local.get $old)) + + (func (export "caml_atomic_exchange") + (param $ref (ref eq)) (param $v (ref eq)) (result (ref eq)) + (local $b (ref $block)) + (local $r (ref eq)) + (local.set $b (ref.cast (ref $block) (local.get $ref))) + (local.set $r (array.get $block (local.get $b) (i32.const 1))) + (array.set $block (local.get $b) (i32.const 1) (local.get $v)) + (local.get $r)) + + (global $caml_domain_dls (mut (ref eq)) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (func (export "caml_domain_dls_set") (param $a (ref eq)) (result (ref eq)) + (global.set $caml_domain_dls (local.get $a)) + (ref.i31 (i32.const 0))) + + (func (export "caml_domain_dls_compare_and_set") (param $old (ref eq)) (param $new (ref eq)) (result (ref eq)) + (if (result (ref eq)) + (ref.eq (global.get $caml_domain_dls) (local.get $old)) + (then + (global.set $caml_domain_dls (local.get $new)) + (ref.i31 (i32.const 1))) + (else + (ref.i31 (i32.const 0))))) + + (func (export "caml_domain_dls_get") (param (ref eq)) (result (ref eq)) + (global.get $caml_domain_dls)) + + (global $caml_ml_domain_unique_token (ref eq) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (func (export "caml_ml_domain_unique_token") + (param (ref eq)) (result (ref eq)) + (global.get $caml_ml_domain_unique_token)) + + (func (export "caml_ml_domain_set_name") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_recommended_domain_count") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 1))) + + (global $caml_domain_id (export "caml_domain_id") (mut i32) (i32.const 0)) + (global $caml_domain_latest_id (export "caml_domain_latest_id") (mut i32) + (i32.const 1)) + + (func (export "caml_ml_domain_id") (export "caml_ml_domain_index") + (param (ref eq)) (result (ref eq)) + (ref.i31 (global.get $caml_domain_id))) + + (func (export "caml_ml_domain_cpu_relax") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) diff --git a/runtime/wasm/dune b/runtime/wasm/dune new file mode 100644 index 0000000000..90422c0f9d --- /dev/null +++ b/runtime/wasm/dune @@ -0,0 +1,84 @@ +(install + (section lib) + (package wasm_of_ocaml-compiler) + (files runtime.wasm runtime.js)) + +(rule + (target version-dependent.wat) + (deps version-dependent/post-5.2.wat) + (enabled_if + (>= %{ocaml_version} 5.2.0)) + (action + (copy %{deps} %{target}))) + +(rule + (target version-dependent.wat) + (deps version-dependent/post-5.1.wat) + (enabled_if + (and + (>= %{ocaml_version} 5.1.0) + (< %{ocaml_version} 5.2.0))) + (action + (copy %{deps} %{target}))) + +(rule + (target version-dependent.wat) + (deps version-dependent/pre-5.1.wat) + (enabled_if + (< %{ocaml_version} 5.1.0)) + (action + (copy %{deps} %{target}))) + +(rule + (target runtime.wasm) + (deps runtime.merged.wasm) + (action + (run + wasm-opt + -g + --enable-gc + --enable-exception-handling + --enable-reference-types + --enable-tail-call + --enable-strings + --enable-multivalue + --enable-bulk-memory + %{deps} + -O3 + -o + %{target}))) + +(rule + (target runtime.merged.wasm) + (deps + args + (glob_files *.wat)) + (action + (progn + (bash + "which wasm-merge > /dev/null || (echo 'Error: Binaryen tools not found in the PATH'; false)") + (bash + "wasm-merge --version | grep -q 'version \\(11[89]\\|1[2-9][0-9]\\)' || (echo 'Error: Binaryen version 118 or greater is currently required'; false)") + (run + wasm-merge + -g + --enable-gc + --enable-exception-handling + --enable-reference-types + --enable-tail-call + --enable-strings + --enable-multivalue + --enable-bulk-memory + %{read-lines:args} + -o + %{target})))) + +(rule + (target args) + (deps + args.ml + (glob_files *.wat)) + (action + (with-stdout-to + %{target} + (run ocaml %{deps})))) diff --git a/runtime/wasm/dynlink.wat b/runtime/wasm/dynlink.wat new file mode 100644 index 0000000000..45e7d98f00 --- /dev/null +++ b/runtime/wasm/dynlink.wat @@ -0,0 +1,19 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module +) diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat new file mode 100644 index 0000000000..dbc41b3c76 --- /dev/null +++ b/runtime/wasm/effect.wat @@ -0,0 +1,735 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_raise_constant" + (func $caml_raise_constant (param (ref eq)))) + (import "fail" "caml_raise_with_arg" + (func $caml_raise_with_arg (param $tag (ref eq)) (param $arg (ref eq)))) + (import "obj" "caml_fresh_oo_id" + (func $caml_fresh_oo_id (param (ref eq)) (result (ref eq)))) + (import "obj" "cont_tag" (global $cont_tag i32)) + (import "stdlib" "caml_named_value" + (func $caml_named_value (param (ref $string)) (result (ref null eq)))) + (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) + (import "fail" "javascript_exception" + (tag $javascript_exception (param externref))) + (import "jslib" "caml_wrap_exception" + (func $caml_wrap_exception (param externref) (result (ref eq)))) + (import "bindings" "start_fiber" (func $start_fiber (param (ref eq)))) + (import "bindings" "suspend_fiber" + (func $suspend_fiber + (param $f funcref) (param $env eqref) (result anyref))) + (import "bindings" "resume_fiber" + (func $resume_fiber (param externref) (param (ref eq)))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) + (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) + (type $function_3 + (func (param (ref eq) (ref eq) (ref eq) (ref eq)) (result (ref eq)))) + (type $closure_3 + (sub $closure + (struct (field (ref $function_1)) (field (ref $function_3))))) + + ;; Apply a function f to a value v, both contained in a pair (f, v) + + (type $pair (struct (field (ref eq)) (field (ref eq)))) + + (func $apply_pair (param $p (ref $pair)) (result (ref eq)) + (local $f (ref eq)) + (return_call_ref $function_1 (struct.get $pair 1 (local.get $p)) + (local.tee $f (struct.get $pair 0 (local.get $p))) + (struct.get $closure 0 (ref.cast (ref $closure) (local.get $f))))) + + ;; Low-level primitives + + ;; Capturing the current continuation + + (type $cont_func (func (param (ref $pair)) (param (ref eq)))) + (type $cont (sub (struct (field $cont_func (ref $cont_func))))) + + (type $called_with_continuation + (func (param (ref $cont)) (param (ref eq)))) + + (type $thunk + (struct (field (ref $called_with_continuation)) (field (ref eq)))) + + (type $cont_resume + (sub final $cont + (struct + (field $cont_func (ref $cont_func)) + (field $cont_resolver externref)))) + + (func $invoke_promise_resolver (param $p (ref $pair)) (param (ref eq)) + (return_call $resume_fiber + (struct.get $cont_resume $cont_resolver + (ref.cast (ref $cont_resume) (local.get 1))) + (local.get $p))) + + (func $apply_continuation (param $resolver (ref extern)) (param $v (ref eq)) + (local $t (ref $thunk)) + (local.set $t (ref.cast (ref $thunk) (local.get $v))) + (return_call_ref $called_with_continuation + (struct.new $cont_resume + (ref.func $invoke_promise_resolver) (local.get $resolver)) + (struct.get $thunk 1 (local.get $t)) + (struct.get $thunk 0 (local.get $t)))) + + (func $capture_continuation + (param $f (ref $called_with_continuation)) + (param $v (ref eq)) + (result (ref eq)) + (return_call $apply_pair + (ref.cast (ref $pair) + (call $suspend_fiber + (ref.func $apply_continuation) + (struct.new $thunk (local.get $f) (local.get $v)))))) + + ;; Stack of fibers + + (type $handlers + (struct + (field $value (ref eq)) + (field $exn (ref eq)) + (field $effect (ref eq)))) + + (type $generic_fiber (sub (struct (field $handlers (mut (ref $handlers)))))) + + (type $fiber + (sub final $generic_fiber + (struct + (field $handlers (mut (ref $handlers))) + (field $cont (ref $cont)) + (field $next (ref null $fiber))))) + + (data $effect_unhandled "Effect.Unhandled") + + (func $raise_unhandled + (param $eff (ref eq)) (param (ref eq)) (result (ref eq)) + (local $effect_unhandled (ref $string)) + (local.set $effect_unhandled + (array.new_data $string $effect_unhandled + (i32.const 0) (i32.const 16))) + (block $null + (call $caml_raise_with_arg + (br_on_null $null + (call $caml_named_value + (local.get $effect_unhandled))) + (local.get $eff))) + (call $caml_raise_constant + (array.new_fixed $block 3 (ref.i31 (i32.const 248)) + (local.get $effect_unhandled) + (call $caml_fresh_oo_id (ref.i31 (i32.const 0))))) + (ref.i31 (i32.const 0))) + + (func $uncaught_effect_handler + (param $eff (ref eq)) (param $cont (ref eq)) (param $k (ref eq)) + (param (ref eq)) (result (ref eq)) + (local $k' (ref $cont)) + (local.set $k' + (call $push_stack + (ref.cast (ref $fiber) + (array.get $block + (ref.cast (ref $block) (local.get $cont)) + (i32.const 1))) + (ref.cast (ref $cont) (local.get $k)))) + (call_ref $cont_func + (struct.new $pair + (struct.new $closure (ref.func $raise_unhandled)) + (local.get $eff)) + (local.get $k') + (struct.get $cont $cont_func (local.get $k'))) + (ref.i31 (i32.const 0))) + + (func $dummy_fun (param (ref eq)) (param (ref eq)) (result (ref eq)) + (unreachable)) + + (func $default_continuation (param $p (ref $pair)) (param (ref eq)) + (drop (call $apply_pair (local.get $p)))) + + (global $stack (mut (ref null $fiber)) + (struct.new $fiber + (struct.new $handlers + (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) + (struct.new $closure_3 + (ref.func $dummy_fun) + (ref.func $uncaught_effect_handler))) + (struct.new $cont (ref.func $default_continuation)) + (ref.null $fiber))) + + ;; Utility functions moving fibers between a continuation and the + ;; current stack of fibers + + (func $pop_fiber (result (ref $cont)) + (local $f (ref $fiber)) + (local.set $f (ref.as_non_null (global.get $stack))) + (global.set $stack + (struct.get $fiber $next (local.get $f))) + (struct.get $fiber $cont (local.get $f))) + + (func $push_stack + (param $stack (ref $fiber)) (param $k (ref $cont)) + (result (ref $cont)) + (block $done + (loop $loop + (global.set $stack + (struct.new $fiber + (struct.get $fiber $handlers (local.get $stack)) + (local.get $k) + (global.get $stack))) + (local.set $k + (struct.get $fiber $cont (local.get $stack))) + (local.set $stack + (br_on_null $done + (struct.get $fiber $next (local.get $stack)))) + (br $loop))) + (local.get $k)) + + ;; Resume + + (func $do_resume (param $k (ref $cont)) (param $vp (ref eq)) + (local $p (ref $pair)) + (local $stack (ref $fiber)) + (local.set $p (ref.cast (ref $pair) (local.get $vp))) + (local.set $stack + (ref.cast (ref $fiber) (struct.get $pair 0 (local.get $p)))) + (local.set $p (ref.cast (ref $pair) (struct.get $pair 1 (local.get $p)))) + (local.set $k (call $push_stack (local.get $stack) (local.get $k))) + (return_call_ref $cont_func (local.get $p) (local.get $k) + (struct.get $cont $cont_func (local.get $k)))) + + (data $already_resumed "Effect.Continuation_already_resumed") + + (func (export "%resume") + (param $stack (ref eq)) (param $f (ref eq)) (param $v (ref eq)) + (result (ref eq)) + (local $k (ref $cont)) + (local $pair (ref $pair)) + (if (ref.eq (local.get $stack) (ref.i31 (i32.const 0))) + (then + (call $caml_raise_constant + (ref.as_non_null + (call $caml_named_value + (array.new_data $string $already_resumed + (i32.const 0) (i32.const 35))))))) + (return_call $capture_continuation + (ref.func $do_resume) + (struct.new $pair + (local.get $stack) + (struct.new $pair (local.get $f) (local.get $v))))) + + ;; Perform + + (type $call_handler_env + (sub final $closure + (struct + (field (ref $function_1)) + (field $handler (ref eq)) + (field $eff (ref eq)) + (field $cont (ref eq))))) + + (func $call_effect_handler + (param $k (ref eq)) (param $venv (ref eq)) (result (ref eq)) + (local $env (ref $call_handler_env)) + (local $handler (ref $closure_3)) + (local.set $env (ref.cast (ref $call_handler_env) (local.get $venv))) + (return_call_ref $function_3 + (struct.get $call_handler_env $eff (local.get $env)) + (struct.get $call_handler_env $cont (local.get $env)) + (local.get $k) + (local.tee $handler + (ref.cast (ref $closure_3) + (struct.get $call_handler_env $handler (local.get $env)))) + (struct.get $closure_3 1 (local.get $handler)))) + + (func $do_perform + (param $k0 (ref $cont)) (param $vp (ref eq)) + (local $eff (ref eq)) (local $cont (ref $block)) + (local $handler (ref eq)) + (local $k1 (ref $cont)) + (local $p (ref $pair)) + (local $next_fiber (ref eq)) + (local.set $p (ref.cast (ref $pair) (local.get $vp))) + (local.set $eff (struct.get $pair 0 (local.get $p))) + (local.set $cont + (ref.cast (ref $block) (struct.get $pair 1 (local.get $p)))) + (local.set $handler + (struct.get $handlers $effect + (struct.get $fiber $handlers (global.get $stack)))) + (local.set $next_fiber (array.get $block (local.get $cont) (i32.const 1))) + (array.set $block + (local.get $cont) + (i32.const 1) + (struct.new $fiber + (struct.get $fiber $handlers (global.get $stack)) + (local.get $k0) + (if (result (ref null $fiber)) + (ref.test (ref $fiber) (local.get $next_fiber)) + (then (ref.cast (ref $fiber) (local.get $next_fiber))) + (else (ref.null $fiber))))) + (local.set $k1 (call $pop_fiber)) + (return_call_ref $cont_func + (struct.new $pair + (struct.new $call_handler_env + (ref.func $call_effect_handler) + (local.get $handler) + (local.get $eff) + (local.get $cont)) + (local.get $k1)) + (local.get $k1) + (struct.get $cont $cont_func (local.get $k1)))) + + (func $reperform (export "%reperform") + (param $eff (ref eq)) (param $cont (ref eq)) + (result (ref eq)) + (return_call $capture_continuation + (ref.func $do_perform) + (struct.new $pair (local.get $eff) (local.get $cont)))) + + (func (export "%perform") (param $eff (ref eq)) (result (ref eq)) + (return_call $reperform (local.get $eff) + (array.new_fixed $block 3 (ref.i31 (global.get $cont_tag)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0))))) + + ;; Allocate a stack + + (func $call_handler (param $f (ref eq)) (param $x (ref eq)) + ;; Propagate a value or an exception to the parent fiber + (local $cont (ref $cont)) + (return_call_ref $cont_func + (struct.new $pair (local.get $f) (local.get $x)) + (local.tee $cont (call $pop_fiber)) + (struct.get $cont $cont_func (local.get $cont)))) + + (func (export "caml_start_fiber") (param $p eqref) + ;; Start executing some code in a new fiber + (local $exn (ref eq)) + (local $res (ref eq)) + (local.set $res + (try (result (ref eq)) + (do + (try (result (ref eq)) + (do + (call $apply_pair (ref.cast (ref $pair) (local.get $p)))) + (catch $javascript_exception + (throw $ocaml_exception + (call $caml_wrap_exception (pop externref)))))) + (catch $ocaml_exception + (local.set $exn (pop (ref eq))) + (return_call $call_handler + (struct.get $handlers $exn + (struct.get $fiber $handlers (global.get $stack))) + (local.get $exn))))) + (return_call $call_handler + (struct.get $handlers $value + (struct.get $fiber $handlers (global.get $stack))) + (local.get $res))) + + (func $initial_cont (param $p (ref $pair)) (param (ref eq)) + (return_call $start_fiber (local.get $p))) + + (func (export "caml_alloc_stack") + (param $hv (ref eq)) (param $hx (ref eq)) (param $hf (ref eq)) + (result (ref eq)) + (struct.new $fiber + (struct.new $handlers (local.get $hv) (local.get $hx) (local.get $hf)) + (struct.new $cont (ref.func $initial_cont)) + (ref.null $fiber))) + + ;; Other functions + + (func $caml_continuation_use_noexc (export "caml_continuation_use_noexc") + (param (ref eq)) (result (ref eq)) + (local $cont (ref $block)) + (local $stack (ref eq)) + (drop (block $used (result (ref eq)) + (local.set $cont (ref.cast (ref $block) (local.get 0))) + (local.set $stack + (br_on_cast_fail $used (ref eq) (ref $generic_fiber) + (array.get $block (local.get $cont) (i32.const 1)))) + (array.set $block (local.get $cont) (i32.const 1) + (ref.i31 (i32.const 0))) + (return (local.get $stack)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_continuation_use_and_update_handler_noexc") + (param $cont (ref eq)) (param $hval (ref eq)) (param $hexn (ref eq)) + (param $heff (ref eq)) (result (ref eq)) + (local $stack (ref eq)) + (local.set $stack (call $caml_continuation_use_noexc (local.get $cont))) + (drop (block $used (result (ref eq)) + (struct.set $generic_fiber $handlers + (br_on_cast_fail $used (ref eq) (ref $generic_fiber) + (local.get $stack)) + (struct.new $handlers + (local.get $hval) (local.get $hexn) (local.get $heff))) + (ref.i31 (i32.const 0)))) + (local.get $stack)) + + (func (export "caml_get_continuation_callstack") + (param (ref eq) (ref eq)) (result (ref eq)) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (func (export "caml_is_continuation") (param (ref eq)) (result i32) + (drop (block $not_continuation (result (ref eq)) + (return + (ref.eq + (array.get $block + (br_on_cast_fail $not_continuation (ref eq) (ref $block) + (local.get 0)) + (i32.const 0)) + (ref.i31 (global.get $cont_tag)))))) + (i32.const 0)) + + ;; Effects through CPS transformation + + (type $function_2 + (func (param (ref eq) (ref eq) (ref eq)) (result (ref eq)))) + (type $function_4 + (func (param (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (result (ref eq)))) + (type $cps_closure (sub (struct (field (ref $function_2))))) + (type $cps_closure_0 (sub (struct (field (ref $function_1))))) + (type $cps_closure_3 + (sub $cps_closure + (struct (field (ref $function_2)) (field (ref $function_4))))) + + (type $iterator + (sub final $closure + (struct + (field (ref $function_1)) + (field $i (mut i32)) + (field $args (ref $block))))) + + (type $exn_stack + (struct (field $h (ref eq)) (field $next (ref null $exn_stack)))) + + (type $cps_fiber + (sub final $generic_fiber + (struct + (field $handlers (mut (ref $handlers))) + (field $cont (ref eq)) + (field $exn_stack (ref null $exn_stack)) + (field $next (ref null $cps_fiber))))) + + (global $exn_stack (mut (ref null $exn_stack)) (ref.null $exn_stack)) + + (func (export "caml_push_trap") (param $h (ref eq)) (result (ref eq)) + (global.set $exn_stack + (struct.new $exn_stack (local.get $h) (global.get $exn_stack))) + (ref.i31 (i32.const 0))) + + (func $raise_exception + (param $exn (ref eq)) (param (ref eq)) (result (ref eq)) + (throw $ocaml_exception (local.get $exn))) + + (global $raise_exception (ref eq) + (struct.new $closure (ref.func $raise_exception))) + + (func (export "caml_pop_trap") (result (ref eq)) + (local $top (ref $exn_stack)) + (block $empty + (local.set $top (br_on_null $empty (global.get $exn_stack))) + (global.set $exn_stack + (struct.get $exn_stack $next (local.get $top))) + (return (struct.get $exn_stack $h (local.get $top)))) + (global.get $raise_exception)) + + (func (export "caml_maybe_attach_backtrace") + (param $exn (ref eq)) (param (ref eq)) (result (ref eq)) + (local.get $exn)) + + (func $identity (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local.get 0)) + + (global $identity (ref $closure) (struct.new $closure (ref.func $identity))) + + (func $trampoline_iterator + (param $f (ref eq)) (param $venv (ref eq)) (result (ref eq)) + (local $env (ref $iterator)) + (local $i i32) (local $args (ref $block)) + (local.set $env (ref.cast (ref $iterator) (local.get $venv))) + (local.set $i (struct.get $iterator $i (local.get $env))) + (local.set $args (struct.get $iterator $args (local.get $env))) + (struct.set $iterator $i (local.get $env) + (i32.add (local.get $i) (i32.const 1))) + (return_call_ref $function_2 + (array.get $block (local.get $args) (local.get $i)) + (if (result (ref eq)) + (i32.eq (i32.add (local.get $i) (i32.const 1)) + (array.len (local.get $args))) + (then (global.get $identity)) + (else (local.get $env))) + (local.get $f) + (struct.get $cps_closure 0 + (ref.cast (ref $cps_closure) (local.get $f))))) + + (func $apply_iterator + (param $f (ref eq)) (param $venv (ref eq)) (result (ref eq)) + (local $env (ref $iterator)) + (local $i i32) (local $args (ref $block)) + (local.set $env (ref.cast (ref $iterator) (local.get $venv))) + (local.set $i (struct.get $iterator $i (local.get $env))) + (local.set $args (struct.get $iterator $args (local.get $env))) + (struct.set $iterator $i (local.get $env) + (i32.add (local.get $i) (i32.const 1))) + (return_call_ref $function_2 + (array.get $block (local.get $args) (local.get $i)) + (if (result (ref eq)) + (i32.eq (i32.add (local.get $i) (i32.const 2)) + (array.len (local.get $args))) + (then + (array.get $block (local.get $args) + (i32.add (local.get $i) (i32.const 1)))) + (else + (local.get $env))) + (local.get $f) + (struct.get $cps_closure 0 + (ref.cast (ref $cps_closure) (local.get $f))))) + + (func (export "caml_apply_continuation") + (param $args (ref eq)) (result (ref eq)) + (struct.new $iterator + (ref.func $apply_iterator) + (i32.const 1) + (ref.cast (ref $block) (local.get $args)))) + + (func $dummy_cps_fun + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (unreachable)) + + (global $cps_fiber_stack (mut (ref null $cps_fiber)) (ref.null $cps_fiber)) + + (global $default_fiber_stack (ref null $cps_fiber) + (struct.new $cps_fiber + (struct.new $handlers + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (struct.new $cps_closure_3 + (ref.func $dummy_cps_fun) + (ref.func $cps_uncaught_effect_handler))) + (ref.i31 (i32.const 0)) + (ref.null $exn_stack) + (ref.null $cps_fiber))) + + (func $caml_trampoline (export "caml_trampoline") + (param $f (ref eq)) (param $vargs (ref eq)) (result (ref eq)) + (local $args (ref $block)) + (local $i i32) (local $res (ref eq)) + (local $exn (ref eq)) (local $top (ref $exn_stack)) + (local $saved_exn_stack (ref null $exn_stack)) + (local $saved_fiber_stack (ref null $cps_fiber)) + (local.set $saved_exn_stack (global.get $exn_stack)) + (local.set $saved_fiber_stack (global.get $cps_fiber_stack)) + (global.set $exn_stack (ref.null $exn_stack)) + (global.set $cps_fiber_stack (global.get $default_fiber_stack)) + (local.set $args (ref.cast (ref $block) (local.get $vargs))) + (local.set $exn + (try (result (ref eq)) + (do + (local.set $res + (if (result (ref eq)) + (i32.eq (array.len (local.get $args)) (i32.const 1)) + (then + (call_ref $function_1 (global.get $identity) + (local.get $f) + (struct.get $cps_closure_0 0 + (ref.cast (ref $cps_closure_0) (local.get $f))))) + (else + (call_ref $function_2 + (array.get $block (local.get $args) (i32.const 1)) + (if (result (ref eq)) + (i32.eq (i32.const 2) + (array.len (local.get $args))) + (then (global.get $identity)) + (else + (struct.new $iterator + (ref.func $trampoline_iterator) + (i32.const 2) + (local.get $args)))) + (local.get $f) + (struct.get $cps_closure 0 + (ref.cast (ref $cps_closure) (local.get $f))))))) + (global.set $exn_stack (local.get $saved_exn_stack)) + (global.set $cps_fiber_stack (local.get $saved_fiber_stack)) + (return (local.get $res))) + (catch $ocaml_exception + (pop (ref eq))) + (catch $javascript_exception + (call $caml_wrap_exception (pop externref))))) + (loop $loop + (block $empty + (local.set $top + (br_on_null $empty (global.get $exn_stack))) + (global.set $exn_stack + (struct.get $exn_stack $next (local.get $top))) + (local.set $f (struct.get $exn_stack $h (local.get $top))) + (try + (do + (local.set $res + (call_ref $function_1 + (local.get $exn) + (local.get $f) + (struct.get $closure 0 + (ref.cast (ref $closure) (local.get $f))))) + (global.set $exn_stack (local.get $saved_exn_stack)) + (global.set $cps_fiber_stack (local.get $saved_fiber_stack)) + (return (local.get $res))) + (catch $ocaml_exception + (local.set $exn (pop (ref eq))) + (br $loop)) + (catch $javascript_exception + (local.set $exn (call $caml_wrap_exception (pop externref))) + (br $loop))))) + (global.set $exn_stack (local.get $saved_exn_stack)) + (global.set $cps_fiber_stack (local.get $saved_fiber_stack)) + (throw $ocaml_exception (local.get $exn))) + + (global $caml_trampoline_ref (export "caml_trampoline_ref") + (mut (ref null $function_1)) (ref.null $function_1)) + + (func $caml_pop_fiber (result (ref eq)) + (local $top (ref $cps_fiber)) + (local.set $top (ref.as_non_null (global.get $cps_fiber_stack))) + (global.set $cps_fiber_stack + (struct.get $cps_fiber $next (local.get $top))) + (global.set $exn_stack + (struct.get $cps_fiber $exn_stack (local.get $top))) + (struct.get $cps_fiber $cont (local.get $top))) + + (func $caml_resume_stack (export "caml_resume_stack") + (param $vstack (ref eq)) (param $k (ref eq)) (result (ref eq)) + (local $stack (ref $cps_fiber)) + (drop (block $already_resumed (result (ref eq)) + (local.set $stack + (br_on_cast_fail $already_resumed (ref eq) (ref $cps_fiber) + (local.get $vstack))) + (block $done + (loop $loop + (global.set $cps_fiber_stack + (struct.new $cps_fiber + (struct.get $cps_fiber $handlers (local.get $stack)) + (local.get $k) + (global.get $exn_stack) + (global.get $cps_fiber_stack))) + (local.set $k (struct.get $cps_fiber $cont (local.get $stack))) + (global.set $exn_stack + (struct.get $cps_fiber $exn_stack (local.get $stack))) + (local.set $stack + (br_on_null $done + (struct.get $cps_fiber $next (local.get $stack)))) + (br $loop))) + (return (local.get $k)))) + (call $caml_raise_constant + (ref.as_non_null + (call $caml_named_value + (array.new_data $string $already_resumed + (i32.const 0) (i32.const 35))))) + (ref.i31 (i32.const 0))) + + (func (export "caml_perform_effect") + (param $eff (ref eq)) (param $vcont (ref eq)) (param $k0 (ref eq)) + (result (ref eq)) + (local $handlers (ref $handlers)) + (local $handler (ref eq)) (local $k1 (ref eq)) + (local $cont (ref $block)) + (local $next_fiber (ref eq)) + (local.set $cont + (block $reperform (result (ref $block)) + (drop + (br_on_cast $reperform (ref eq) (ref $block) + (local.get $vcont))) + (array.new_fixed $block 3 (ref.i31 (global.get $cont_tag)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0))))) + (local.set $handlers + (struct.get $cps_fiber $handlers + (ref.as_non_null (global.get $cps_fiber_stack)))) + (local.set $handler + (struct.get $handlers $effect (local.get $handlers))) + (local.set $next_fiber + (array.get $block (local.get $cont) (i32.const 1))) + (array.set $block (local.get $cont) (i32.const 1) + (struct.new $cps_fiber + (local.get $handlers) + (local.get $k0) + (global.get $exn_stack) + (if (result (ref null $cps_fiber)) + (ref.test (ref $cps_fiber) (local.get $next_fiber)) + (then (ref.cast (ref $cps_fiber) (local.get $next_fiber))) + (else (ref.null $cps_fiber))))) + (local.set $k1 (call $caml_pop_fiber)) + (return_call_ref $function_4 + (local.get $eff) (local.get $cont) (local.get $k1) (local.get $k1) + (local.get $handler) + (struct.get $cps_closure_3 1 + (ref.cast (ref $cps_closure_3) (local.get $handler))))) + + (func $cps_call_handler + (param $handler (ref eq)) (param $x (ref eq)) (result (ref eq)) + (return_call_ref $function_2 + (local.get $x) + (call $caml_pop_fiber) + (local.get $handler) + (struct.get $cps_closure 0 + (ref.cast (ref $cps_closure) (local.get $handler))))) + + (func $value_handler (param $x (ref eq)) (param (ref eq)) (result (ref eq)) + (return_call $cps_call_handler + (struct.get $handlers $value + (struct.get $cps_fiber $handlers + (ref.as_non_null (global.get $cps_fiber_stack)))) + (local.get $x))) + + (global $value_handler (ref $closure) + (struct.new $closure (ref.func $value_handler))) + + (func $exn_handler (param $x (ref eq)) (param (ref eq)) (result (ref eq)) + (return_call $cps_call_handler + (struct.get $handlers $exn + (struct.get $cps_fiber $handlers + (ref.as_non_null (global.get $cps_fiber_stack)))) + (local.get $x))) + + (global $exn_handler (ref $closure) + (struct.new $closure (ref.func $exn_handler))) + + (func (export "caml_cps_alloc_stack") + (param $hv (ref eq)) (param $hx (ref eq)) (param $hf (ref eq)) + (result (ref eq)) + (struct.new $cps_fiber + (struct.new $handlers + (local.get $hv) (local.get $hx) (local.get $hf)) + (global.get $value_handler) + (struct.new $exn_stack + (global.get $exn_handler) (ref.null $exn_stack)) + (ref.null $cps_fiber))) + + (func $cps_uncaught_effect_handler + (param $eff (ref eq)) (param $k (ref eq)) (param $ms (ref eq)) + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (drop + (call $caml_resume_stack + (array.get $block + (ref.cast (ref $block) (local.get $k)) (i32.const 1)) + (local.get $ms))) + (call $raise_unhandled (local.get $eff) (ref.i31 (i32.const 0)))) + + (func (export "caml_cps_initialize_effects") + (global.set $caml_trampoline_ref (ref.func $caml_trampoline))) +) diff --git a/runtime/wasm/fail.wat b/runtime/wasm/fail.wat new file mode 100644 index 0000000000..e3dc000d55 --- /dev/null +++ b/runtime/wasm/fail.wat @@ -0,0 +1,118 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "stdlib" "caml_global_data" + (global $caml_global_data (mut (ref $block)))) + (import "bindings" "jstag" (tag $javascript_exception (param externref))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + + (tag $ocaml_exception (export "ocaml_exception") (param (ref eq))) + (export "javascript_exception" (tag $javascript_exception)) + + (func $caml_raise_constant (export "caml_raise_constant") (param (ref eq)) + (throw $ocaml_exception (local.get 0))) + + (func $caml_raise_with_arg (export "caml_raise_with_arg") + (param $tag (ref eq)) (param $arg (ref eq)) + (throw $ocaml_exception + (array.new_fixed $block 3 + (ref.i31 (i32.const 0)) (local.get $tag) (local.get $arg)))) + + (global $OUT_OF_MEMORY_EXN i32 (i32.const 0)) + + (func (export "caml_raise_out_of_memory") + (return_call $caml_raise_constant + (array.get $block (global.get $caml_global_data) + (global.get $OUT_OF_MEMORY_EXN)))) + + (global $SYS_ERROR_EXN i32 (i32.const 1)) + + (func (export "caml_raise_sys_error") (param $msg (ref eq)) + (return_call $caml_raise_with_arg + (array.get $block (global.get $caml_global_data) + (global.get $SYS_ERROR_EXN)) + (local.get $msg))) + + (global $FAILURE_EXN i32 (i32.const 2)) + + (func (export "caml_failwith_tag") (result (ref eq)) + (array.get $block (global.get $caml_global_data) + (global.get $FAILURE_EXN))) + + (func (export "caml_failwith") (param $arg (ref eq)) + (return_call $caml_raise_with_arg + (array.get $block (global.get $caml_global_data) + (global.get $FAILURE_EXN)) + (local.get 0))) + + (global $INVALID_EXN i32 (i32.const 3)) + + (func $caml_invalid_argument (export "caml_invalid_argument") + (param $arg (ref eq)) + (return_call $caml_raise_with_arg + (array.get $block (global.get $caml_global_data) + (global.get $INVALID_EXN)) + (local.get 0))) + + (data $index_out_of_bounds "index out of bounds") + + (func (export "caml_bound_error") + (return_call $caml_invalid_argument + (array.new_data $string $index_out_of_bounds + (i32.const 0) (i32.const 19)))) + + (global $END_OF_FILE_EXN i32 (i32.const 4)) + + (func (export "caml_raise_end_of_file") + (return_call $caml_raise_constant + (array.get $block (global.get $caml_global_data) + (global.get $END_OF_FILE_EXN)))) + + (global $ZERO_DIVIDE_EXN i32 (i32.const 5)) + + (func (export "caml_raise_zero_divide") + (return_call $caml_raise_constant + (array.get $block (global.get $caml_global_data) + (global.get $ZERO_DIVIDE_EXN)))) + + (global $NOT_FOUND_EXN i32 (i32.const 6)) + + (func (export "caml_raise_not_found") + (return_call $caml_raise_constant + (array.get $block (global.get $caml_global_data) + (global.get $NOT_FOUND_EXN)))) + + (global $MATCH_FAILURE_EXN i32 (i32.const 7)) + (global $ASSERT_FAILURE_EXN i32 (i32.const 10)) + (global $UNDEFINED_RECURSIVE_MODULE_EXN i32 (i32.const 11)) + + (func (export "caml_is_special_exception") (param (ref eq)) (result i32) + (i32.or + (ref.eq (local.get 0) + (array.get $block (global.get $caml_global_data) + (global.get $MATCH_FAILURE_EXN))) + (i32.or + (ref.eq (local.get 0) + (array.get $block (global.get $caml_global_data) + (global.get $ASSERT_FAILURE_EXN))) + (ref.eq (local.get 0) + (array.get $block (global.get $caml_global_data) + (global.get $UNDEFINED_RECURSIVE_MODULE_EXN)))))) +) diff --git a/runtime/wasm/float.wat b/runtime/wasm/float.wat new file mode 100644 index 0000000000..50e0b200d0 --- /dev/null +++ b/runtime/wasm/float.wat @@ -0,0 +1,1173 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "bindings" "format_float" + (func $format_float + (param i32) (param i32) (param i32) (param f64) (result anyref))) + (import "bindings" "identity" + (func $parse_float (param anyref) (result f64))) + (import "Math" "exp" (func $exp (param f64) (result f64))) + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + (import "ints" "lowercase_hex_table" + (global $lowercase_hex_table (ref $chars))) + (import "jsstring" "jsstring_of_string" + (func $jsstring_of_string (param (ref $string)) (result anyref))) + (import "jsstring" "string_of_jsstring" + (func $string_of_jsstring (param anyref) (result (ref $string)))) + + (type $float (struct (field f64))) + (type $string (array (mut i8))) + (type $block (array (mut (ref eq)))) + + (type $chars (array i8)) + + (global $infinity (ref $chars) + (array.new_fixed $chars 8 + (i32.const 105) (i32.const 110) (i32.const 102) (i32.const 105) + (i32.const 110) (i32.const 105) (i32.const 116) (i32.const 121))) + + (global $nan (ref $chars) + (array.new_fixed $chars 3 (i32.const 110) (i32.const 97) (i32.const 110))) + + (func (export "Double_val") (param (ref eq)) (result f64) + (struct.get $float 0 (ref.cast (ref $float) (local.get 0)))) + + (func (export "caml_hexstring_of_float") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local $b i64) (local $prec i32) (local $style i32) + (local $sign i32) (local $exp i32) (local $m i64) + (local $i i32) (local $j i32) (local $d i32) (local $txt (ref $chars)) + (local $len i32) (local $s (ref $string)) + (local $unit i64) (local $half i64) (local $mask i64) (local $frac i64) + (local.set $prec (i31.get_s (ref.cast (ref i31) (local.get 1)))) + (local.set $style (i31.get_s (ref.cast (ref i31) (local.get 2)))) + (local.set $b + (i64.reinterpret_f64 + (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) + (local.set $sign (i32.wrap_i64 (i64.shr_u (local.get $b) (i64.const 63)))) + (local.set $exp + (i32.and (i32.wrap_i64 (i64.shr_u (local.get $b) (i64.const 52))) + (i32.const 0x7FF))) + (local.set $m + (i64.and (local.get $b) + (i64.sub (i64.shl (i64.const 1) (i64.const 52)) (i64.const 1)))) + (local.set $i + (i32.or (local.get $sign) + (i32.ne (local.get $style) (i32.const 45)))) ;; '-' + (local.set $s + (block $sign (result (ref $string)) + (if (i32.eq (local.get $exp) (i32.const 0x7FF)) + (then + (local.set $txt + (if (result (ref $chars)) (i64.eqz (local.get $m)) + (then + (global.get $infinity)) + (else + (global.get $nan)))) + (local.set $len (array.len (local.get $txt))) + (local.set $s + (array.new $string (i32.const 0) + (i32.add (local.get $i) (local.get $len)))) + (array.copy $string $chars + (local.get $s) (local.get $i) (local.get $txt) (i32.const 0) + (local.get $len)) + (br $sign (local.get $s)))) + (if (i32.eqz (local.get $exp)) + (then + (if (i64.ne (local.get $m) (i64.const 0)) + (then (local.set $exp (i32.const -1022))))) + (else + (local.set $exp (i32.sub (local.get $exp) (i32.const 1023))) + (local.set $m + (i64.or (local.get $m) + (i64.shl (i64.const 1) (i64.const 52)))))) + (if (i32.and (i32.ge_s (local.get $prec) (i32.const 0)) + (i32.lt_s (local.get $prec) (i32.const 13))) + (then + (local.set $unit + (i64.shl (i64.const 1) + (i64.extend_i32_s + (i32.sub (i32.const 52) + (i32.shl (local.get $prec) (i32.const 2)))))) + (local.set $half + (i64.shr_u (local.get $unit) (i64.const 1))) + (local.set $mask (i64.sub (local.get $unit) (i64.const 1))) + (local.set $frac (i64.and (local.get $m) (local.get $mask))) + (local.set $m + (i64.and (local.get $m) + (i64.xor (i64.const -1) (local.get $mask)))) + (if (i32.or (i64.gt_u (local.get $frac) (local.get $half)) + (i32.and (i64.eq (local.get $frac) (local.get $half)) + (i64.ne (i64.and (local.get $m) + (local.get $unit)) + (i64.const 0)))) + (then + (local.set $m + (i64.add (local.get $m) (local.get $unit))))))) + (local.set $frac (i64.shl (local.get $m) (i64.const 12))) + (local.set $j (i32.const 0)) + (loop $prec + (if (i64.ne (local.get $frac) (i64.const 0)) + (then + (local.set $j (i32.add (local.get $j) (i32.const 1))) + (local.set $frac (i64.shl (local.get $frac) (i64.const 4))) + (br $prec)))) + (if (i32.lt_s (local.get $prec) (local.get $j)) + (then (local.set $prec (local.get $j)))) + (if (i32.ge_s (local.get $exp) (i32.const 0)) + (then (local.set $d (local.get $exp))) + (else (local.set $d (i32.sub (i32.const 0) (local.get $exp))))) + (local.set $j (i32.const 0)) + (loop $count + (local.set $j (i32.add (local.get $j) (i32.const 1))) + (local.set $d (i32.div_u (local.get $d) (i32.const 10))) + (br_if $count (local.get $d))) + (local.set $len (i32.add (i32.add (local.get $i) (local.get $prec)) + (i32.add (i32.const 6) (local.get $j)))) + (if (i32.eqz (local.get $prec)) + (then (local.set $len (i32.sub (local.get $len) (i32.const 1))))) + (local.set $s (array.new $string (i32.const 0) (local.get $len))) + (if (i32.ge_s (local.get $exp) (i32.const 0)) + (then (local.set $d (local.get $exp))) + (else (local.set $d (i32.sub (i32.const 0) (local.get $exp))))) + (loop $write + (local.set $len (i32.sub (local.get $len) (i32.const 1))) + (array.set $string (local.get $s) (local.get $len) + (i32.add (i32.const 48) + (i32.rem_u (local.get $d) (i32.const 10)))) + (local.set $d (i32.div_u (local.get $d) (i32.const 10))) + (br_if $write (local.get $d))) + (array.set $string (local.get $s) + (i32.sub (local.get $len) (i32.const 1)) + (select (i32.const 43) (i32.const 45) + (i32.ge_s (local.get $exp) (i32.const 0)))) + (array.set $string (local.get $s) (local.get $i) (i32.const 48)) ;; '0' + (array.set $string (local.get $s) (i32.add (local.get $i) (i32.const 1)) + (i32.const 120)) ;; 'x' + (array.set $string (local.get $s) (i32.add (local.get $i) (i32.const 2)) + (i32.add + (i32.wrap_i64 (i64.shr_u (local.get $m) (i64.const 52))) + (i32.const 48))) ;; '0' + (local.set $i (i32.add (local.get $i) (i32.const 3))) + (if (i32.gt_s (local.get $prec) (i32.const 0)) + (then + (array.set $string (local.get $s) (local.get $i) + (i32.const 46)) ;; '.' + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $frac (i64.shl (local.get $m) (i64.const 12))) + (loop $write + (array.set $string (local.get $s) (local.get $i) + (array.get_u $chars (global.get $lowercase_hex_table) + (i32.wrap_i64 + (i64.shr_u (local.get $frac) (i64.const 60))))) + (local.set $frac (i64.shl (local.get $frac) (i64.const 4))) + (local.set $prec (i32.sub (local.get $prec) (i32.const 1))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $write (i32.gt_s (local.get $prec) (i32.const 0)))))) + (array.set $string (local.get $s) (local.get $i) (i32.const 112)) + (local.get $s))) + (if (local.get $sign) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 45))) ;; '-' + (else + (if (i32.ne (local.get $style) (i32.const 45)) ;; '-' + (then + (array.set $string (local.get $s) (i32.const 0) + (local.get $style)))))) + (local.get $s)) + + (data $format_error "format_float: bad format") + + (func $parse_format + (param $s (ref $string)) (result i32 i32 i32 i32) + (local $i i32) (local $len i32) (local $c i32) + (local $sign_style i32) (local $precision i32) + (local $conversion i32) (local $uppercase i32) + (local.set $len (array.len (local.get $s))) + (local.set $i (i32.const 1)) + (block $return + (block $bad_format + (br_if $bad_format (i32.lt_u (local.get $len) (i32.const 2))) + (br_if $bad_format + (i32.ne (array.get_u $string (local.get $s) (i32.const 0)) + (i32.const 37))) ;; '%' + (local.set $c (array.get_u $string (local.get $s) (i32.const 1))) + (if (i32.eq (local.get $c) (i32.const 43)) ;; '+' + (then + (local.set $sign_style (i32.const 1)) + (local.set $i (i32.add (local.get $i) (i32.const 1))))) + (if (i32.eq (local.get $c) (i32.const 32)) ;; ' ' + (then + (local.set $sign_style (i32.const 2)) + (local.set $i (i32.add (local.get $i) (i32.const 1))))) + (br_if $bad_format (i32.eq (local.get $i) (local.get $len))) + (br_if $bad_format + (i32.ne (array.get_u $string (local.get $s) (local.get $i)) + (i32.const 46))) ;; '.' + (loop $precision + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $bad_format (i32.eq (local.get $i) (local.get $len))) + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.and (i32.ge_u (local.get $c) (i32.const 48)) ;; '0' + (i32.le_u (local.get $c) (i32.const 57))) ;; '9' + (then + (local.set $precision + (i32.add (i32.mul (local.get $precision) (i32.const 10)) + (i32.sub (local.get $c) (i32.const 48)))) + (br $precision)))) + (br_if $bad_format + (i32.ne (i32.add (local.get $i) (i32.const 1)) (local.get $len))) + (local.set $uppercase (i32.lt_s (local.get $c) (i32.const 96))) + (local.set $conversion + (i32.sub + (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 69))) ;; 'E' + (br_if $return (i32.le_u (local.get $conversion) (i32.const 2)))) + (call $caml_invalid_argument + (array.new_data $string $format_error + (i32.const 0) (i32.const 22)))) + (tuple.make 4 + (local.get $sign_style) + (local.get $precision) + (local.get $conversion) + (local.get $uppercase))) + + (global $inf (ref $chars) + (array.new_fixed $chars 3 + (i32.const 105) (i32.const 110) (i32.const 102))) + + (func (export "caml_format_float") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local $f f64) (local $b i64) (local $format (tuple i32 i32 i32 i32)) + (local $sign_style i32) (local $precision i32) + (local $conversion i32) (local $uppercase i32) + (local $negative i32) + (local $exp i32) (local $m i64) + (local $i i32) (local $len i32) (local $c i32) + (local $s (ref $string)) (local $txt (ref $chars)) + (local $num anyref) + (local.set $f (struct.get $float 0 (ref.cast (ref $float) (local.get 1)))) + (local.set $b (i64.reinterpret_f64 (local.get $f))) + (local.set $format + (call $parse_format (ref.cast (ref $string) (local.get 0)))) + (local.set $sign_style (tuple.extract 4 0 (local.get $format))) + (local.set $precision (tuple.extract 4 1 (local.get $format))) + (local.set $conversion (tuple.extract 4 2 (local.get $format))) + (local.set $uppercase (tuple.extract 4 3 (local.get $format))) + (local.set $negative + (i32.wrap_i64 (i64.shr_u (local.get $b) (i64.const 63)))) + (local.set $i + (i32.or (local.get $negative) + (i32.ne (local.get $sign_style) (i32.const 0)))) + (local.set $s + (block $sign (result (ref $string)) + (local.set $exp + (i32.and (i32.wrap_i64 (i64.shr_u (local.get $b) (i64.const 52))) + (i32.const 0x7FF))) + (if (i32.eq (local.get $exp) (i32.const 0x7FF)) + (then + (local.set $m (i64.shl (local.get $b) (i64.const 12))) + (local.set $txt + (if (result (ref $chars)) (i64.eqz (local.get $m)) + (then + (global.get $inf)) + (else + (local.set $negative (i32.const 0)) + (local.set $i + (i32.ne (local.get $sign_style) (i32.const 0))) + (global.get $nan)))) + (local.set $len (array.len (local.get $txt))) + (local.set $s + (array.new $string (i32.const 0) + (i32.add (local.get $i) (local.get $len)))) + (array.copy $string $chars + (local.get $s) (local.get $i) (local.get $txt) (i32.const 0) + (local.get $len)) + (br $sign (local.get $s)))) + (local.set $num + (call $format_float + (local.get $precision) (local.get $conversion) + (local.get $i) + (f64.abs (local.get $f)))) + (local.set $s (call $string_of_jsstring (local.get $num))) + (br $sign (local.get $s)))) + (if (local.get $negative) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 45))) ;; '-' + (else + (if (local.get $sign_style) + (then + (if (i32.eq (local.get $sign_style) (i32.const 1)) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 43))) ;; '+' + (else + (array.set $string (local.get $s) (i32.const 0) + (i32.const 32)))))))) ;; ' ' + (if (local.get $uppercase) + (then + (local.set $i (i32.const 0)) + (local.set $len (array.len (local.get $s))) + (loop $uppercase + (local.set $c (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.and (i32.ge_u (local.get $c) (i32.const 97)) ;; 'a' + (i32.le_u (local.get $c) (i32.const 122))) ;; 'z' + (then + (array.set $string (local.get $s) (local.get $i) + (i32.sub (local.get $c) (i32.const 32))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $uppercase (i32.lt_u (local.get $i) (local.get $len)))))) + (local.get $s)) + + (data $float_of_string "float_of_string") + + (func $caml_float_of_hex (param $s (ref $string)) (param $i i32) (result f64) + (local $len i32) (local $c i32) (local $d i32) (local $m i64) + (local $f f64) (local $negative i32) + (local $dec_point i32) (local $exp i32) (local $adj i32) + (local $n_bits i32) (local $m_bits i32) (local $x_bits i32) + (local.set $len (array.len (local.get $s))) + (local.set $dec_point (i32.const -1)) + (block $error + (loop $parse + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.eq (local.get $c) (i32.const 46)) ;; '.' + (then + (br_if $error + (i32.ge_s (local.get $dec_point) (i32.const 0))) + (local.set $dec_point (local.get $n_bits)) + (br $parse))) + (if (i32.or (i32.eq (local.get $c) (i32.const 80)) ;; 'P' + (i32.eq (local.get $c) (i32.const 112))) ;; 'p' + (then + (br_if $error (i32.eq (local.get $i) (local.get $len))) + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.eq (local.get $c) (i32.const 45)) ;; '-' + (then + (local.set $negative (i32.const 1)) + (br_if $error + (i32.eq (local.get $i) (local.get $len))) + (local.set $c + (array.get_u $string + (local.get $s) (local.get $i))) + (local.set $i + (i32.add (local.get $i) (i32.const 1))))) + (if (i32.eq (local.get $c) (i32.const 43)) ;; '+' + (then + (br_if $error + (i32.eq (local.get $i) (local.get $len))) + (local.set $c + (array.get_u $string + (local.get $s) (local.get $i))) + (local.set $i + (i32.add (local.get $i) (i32.const 1))))) + (block $overflow + (loop $parse_exponent + (br_if $error + (i32.or (i32.lt_u (local.get $c) (i32.const 48)) + (i32.gt_u (local.get $c) (i32.const 57)))) + (local.set $d + (i32.sub (local.get $c) (i32.const 48))) + (local.set $exp + (i32.add + (i32.mul (local.get $exp) (i32.const 10)) + (local.get $d))) + (br_if $overflow + (i32.lt_u (local.get $exp) (local.get $d))) + (if (i32.ne (local.get $i) (local.get $len)) + (then + (local.set $c + (array.get_u $string + (local.get $s) (local.get $i))) + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (br $parse_exponent)))) + (if (local.get $negative) + (then + (br_if $overflow + (i32.gt_u (local.get $exp) + (i32.const 0x80000000))) + (local.set $exp + (i32.sub (i32.const 0) (local.get $exp)))) + (else + (br_if $overflow + (i32.ge_u (local.get $exp) + (i32.const 0x80000000))))) + (br $parse)) + (if (i32.or (local.get $negative) + (i64.eqz (local.get $m))) + (then + (return (f64.const 0))) + (else + (return (f64.const inf)))))) + (if (i32.and (i32.ge_u (local.get $c) (i32.const 48)) + (i32.le_u (local.get $c) (i32.const 57))) + (then + (local.set $d (i32.sub (local.get $c) (i32.const 48)))) + (else (if (i32.and (i32.ge_u (local.get $c) (i32.const 97)) + (i32.le_u (local.get $c) (i32.const 102))) + (then + (local.set $d (i32.sub (local.get $c) (i32.const 87)))) + (else (if (i32.and (i32.ge_u (local.get $c) (i32.const 65)) + (i32.le_u (local.get $c) (i32.const 70))) + (then + (local.set $d (i32.sub (local.get $c) (i32.const 55)))) + (else + (br $error))))))) + (local.set $n_bits + (i32.add (local.get $n_bits) (i32.const 4))) + (br_if $parse + (i32.and (i32.eqz (local.get $d)) (i64.eqz (local.get $m)))) + (if (i32.lt_u (local.get $m_bits) (i32.const 60)) + (then + (local.set $m + (i64.add (i64.shl (local.get $m) (i64.const 4)) + (i64.extend_i32_u (local.get $d)))) + (local.set $m_bits + (i32.add (local.get $m_bits) (i32.const 4)))) + (else + (if (local.get $d) + (then + (local.set $m + (i64.or (local.get $m) (i64.const 1))))) + (local.set $x_bits + (i32.add (local.get $x_bits) (i32.const 4))))) + (br $parse)))) + (br_if $error (i32.eqz (local.get $n_bits))) + (local.set $f (f64.convert_i64_s (local.get $m))) + (local.set $adj (local.get $x_bits)) + (if (i32.ge_s (local.get $dec_point) (i32.const 0)) + (then + (local.set $adj + (i32.add (local.get $adj) + (i32.sub (local.get $dec_point) (local.get $n_bits)))))) + (if (i32.and (i32.gt_s (local.get $adj) (i32.const 0)) + (i32.gt_s (local.get $exp) (i32.const 0x7fffffff))) + (then (local.set $exp (i32.const 0x7fffffff))) + (else (if (i32.and (i32.lt_s (local.get $adj) (i32.const 0)) + (i32.lt_s (local.get $exp) (i32.const 0x80000000))) + (then (local.set $exp (i32.const 0x80000000))) + (else + (local.set $exp (i32.add (local.get $exp) (local.get $adj))))))) + (if (local.get $exp) + (then (local.set $f (call $ldexp (local.get $f) (local.get $exp))))) + (return (local.get $f))) + (call $caml_failwith + (array.new_data $string $float_of_string (i32.const 0) (i32.const 15))) + (f64.const 0)) + + (func $on_whitespace (param $s (ref $string)) (param $i i32) (result i32) + (local $c i32) + (local.set $c (array.get_u $string (local.get $s) (local.get $i))) + (i32.or (i32.eq (local.get $c) (i32.const 32)) ;; ' ' + (i32.le_u (i32.sub (local.get $c) (i32.const 9)) (i32.const 4)))) + + (func (export "caml_float_of_string") (param (ref eq)) (result (ref eq)) + (local $s (ref $string)) (local $len i32) (local $i i32) (local $j i32) + (local $s' (ref $string)) + (local $negative i32) (local $c i32) + (local $f f64) + (local.set $s (ref.cast (ref $string) (local.get 0))) + (local.set $len (array.len (local.get $s))) + (loop $count + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (if (i32.eq (i32.const 95) ;; '_' + (array.get_u $string (local.get $s) (local.get $i))) + (then + (local.set $j (i32.add (local.get $j) (i32.const 1))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $count)))) + (if (local.get $j) + (then + (local.set $s' + (array.new $string (i32.const 0) + (i32.sub (local.get $len) (local.get $j)))) + (local.set $i (i32.const 0)) + (local.set $j (i32.const 0)) + (loop $copy + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.ne (local.get $c) (i32.const 95)) ;; '_' + (then + (array.set $string (local.get $s') + (local.get $j) (local.get $c)) + (local.set $j + (i32.add (local.get $j) (i32.const 1))))) + (br $copy)))) + (local.set $len (array.len (local.get $s'))) + (local.set $s (local.get $s')))) + (local.set $i (i32.const 0)) + (loop $skip_spaces + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (if (call $on_whitespace (local.get $s) (local.get $i)) + (then + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $skip_spaces)))))) + (block $error + (br_if $error (i32.eq (local.get $i) (local.get $len))) + (br_if $error + (call $on_whitespace + (local.get $s) (i32.sub (local.get $len) (i32.const 1)))) + (local.set $c (array.get_u $string (local.get $s) (i32.const 0))) + (if (i32.eq (local.get $c) (i32.const 45)) ;; '-' + (then + (local.set $negative (i32.const 1)) + (local.set $i (i32.const 1)))) + (if (i32.eq (local.get $c) (i32.const 43)) ;; '+' + (then + (local.set $i (i32.const 1)))) + (if (i32.lt_u (i32.add (local.get $i) (i32.const 2)) (local.get $len)) + (then + (if (i32.eq (array.get_u $string (local.get $s) (local.get $i)) + (i32.const 48)) ;; '0' + (then + (if (i32.eq (i32.and + (array.get_u $string (local.get $s) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 0xdf)) + (i32.const 88)) ;; 'X' + (then + (local.set $f + (call $caml_float_of_hex (local.get $s) + (i32.add (local.get $i) (i32.const 2)))) + (if (local.get $negative) + (then (local.set $f (f64.neg (local.get $f))))) + (return (struct.new $float (local.get $f))))))))) + (if (i32.eq (i32.add (local.get $i) (i32.const 3)) (local.get $len)) + (then + (local.set $c (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 78)) (then ;; 'N' + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 65)) (then ;; 'A' + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 78)) ;; 'N' + (then + (return + (struct.new $float (f64.const nan))))))))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 73)) (then ;; 'I' + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 78)) (then ;; 'N' + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 70)) ;; 'F' + (then + (return + (struct.new $float + (select + (f64.const -inf) + (f64.const inf) + (local.get $negative)))))))))))) + (if (i32.eq (i32.add (local.get $i) (i32.const 8)) (local.get $len)) + (then + (local.set $c (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 73)) (then ;; 'I' + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 78)) (then ;; 'N' + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 70)) (then ;; 'F' + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 73)) (then ;; 'I' + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string + (local.get $s) (local.get $i))) + (if (i32.eq (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 78)) (then ;; 'N' + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string + (local.get $s) (local.get $i))) + (if (i32.eq + (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 73)) (then ;; 'I' + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string + (local.get $s) (local.get $i))) + (if (i32.eq + (i32.and (local.get $c) (i32.const 0xdf)) + (i32.const 84)) (then ;; 'T' + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (local.set $c + (array.get_u $string + (local.get $s) (local.get $i))) + (if (i32.eq + (i32.and (local.get $c) + (i32.const 0xdf)) + (i32.const 89)) (then ;; 'Y' + (return + (struct.new $float + (select + (f64.const -inf) + (f64.const inf) + (local.get $negative)))) + )))))))))))))))))) + (local.set $f + (call $parse_float (call $jsstring_of_string (local.get $s)))) + (br_if $error (f64.ne (local.get $f) (local.get $f))) + (return (struct.new $float (local.get $f)))) + (call $caml_failwith + (array.new_data $string $float_of_string (i32.const 0) (i32.const 15))) + (return (ref.i31 (i32.const 0)))) + + (func (export "caml_nextafter_float") + (param $x f64) (param $y f64) (result f64) + (local $i i64) (local $j i64) + (if (f64.ne (local.get $x) (local.get $x)) (then (return (local.get $x)))) + (if (f64.ne (local.get $y) (local.get $y)) (then (return (local.get $y)))) + (if (f64.eq (local.get $x) (local.get $y)) + (then (return (local.get $y)))) + (if (f64.eq (local.get $x) (f64.const 0)) + (then + (if (f64.ge (local.get $y) (f64.const 0)) + (then (return (f64.const 0x1p-1074))) + (else (return (f64.const -0x1p-1074))))) + (else + (local.set $i (i64.reinterpret_f64 (local.get $x))) + (local.set $j (i64.reinterpret_f64 (local.get $y))) + (if (i32.and (i64.lt_s (local.get $i) (local.get $j)) + (i64.lt_u (local.get $i) (local.get $j))) + (then (local.set $i (i64.add (local.get $i) (i64.const 1)))) + (else (local.set $i (i64.sub (local.get $i) (i64.const 1))))) + (return (f64.reinterpret_i64 (local.get $i)))))) + + (func (export "caml_classify_float") (param $x f64) (result (ref eq)) + (local $a f64) + (local.set $a (f64.abs (local.get $x))) + (ref.i31 + (if (result i32) (f64.ge (local.get $a) (f64.const 0x1p-1022)) + (then + (if (result i32) (f64.lt (local.get $a) (f64.const inf)) + (then (i32.const 0)) ;; normal + (else (i32.const 3)))) ;; infinity + (else + (if (result i32) (f64.eq (local.get $a) (f64.const 0)) + (then (i32.const 2)) ;; zero + (else + (if (result i32) (f64.eq (local.get $a) (local.get $a)) + (then (i32.const 1)) ;; subnormal + (else (i32.const 4))))))))) ;; nan + + (func (export "caml_modf_float") (param (ref eq)) (result (ref eq)) + (local $x f64) (local $a f64) (local $i f64) (local $f f64) + (local.set $x (struct.get $float 0 (ref.cast (ref $float) (local.get 0)))) + (local.set $a (f64.abs (local.get $x))) + (if (f64.ge (local.get $a) (f64.const 0)) + (then + (if (f64.lt (local.get $a) (f64.const inf)) + (then ;; normal + (local.set $i (f64.floor (local.get $a))) + (local.set $f (f64.sub (local.get $a) (local.get $i))) + (local.set $i (f64.copysign (local.get $i) (local.get $x))) + (local.set $f (f64.copysign (local.get $f) (local.get $x)))) + (else ;; infinity + (local.set $i (local.get $x)) + (local.set $f (f64.copysign (f64.const 0) (local.get $x)))))) + (else ;; zero or nan + (local.set $i (local.get $x)) + (local.set $f (local.get $x)))) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (struct.new $float (local.get $f)) (struct.new $float (local.get $i)))) + + (func $ldexp (param $x f64) (param $n i32) (result f64) + (if (i32.gt_s (local.get $n) (i32.const 1023)) + (then + (local.set $x (f64.mul (local.get $x) (f64.const 0x1p1023))) + (local.set $n (i32.sub (local.get $n) (i32.const 1023))) + (if (i32.gt_s (local.get $n) (i32.const 1023)) + (then + ;; subnormal + (local.set $x (f64.mul (local.get $x) (f64.const 0x1p1023))) + (local.set $n (i32.sub (local.get $n) (i32.const 1023))) + (if (i32.gt_s (local.get $n) (i32.const 1023)) + (then (local.set $n (i32.const 1023))))))) + (else + (if (i32.lt_s (local.get $n) (i32.const -1022)) + (then + (local.set $x (f64.mul (local.get $x) (f64.const 0x1p-969))) + (local.set $n (i32.add (local.get $n) (i32.const 969))) + (if (i32.lt_s (local.get $n) (i32.const -1022)) + (then + (local.set $x + (f64.mul (local.get $x) (f64.const 0x1p-969))) + (local.set $n (i32.add (local.get $n) (i32.const 969))) + (if (i32.lt_s (local.get $n) (i32.const -1022)) + (then (local.set $n (i32.const -1022)))))))))) + (f64.mul (local.get $x) + (f64.reinterpret_i64 + (i64.shl (i64.add (i64.extend_i32_s (local.get $n)) + (i64.const 0x3ff)) + (i64.const 52))))) + + (func (export "caml_ldexp_float") + (param $x f64) (param $i (ref eq)) (result f64) + (call $ldexp + (local.get $x) + (i31.get_s (ref.cast (ref i31) (local.get $i))))) + + (func $frexp (param $x f64) (result f64 i32) + (local $y i64) + (local $e i32) + (local $r (tuple f64 i32)) + (local.set $y (i64.reinterpret_f64 (local.get $x))) + (local.set $e + (i32.and (i32.const 0x7ff) + (i32.wrap_i64 (i64.shr_u (local.get $y) (i64.const 52))))) + (if (i32.eqz (local.get $e)) + (then + (if (f64.ne (local.get $x) (f64.const 0)) + (then + (local.set $r + (call $frexp (f64.mul (local.get $x) (f64.const 0x1p64)))) + (return + (tuple.make 2 + (tuple.extract 2 0 (local.get $r)) + (i32.sub (tuple.extract 2 1 (local.get $r)) + (i32.const 64))))) + (else + (return (tuple.make 2 (local.get $x) (i32.const 0)))))) + (else + (if (i32.eq (local.get $e) (i32.const 0x7ff)) + (then + (return (tuple.make 2 (local.get $x) (i32.const 0))))))) + (tuple.make 2 + (f64.reinterpret_i64 + (i64.or (i64.and (local.get $y) (i64.const 0x800fffffffffffff)) + (i64.const 0x3fe0000000000000))) + (i32.sub (local.get $e) (i32.const 0x3fe)))) + + (func (export "caml_frexp_float") (param (ref eq)) (result (ref eq)) + (local $r (tuple f64 i32)) + (local.set $r + (call $frexp + (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (struct.new $float (tuple.extract 2 0 (local.get $r))) + (ref.i31 (tuple.extract 2 1 (local.get $r))))) + + (func (export "caml_signbit_float") (param $x f64) (result (ref eq)) + (ref.i31 + (i32.wrap_i64 + (i64.shr_u (i64.reinterpret_f64 (local.get $x)) (i64.const 63))))) + + (func $erf (export "caml_erf_float") (param $x f64) (result f64) + (local $a1 f64) (local $a2 f64) (local $a3 f64) + (local $a4 f64) (local $a5 f64) (local $p f64) + (local $t f64) (local $y f64) + (local.set $a1 (f64.const 0.254829592)) + (local.set $a2 (f64.const -0.284496736)) + (local.set $a3 (f64.const 1.421413741)) + (local.set $a4 (f64.const -1.453152027)) + (local.set $a5 (f64.const 1.061405429)) + (local.set $p (f64.const 0.3275911)) + (local.set $t + (f64.div (f64.const 1) + (f64.add (f64.const 1) + (f64.mul (local.get $p) (f64.abs (local.get $x)))))) + (local.set $y + (f64.sub (f64.const 1) + (f64.mul + (f64.add + (f64.mul + (f64.add + (f64.mul + (f64.add + (f64.mul + (f64.add + (f64.mul (local.get $a5) (local.get $t)) + (local.get $a4)) + (local.get $t)) + (local.get $a3)) + (local.get $t)) + (local.get $a2)) + (local.get $t)) + (local.get $a1)) + (f64.mul (local.get $t) + (call $exp + (f64.neg (f64.mul (local.get $x) (local.get $x)))))))) + (f64.copysign (local.get $y) (local.get $x))) + + (func (export "caml_erfc_float") (param $x f64) (result f64) + (f64.sub (f64.const 1) (call $erf (local.get $x)))) + + (func (export "caml_fma_float") + (param $vx (ref eq)) (param $vy (ref eq)) (param $vz (ref eq)) + (result (ref eq)) + (local $x f64) + (local $y f64) + (local $z f64) + (local $3 i64) + (local $4 i64) + (local $5 i64) + (local $6 i64) + (local $7 i64) + (local $8 i64) + (local $9 i32) + (local $10 i32) + (local $11 f64) + (local $12 f64) + (local $13 f64) + (local $14 f64) + (local $15 f64) + (local.set $x + (struct.get $float 0 (ref.cast (ref $float) (local.get $vx)))) + (local.set $y + (struct.get $float 0 (ref.cast (ref $float) (local.get $vy)))) + (local.set $z + (struct.get $float 0 (ref.cast (ref $float) (local.get $vz)))) + (local.set $7 + (i64.add + (local.tee $4 + (i64.and + (i64.shr_u + (local.tee $3 (i64.reinterpret_f64 (local.get $y))) + (i64.const 52)) + (i64.const 2047))) + (local.tee $6 + (i64.and + (i64.shr_u + (local.tee $5 (i64.reinterpret_f64 (local.get $x))) + (i64.const 52)) + (i64.const 2047))))) + (local.set $8 (i64.reinterpret_f64 (local.get $z))) + (block $label$1 + (block $label$2 + (br_if $label$2 (i64.gt_u (local.get $4) (i64.const 1993))) + (br_if $label$2 (i64.gt_u (local.get $6) (i64.const 1993))) + (br_if $label$2 (i64.gt_u (local.get $7) (i64.const 3016))) + (br_if $label$2 + (i64.gt_u + (i64.and (local.get $8) (i64.const 0x7fe0000000000000)) + (i64.const 0x7c90000000000000))) + (local.set $9 (i32.const 0)) + (br_if $label$2 (i64.le_u (local.get $7) (i64.const 1076))) + (local.set $10 (i32.const 0)) + (br $label$1)) + (local.set $8 + (i64.and (i64.shr_u (local.get $8) (i64.const 52)) + (i64.const 2047))) + (block $cont + (br_if $cont (i64.eq (local.get $4) (i64.const 2047))) + (br_if $cont (i64.eq (local.get $6) (i64.const 2047))) + (br_if $cont (i64.ne (local.get $8) (i64.const 2047))) + (return + (struct.new $float + (f64.add (f64.add (local.get $x) (local.get $z)) + (local.get $y))))) + (block $cont + (br_if $cont (f64.eq (local.get $y) (f64.const 0))) + (br_if $cont (f64.eq (local.get $x) (f64.const 0))) + (br_if $cont (f64.ne (local.get $z) (f64.const 0))) + (return + (struct.new $float + (f64.mul (local.get $x) (local.get $y))))) + (block $cont + (block $then + (br_if $then (i64.eq (local.get $6) (i64.const 2047))) + (br_if $then (i64.eq (local.get $4) (i64.const 2047))) + (br_if $then (f64.eq (local.get $y) (f64.const 0))) + (br_if $then (f64.eq (local.get $x) (f64.const 0))) + (br_if $cont (i64.ne (local.get $8) (i64.const 2047)))) + (return + (struct.new $float + (f64.add (f64.mul (local.get $x) (local.get $y)) + (local.get $z))))) + (block $cont + (br_if $cont (i64.lt_u (local.get $7) (i64.const 3071))) + (return + (struct.new $float (f64.mul (local.get $x) (local.get $y))))) + (block $cont + (br_if $cont (i64.gt_u (local.get $7) (i64.const 967))) + (local.set $y + (select + (f64.const 0x1p-1074) + (f64.const -0x1p-1074) + (i64.gt_s (i64.xor (local.get $3) (local.get $5)) + (i64.const -1)))) + (block $cont2 + (br_if $cont2 (i64.lt_u (local.get $8) (i64.const 3))) + (return + (struct.new $float(f64.add (local.get $y) (local.get $z))))) + (return + (struct.new $float + (f64.mul + (f64.add (f64.mul (local.get $z) (f64.const 0x1p54)) + (local.get $y)) + (f64.const 0x1p-54))))) + (block $label$10 + (block $label$11 + (block $label$12 + (br_if $label$12 (i64.lt_u (local.get $7) (i64.const 3017))) + (local.set $z + (select + (f64.mul (local.get $z) (f64.const 0x1p-53)) + (local.get $z) + (i64.gt_u (local.get $8) (i64.const 53)))) + (local.set $x + (select + (f64.mul (local.get $x) (f64.const 0x1p-53)) + (local.get $x) + (local.tee $9 (i64.gt_u (local.get $6) (local.get $4))))) + (local.set $y + (select + (local.get $y) + (f64.mul (local.get $y) (f64.const 0x1p-53)) + (local.get $9))) + (br $label$11)) + (br_if $label$10 (i64.lt_u (local.get $8) (i64.const 1994))) + (block $label$13 + (block $label$14 + (br_if $label$14 (i64.gt_u (local.get $7) (i64.const 1129))) + (block $label$15 + (br_if $label$15 + (i64.le_u (local.get $6) (local.get $4))) + (local.set $x + (f64.mul (local.get $x) (f64.const 0x1p108))) + (br $label$13)) + (local.set $y (f64.mul (local.get $y) (f64.const 0x1p108))) + (br $label$13)) + (block $label$16 + (br_if $label$16 (i64.le_u (local.get $6) (local.get $4))) + (local.set $x + (select + (f64.mul (local.get $x) (f64.const 0x1p-53)) + (local.get $x) + (i64.gt_u (local.get $6) (i64.const 53)))) + (br $label$13)) + (local.set $y + (select + (f64.mul (local.get $y) (f64.const 0x1p-53)) + (local.get $y) + (i64.gt_u (local.get $4) (i64.const 53))))) + (local.set $z (f64.mul (local.get $z) (f64.const 0x1p-53)))) + (local.set $10 (i32.const 0)) + (local.set $9 (i32.const 1)) + (br $label$1)) + (block $label$17 + (block $label$18 + (br_if $label$18 (i64.lt_u (local.get $6) (i64.const 1994))) + (local.set $y (f64.mul (local.get $y) (f64.const 0x1p53))) + (local.set $x (f64.mul (local.get $x) (f64.const 0x1p-53))) + (br $label$17)) + (block $label$19 + (br_if $label$19 (i64.lt_u (local.get $4) (i64.const 1994))) + (local.set $x (f64.mul (local.get $x) (f64.const 0x1p53))) + (local.set $y (f64.mul (local.get $y) (f64.const 0x1p-53))) + (br $label$17)) + (local.set $z + (select + (f64.mul (local.get $z) (f64.const 0x1p108)) + (local.get $z) + (local.tee $10 (i64.lt_u (local.get $8) (i64.const 219))))) + (local.set $x + (select + (f64.mul (local.get $x) (f64.const 0x1p108)) + (local.get $x) + (local.tee $9 (i64.gt_u (local.get $6) (local.get $4))))) + (local.set $y + (select + (local.get $y) + (f64.mul (local.get $y) (f64.const 0x1p108)) + (local.get $9))) + (local.set $9 (i32.const 0)) + (br $label$1)) + (local.set $9 (i32.const 0)) + (local.set $10 (i32.const 0))) + (block $cont + (br_if $cont (f64.ne (local.get $z) (f64.const 0))) + (br_if $cont + (i32.eqz + (i32.or + (f64.eq (local.get $y) (f64.const 0)) + (f64.eq (local.get $x) (f64.const 0))))) + (return + (struct.new $float + (f64.add + (f64.mul (local.get $x) (local.get $y)) (local.get $z))))) + (local.set $x + (f64.sub + (f64.mul + (local.tee $12 + (f64.sub + (local.get $x) + (local.tee $11 + (f64.sub + (local.tee $11 + (f64.mul (local.get $x) (f64.const 0x8000001))) + (f64.sub (local.get $11) (local.get $x)))))) + (local.tee $14 + (f64.sub + (local.get $y) + (local.tee $13 + (f64.sub + (local.tee $13 + (f64.mul (local.get $y) (f64.const 0x8000001))) + (f64.sub (local.get $13) (local.get $y))))))) + (f64.sub + (f64.sub + (f64.sub + (local.tee $15 (f64.mul (local.get $y) (local.get $x))) + (f64.mul (local.get $11) (local.get $13))) + (f64.mul (local.get $12) (local.get $13))) + (f64.mul (local.get $11) (local.get $14))))) + (block $label$21 + (block $label$22 + (br_if $label$22 + (f64.ne + (local.tee $y (f64.add (local.get $z) (local.get $15))) + (f64.const 0))) + (br_if $label$21 (f64.eq (local.get $x) (f64.const 0)))) + (block $cont + (br_if $cont + (f64.eq + (local.tee $z + (f64.add + (local.tee $11 + (f64.add + (f64.sub (local.get $x) + (local.tee $13 + (f64.sub + (local.tee $z + (f64.add + (local.tee $11 + (f64.add + (f64.sub (local.get $15) + (local.tee $11 + (f64.sub + (local.get $y) + (local.get $z)))) + (f64.sub (local.get $z) + (f64.sub + (local.get $y) + (local.get $11))))) + (local.get $x))) + (local.get $11)))) + (f64.sub (local.get $11) + (f64.sub (local.get $z) (local.get $13))))) + (f64.sub + (local.tee $y + (f64.add + (f64.sub (local.get $z) + (local.tee $13 + (f64.sub + (local.tee $x + (f64.add (local.get $y) + (local.get $z))) + (local.get $y)))) + (f64.sub + (local.get $y) + (f64.sub (local.get $x) (local.get $13))))) + (local.tee $y + (f64.add (local.get $11) (local.get $y)))))) + (f64.const 0))) + (br_if $cont + (i32.and + (i32.wrap_i64 + (local.tee $4 (i64.reinterpret_f64 (local.get $y)))) + (i32.const 1))) + (local.set $y + (f64.reinterpret_i64 + (i64.add + (select + (i64.const 1) + (i64.const -1) + (i32.xor + (f64.lt (local.get $y) (f64.const 0)) + (f64.gt (local.get $z) (f64.const 0)))) + (local.get $4))))) + (local.set $y (f64.add (local.get $x) (local.get $y))) + (block $cont + (br_if $cont (i32.eqz (local.get $9))) + (return + (struct.new $float + (f64.mul (local.get $y) (f64.const 0x1p53))))) + (local.set $y + (select + (f64.mul (local.get $y) (f64.const 0x1p-108)) + (local.get $y) + (local.get $10)))) + (struct.new $float (local.get $y))) + + (func (export "caml_float_compare") + (param $x f64) (param $y f64) (result (ref eq)) + (ref.i31 + (i32.add + (i32.sub (f64.gt (local.get $x) (local.get $y)) + (f64.lt (local.get $x) (local.get $y))) + (i32.sub (f64.eq (local.get $x) (local.get $x)) + (f64.eq (local.get $y) (local.get $y)))))) + + (func (export "caml_round") (param $x f64) (result f64) + (local $y f64) + (if (result f64) (f64.ge (local.get $x) (f64.const 0)) + (then + (local.set $y (f64.floor (local.get $x))) + (if (result f64) + (f64.ge (f64.sub (local.get $x) (local.get $y)) (f64.const 0.5)) + (then (f64.add (local.get $y) (f64.const 1))) + (else (local.get $y)))) + (else + (local.set $y (f64.ceil (local.get $x))) + (if (result f64) + (f64.ge (f64.sub (local.get $y) (local.get $x)) (f64.const 0.5)) + (then (f64.sub (local.get $y) (f64.const 1))) + (else (local.get $y)))))) +) diff --git a/runtime/wasm/fs.wat b/runtime/wasm/fs.wat new file mode 100644 index 0000000000..f01d5612d0 --- /dev/null +++ b/runtime/wasm/fs.wat @@ -0,0 +1,153 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "jslib" "log_str" (func $log_str (param (ref $string)))) + (import "bindings" "getcwd" (func $getcwd (result anyref))) + (import "bindings" "chdir" (func $chdir (param anyref))) + (import "bindings" "mkdir" (func $mkdir (param anyref) (param i32))) + (import "bindings" "unlink" (func $unlink (param anyref))) + (import "bindings" "readdir" + (func $readdir (param anyref) (result (ref extern)))) + (import "bindings" "file_exists" + (func $file_exists (param anyref) (result (ref eq)))) + (import "bindings" "is_directory" + (func $is_directory (param anyref) (result (ref eq)))) + (import "bindings" "rename" (func $rename (param anyref) (param anyref))) + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "jslib" "caml_string_of_jsstring" + (func $caml_string_of_jsstring (param (ref eq)) (result (ref eq)))) + (import "jslib" "caml_jsstring_of_string" + (func $caml_jsstring_of_string (param (ref eq)) (result (ref eq)))) + (import "jslib" "caml_js_to_string_array" + (func $caml_js_to_string_array (param $a (ref extern)) (result (ref eq)))) + (import "fail" "caml_raise_sys_error" + (func $caml_raise_sys_error (param (ref eq)))) + (import "fail" "javascript_exception" + (tag $javascript_exception (param externref))) + (import "sys" "caml_handle_sys_error" + (func $caml_handle_sys_error (param externref))) + + (type $string (array (mut i8))) + + (func (export "caml_sys_getcwd") + (param (ref eq)) (result (ref eq)) + (return_call $caml_string_of_jsstring (call $wrap (call $getcwd)))) + + (func (export "caml_sys_chdir") + (param $name (ref eq)) (result (ref eq)) + (try + (do + (call $chdir + (call $unwrap (call $caml_jsstring_of_string (local.get $name))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_sys_mkdir") + (param $name (ref eq)) (param $perm (ref eq)) (result (ref eq)) + (try + (do + (call $mkdir + (call $unwrap (call $caml_jsstring_of_string (local.get $name))) + (i31.get_u (ref.cast (ref i31) (local.get $perm))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_sys_read_directory") + (param $name (ref eq)) (result (ref eq)) + (try + (do + (return + (call $caml_js_to_string_array + (call $readdir + (call $unwrap + (call $caml_jsstring_of_string (local.get $name))))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)) + (return (ref.i31 (i32.const 0)))))) + + (func (export "caml_sys_remove") + (param $name (ref eq)) (result (ref eq)) + (try + (do + (call $unlink + (call $unwrap (call $caml_jsstring_of_string (local.get $name))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_sys_rename") + (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) + (try + (do + (call $rename + (call $unwrap (call $caml_jsstring_of_string (local.get $o))) + (call $unwrap (call $caml_jsstring_of_string (local.get $n))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_sys_file_exists") + (param $name (ref eq)) (result (ref eq)) + (return_call $file_exists + (call $unwrap (call $caml_jsstring_of_string (local.get $name))))) + + (data $no_such_file ": No such file or directory") + + (func $caml_raise_no_such_file (param $vname (ref eq)) + (local $name (ref $string)) (local $msg (ref $string)) + (local $len i32) + (local.set $name (ref.cast (ref $string) (local.get $vname))) + (local.set $len (array.len (local.get $name))) + (local.set $msg + (array.new $string (i32.const 0) + (i32.add (local.get $len) (i32.const 27)))) + (array.copy $string $string + (local.get $msg) (i32.const 0) + (local.get $name) (i32.const 0) + (local.get $len)) + (array.init_data $string $no_such_file + (local.get $msg) (local.get $len) (i32.const 0) (i32.const 27)) + (call $caml_raise_sys_error (local.get $msg))) + + (data $caml_read_file_content "caml_read_file_content") + + (func (export "caml_read_file_content") + (param (ref eq)) (result (ref eq)) + (call $caml_raise_no_such_file (local.get 0)) + (ref.i31 (i32.const 0))) + + (func (export "caml_fs_init") (result (ref eq)) + (ref.i31 (i32.const 0))) + + (data $caml_sys_is_directory "caml_sys_is_directory") + + (func (export "caml_sys_is_directory") + (param $name (ref eq)) (result (ref eq)) + (try + (do + (return + (call $is_directory + (call $unwrap + (call $caml_jsstring_of_string (local.get $name)))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)) + (return (ref.i31 (i32.const 0)))))) +) diff --git a/runtime/wasm/gc.wat b/runtime/wasm/gc.wat new file mode 100644 index 0000000000..01d873cc10 --- /dev/null +++ b/runtime/wasm/gc.wat @@ -0,0 +1,118 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (type $float (struct (field f64))) + (type $block (array (mut (ref eq)))) + + (func (export "caml_gc_minor") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_gc_major") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_gc_full_major") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_gc_compaction") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_gc_counters") (param (ref eq)) (result (ref eq)) + (local $f (ref eq)) + (local.set $f (struct.new $float (f64.const 0))) + (array.new_fixed $block 4 (ref.i31 (i32.const 0)) + (local.get $f) (local.get $f) (local.get $f))) + + (export "caml_gc_quick_stat" (func $caml_gc_stat)) + (func $caml_gc_stat (export "caml_gc_stat") + (param (ref eq)) (result (ref eq)) + (local $f (ref eq)) + (local.set $f (struct.new $float (f64.const 0))) + (array.new_fixed $block 18 (ref.i31 (i32.const 0)) + (local.get $f) (local.get $f) (local.get $f) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)))) + + (func (export "caml_gc_set") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_gc_get") (param (ref eq)) (result (ref eq)) + (array.new_fixed $block 12 + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0)))) + + (func (export "caml_gc_huge_fallback_count") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_gc_major_slice") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_gc_major_bucket") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_gc_major_credit") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_gc_minor_free") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_gc_minor_words") + (param (ref eq)) (result (ref eq)) + (struct.new $float (f64.const 0))) + + (func (export "caml_final_register") + (param (ref eq) (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_final_register_called_without_value") + (param (ref eq) (ref eq)) (result (ref eq)) + ;; ZZZ Use FinalizationRegistry? + (ref.i31 (i32.const 0))) + + (func (export "caml_final_release") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_memprof_start") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_memprof_set") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_memprof_stop") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_eventlog_pause") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_eventlog_resume") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) diff --git a/runtime/wasm/hash.wat b/runtime/wasm/hash.wat new file mode 100644 index 0000000000..543df44919 --- /dev/null +++ b/runtime/wasm/hash.wat @@ -0,0 +1,325 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "obj" "object_tag" (global $object_tag i32)) + (import "obj" "forward_tag" (global $forward_tag i32)) + (import "jsstring" "jsstring_test" + (func $jsstring_test (param anyref) (result i32))) + (import "jsstring" "jsstring_hash" + (func $jsstring_hash (param i32) (param anyref) (result i32))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $float (struct (field f64))) + (type $js (struct (field anyref))) + + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $dup (func (param (ref eq)) (result (ref eq)))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)) + (field $dup (ref null $dup)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + + (func $caml_hash_mix_int (export "caml_hash_mix_int") + (param $h i32) (param $d i32) (result i32) + (i32.add + (i32.mul + (i32.rotl + (i32.xor + (i32.mul + (i32.rotl + (i32.mul (local.get $d) (i32.const 0xcc9e2d51)) + (i32.const 15)) + (i32.const 0x1b873593)) + (local.get $h)) + (i32.const 13)) + (i32.const 5)) + (i32.const 0xe6546b64))) + + (func $caml_hash_mix_final (export "caml_hash_mix_final") + (param $h i32) (result i32) + (local.set $h + (i32.xor (local.get $h) (i32.shr_u (local.get $h) (i32.const 16)))) + (local.set $h (i32.mul (local.get $h) (i32.const 0x85ebca6b))) + (local.set $h + (i32.xor (local.get $h) (i32.shr_u (local.get $h) (i32.const 13)))) + (local.set $h (i32.mul (local.get $h) (i32.const 0xc2b2ae35))) + (i32.xor (local.get $h) (i32.shr_u (local.get $h) (i32.const 16)))) + + (func $caml_hash_mix_int64 (export "caml_hash_mix_int64") + (param $h i32) (param $d i64) (result i32) + (return_call $caml_hash_mix_int + (call $caml_hash_mix_int (local.get $h) (i32.wrap_i64 (local.get $d))) + (i32.wrap_i64 (i64.shr_u (local.get $d) (i64.const 32))))) + + (func $caml_hash_mix_double (export "caml_hash_mix_double") + (param $h i32) (param $d f64) (result i32) + (local $i i64) + (local.set $i (i64.reinterpret_f64 (local.get $d))) + (if (i64.eq (i64.and (local.get $i) (i64.const 0x7FF0000000000000)) + (i64.const 0x7ff0000000000000)) + (then + (if (i64.ne (i64.and (local.get $i) (i64.const 0xFFFFFFFFFFFFF)) + (i64.const 0)) + (then (local.set $i (i64.const 0x7ff0000000000001)))))) + (if (i64.eq (local.get $i) (i64.const 0x8000000000000000)) + (then (local.set $i (i64.const 0)))) + (return_call $caml_hash_mix_int64 (local.get $h) (local.get $i))) + + (func $caml_hash_mix_float (export "caml_hash_mix_float") + (param $h i32) (param $d f32) (result i32) + (local $i i32) + (local.set $i (i32.reinterpret_f32 (local.get $d))) + (if (i32.eq (i32.and (local.get $i) (i32.const 0x7F800000)) + (i32.const 0x7F800000)) + (then + (if (i32.ne (i32.and (local.get $i) (i32.const 0x7FFFFF)) + (i32.const 0)) + (then (local.set $i (i32.const 0x7F800001)))))) + (if (i32.eq (local.get $i) (i32.const 0x80000000)) + (then (local.set $i (i32.const 0)))) + (return_call $caml_hash_mix_int (local.get $h) (local.get $i))) + + (func $caml_hash_mix_string (export "caml_hash_mix_string") + (param $h i32) (param $s (ref $string)) (result i32) + (local $i i32) (local $len i32) (local $w i32) + (local.set $len (array.len (local.get $s))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.le_u (i32.add (local.get $i) (i32.const 4)) (local.get $len)) + (then + (local.set $h + (call $caml_hash_mix_int + (local.get $h) + (i32.or + (i32.or + (array.get_u $string (local.get $s) (local.get $i)) + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8))) + (i32.or + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $i) (i32.const 2))) + (i32.const 16)) + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $i) (i32.const 3))) + (i32.const 24)))))) + (local.set $i (i32.add (local.get $i) (i32.const 4))) + (br $loop)))) + (local.set $w (i32.const 0)) + (block $0_bytes + (block $1_byte + (block $2_bytes + (block $3_bytes + (br_table $0_bytes $1_byte $2_bytes $3_bytes + (i32.and (local.get $len) (i32.const 3)))) + (local.set $w + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $i) (i32.const 2))) + (i32.const 16)))) + (local.set $w + (i32.or (local.get $w) + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8))))) + (local.set $w + (i32.or (local.get $w) + (array.get_u $string (local.get $s) (local.get $i)))) + (local.set $h (call $caml_hash_mix_int (local.get $h) (local.get $w)))) + (i32.xor (local.get $h) (local.get $len))) + + (global $HASH_QUEUE_SIZE i32 (i32.const 256)) + (global $MAX_FORWARD_DEREFERENCE i32 (i32.const 1000)) + + (global $caml_hash_queue (ref $block) + (array.new $block (ref.i31 (i32.const 0)) (global.get $HASH_QUEUE_SIZE))) + + (func (export "caml_hash") + (param $count (ref eq)) (param $limit (ref eq)) (param $seed (ref eq)) + (param $obj (ref eq)) (result (ref eq)) + (local $sz i32) (local $num i32) (local $h i32) + (local $rd i32) (local $wr i32) + (local $v (ref eq)) + (local $b (ref $block)) + (local $i i32) + (local $len i32) + (local $tag i32) + (local $str anyref) + (local.set $sz (i31.get_u (ref.cast (ref i31) (local.get $limit)))) + (if (i32.gt_u (local.get $sz) (global.get $HASH_QUEUE_SIZE)) + (then (local.set $sz (global.get $HASH_QUEUE_SIZE)))) + (local.set $num (i31.get_u (ref.cast (ref i31) (local.get $count)))) + (local.set $h (i31.get_s (ref.cast (ref i31) (local.get $seed)))) + (array.set $block + (global.get $caml_hash_queue) (i32.const 0) (local.get $obj)) + (local.set $rd (i32.const 0)) + (local.set $wr (i32.const 1)) + (loop $loop + (if (i32.and (i32.lt_u (local.get $rd) (local.get $wr)) + (i32.gt_u (local.get $num) (i32.const 0))) + (then + (local.set $v + (array.get $block (global.get $caml_hash_queue) + (local.get $rd))) + (local.set $rd (i32.add (local.get $rd) (i32.const 1))) + (block $again + (drop (block $not_int (result (ref eq)) + (local.set $h + (call $caml_hash_mix_int (local.get $h) + (i32.add + (i32.shl + (i31.get_s + (br_on_cast_fail + $not_int (ref eq) (ref i31) + (local.get $v))) + (i32.const 1)) + (i32.const 1)))) + (local.set $num (i32.sub (local.get $num) (i32.const 1))) + (br $loop))) + (drop (block $not_string (result (ref eq)) + (local.set $h + (call $caml_hash_mix_string (local.get $h) + (br_on_cast_fail $not_string (ref eq) (ref $string) + (local.get $v)))) + (local.set $num (i32.sub (local.get $num) (i32.const 1))) + (br $loop))) + (drop (block $not_block (result (ref eq)) + (local.set $b + (br_on_cast_fail $not_block (ref eq) (ref $block) + (local.get $v))) + (local.set $tag + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $b) (i32.const 0))))) + (if (i32.eq (local.get $tag) (global.get $forward_tag)) + (then + (local.set $i (i32.const 0)) + (loop $forward + (local.set $v + (array.get $block + (local.get $b) (i32.const 1))) + (drop (block $not_block' (result (ref eq)) + (local.set $b + (br_on_cast_fail + $not_block' (ref eq) (ref $block) + (local.get $v))) + (br_if $again + (i32.eqz + (ref.eq + (array.get $block (local.get $b) + (i32.const 0)) + (ref.i31 (global.get $forward_tag))))) + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (br_if $loop + (i32.eq + (local.get $i) + (global.get $MAX_FORWARD_DEREFERENCE))) + (br $forward))) + (br $again)))) + (if (i32.eq (local.get $tag) (global.get $object_tag)) + (then + (local.set $h + (call $caml_hash_mix_int (local.get $h) + (i31.get_s + (ref.cast (ref i31) + (array.get $block + (local.get $b) (i32.const 2)))))) + (br $loop))) + (local.set $len (array.len (local.get $b))) + (local.set $h + (call $caml_hash_mix_int (local.get $h) + (i32.or + (i32.shl (i32.sub (local.get $len) (i32.const 1)) + (i32.const 10)) + (local.get $tag)))) + (local.set $i (i32.const 1)) + (loop $block_iter + (br_if $loop (i32.ge_u (local.get $i) (local.get $len))) + (br_if $loop (i32.ge_u (local.get $wr) (local.get $sz))) + (array.set $block (global.get $caml_hash_queue) + (local.get $wr) + (array.get $block (local.get $b) (local.get $i))) + (local.set $wr (i32.add (local.get $wr) (i32.const 1))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $block_iter)))) + (drop (block $not_float (result (ref eq)) + (local.set $h + (call $caml_hash_mix_double (local.get $h) + (struct.get $float 0 + (br_on_cast_fail $not_float (ref eq) (ref $float) + (local.get $v))))) + (local.set $num (i32.sub (local.get $num) (i32.const 1))) + (br $loop))) + (drop (block $not_custom (result (ref eq)) + (local.set $h + (call $caml_hash_mix_int (local.get $h) + (call_ref $hash + (local.get $v) + (br_on_null $loop + (struct.get $custom_operations $hash + (struct.get $custom 0 + (br_on_cast_fail $not_custom + (ref eq) (ref $custom) + (local.get $v)))))))) + (local.set $num (i32.sub (local.get $num) (i32.const 1))) + (br $loop))) + (drop (block $not_jsstring (result anyref) + (local.set $str + (struct.get $js 0 + (br_on_cast_fail $not_jsstring (ref eq) (ref $js) + (local.get $v)))) + (drop (br_if $not_jsstring + (ref.i31 (i32.const 0)) + (i32.eqz (call $jsstring_test (local.get $str))))) + (local.set $h + (call $jsstring_hash (local.get $h) (local.get $str))) + (ref.i31 (i32.const 0)))) + ;; closures and continuations and other js values are ignored + (br $loop))))) + ;; clear the queue to avoid a memory leak + (array.fill $block (global.get $caml_hash_queue) + (i32.const 0) (ref.i31 (i32.const 0)) (local.get $wr)) + (ref.i31 (i32.and (call $caml_hash_mix_final (local.get $h)) + (i32.const 0x3FFFFFFF)))) + + (func (export "caml_string_hash") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local $h i32) + (ref.i31 + (i32.and + (call $caml_hash_mix_final + (call $caml_hash_mix_string + (i31.get_s (ref.cast (ref i31) (local.get 0))) + (ref.cast (ref $string) (local.get 1)))) + (i32.const 0x3FFFFFFF)))) +) diff --git a/runtime/wasm/int32.wat b/runtime/wasm/int32.wat new file mode 100644 index 0000000000..79ce5095d8 --- /dev/null +++ b/runtime/wasm/int32.wat @@ -0,0 +1,193 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "ints" "parse_int" + (func $parse_int + (param (ref eq)) (param i32) (param (ref $string)) (result i32))) + (import "ints" "format_int" + (func $format_int + (param (ref eq)) (param i32) (param i32) (result (ref eq)))) + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "marshal" "caml_serialize_int_1" + (func $caml_serialize_int_1 (param (ref eq)) (param i32))) + (import "marshal" "caml_serialize_int_4" + (func $caml_serialize_int_4 (param (ref eq)) (param i32))) + (import "marshal" "caml_deserialize_uint_1" + (func $caml_deserialize_uint_1 (param (ref eq)) (result i32))) + (import "marshal" "caml_deserialize_int_4" + (func $caml_deserialize_int_4 (param (ref eq)) (result i32))) + + (type $string (array (mut i8))) + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $dup (func (param (ref eq)) (result (ref eq)))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)) + (field $dup (ref null $dup)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + + (global $int32_ops (export "int32_ops") (ref $custom_operations) + (struct.new $custom_operations + (array.new_fixed $string 2 (i32.const 95) (i32.const 105)) ;; "_i" + (ref.func $int32_cmp) + (ref.null $compare) + (ref.func $int32_hash) + (struct.new $fixed_length (i32.const 4) (i32.const 4)) + (ref.func $int32_serialize) + (ref.func $int32_deserialize) + (ref.func $int32_dup))) + + (type $int32 + (sub final $custom (struct (field (ref $custom_operations)) (field i32)))) + + (func $int32_cmp + (param $v1 (ref eq)) (param $v2 (ref eq)) (param i32) (result i32) + (local $i1 i32) (local $i2 i32) + (local.set $i1 + (struct.get $int32 1 (ref.cast (ref $int32) (local.get $v1)))) + (local.set $i2 + (struct.get $int32 1 (ref.cast (ref $int32) (local.get $v2)))) + (i32.sub (i32.gt_s (local.get $i1) (local.get $i2)) + (i32.lt_s (local.get $i1) (local.get $i2)))) + + (func $int32_hash (param $v (ref eq)) (result i32) + (struct.get $int32 1 (ref.cast (ref $int32) (local.get $v)))) + + (func $int32_serialize + (param $s (ref eq)) (param $v (ref eq)) (result i32) (result i32) + (call $caml_serialize_int_4 (local.get $s) + (struct.get $int32 1 (ref.cast (ref $int32) (local.get $v)))) + (tuple.make 2 (i32.const 4) (i32.const 4))) + + (func $int32_deserialize (param $s (ref eq)) (result (ref eq)) (result i32) + (tuple.make 2 + (struct.new $int32 (global.get $int32_ops) + (call $caml_deserialize_int_4 (local.get $s))) + (i32.const 4))) + + (func $int32_dup (param $v (ref eq)) (result (ref eq)) + (local $d (ref $int32)) + (local.set $d (ref.cast (ref $int32) (local.get $v))) + (struct.new $int32 + (struct.get $int32 0 (local.get $d)) + (struct.get $int32 1 (local.get $d)))) + + (func $caml_copy_int32 (export "caml_copy_int32") + (param $i i32) (result (ref eq)) + (struct.new $int32 (global.get $int32_ops) (local.get $i))) + + (export "Nativeint_val" (func $Int32_val)) + (func $Int32_val (export "Int32_val") (param (ref eq)) (result i32) + (struct.get $int32 1 (ref.cast (ref $int32) (local.get 0)))) + + (export "caml_nativeint_bswap" (func $caml_int32_bswap)) + (func $caml_int32_bswap (export "caml_int32_bswap") + (param $i i32) (result i32) + (i32.or + (i32.rotr (i32.and (local.get $i) (i32.const 0x00FF00FF)) + (i32.const 8)) + (i32.rotl (i32.and (local.get $i) (i32.const 0xFF00FF00)) + (i32.const 8)))) + + (global $INT32_ERRMSG (ref $string) + (array.new_fixed $string 15 ;; "Int32.of_string" + (i32.const 73) (i32.const 110) (i32.const 116) (i32.const 51) + (i32.const 50) (i32.const 46) (i32.const 111) (i32.const 102) + (i32.const 95) (i32.const 115) (i32.const 116) (i32.const 114) + (i32.const 105) (i32.const 110) (i32.const 103))) + + (func (export "caml_int32_of_string") (param $v (ref eq)) (result (ref eq)) + (return_call $caml_copy_int32 + (call $parse_int + (local.get $v) (i32.const 32) (global.get $INT32_ERRMSG)))) + + (export "caml_nativeint_compare" (func $caml_int32_compare)) + (func $caml_int32_compare (export "caml_int32_compare") + (param $i1 i32) (param $i2 i32) (result (ref eq)) + (ref.i31 (i32.sub (i32.gt_s (local.get $i1) (local.get $i2)) + (i32.lt_s (local.get $i1) (local.get $i2))))) + + (global $nativeint_ops (export "nativeint_ops") (ref $custom_operations) + (struct.new $custom_operations + (array.new_fixed $string 2 (i32.const 95) (i32.const 110)) ;; "_n" + (ref.func $int32_cmp) + (ref.null $compare) + (ref.func $int32_hash) + (struct.new $fixed_length (i32.const 4) (i32.const 8)) + (ref.func $nativeint_serialize) + (ref.func $nativeint_deserialize) + (ref.func $int32_dup))) + + (func $nativeint_serialize + (param $s (ref eq)) (param $v (ref eq)) (result i32) (result i32) + (call $caml_serialize_int_1 (local.get $s) (i32.const 1)) + (call $caml_serialize_int_4 (local.get $s) + (struct.get $int32 1 (ref.cast (ref $int32) (local.get $v)))) + (tuple.make 2 (i32.const 4) (i32.const 8))) + + (data $integer_too_large "input_value: native integer value too large") + + (func $nativeint_deserialize + (param $s (ref eq)) (result (ref eq)) (result i32) + (if (i32.ne (call $caml_deserialize_uint_1 (local.get $s)) (i32.const 1)) + (then + (call $caml_failwith + (array.new_data $string $integer_too_large + (i32.const 0) (i32.const 43))))) + (tuple.make 2 + (struct.new $int32 (global.get $nativeint_ops) + (call $caml_deserialize_int_4 (local.get $s))) + (i32.const 4))) + + (func $caml_copy_nativeint (export "caml_copy_nativeint") + (param $i i32) (result (ref eq)) + (struct.new $int32 (global.get $nativeint_ops) (local.get $i))) + + (global $NATIVEINT_ERRMSG (ref $string) + (array.new_fixed $string 16 ;; "Nativeint.of_string" + (i32.const 78) (i32.const 97) (i32.const 116) (i32.const 105) + (i32.const 118) (i32.const 101) (i32.const 46) (i32.const 111) + (i32.const 102) (i32.const 95) (i32.const 115) (i32.const 116) + (i32.const 114) (i32.const 105) (i32.const 110) (i32.const 103))) + + (func (export "caml_nativeint_of_string") + (param $v (ref eq)) (result (ref eq)) + (return_call $caml_copy_nativeint + (call $parse_int + (local.get $v) (i32.const 32) (global.get $NATIVEINT_ERRMSG)))) + + (export "caml_nativeint_format" (func $caml_int32_format)) + (func $caml_int32_format (export "caml_int32_format") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (return_call $format_int (local.get 0) + (struct.get $int32 1 + (ref.cast (ref $int32) (local.get 1))) (i32.const 0))) +) diff --git a/runtime/wasm/int64.wat b/runtime/wasm/int64.wat new file mode 100644 index 0000000000..de7e64c52b --- /dev/null +++ b/runtime/wasm/int64.wat @@ -0,0 +1,331 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "ints" "parse_sign_and_base" + (func $parse_sign_and_base + (param (ref $string)) (result i32 i32 i32 i32))) + (import "ints" "parse_digit" (func $parse_digit (param i32) (result i32))) + (import "ints" "parse_int_format" + (func $parse_int_format + (param (ref $string)) (result i32 i32 i32 i32 i32))) + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "marshal" "caml_serialize_int_8" + (func $caml_serialize_int_8 (param (ref eq)) (param i64))) + (import "marshal" "caml_deserialize_int_8" + (func $caml_deserialize_int_8 (param (ref eq)) (result i64))) + (import "ints" "lowercase_hex_table" + (global $lowercase_hex_table (ref $chars))) + (import "ints" "uppercase_hex_table" + (global $uppercase_hex_table (ref $chars))) + + (type $string (array (mut i8))) + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $dup (func (param (ref eq)) (result (ref eq)))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)) + (field $dup (ref null $dup)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + + (global $int64_ops (export "int64_ops") (ref $custom_operations) + (struct.new $custom_operations + (array.new_fixed $string 2 (i32.const 95) (i32.const 106)) ;; "_j" + (ref.func $int64_cmp) + (ref.null $compare) + (ref.func $int64_hash) + (struct.new $fixed_length (i32.const 8) (i32.const 8)) + (ref.func $int64_serialize) + (ref.func $int64_deserialize) + (ref.func $int64_dup))) + + (type $int64 + (sub final $custom (struct (field (ref $custom_operations)) (field i64)))) + + (func $int64_cmp + (param $v1 (ref eq)) (param $v2 (ref eq)) (param i32) (result i32) + (local $i1 i64) (local $i2 i64) + (local.set $i1 + (struct.get $int64 1 (ref.cast (ref $int64) (local.get $v1)))) + (local.set $i2 + (struct.get $int64 1 (ref.cast (ref $int64) (local.get $v2)))) + (i32.sub (i64.gt_s (local.get $i1) (local.get $i2)) + (i64.lt_s (local.get $i1) (local.get $i2)))) + + (func $int64_hash (param $v (ref eq)) (result i32) + (local $i i64) + (local.set $i + (struct.get $int64 1 (ref.cast (ref $int64) (local.get $v)))) + (i32.xor + (i32.wrap_i64 (local.get $i)) + (i32.wrap_i64 (i64.shr_u (local.get $i) (i64.const 32))))) + + (func $int64_serialize + (param $s (ref eq)) (param $v (ref eq)) (result i32) (result i32) + (call $caml_serialize_int_8 (local.get $s) + (struct.get $int64 1 (ref.cast (ref $int64) (local.get $v)))) + (tuple.make 2 (i32.const 8) (i32.const 8))) + + (func $int64_deserialize (param $s (ref eq)) (result (ref eq)) (result i32) + (tuple.make 2 + (struct.new $int64 (global.get $int64_ops) + (call $caml_deserialize_int_8 (local.get $s))) + (i32.const 8))) + + (func $int64_dup (param $v (ref eq)) (result (ref eq)) + (struct.new $int64 (global.get $int64_ops) + (struct.get $int64 1 (ref.cast (ref $int64) (local.get $v))))) + + (func $caml_copy_int64 (export "caml_copy_int64") + (param $i i64) (result (ref eq)) + (struct.new $int64 (global.get $int64_ops) (local.get $i))) + + (func (export "Int64_val") (param (ref eq)) (result i64) + (struct.get $int64 1 (ref.cast (ref $int64) (local.get 0)))) + + (func (export "caml_int64_bswap") (param $i i64) (result i64) + (i64.or + (i64.or + (i64.rotr (i64.and (local.get $i) (i64.const 0x000000FF000000FF)) + (i64.const 8)) + (i64.rotr (i64.and (local.get $i) (i64.const 0x0000FF000000FF00)) + (i64.const 24))) + (i64.or + (i64.rotl (i64.and (local.get $i) (i64.const 0x00FF000000FF0000)) + (i64.const 24)) + (i64.rotl (i64.and (local.get $i) (i64.const 0xFF000000FF000000)) + (i64.const 8))))) + + (func (export "caml_int64_compare") + (param $i1 i64) (param $i2 i64) (result (ref eq)) + (ref.i31 (i32.sub (i64.gt_s (local.get $i1) (local.get $i2)) + (i64.lt_s (local.get $i1) (local.get $i2))))) + + (global $INT64_ERRMSG (ref $string) + (array.new_fixed $string 15 ;; "Int64.of_string" + (i32.const 73) (i32.const 110) (i32.const 116) (i32.const 54) + (i32.const 52) (i32.const 46) (i32.const 111) (i32.const 102) + (i32.const 95) (i32.const 115) (i32.const 116) (i32.const 114) + (i32.const 105) (i32.const 110) (i32.const 103))) + + ;; Parse a sequence of digits into an i64 as dicted by $base, + ;; $signedness and $sign. The sequence is read in $s starting from $i. + ;; In case of failure raise [Failure $errmsg]. + ;; Used by $caml_int64_of_string below and by $caml_uint64_of_string in + ;; package "integers". + (func $caml_i64_of_digits (export "caml_i64_of_digits") + (param $base i32) (param $signedness i32) (param $sign i32) + (param $s (ref $string)) (param $i i32) (param $errmsg (ref $string)) + (result i64) + (local $len i32) (local $d i32) (local $c i32) + (local $res i64) (local $threshold i64) + (local.set $len (array.len (local.get $s))) + (if (i32.eqz (local.get $len)) + (then (call $caml_failwith (local.get $errmsg)))) + (local.set $threshold + (i64.div_u (i64.const -1) (i64.extend_i32_u (local.get $base)))) + (local.set $d + (call $parse_digit (array.get_u $string (local.get $s) (local.get $i)))) + (if (i32.ge_u (local.get $d) (local.get $base)) + (then (call $caml_failwith (local.get $errmsg)))) + (local.set $res (i64.extend_i32_u (local.get $d))) + (loop $loop + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.lt_s (local.get $i) (local.get $len)) + (then + (local.set $c (array.get_u $string (local.get $s) (local.get $i))) + (br_if $loop (i32.eq (local.get $c) (i32.const 95))) ;; '_' + (local.set $d (call $parse_digit (local.get $c))) + (if (i32.ge_u (local.get $d) (local.get $base)) + (then (call $caml_failwith (local.get $errmsg)))) + (if (i64.gt_u (local.get $res) (local.get $threshold)) + (then (call $caml_failwith (local.get $errmsg)))) + (local.set $res + (i64.add (i64.mul (local.get $res) + (i64.extend_i32_u (local.get $base))) + (i64.extend_i32_u (local.get $d)))) + (if (i64.lt_u (local.get $res) (i64.extend_i32_u (local.get $d))) + (then (call $caml_failwith (local.get $errmsg)))) + (br $loop)))) + (if (local.get $signedness) + (then + (if (i32.gt_s (local.get $sign) (i32.const 0)) + (then + (if (i64.ge_u (local.get $res) + (i64.shl (i64.const 1) (i64.const 63))) + (then (call $caml_failwith (local.get $errmsg))))) + (else + (if (i64.gt_u (local.get $res) + (i64.shl (i64.const 1) (i64.const 63))) + (then + (call $caml_failwith (local.get $errmsg)))))))) + (if (i32.lt_s (local.get $sign) (i32.const 0)) + (then (local.set $res (i64.sub (i64.const 0) (local.get $res))))) + (local.get $res)) + + (func (export "caml_int64_of_string") (param $v (ref eq)) (result (ref eq)) + (local $s (ref $string)) + (local $i i32) (local $signedness i32) (local $sign i32) (local $base i32) + (local $t (tuple i32 i32 i32 i32)) + (local.set $s (ref.cast (ref $string) (local.get $v))) + (local.set $t (call $parse_sign_and_base (local.get $s))) + (local.set $i (tuple.extract 4 0 (local.get $t))) + (local.set $signedness (tuple.extract 4 1 (local.get $t))) + (local.set $sign (tuple.extract 4 2 (local.get $t))) + (local.set $base (tuple.extract 4 3 (local.get $t))) + (return_call + $caml_copy_int64 + (call $caml_i64_of_digits (local.get $base) + (local.get $signedness) + (local.get $sign) + (local.get $s) + (local.get $i) + (global.get $INT64_ERRMSG)))) + + (data $caml_int64_create_lo_mi_hi "caml_int64_create_lo_mi_hi") + + (func $format_int64_default (param $d i64) (result (ref eq)) + (local $s (ref $string)) + (local $negative i32) (local $i i32) (local $n i64) + (if (i64.lt_s (local.get $d) (i64.const 0)) + (then + (local.set $negative (i32.const 1)) + (local.set $i (i32.const 1)) + (local.set $d (i64.sub (i64.const 0) (local.get $d))))) + (local.set $n (local.get $d)) + (loop $count + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $n (i64.div_u (local.get $n) (i64.const 10))) + (br_if $count (i64.ne (local.get $n) (i64.const 0)))) + (local.set $s (array.new $string (i32.const 0) (local.get $i))) + (loop $write + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (array.set $string (local.get $s) (local.get $i) + (i32.add (i32.const 48) + (i32.wrap_i64 (i64.rem_u (local.get $d) (i64.const 10))))) + (local.set $d (i64.div_u (local.get $d) (i64.const 10))) + (br_if $write (i64.ne (local.get $d) (i64.const 0)))) + (if (local.get $negative) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 45)))) ;; '-' + (local.get $s)) + + (type $chars (array i8)) + + (func (export "caml_int64_format") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local $d i64) + (local $s (ref $string)) + (local $format (tuple i32 i32 i32 i32 i32)) + (local $sign_style i32) (local $alternate i32) (local $signed i32) + (local $base i64) (local $uppercase i32) + (local $negative i32) + (local $i i32) + (local $n i64) + (local $chars (ref $chars)) + (local.set $s (ref.cast (ref $string) (local.get 0))) + (local.set $d (struct.get $int64 1 (ref.cast (ref $int64) (local.get 1)))) + (if (i32.eq (array.len (local.get $s)) (i32.const 2)) + (then + (if (i32.eq (array.get_u $string (local.get $s) (i32.const 1)) + (i32.const 100)) ;; 'd' + (then (return_call $format_int64_default (local.get $d)))))) + (local.set $format (call $parse_int_format (local.get $s))) + (local.set $sign_style (tuple.extract 5 0 (local.get $format))) + (local.set $alternate (tuple.extract 5 1 (local.get $format))) + (local.set $signed (tuple.extract 5 2 (local.get $format))) + (local.set $base + (i64.extend_i32_u (tuple.extract 5 3 (local.get $format)))) + (local.set $uppercase (tuple.extract 5 4 (local.get $format))) + (if (i32.and (local.get $signed) (i64.lt_s (local.get $d) (i64.const 0))) + (then + (local.set $negative (i32.const 1)) + (local.set $d (i64.sub (i64.const 0) (local.get $d))))) + (local.set $n (local.get $d)) + (loop $count + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $n (i64.div_u (local.get $n) (local.get $base))) + (br_if $count (i64.ne (local.get $n) (i64.const 0)))) + (if (i32.or (local.get $negative) + (local.get $sign_style)) + (then (local.set $i (i32.add (local.get $i) (i32.const 1))))) + (if (local.get $alternate) + (then + (if (i64.ne (local.get $d) (i64.const 0)) + (then + (if (i64.eq (local.get $base) (i64.const 16)) + (then + (local.set $i (i32.add (local.get $i) (i32.const 2))))) + (if (i64.eq (local.get $base) (i64.const 8)) + (then + (local.set $i + (i32.add (local.get $i) (i32.const 1))))))))) + (local.set $chars + (select (result (ref $chars)) + (global.get $uppercase_hex_table) + (global.get $lowercase_hex_table) + (local.get $uppercase))) + (local.set $s (array.new $string (i32.const 0) (local.get $i))) + (loop $write + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (array.set $string (local.get $s) (local.get $i) + (array.get_u $chars (local.get $chars) + (i32.wrap_i64 (i64.rem_u (local.get $d) (local.get $base))))) + (local.set $d (i64.div_u (local.get $d) (local.get $base))) + (br_if $write (i64.ne (local.get $d) (i64.const 0)))) + (if (local.get $negative) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 45))) ;; '-' + (else + (if (local.get $sign_style) + (then + (if (i32.eq (local.get $sign_style) (i32.const 1)) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 43))) ;; '+' + (else + (array.set $string (local.get $s) (i32.const 0) + (i32.const 32)))))))) ;; ' ' + (if (local.get $alternate) + (then + (if (local.get $i) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 48)) ;; '0' + (if (i64.eq (local.get $base) (i64.const 16)) + (then + (array.set $string (local.get $s) (i32.const 1) + (select (i32.const 88) (i32.const 120) ;; 'X' 'x' + (local.get $uppercase))))))))) + (local.get $s)) + +) diff --git a/runtime/wasm/ints.wat b/runtime/wasm/ints.wat new file mode 100644 index 0000000000..1744e733f7 --- /dev/null +++ b/runtime/wasm/ints.wat @@ -0,0 +1,387 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + + (type $string (array (mut i8))) + + (func (export "caml_format_int") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (return_call $format_int + (local.get 0) + (i31.get_s (ref.cast (ref i31) (local.get 1))) (i32.const 1))) + + (func $parse_sign_and_base (export "parse_sign_and_base") + (param $s (ref $string)) (result i32 i32 i32 i32) + (local $i i32) (local $len i32) (local $c i32) + (local $signedness i32) (local $sign i32) (local $base i32) + (local.set $i (i32.const 0)) + (local.set $len (array.len (local.get $s))) + (local.set $signedness (i32.const 1)) + (local.set $sign (i32.const 1)) + (local.set $base (i32.const 10)) + (if (i32.ne (local.get $len) (i32.const 0)) + (then + (local.set $c (array.get_u $string (local.get $s) (i32.const 0))) + (if (i32.eq (local.get $c) (i32.const 45)) + (then + (local.set $sign (i32.const -1)) + (local.set $i (i32.const 1))) + (else (if (i32.eq (local.get $c) (i32.const 43)) + (then (local.set $i (i32.const 1)))))))) + (if (i32.lt_s (i32.add (local.get $i) (i32.const 1)) (local.get $len)) + (then (if (i32.eq (array.get_u $string (local.get $s) (local.get $i)) + (i32.const 48)) + (then + (local.set $c + (array.get_u $string (local.get $s) + (i32.add (local.get $i) (i32.const 1)))) + (if (i32.or (i32.eq (local.get $c) (i32.const 88)) + (i32.eq (local.get $c) (i32.const 120))) + (then + (local.set $base (i32.const 16)) + (local.set $signedness (i32.const 0)) + (local.set $i (i32.add (local.get $i) (i32.const 2)))) + (else (if (i32.or (i32.eq (local.get $c) (i32.const 79)) + (i32.eq (local.get $c) (i32.const 111))) + (then + (local.set $base (i32.const 8)) + (local.set $signedness (i32.const 0)) + (local.set $i (i32.add (local.get $i) (i32.const 2)))) + (else (if (i32.or (i32.eq (local.get $c) (i32.const 66)) + (i32.eq (local.get $c) (i32.const 98))) + (then + (local.set $base (i32.const 2)) + (local.set $signedness (i32.const 0)) + (local.set $i (i32.add (local.get $i) (i32.const 2)))) + (else (if (i32.or (i32.eq (local.get $c) (i32.const 85)) + (i32.eq (local.get $c) (i32.const 117))) + (then + (local.set $signedness (i32.const 0)) + (local.set $i (i32.add (local.get $i) + (i32.const 2))))))))))))))) + (tuple.make 4 + (local.get $i) (local.get $signedness) (local.get $sign) + (local.get $base))) + + (func $parse_digit (export "parse_digit") (param $c i32) (result i32) + (if (i32.and (i32.ge_u (local.get $c) (i32.const 48)) + (i32.le_u (local.get $c) (i32.const 57))) + (then (return (i32.sub (local.get $c) (i32.const 48))))) + (if (i32.and (i32.ge_u (local.get $c) (i32.const 65)) + (i32.le_u (local.get $c) (i32.const 90))) + (then (return (i32.sub (local.get $c) (i32.const 55))))) + (if (i32.and (i32.ge_u (local.get $c) (i32.const 97)) + (i32.le_u (local.get $c) (i32.const 122))) + (then (return (i32.sub (local.get $c) (i32.const 87))))) + (return (i32.const -1))) + + (func $parse_int (export "parse_int") + (param $v (ref eq)) (param $nbits i32) (param $errmsg (ref $string)) + (result i32) + (local $s (ref $string)) + (local $i i32) (local $len i32) (local $d i32) (local $c i32) + (local $signedness i32) (local $sign i32) (local $base i32) + (local $res i32) (local $threshold i32) + (local $t (tuple i32 i32 i32 i32)) + (local.set $s (ref.cast (ref $string) (local.get $v))) + (local.set $len (array.len (local.get $s))) + (if (i32.eqz (local.get $len)) + (then (call $caml_failwith (local.get $errmsg)))) + (local.set $t (call $parse_sign_and_base (local.get $s))) + (local.set $i (tuple.extract 4 0 (local.get $t))) + (local.set $signedness (tuple.extract 4 1 (local.get $t))) + (local.set $sign (tuple.extract 4 2 (local.get $t))) + (local.set $base (tuple.extract 4 3 (local.get $t))) + (local.set $threshold (i32.div_u (i32.const -1) (local.get $base))) + (if (i32.ge_s (local.get $i) (local.get $len)) + (then (call $caml_failwith (local.get $errmsg)))) + (local.set $d + (call $parse_digit (array.get_u $string (local.get $s) (local.get $i)))) + (if (i32.ge_u (local.get $d) (local.get $base)) + (then (call $caml_failwith (local.get $errmsg)))) + (local.set $res (local.get $d)) + (loop $loop + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.lt_s (local.get $i) (local.get $len)) + (then + (local.set $c (array.get_u $string (local.get $s) (local.get $i))) + (br_if $loop (i32.eq (local.get $c) (i32.const 95))) ;; '_' + (local.set $d (call $parse_digit (local.get $c))) + (if (i32.ge_u (local.get $d) (local.get $base)) + (then (call $caml_failwith (local.get $errmsg)))) + (if (i32.gt_u (local.get $res) (local.get $threshold)) + (then (call $caml_failwith (local.get $errmsg)))) + (local.set $res + (i32.add (i32.mul (local.get $res) (local.get $base)) + (local.get $d))) + (if (i32.lt_u (local.get $res) (local.get $d)) + (then (call $caml_failwith (local.get $errmsg)))) + (br $loop)))) + (if (local.get $signedness) + (then + (local.set $threshold + (i32.shl (i32.const 1) + (i32.sub (local.get $nbits) (i32.const 1)))) + (if (i32.gt_s (local.get $sign) (i32.const 0)) + (then + (if (i32.ge_u (local.get $res) (local.get $threshold)) + (then (call $caml_failwith (local.get $errmsg))))) + (else + (if (i32.gt_u (local.get $res) (local.get $threshold)) + (then (call $caml_failwith (local.get $errmsg))))))) + (else + (if (i32.and + (i32.lt_u (local.get $nbits) (i32.const 32)) + (i32.ge_u (local.get $res) + (i32.shl (i32.const 1) (local.get $nbits)))) + (then (call $caml_failwith (local.get $errmsg)))))) + (if (i32.lt_s (local.get $sign) (i32.const 0)) + (then (local.set $res (i32.sub (i32.const 0) (local.get $res))))) + (local.get $res)) + + (global $INT_ERRMSG (ref $string) + (array.new_fixed $string 13 ;; "int.of_string" + (i32.const 105) (i32.const 110) (i32.const 116) (i32.const 95) + (i32.const 111) (i32.const 102) (i32.const 95) (i32.const 115) + (i32.const 116) (i32.const 114) (i32.const 105) (i32.const 110) + (i32.const 103))) + + (func (export "caml_int_of_string") + (param $v (ref eq)) (result (ref eq)) + (ref.i31 + (call $parse_int + (local.get $v) (i32.const 31) (global.get $INT_ERRMSG)))) + + (func (export "caml_bswap16") (param (ref eq)) (result (ref eq)) + (local $x i32) + (local.set $x (i31.get_s (ref.cast (ref i31) (local.get 0)))) + (ref.i31 + (i32.or + (i32.shl (i32.and (local.get $x) (i32.const 0xFF)) (i32.const 8)) + (i32.and + (i32.shr_u (local.get $x) (i32.const 8)) (i32.const 0xFF))))) + + (type $chars (array i8)) + + (global $lowercase_hex_table (export "lowercase_hex_table") (ref $chars) + (array.new_fixed $chars 16 + (i32.const 48) (i32.const 49) (i32.const 50) (i32.const 51) + (i32.const 52) (i32.const 53) (i32.const 54) (i32.const 55) + (i32.const 56) (i32.const 57) (i32.const 97) (i32.const 98) + (i32.const 99) (i32.const 100) (i32.const 101) (i32.const 102))) + + (global $uppercase_hex_table (export "uppercase_hex_table") (ref $chars) + (array.new_fixed $chars 16 + (i32.const 48) (i32.const 49) (i32.const 50) (i32.const 51) + (i32.const 52) (i32.const 53) (i32.const 54) (i32.const 55) + (i32.const 56) (i32.const 57) (i32.const 65) (i32.const 66) + (i32.const 67) (i32.const 68) (i32.const 69) (i32.const 70))) + + (func $format_int_default (param $d i32) (result (ref eq)) + (local $s (ref $string)) + (local $negative i32) (local $i i32) (local $n i32) + (if (i32.lt_s (local.get $d) (i32.const 0)) + (then + (local.set $negative (i32.const 1)) + (local.set $i (i32.const 1)) + (local.set $d (i32.sub (i32.const 0) (local.get $d))))) + (local.set $n (local.get $d)) + (loop $count + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $n (i32.div_u (local.get $n) (i32.const 10))) + (br_if $count (local.get $n))) + (local.set $s (array.new $string (i32.const 0) (local.get $i))) + (loop $write + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (array.set $string (local.get $s) (local.get $i) + (i32.add (i32.const 48) + (i32.rem_u (local.get $d) (i32.const 10)))) + (local.set $d (i32.div_u (local.get $d) (i32.const 10))) + (br_if $write (local.get $d))) + (if (local.get $negative) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 45)))) ;; '-' + (local.get $s)) + + (data $format_error "format_int: bad format") + + (func $parse_int_format (export "parse_int_format") + (param $s (ref $string)) (result i32 i32 i32 i32 i32) + (local $i i32) (local $len i32) (local $c i32) + (local $sign_style i32) (local $alternate i32) (local $base i32) + (local $signed i32) (local $uppercase i32) + (local.set $len (array.len (local.get $s))) + (local.set $i (i32.const 1)) + (block $return + (block $bad_format + (br_if $bad_format (i32.lt_u (local.get $len) (i32.const 2))) + (br_if $bad_format + (i32.ne (array.get_u $string (local.get $s) (i32.const 0)) + (i32.const 37))) ;; '%' + (local.set $c (array.get_u $string (local.get $s) (i32.const 1))) + (if (i32.eq (local.get $c) (i32.const 43)) ;; '+' + (then + (local.set $sign_style (i32.const 1)) + (local.set $i (i32.add (local.get $i) (i32.const 1))))) + (if (i32.eq (local.get $c) (i32.const 32)) ;; ' ' + (then + (local.set $sign_style (i32.const 2)) + (local.set $i (i32.add (local.get $i) (i32.const 1))))) + (if (i32.eq (local.get $c) (i32.const 35)) ;; '#' + (then + (local.set $alternate (i32.const 1)) + (local.set $i (i32.add (local.get $i) (i32.const 1))))) + (br_if $bad_format (i32.eq (local.get $i) (local.get $len))) + (local.set $c (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.or (i32.or (i32.eq (local.get $c) (i32.const 76)) ;; 'L' + (i32.eq (local.get $c) (i32.const 108))) ;; 'l' + (i32.eq (local.get $c) (i32.const 110))) ;; 'n' + (then + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $bad_format (i32.eq (local.get $i) (local.get $len))) + (local.set $c + (array.get_u $string (local.get $s) (local.get $i))))) + (br_if $bad_format + (i32.ne (i32.add (local.get $i) (i32.const 1)) (local.get $len))) + (if (i32.or (i32.eq (local.get $c) (i32.const 100)) ;; 'd' + (i32.eq (local.get $c) (i32.const 105))) ;; 'i' + (then + (local.set $base (i32.const 10)) + (local.set $signed (i32.const 1))) + (else (if (i32.eq (local.get $c) (i32.const 117)) ;; 'u' + (then + (local.set $base (i32.const 10))) + (else (if (i32.eq (local.get $c) (i32.const 120)) ;; 'x' + (then + (local.set $base (i32.const 16))) + (else (if (i32.eq (local.get $c) (i32.const 88)) ;; 'X' + (then + (local.set $base (i32.const 16)) + (local.set $uppercase (i32.const 1))) + (else (if (i32.eq (local.get $c) (i32.const 111)) ;; 'o' + (then + (local.set $base (i32.const 8))) + (else + (br $bad_format))))))))))) + (br $return)) + (call $caml_invalid_argument + (array.new_data $string $format_error + (i32.const 0) (i32.const 22)))) + (tuple.make 5 + (local.get $sign_style) + (local.get $alternate) + (local.get $signed) + (local.get $base) + (local.get $uppercase))) + + (func $format_int (export "format_int") + (param (ref eq)) (param $d i32) (param $small i32) (result (ref eq)) + (local $s (ref $string)) + (local $format (tuple i32 i32 i32 i32 i32)) + (local $sign_style i32) (local $alternate i32) (local $signed i32) + (local $base i32) (local $uppercase i32) + (local $negative i32) + (local $i i32) + (local $n i32) + (local $chars (ref $chars)) + (local.set $s (ref.cast (ref $string) (local.get 0))) + (if (i32.eq (array.len (local.get $s)) (i32.const 2)) + (then + (if (i32.eq (array.get_u $string (local.get $s) (i32.const 1)) + (i32.const 100)) ;; 'd' + (then (return_call $format_int_default (local.get $d)))))) + (local.set $format (call $parse_int_format (local.get $s))) + (local.set $sign_style (tuple.extract 5 0 (local.get $format))) + (local.set $alternate (tuple.extract 5 1 (local.get $format))) + (local.set $signed (tuple.extract 5 2 (local.get $format))) + (local.set $base (tuple.extract 5 3 (local.get $format))) + (local.set $uppercase (tuple.extract 5 4 (local.get $format))) + (if (i32.lt_s (local.get $d) (i32.const 0)) + (then + (if (local.get $signed) + (then + (local.set $negative (i32.const 1)) + (local.set $d (i32.sub (i32.const 0) (local.get $d)))) + (else + (if (local.get $small) + (then + (local.set $d + (i32.and (local.get $d) (i32.const 0x7fffffff))))))))) + (local.set $n (local.get $d)) + (loop $count + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $n (i32.div_u (local.get $n) (local.get $base))) + (br_if $count (local.get $n))) + (if (i32.or (local.get $negative) + (local.get $sign_style)) + (then (local.set $i (i32.add (local.get $i) (i32.const 1))))) + (if (local.get $alternate) + (then + (if (local.get $d) + (then + (if (i32.eq (local.get $base) (i32.const 16)) + (then + (local.set $i (i32.add (local.get $i) (i32.const 2))))) + (if (i32.eq (local.get $base) (i32.const 8)) + (then + (local.set $i + (i32.add (local.get $i) (i32.const 1))))))))) + (local.set $chars + (select (result (ref $chars)) + (global.get $uppercase_hex_table) + (global.get $lowercase_hex_table) + (local.get $uppercase))) + (local.set $s (array.new $string (i32.const 0) (local.get $i))) + (loop $write + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (array.set $string (local.get $s) (local.get $i) + (array.get_u $chars (local.get $chars) + (i32.rem_u (local.get $d) (local.get $base)))) + (local.set $d (i32.div_u (local.get $d) (local.get $base))) + (br_if $write (local.get $d))) + (if (local.get $negative) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 45))) ;; '-' + (else + (if (local.get $sign_style) + (then + (if (i32.eq (local.get $sign_style) (i32.const 1)) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 43))) ;; '+' + (else + (array.set $string (local.get $s) (i32.const 0) + (i32.const 32)))))))) ;; ' ' + (if (local.get $alternate) + (then + (if (local.get $i) + (then + (array.set $string (local.get $s) (i32.const 0) + (i32.const 48)) ;; '0' + (if (i32.eq (local.get $base) (i32.const 16)) + (then + (array.set $string (local.get $s) (i32.const 1) + (select (i32.const 88) (i32.const 120) ;; 'X' 'x' + (local.get $uppercase))))))))) + (local.get $s)) +) diff --git a/runtime/wasm/io.wat b/runtime/wasm/io.wat new file mode 100644 index 0000000000..76e02a2d39 --- /dev/null +++ b/runtime/wasm/io.wat @@ -0,0 +1,853 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_raise_end_of_file" (func $caml_raise_end_of_file)) + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "jslib" "caml_jsstring_of_string" + (func $caml_jsstring_of_string (param (ref eq)) (result (ref eq)))) + (import "jslib" "caml_list_of_js_array" + (func $caml_list_of_js_array (param (ref eq)) (result (ref eq)))) + (import "bindings" "open" + (func $open (param anyref) (param i32) (param i32) (result i32))) + (import "bindings" "close" (func $close (param i32))) + (import "bindings" "write" + (func $write + (param i32) (param (ref extern)) (param i32) (param i32) (param i64) + (result i32))) + (import "bindings" "write" + (func $write' + (param i32) (param (ref extern)) (param i32) (param i32) + (param nullexternref) (result i32))) + (import "bindings" "read" + (func $read + (param i32) (param (ref extern)) (param i32) (param i32) (param i64) + (result i32))) + (import "bindings" "read" + (func $read' + (param i32) (param (ref extern)) (param i32) (param i32) + (param nullexternref) (result i32))) + (import "bindings" "file_size" (func $file_size (param i32) (result i64))) + (import "bindings" "register_channel" + (func $register_channel (param (ref eq)))) + (import "bindings" "unregister_channel" + (func $unregister_channel (param (ref eq)))) + (import "bindings" "channel_list" (func $channel_list (result anyref))) + (import "bindings" "ta_new" (func $ta_new (param i32) (result (ref extern)))) + (import "bindings" "ta_copy" + (func $ta_copy (param (ref extern)) (param i32) (param i32) (param i32))) + (import "bindings" "ta_set_ui8" + (func $ta_set_ui8 (param (ref extern)) (param i32) (param i32))) ;; ZZZ ?? + (import "bindings" "ta_get_ui8" + (func $ta_get_ui8 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_blit_from_string" + (func $ta_blit_from_string + (param (ref $string)) (param i32) (param (ref extern)) (param i32) + (param i32))) + (import "bindings" "ta_blit_to_string" + (func $ta_blit_to_string + (param (ref extern)) (param i32) (param (ref $string)) (param i32) + (param i32))) + (import "custom" "custom_compare_id" + (func $custom_compare_id + (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (import "custom" "custom_hash_id" + (func $custom_hash_id (param (ref eq)) (result i32))) + (import "custom" "custom_next_id" (func $custom_next_id (result i64))) + (import "int64" "caml_copy_int64" + (func $caml_copy_int64 (param i64) (result (ref eq)))) + (import "int64" "Int64_val" + (func $Int64_val (param (ref eq)) (result i64))) + (import "fail" "javascript_exception" + (tag $javascript_exception (param externref))) + (import "sys" "caml_handle_sys_error" + (func $caml_handle_sys_error (param externref))) + + (import "bindings" "map_new" (func $map_new (result (ref extern)))) + (import "bindings" "map_get" + (func $map_get + (param (ref extern)) (param i32) (result (ref $fd_offset)))) + (import "bindings" "map_set" + (func $map_set + (param (ref extern)) (param i32) (param (ref $fd_offset)))) + (import "bindings" "map_delete" + (func $map_delete (param (ref extern)) (param i32))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $offset_array (array (mut i64))) + + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $dup (func (param (ref eq)) (result (ref eq)))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)) + (field $dup (ref null $dup)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + (type $custom_with_id + (sub $custom + (struct + (field (ref $custom_operations)) + (field $id i64)))) + + (global $channel_ops (ref $custom_operations) + (struct.new $custom_operations + (array.new_fixed $string 5 ;; "_chan" + (i32.const 95) (i32.const 99) (i32.const 104) (i32.const 97) + (i32.const 110)) + (ref.func $custom_compare_id) + (ref.null $compare) + (ref.func $custom_hash_id) + (ref.null $fixed_length) + (ref.null $serialize) + (ref.null $deserialize) + (ref.null $dup))) + + (type $channel + (sub final $custom_with_id + (struct + (field (ref $custom_operations)) + (field i64) + (field $fd (mut i32)) + (field $buffer (mut (ref extern))) + (field $curr (mut i32)) + (field $max (mut i32)) + (field $size (mut i32)) + (field $unbuffered (mut i32))))) + + (type $fd_offset + (struct (field $offset (mut i64)) (field $seeked (mut i32)))) + + (global $fd_offsets (mut externref) (ref.null extern)) + + (func $get_fd_offsets (result (ref extern)) + (local $m (ref extern)) + (if (ref.is_null (global.get $fd_offsets)) + (then + (local.set $m (call $map_new)) + (call $map_set (local.get $m) (i32.const 0) + (struct.new $fd_offset (i64.const 0) (i32.const 0))) + (call $map_set (local.get $m) (i32.const 1) + (struct.new $fd_offset (i64.const 0) (i32.const 0))) + (call $map_set (local.get $m) (i32.const 2) + (struct.new $fd_offset (i64.const 0) (i32.const 0))) + (global.set $fd_offsets (local.get $m)))) + (ref.as_non_null (global.get $fd_offsets))) + + (func $initialize_fd_offset (param $fd i32) (param $offset i64) + (call $map_set (call $get_fd_offsets) + (local.get $fd) + (struct.new $fd_offset (local.get $offset) (i32.const 0)))) + + (func $release_fd_offset (param $fd i32) + (call $map_delete (call $get_fd_offsets) (local.get $fd))) + + (func $get_fd_offset (param $fd i32) (result (ref $fd_offset)) + (call $map_get (call $get_fd_offsets) (local.get $fd))) + + (global $IO_BUFFER_SIZE i32 (i32.const 65536)) + + (type $open_flags (array i8)) + ;; 1 O_RDONLY + ;; 2 O_WRONLY + ;; 4 O_APPEND + ;; 8 O_CREAT + ;; 16 O_TRUNC + ;; 32 O_EXCL + ;; 64 O_NONBLOCK + (global $sys_open_flags (ref $open_flags) + (array.new_fixed $open_flags 9 + (i32.const 1) (i32.const 2) (i32.const 6) (i32.const 8) (i32.const 16) + (i32.const 32) (i32.const 0) (i32.const 0) (i32.const 64))) + + (func $convert_flag_list (param $vflags (ref eq)) (result i32) + (local $flags i32) + (local $cons (ref $block)) + (loop $loop + (drop (block $done (result (ref eq)) + (local.set $cons + (br_on_cast_fail $done (ref eq) (ref $block) (local.get $vflags))) + (local.set $flags + (i32.or (local.get $flags) + (array.get_u $open_flags (global.get $sys_open_flags) + (i31.get_u + (ref.cast (ref i31) + (array.get $block + (local.get $cons) (i32.const 1))))))) + (local.set $vflags + (array.get $block (local.get $cons) (i32.const 2))) + (br $loop)))) + (local.get $flags)) + + (func (export "caml_sys_open") + (param $path (ref eq)) (param $vflags (ref eq)) (param $perm (ref eq)) + (result (ref eq)) + (local $fd i32) (local $flags i32) (local $offset i64) + (local.set $flags (call $convert_flag_list (local.get $vflags))) + (try + (do + (local.set $fd + (call $open + (call $unwrap + (call $caml_jsstring_of_string (local.get $path))) + (local.get $flags) + (i31.get_u (ref.cast (ref i31) (local.get $perm))))) + (if (i32.and (local.get $flags) (i32.const 4)) ;; O_APPEND + (then (local.set $offset (call $file_size (local.get $fd)))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)))) + (call $initialize_fd_offset (local.get $fd) (local.get $offset)) + (ref.i31 (local.get $fd))) + + (func (export "caml_sys_close") (param (ref eq)) (result (ref eq)) + (local $fd i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get 0)))) + (call $release_fd_offset (local.get $fd)) + (try + (do + (call $close (local.get $fd))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_set_channel_name") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_out_channels_list") + (param (ref eq)) (result (ref eq)) + (return_call $caml_list_of_js_array (call $wrap (call $channel_list)))) + + (func (export "caml_ml_open_descriptor_in") + (param $fd (ref eq)) (result (ref eq)) + (struct.new $channel + (global.get $channel_ops) + (call $custom_next_id) + (i31.get_u (ref.cast (ref i31) (local.get $fd))) + (call $ta_new (global.get $IO_BUFFER_SIZE)) + (i32.const 0) + (i32.const 0) + (global.get $IO_BUFFER_SIZE) + (i32.const 0))) + + (global $caml_stderr (export "caml_stderr") + (mut (ref eq)) (ref.i31 (i32.const 0))) + + (func (export "caml_ml_open_descriptor_out") + (param $fd (ref eq)) (result (ref eq)) + (local $res (ref eq)) + (local.set $res + (struct.new $channel + (global.get $channel_ops) + (call $custom_next_id) + (i31.get_u (ref.cast (ref i31) (local.get $fd))) + (call $ta_new (global.get $IO_BUFFER_SIZE)) + (i32.const 0) + (i32.const -1) + (global.get $IO_BUFFER_SIZE) + (i32.const 0))) + (call $register_channel (local.get $res)) + (if (ref.eq (local.get $fd) (ref.i31 (i32.const 2))) + (then + (global.set $caml_stderr (local.get $res)))) + (local.get $res)) + + (func (export "caml_ml_close_channel") + (param (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) + (local $fd i32) + (local.set $ch (ref.cast (ref $channel) (local.get 0))) + (struct.set $channel $curr (local.get $ch) (i32.const 0)) + (struct.set $channel $max (local.get $ch) (i32.const 0)) + (struct.set $channel $size (local.get $ch) (i32.const 0)) + (local.set $fd (struct.get $channel $fd (local.get $ch))) + (if (i32.ne (local.get $fd) (i32.const -1)) + (then + (struct.set $channel $fd (local.get $ch) (i32.const -1)) + (call $unregister_channel (local.get $ch)) + (call $release_fd_offset (local.get $fd)) + (try + (do + (call $close (local.get $fd))) + (catch $javascript_exception + ;; ignore exception + (drop (pop externref)))))) + (ref.i31 (i32.const 0))) + + (func $caml_do_read + (param $ch (ref $channel)) (param $pos i32) (param $len i32) (result i32) + (local $fd i32) + (local $fd_offset (ref $fd_offset)) + (local $offset i64) + (local $n i32) + (local.set $fd (struct.get $channel $fd (local.get $ch))) + (local.set $fd_offset (call $get_fd_offset (local.get $fd))) + (local.set $offset (struct.get $fd_offset $offset (local.get $fd_offset))) + (try + (do + (local.set $n + (if (result i32) + (struct.get $fd_offset $seeked (local.get $fd_offset)) + (then + (call $read + (local.get $fd) + (struct.get $channel $buffer (local.get $ch)) + (local.get $pos) + (local.get $len) + (local.get $offset))) + (else + (call $read' + (local.get $fd) + (struct.get $channel $buffer (local.get $ch)) + (local.get $pos) + (local.get $len) + (ref.null noextern)))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)))) + (struct.set $fd_offset $offset + (local.get $fd_offset) + (i64.add (local.get $offset) (i64.extend_i32_u (local.get $n)))) + (local.get $n)) + + (func $caml_refill (param $ch (ref $channel)) (result i32) + (local $n i32) + (local $buf (ref extern)) + (local.set $buf (struct.get $channel $buffer (local.get $ch))) + (local.set $n + (call $caml_do_read (local.get $ch) + (i32.const 0) (struct.get $channel $size (local.get $ch)))) + (if (i32.eqz (local.get $n)) + (then (call $caml_raise_end_of_file))) + (struct.set $channel $max (local.get $ch) (local.get $n)) + (struct.set $channel $curr (local.get $ch) (i32.const 1)) + (return (call $ta_get_ui8 (local.get $buf) (i32.const 0)))) + + (func $caml_getblock (export "caml_getblock") + (param $vch (ref eq)) (param $s (ref $string)) + (param $pos i32) (param $len i32) + (result i32) + (local $ch (ref $channel)) + (local $avail i32) + (local $nread i32) + (if (i32.eqz (local.get $len)) + (then (return (i32.const 0)))) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (local.set $avail + (i32.sub (struct.get $channel $max (local.get $ch)) + (struct.get $channel $curr (local.get $ch)))) + (if (local.get $avail) + (then + (if (i32.gt_u (local.get $len) (local.get $avail)) + (then (local.set $len (local.get $avail)))) + (call $ta_blit_to_string + (struct.get $channel $buffer (local.get $ch)) + (struct.get $channel $curr (local.get $ch)) + (local.get $s) (local.get $pos) + (local.get $len)) + (struct.set $channel $curr (local.get $ch) + (i32.add (struct.get $channel $curr (local.get $ch)) + (local.get $len))) + (return (local.get $len)))) + (local.set $nread + (call $caml_do_read (local.get $ch) + (i32.const 0) (struct.get $channel $size (local.get $ch)))) + (struct.set $channel $max (local.get $ch) (local.get $nread)) + (if (i32.gt_u (local.get $len) (local.get $nread)) + (then (local.set $len (local.get $nread)))) + (call $ta_blit_to_string + (struct.get $channel $buffer (local.get $ch)) + (i32.const 0) + (local.get $s) (local.get $pos) + (local.get $len)) + (struct.set $channel $curr (local.get $ch) (local.get $len)) + (local.get $len)) + + (func (export "caml_really_getblock") + (param $ch (ref eq)) (param $s (ref $string)) + (param $pos i32) (param $len i32) + (result i32) + (local $read i32) (local $n i32) + (local.set $n (local.get $len)) + (loop $loop + (if (local.get $n) + (then + (local.set $read + (call $caml_getblock(local.get $ch) + (local.get $s) (local.get $pos) (local.get $n))) + (if (i32.eqz (local.get $read)) + (then (return (i32.sub (local.get $len) (local.get $n))))) + (local.set $pos (i32.add (local.get $pos) (local.get $read))) + (local.set $n (i32.sub (local.get $n) (local.get $read))) + (br $loop)))) + (local.get $len)) + + (func (export "caml_ml_input") + (param $vch (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) (local $s (ref $string)) + (local $pos i32) (local $len i32) (local $curr i32) + (local $i i32) (local $avail i32) (local $nread i32) + (local $buf (ref extern)) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (local.set $s (ref.cast (ref $string) (local.get $vs))) + (local.set $pos (i31.get_u (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (local.set $buf (struct.get $channel $buffer (local.get $ch))) + (local.set $curr (struct.get $channel $curr (local.get $ch))) + (local.set $avail + (i32.sub (struct.get $channel $max (local.get $ch)) (local.get $curr))) + (if (i32.gt_u (local.get $len) (local.get $avail)) + (then + (if (i32.gt_u (local.get $avail) (i32.const 0)) + (then + (local.set $len (local.get $avail))) + (else + (local.set $nread + (call $caml_do_read (local.get $ch) + (i32.const 0) + (struct.get $channel $size (local.get $ch)))) + (struct.set $channel $max (local.get $ch) (local.get $nread)) + (local.set $curr (i32.const 0)) + (if (i32.gt_u (local.get $len) (local.get $nread)) + (then (local.set $len (local.get $nread)))))))) + (call $ta_blit_to_string + (local.get $buf) (local.get $curr) + (local.get $s) (local.get $pos) (local.get $len)) + (struct.set $channel $curr (local.get $ch) + (i32.add (local.get $curr) (local.get $len))) + (ref.i31 (local.get $len))) + + (func $caml_getch (param $ch (ref $channel)) (result i32) + (local $curr i32) + (local.set $curr (struct.get $channel $curr (local.get $ch))) + (if (i32.ge_u (local.get $curr) (struct.get $channel $max (local.get $ch))) + (then (return_call $caml_refill (local.get $ch)))) + (struct.set $channel $curr (local.get $ch) + (i32.add (local.get $curr) (i32.const 1))) + (return_call $ta_get_ui8 + (struct.get $channel $buffer (local.get $ch)) + (local.get $curr))) + + (func (export "caml_ml_input_char") + (param $ch (ref eq)) (result (ref eq)) + (ref.i31 (call $caml_getch (ref.cast (ref $channel) (local.get $ch))))) + + (func (export "caml_ml_input_int") + (param $vch (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) (local $res i32) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (local.set $res + (i32.shl (call $caml_getch (local.get $ch)) (i32.const 24))) + (local.set $res + (i32.or (local.get $res) + (i32.shl (call $caml_getch (local.get $ch)) (i32.const 16)))) + (local.set $res + (i32.or (local.get $res) + (i32.shl (call $caml_getch (local.get $ch)) (i32.const 8)))) + (return + (ref.i31 (i32.or (local.get $res) (call $caml_getch (local.get $ch)))))) + + (func (export "caml_ml_pos_in") + (param $vch (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (ref.i31 + (i32.sub + (i32.wrap_i64 + (struct.get $fd_offset $offset + (call $get_fd_offset + (struct.get $channel $fd (local.get $ch))))) + (i32.sub + (struct.get $channel $max (local.get $ch)) + (struct.get $channel $curr (local.get $ch)))))) + + (func (export "caml_ml_pos_in_64") + (param $vch (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (call $caml_copy_int64 + (i64.sub + (struct.get $fd_offset $offset + (call $get_fd_offset + (struct.get $channel $fd (local.get $ch)))) + (i64.extend_i32_s + (i32.sub + (struct.get $channel $max (local.get $ch)) + (struct.get $channel $curr (local.get $ch))))))) + + (func (export "caml_ml_pos_out") + (param $vch (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (ref.i31 + (i32.add + (i32.wrap_i64 + (struct.get $fd_offset $offset + (call $get_fd_offset + (struct.get $channel $fd (local.get $ch))))) + (struct.get $channel $curr (local.get $ch))))) + + (func (export "caml_ml_pos_out_64") + (param $vch (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (call $caml_copy_int64 + (i64.add + (struct.get $fd_offset $offset + (call $get_fd_offset + (struct.get $channel $fd (local.get $ch)))) + (i64.extend_i32_s (struct.get $channel $curr (local.get $ch)))))) + + (func $caml_seek_in + (param $ch (ref $channel)) (param $dest i64) (result (ref eq)) + (local $fd i32) (local $offset i64) + (local $fd_offset (ref $fd_offset)) + (local.set $fd (struct.get $channel $fd (local.get $ch))) + (local.set $fd_offset (call $get_fd_offset (local.get $fd))) + (local.set $offset + (struct.get $fd_offset $offset (local.get $fd_offset))) + (if (i32.and + (i64.ge_s + (local.get $dest) + (i64.sub + (local.get $offset) + (i64.extend_i32_s + (struct.get $channel $max (local.get $ch))))) + (i64.le_s (local.get $dest) (local.get $offset))) + (then + (struct.set $channel $curr (local.get $ch) + (i32.sub + (struct.get $channel $max (local.get $ch)) + (i32.wrap_i64 + (i64.sub (local.get $offset) (local.get $dest)))))) + (else + ;; ZZZ Check for error + (struct.set $fd_offset $offset (local.get $fd_offset) + (local.get $dest)) + (struct.set $fd_offset $seeked (local.get $fd_offset) + (i32.const 1)) + (struct.set $channel $curr (local.get $ch) (i32.const 0)) + (struct.set $channel $max (local.get $ch) (i32.const 0)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_seek_in") + (param $ch (ref eq)) (param $dest (ref eq)) (result (ref eq)) + (return_call $caml_seek_in (ref.cast (ref $channel) (local.get $ch)) + (i64.extend_i32_s + (i31.get_s (ref.cast (ref i31) (local.get $dest)))))) + + (func (export "caml_ml_seek_in_64") + (param $ch (ref eq)) (param $dest (ref eq)) (result (ref eq)) + (return_call $caml_seek_in (ref.cast (ref $channel) (local.get $ch)) + (call $Int64_val (local.get $dest)))) + + (func (export "caml_ml_seek_out") + (param $vch (ref eq)) (param $voffset (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) + (local $fd_offset (ref $fd_offset)) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (call $caml_flush (local.get $ch)) + ;; ZZZ Check for error + (local.set $fd_offset + (call $get_fd_offset (struct.get $channel $fd (local.get $ch)))) + (struct.set $fd_offset $offset (local.get $fd_offset) + (i64.extend_i32_s + (i31.get_s (ref.cast (ref i31) (local.get $voffset))))) + (struct.set $fd_offset $seeked (local.get $fd_offset) (i32.const 1)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_seek_out_64") + (param $vch (ref eq)) (param $voffset (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) + (local $fd_offset (ref $fd_offset)) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (call $caml_flush (local.get $ch)) + ;; ZZZ Check for error + (local.set $fd_offset + (call $get_fd_offset (struct.get $channel $fd (local.get $ch)))) + (struct.set $fd_offset $offset (local.get $fd_offset) + (call $Int64_val (local.get $voffset))) + (struct.set $fd_offset $seeked (local.get $fd_offset) (i32.const 1)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_input_scan_line") + (param $vch (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) (local $p i32) (local $n i32) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (local.set $p (struct.get $channel $curr (local.get $ch))) + (loop $loop + (if (i32.ge_u (local.get $p) (struct.get $channel $max (local.get $ch))) + (then + (if (struct.get $channel $curr (local.get $ch)) + (then + (local.set $n (struct.get $channel $curr (local.get $ch))) + (call $ta_copy + (struct.get $channel $buffer (local.get $ch)) + (i32.const 0) (local.get $n) + (i32.sub (struct.get $channel $max (local.get $ch)) + (struct.get $channel $curr (local.get $ch)))) + (struct.set $channel $curr (local.get $ch) (i32.const 0)) + (struct.set $channel $max (local.get $ch) + (i32.sub (struct.get $channel $max (local.get $ch)) + (local.get $n))) + (local.set $p (i32.sub (local.get $p) (local.get $n))))) + (if (i32.ge_u (struct.get $channel $max (local.get $ch)) + (struct.get $channel $size (local.get $ch))) + (then + (return + (ref.i31 + (i32.sub (struct.get $channel $curr (local.get $ch)) + (struct.get $channel $size (local.get $ch))))))) + (local.set $n + (call $caml_do_read + (local.get $ch) + (struct.get $channel $max (local.get $ch)) + (i32.sub + (struct.get $channel $size (local.get $ch)) + (struct.get $channel $max (local.get $ch))))) + (if (i32.eqz (local.get $n)) + (then + (return + (ref.i31 + (i32.sub (struct.get $channel $curr (local.get $ch)) + (struct.get $channel $max (local.get $ch))))))) + (struct.set $channel $max (local.get $ch) + (i32.add (struct.get $channel $max (local.get $ch)) + (local.get $n))))) + (if (i32.eq (i32.const 10) ;; '\n' + (call $ta_get_ui8 (struct.get $channel $buffer (local.get $ch)) + (local.get $p))) + (then + (return + (ref.i31 + (i32.add (i32.const 1) + (i32.sub (local.get $p) + (struct.get $channel $curr (local.get $ch)))))))) + (local.set $p (i32.add (local.get $p) (i32.const 1))) + (br $loop))) + + (func $caml_flush (param $ch (ref $channel)) + (loop $loop + (br_if $loop (i32.eqz (call $caml_flush_partial (local.get $ch)))))) + + (func $caml_flush_if_unbuffered (export "caml_flush_if_unbuffered") + (param $vch (ref eq)) + (local $ch (ref $channel)) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (if (struct.get $channel $unbuffered (local.get $ch)) + (then (call $caml_flush (local.get $ch))))) + + (func $caml_ml_flush (export "caml_ml_flush") + (param $vch (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (if (i32.ne (struct.get $channel $fd (local.get $ch)) (i32.const -1)) + (then (call $caml_flush (local.get $ch)))) + (ref.i31 (i32.const 0))) + + (func $caml_flush_partial (param $ch (ref $channel)) (result i32) + (local $towrite i32) (local $written i32) (local $fd i32) + (local $fd_offset (ref $fd_offset)) + (local $offset i64) (local $buf (ref extern)) + (local.set $towrite (struct.get $channel $curr (local.get $ch))) + (if (i32.gt_u (local.get $towrite) (i32.const 0)) + (then + (local.set $buf (struct.get $channel $buffer (local.get $ch))) + (local.set $fd (struct.get $channel $fd (local.get $ch))) + (local.set $fd_offset (call $get_fd_offset (local.get $fd))) + (local.set $offset + (struct.get $fd_offset $offset (local.get $fd_offset))) + (try + (do + (local.set $written + (if (result i32) + (struct.get $fd_offset $seeked (local.get $fd_offset)) + (then + (call $write + (local.get $fd) + (local.get $buf) + (i32.const 0) + (local.get $towrite) + (local.get $offset))) + (else + (call $write' + (local.get $fd) + (local.get $buf) + (i32.const 0) + (local.get $towrite) + (ref.null noextern)))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)))) + (struct.set $fd_offset $offset + (local.get $fd_offset) + (i64.add + (local.get $offset) + (i64.extend_i32_u (local.get $written)))) + (local.set $towrite + (i32.sub (local.get $towrite) (local.get $written))) + (if (i32.gt_u (local.get $towrite) (i32.const 0)) + (then + (call $ta_copy (local.get $buf) + (i32.const 0) (local.get $written) (local.get $towrite)))) + (struct.set $channel $curr (local.get $ch) (local.get $towrite)))) + (i32.eqz (local.get $towrite))) + + (func $caml_putblock + (param $ch (ref $channel)) (param $s (ref $string)) (param $pos i32) + (param $len i32) (result i32) + (local $free i32) (local $curr i32) + (local $buf (ref extern)) + (local.set $curr (struct.get $channel $curr (local.get $ch))) + (local.set $free + (i32.sub (struct.get $channel $size (local.get $ch)) (local.get $curr))) + (if (i32.ge_u (local.get $len) (local.get $free)) + (then (local.set $len (local.get $free)))) + (local.set $buf (struct.get $channel $buffer (local.get $ch))) + (call $ta_blit_from_string + (local.get $s) (local.get $pos) + (local.get $buf) (local.get $curr) (local.get $len)) + (struct.set $channel $curr (local.get $ch) + (i32.add (local.get $curr) (local.get $len))) + (if (i32.ge_u (local.get $len) (local.get $free)) + (then (drop (call $caml_flush_partial (local.get $ch))))) + (local.get $len)) + + (func (export "caml_really_putblock") + (param $ch (ref eq)) (param $s (ref $string)) + (param $pos i32) (param $len i32) + (local $written i32) + (loop $loop + (if (local.get $len) + (then + (local.set $written + (call $caml_putblock (ref.cast (ref $channel) (local.get $ch)) + (local.get $s) (local.get $pos) (local.get $len))) + (local.set $pos (i32.add (local.get $pos) (local.get $written))) + (local.set $len (i32.sub (local.get $len) (local.get $written))) + (br $loop))))) + + (export "caml_ml_output_bytes" (func $caml_ml_output)) + (func $caml_ml_output (export "caml_ml_output") + (param $ch (ref eq)) (param $s (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $pos i32) (local $len i32) (local $written i32) + (local.set $pos (i31.get_u (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (loop $loop + (if (i32.gt_u (local.get $len) (i32.const 0)) + (then + (local.set $written + (call $caml_putblock (ref.cast (ref $channel) (local.get $ch)) + (ref.cast (ref $string) (local.get $s)) + (local.get $pos) (local.get $len))) + (local.set $pos (i32.add (local.get $pos) (local.get $written))) + (local.set $len (i32.sub (local.get $len) (local.get $written))) + (br $loop)))) + (call $caml_flush_if_unbuffered (local.get $ch)) + (ref.i31 (i32.const 0))) + + (func $caml_putch (param $ch (ref $channel)) (param $c i32) + (local $curr i32) + (if (i32.ge_u (struct.get $channel $curr (local.get $ch)) + (struct.get $channel $size (local.get $ch))) + (then + (drop (call $caml_flush_partial (local.get $ch))))) + (local.set $curr (struct.get $channel $curr (local.get $ch))) + (call $ta_set_ui8 (struct.get $channel $buffer (local.get $ch)) + (local.get $curr) (local.get $c)) + (struct.set $channel $curr (local.get $ch) + (i32.add (local.get $curr) (i32.const 1)))) + + (func (export "caml_ml_output_char") + (param $ch (ref eq)) (param $c (ref eq)) (result (ref eq)) + (call $caml_putch (ref.cast (ref $channel) (local.get $ch)) + (i31.get_u (ref.cast (ref i31) (local.get 1)))) + (call $caml_flush_if_unbuffered (local.get $ch)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_output_int") + (param $vch (ref eq)) (param $vn (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) (local $n i32) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (local.set $n (i31.get_u (ref.cast (ref i31) (local.get 1)))) + (call $caml_putch (local.get $ch) + (i32.shr_u (local.get $n) (i32.const 24))) + (call $caml_putch (local.get $ch) + (i32.shr_u (local.get $n) (i32.const 16))) + (call $caml_putch (local.get $ch) + (i32.shr_u (local.get $n) (i32.const 8))) + (call $caml_putch (local.get $ch) (local.get $n)) + (call $caml_flush_if_unbuffered (local.get $ch)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_is_buffered") (param $ch (ref eq)) (result (ref eq)) + (ref.i31 + (i32.eqz + (struct.get $channel $unbuffered + (ref.cast (ref $channel) (local.get $ch)))))) + + (func (export "caml_ml_set_buffered") + (param $vch (ref eq)) (param $mode (ref eq)) (result (ref eq)) + (local $ch (ref $channel)) + (local.set $ch (ref.cast (ref $channel) (local.get $vch))) + (if (i31.get_s (ref.cast (ref i31) (local.get $mode))) + (then + (struct.set $channel $unbuffered (local.get $ch) (i32.const 0))) + (else + (struct.set $channel $unbuffered (local.get $ch) (i32.const 1)) + (if (i32.ne (struct.get $channel $fd (local.get $ch)) (i32.const -1)) + (then (call $caml_flush (local.get $ch)))))) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_channel_size") (param (ref eq)) (result (ref eq)) + ;; ZZZ check for overflow + (ref.i31 + (i32.wrap_i64 + (call $file_size (call $caml_ml_get_channel_fd (local.get 0)))))) + + (func (export "caml_ml_channel_size_64") (param (ref eq)) (result (ref eq)) + (call $caml_copy_int64 + (call $file_size (call $caml_ml_get_channel_fd (local.get 0))))) + + (func $caml_ml_get_channel_fd (export "caml_ml_get_channel_fd") + (param (ref eq)) (result i32) + (struct.get $channel $fd (ref.cast (ref $channel) (local.get 0)))) + + (func (export "caml_ml_set_channel_fd") (param (ref eq)) (param i32) + (struct.set $channel $fd + (ref.cast (ref $channel) (local.get 0)) (local.get 1))) + + (func (export "caml_ml_get_channel_offset") (param $ch (ref eq)) (result i64) + (struct.get $fd_offset $offset + (call $get_fd_offset + (struct.get $channel $fd + (ref.cast (ref $channel) (local.get $ch)))))) +) diff --git a/runtime/wasm/jslib.wat b/runtime/wasm/jslib.wat new file mode 100644 index 0000000000..b4468e8dea --- /dev/null +++ b/runtime/wasm/jslib.wat @@ -0,0 +1,680 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "bindings" "log" (func $log_js (param anyref))) + (import "bindings" "identity" (func $to_float (param anyref) (result f64))) + (import "bindings" "identity" (func $from_float (param f64) (result anyref))) + (import "bindings" "identity" (func $to_bool (param anyref) (result i32))) + (import "bindings" "identity" (func $to_int32 (param anyref) (result i32))) + (import "bindings" "identity" (func $from_int32 (param i32) (result anyref))) + (import "bindings" "from_bool" (func $from_bool (param i32) (result anyref))) + (import "bindings" "get" + (func $get (param (ref extern)) (param anyref) (result anyref))) + (import "bindings" "set" + (func $set (param anyref) (param anyref) (param anyref))) + (import "bindings" "delete" (func $delete (param anyref) (param anyref))) + (import "bindings" "instanceof" + (func $instanceof (param anyref) (param anyref) (result i32))) + (import "bindings" "typeof" (func $typeof (param anyref) (result anyref))) + (import "bindings" "equals" + (func $equals (param anyref) (param anyref) (result i32))) + (import "bindings" "strict_equals" + (func $strict_equals (param anyref) (param anyref) (result i32))) + (import "bindings" "fun_call" + (func $fun_call + (param anyref) (param anyref) (param anyref) (result anyref))) + (import "bindings" "meth_call" + (func $meth_call + (param anyref) (param anyref) (param anyref) (result anyref))) + (import "bindings" "new" + (func $new (param anyref) (param anyref) (result anyref))) + (import "bindings" "new_obj" (func $new_obj (result anyref))) + (import "bindings" "new_array" + (func $new_array (param i32) (result (ref extern)))) + (import "bindings" "global_this" (global $global_this anyref)) + (import "bindings" "iter_props" + (func $iter_props (param anyref) (param anyref))) + (import "bindings" "array_length" + (func $array_length (param (ref extern)) (result i32))) + (import "bindings" "array_get" + (func $array_get (param (ref extern)) (param i32) (result anyref))) + (import "bindings" "array_set" + (func $array_set (param (ref extern)) (param i32) (param anyref))) + (import "bindings" "wrap_callback" + (func $wrap_callback (param (ref eq)) (result anyref))) + (import "bindings" "wrap_callback_args" + (func $wrap_callback_args (param (ref eq)) (result anyref))) + (import "bindings" "wrap_callback_strict" + (func $wrap_callback_strict (param i32) (param (ref eq)) (result anyref))) + (import "bindings" "wrap_callback_unsafe" + (func $wrap_callback_unsafe (param (ref eq)) (result anyref))) + (import "bindings" "wrap_meth_callback" + (func $wrap_meth_callback (param (ref eq)) (result anyref))) + (import "bindings" "wrap_meth_callback_args" + (func $wrap_meth_callback_args (param (ref eq)) (result anyref))) + (import "bindings" "wrap_meth_callback_strict" + (func $wrap_meth_callback_strict + (param i32) (param (ref eq)) (result anyref))) + (import "bindings" "wrap_meth_callback_unsafe" + (func $wrap_meth_callback_unsafe (param (ref eq)) (result anyref))) + (import "bindings" "wrap_fun_arguments" + (func $wrap_fun_arguments (param anyref) (result anyref))) + (import "fail" "caml_failwith_tag" + (func $caml_failwith_tag (result (ref eq)))) + (import "stdlib" "caml_named_value" + (func $caml_named_value (param (ref $string)) (result (ref null eq)))) + (import "obj" "caml_callback_1" + (func $caml_callback_1 + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "obj" "caml_is_closure" + (func $caml_is_closure (param (ref eq)) (result i32))) + (import "obj" "caml_is_last_arg" + (func $caml_is_last_arg (param (ref eq)) (result i32))) + (import "jsstring" "jsstring_of_string" + (func $jsstring_of_string (param (ref $string)) (result anyref))) + (import "jsstring" "string_of_jsstring" + (func $string_of_jsstring (param anyref) (result (ref $string)))) + (import "int32" "caml_copy_int32" + (func $caml_copy_int32 (param i32) (result (ref eq)))) + (import "int32" "Int32_val" + (func $Int32_val (param (ref eq)) (result i32))) + (import "int32" "caml_copy_nativeint" + (func $caml_copy_nativeint (param i32) (result (ref eq)))) + (import "int32" "Nativeint_val" + (func $Nativeint_val (param (ref eq)) (result i32))) + + (type $block (array (mut (ref eq)))) + (type $float (struct (field f64))) + (type $float_array (array (mut f64))) + (type $string (array (mut i8))) + (type $js (struct (field anyref))) + (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) + (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) + (type $function_2 + (func (param (ref eq) (ref eq) (ref eq)) (result (ref eq)))) + (type $cps_closure (sub (struct (field (ref $function_2))))) + + (func $wrap (export "wrap") (param anyref) (result (ref eq)) + (block $is_eq (result (ref eq)) + (return + (struct.new $js (br_on_cast $is_eq anyref (ref eq) (local.get 0)))))) + + (func $unwrap (export "unwrap") (param (ref eq)) (result anyref) + (block $not_js (result anyref) + (return + (struct.get $js 0 + (br_on_cast_fail $not_js (ref eq) (ref $js) (local.get 0)))))) + + (func (export "caml_js_equals") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (call $equals + (call $unwrap (local.get 0)) (call $unwrap (local.get 1))))) + + (func (export "caml_js_strict_equals") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (call $strict_equals + (call $unwrap (local.get 0)) (call $unwrap (local.get 1))))) + + (func (export "caml_js_global") (param (ref eq)) (result (ref eq)) + (call $wrap (global.get $global_this))) + + (func (export "caml_js_to_float") (param (ref eq)) (result (ref eq)) + (struct.new $float (call $to_float (call $unwrap (local.get 0))))) + + (func (export "caml_js_from_float") (param (ref eq)) (result (ref eq)) + (return_call $wrap + (call $from_float + (struct.get $float 0 (ref.cast (ref $float) (local.get 0)))))) + + (func (export "caml_js_to_bool") (param (ref eq)) (result (ref eq)) + (ref.i31 + (call $to_bool (call $unwrap (local.get 0))))) + + (func (export "caml_js_from_bool") (param (ref eq)) (result (ref eq)) + (struct.new $js + (call $from_bool (i31.get_s (ref.cast (ref i31) (local.get 0)))))) + + (func (export "caml_js_to_int32") (param (ref eq)) (result (ref eq)) + (return_call $caml_copy_int32 + (call $to_int32 (call $unwrap (local.get 0))))) + + (func (export "caml_js_from_int32") (param (ref eq)) (result (ref eq)) + (return_call $wrap (call $from_int32 (call $Int32_val (local.get 0))))) + + (func (export "caml_js_to_nativeint") (param (ref eq)) (result (ref eq)) + (return_call $caml_copy_nativeint + (call $to_int32 (call $unwrap (local.get 0))))) + + (func (export "caml_js_from_nativeint") (param (ref eq)) (result (ref eq)) + (return_call $wrap (call $from_int32 (call $Nativeint_val (local.get 0))))) + + (func (export "caml_js_pure_expr") + (param $f (ref eq)) (result (ref eq)) + (return_call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) + + (func (export "caml_js_fun_call") + (param $f (ref eq)) (param $args (ref eq)) (result (ref eq)) + (return_call $wrap + (call $fun_call (call $unwrap (local.get $f)) (ref.null any) + (call $unwrap (call $caml_js_from_array (local.get $args)))))) + + (func (export "caml_js_call") + (param $f (ref eq)) (param $o (ref eq)) (param $args (ref eq)) + (result (ref eq)) + (return_call $wrap + (call $fun_call (call $unwrap (local.get $f)) + (call $unwrap (local.get $o)) + (call $unwrap (call $caml_js_from_array (local.get $args)))))) + + (func (export "caml_js_meth_call") + (param $o (ref eq)) (param $f (ref eq)) (param $args (ref eq)) + (result (ref eq)) + (if (ref.test (ref $string) (local.get $f)) + (then + (local.set $f (call $caml_jsbytes_of_string (local.get $f))))) + (return_call $wrap + (call $meth_call (call $unwrap (local.get $o)) + (call $unwrap (local.get $f)) + (call $unwrap (call $caml_js_from_array (local.get $args)))))) + + (func (export "caml_js_get") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (if (ref.test (ref $string) (local.get 1)) + (then + (local.set 1 (call $caml_jsbytes_of_string (local.get 1))))) + (return_call $wrap + (call $get + (ref.as_non_null (extern.convert_any (call $unwrap (local.get 0)))) + (call $unwrap (local.get 1))))) + + (func (export "caml_js_set") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (if (ref.test (ref $string) (local.get 1)) + (then + (local.set 1 (call $caml_jsbytes_of_string (local.get 1))))) + (call $set (call $unwrap (local.get 0)) (call $unwrap (local.get 1)) + (call $unwrap (local.get 2))) + (ref.i31 (i32.const 0))) + + (func (export "caml_js_delete") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (if (ref.test (ref $string) (local.get 1)) + (then + (local.set 1 (call $caml_jsbytes_of_string (local.get 1))))) + (call $delete (call $unwrap (local.get 0)) (call $unwrap (local.get 1))) + (ref.i31 (i32.const 0))) + + (func (export "caml_js_instanceof") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (call $instanceof + (call $unwrap (local.get 0)) (call $unwrap (local.get 1))))) + + (func (export "caml_js_typeof") + (param (ref eq)) (result (ref eq)) + (struct.new $js (call $typeof (call $unwrap (local.get 0))))) + + (func (export "caml_js_new") + (param $c (ref eq)) (param $args (ref eq)) (result (ref eq)) + (return_call $wrap + (call $new (call $unwrap (local.get $c)) + (call $unwrap (call $caml_js_from_array (local.get $args)))))) + + (func (export "caml_ojs_new_arr") + (param $c (ref eq)) (param $args (ref eq)) (result (ref eq)) + (return_call $wrap + (call $new (call $unwrap (local.get $c)) + (call $unwrap (local.get $args))))) + + (func (export "caml_ojs_iterate_properties") + (param $o (ref eq)) (param $f (ref eq)) (result (ref eq)) + (call $iter_props + (call $unwrap (local.get $o)) (call $unwrap (local.get $f))) + (ref.i31 (i32.const 0))) + + (func (export "caml_js_object") + (param (ref eq)) (result (ref eq)) + (local $a (ref $block)) (local $p (ref $block)) + (local $i i32) (local $l i32) + (local $o anyref) + (local.set $a (ref.cast (ref $block) (local.get 0))) + (local.set $l (array.len (local.get $a))) + (local.set $i (i32.const 1)) + (local.set $o (call $new_obj)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (local.set $p + (ref.cast (ref $block) + (array.get $block (local.get $a) (local.get $i)))) + (call $set (local.get $o) + (call $unwrap + (call $caml_jsstring_of_string + (array.get $block (local.get $p) (i32.const 1)))) + (call $unwrap + (array.get $block (local.get $p) (i32.const 2)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (struct.new $js (local.get $o))) + + (func $caml_js_from_array (export "caml_js_from_array") + (param $va (ref eq)) (result (ref eq)) + (local $a (ref $block)) + (local $fa (ref $float_array)) + (local $a' (ref extern)) + (local $i i32) (local $l i32) + (drop (block $not_array (result (ref eq)) + (local.set $a + (br_on_cast_fail $not_array (ref eq) (ref $block) (local.get $va))) + (local.set $l (i32.sub (array.len (local.get $a)) (i32.const 1))) + (local.set $a' (call $new_array (local.get $l))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (call $array_set (local.get $a') (local.get $i) + (call $unwrap (array.get $block (local.get $a) + (i32.add (local.get $i) (i32.const 1))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (struct.new $js (any.convert_extern (local.get $a')))))) + (local.set $fa (ref.cast (ref $float_array) (local.get $va))) + (local.set $l (array.len (local.get $fa))) + (local.set $a' (call $new_array (local.get $l))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (call $array_set (local.get $a') (local.get $i) + (struct.new $float + (array.get $float_array (local.get $fa) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (struct.new $js (any.convert_extern (local.get $a')))) + + (func (export "caml_js_to_array") + (param (ref eq)) (result (ref eq)) + (local $a (ref extern)) + (local $a' (ref $block)) + (local $fa (ref $float_array)) + (local $i i32) (local $l i32) + (local.set $a + (ref.as_non_null (extern.convert_any (call $unwrap (local.get 0))))) + (local.set $l (call $array_length (local.get $a))) + (if (local.get $l) + (then + (if (ref.test (ref $float) + (call $array_get (local.get $a) (i32.const 0))) + (then + (local.set $fa + (array.new $float_array (f64.const 0) (local.get $l))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (array.set $float_array (local.get $fa) + (local.get $i) + (struct.get $float 0 + (ref.cast (ref $float) + (call $array_get + (local.get $a) (local.get $i))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (local.get $fa)))))) + (local.set $a' + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $l) (i32.const 1)))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (array.set $block (local.get $a') + (i32.add (local.get $i) (i32.const 1)) + (call $wrap (call $array_get (local.get $a) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $a')) + + (func (export "caml_js_to_string_array") + (param $a (ref extern)) (result (ref eq)) + (local $a' (ref $block)) (local $l i32) (local $i i32) + (local.set $l (call $array_length (local.get $a))) + (local.set $a' + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $l) (i32.const 1)))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (array.set $block (local.get $a') + (i32.add (local.get $i) (i32.const 1)) + (call $caml_string_of_jsstring + (call $wrap + (call $array_get (local.get $a) (local.get $i))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $a')) + + (func $caml_js_wrap_callback (export "caml_js_wrap_callback") + (param (ref eq)) (result (ref eq)) + (return_call $wrap (call $wrap_callback (local.get 0)))) + + (func (export "caml_js_wrap_callback_arguments") + (param (ref eq)) (result (ref eq)) + (return_call $wrap (call $wrap_callback_args (local.get 0)))) + + (func (export "caml_js_wrap_callback_strict") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (return_call $wrap + (call $wrap_callback_strict + (i31.get_u (ref.cast (ref i31) (local.get 0))) (local.get 1)))) + + (func (export "caml_js_wrap_callback_unsafe") + (param (ref eq)) (result (ref eq)) + (return_call $wrap (call $wrap_callback_unsafe (local.get 0)))) + + (func (export "caml_js_wrap_meth_callback") + (param (ref eq)) (result (ref eq)) + (return_call $wrap (call $wrap_meth_callback (local.get 0)))) + + (func (export "caml_js_wrap_meth_callback_arguments") + (param (ref eq)) (result (ref eq)) + (return_call $wrap (call $wrap_meth_callback_args (local.get 0)))) + + (func (export "caml_js_wrap_meth_callback_strict") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (return_call $wrap + (call $wrap_meth_callback_strict + (i31.get_u (ref.cast (ref i31) (local.get 0))) (local.get 1)))) + + (func (export "caml_js_wrap_meth_callback_unsafe") + (param (ref eq)) (result (ref eq)) + (return_call $wrap (call $wrap_meth_callback_unsafe (local.get 0)))) + + (func (export "caml_ojs_wrap_fun_arguments") + (param (ref eq)) (result (ref eq)) + (return_call $wrap + (call $wrap_fun_arguments + (call $wrap_callback_strict (i32.const 1) (local.get 0))))) + + (func (export "caml_callback") + (param $f (ref eq)) (param $count i32) (param $args (ref extern)) + (param $kind i32) ;; 0 ==> strict / 2 ==> unsafe + (result anyref) + (local $acc (ref eq)) (local $i i32) (local $arg (ref eq)) + (local.set $acc (local.get $f)) + (if (i32.eq (local.get $kind) (i32.const 2)) + (then + (loop $loop + (local.set $f (local.get $acc)) + (local.set $acc + (call $caml_callback_1 (local.get $acc) + (call $wrap + (call $get (local.get $args) + (ref.i31 (local.get $i)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop + (i32.eqz (call $caml_is_last_arg (local.get $f)))))) + (else + (local.set $i (i32.const 0)) + (block $done + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $count)) + (then + (br_if $done + (i32.eqz (call $caml_is_closure (local.get $acc)))) + (local.set $acc + (call $caml_callback_1 (local.get $acc) + (call $wrap + (call $get (local.get $args) + (ref.i31 (local.get $i)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (if (local.get $kind) + (then + (if (call $caml_is_closure (local.get $acc)) + (then (local.set $acc + (call $caml_js_wrap_callback + (local.get $acc))))))))) + (return_call $unwrap (local.get $acc))) + + (export "caml_js_from_string" (func $caml_jsstring_of_string)) + (func $caml_jsstring_of_string (export "caml_jsstring_of_string") + (param (ref eq)) (result (ref eq)) + (local $s (ref $string)) + (local.set $s (ref.cast (ref $string) (local.get 0))) + (return (struct.new $js (call $jsstring_of_string (local.get $s))))) + + (func $caml_jsbytes_of_string (export "caml_jsbytes_of_string") + (param (ref eq)) (result (ref eq)) + (local $s (ref $string)) + (local $s' (ref $string)) + (local $l i32) (local $i i32) (local $n i32) (local $c i32) + (local.set $s (ref.cast (ref $string) (local.get 0))) + (local.set $l (array.len (local.get $s))) + (local.set $i (i32.const 0)) + (local.set $n (i32.const 0)) + (loop $count + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (if (i32.ge_u (array.get_u $string (local.get $s) (local.get $i)) + (i32.const 128)) + (then (local.set $n (i32.add (local.get $n) (i32.const 1))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $count)))) + (if (i32.eqz (local.get $n)) + (then + (return + (struct.new $js + (call $jsstring_of_string (local.get $s)))))) + (local.set $s' + (array.new $string (i32.const 0) + (i32.add (local.get $i) (local.get $n)))) + (local.set $i (i32.const 0)) + (local.set $n (i32.const 0)) + (loop $fill + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (local.set $c (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.lt_u (local.get $c) (i32.const 128)) + (then + (array.set $string + (local.get $s') (local.get $n) (local.get $c)) + (local.set $n (i32.add (local.get $n) (i32.const 1)))) + (else + (array.set $string (local.get $s') + (local.get $n) + (i32.or (i32.shr_u (local.get $c) (i32.const 6)) + (i32.const 0xC0))) + (array.set $string (local.get $s') + (i32.add (local.get $n) (i32.const 1)) + (i32.or (i32.const 0x80) + (i32.and (local.get $c) (i32.const 0x3F)))) + (local.set $n (i32.add (local.get $n) (i32.const 2))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $fill)))) + (return (struct.new $js (call $jsstring_of_string (local.get $s'))))) + + (export "caml_js_to_string" (func $caml_string_of_jsstring)) + (func $caml_string_of_jsstring (export "caml_string_of_jsstring") + (param $s (ref eq)) (result (ref eq)) + (return_call $string_of_jsstring + (struct.get $js 0 (ref.cast (ref $js) (local.get $s))))) + + (func (export "caml_string_of_jsbytes") + (param $s (ref eq)) (result (ref eq)) + (local $l i32) (local $i i32) (local $n i32) (local $c i32) + (local $s' (ref $string)) (local $s'' (ref $string)) + (local.set $s' + (call $string_of_jsstring + (struct.get $js 0 (ref.cast (ref $js) (local.get $s))))) + (local.set $l (array.len (local.get $s'))) + (local.set $i (i32.const 0)) + (local.set $n (i32.const 0)) + (loop $count + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (if (i32.ge_u (array.get_u $string (local.get $s') (local.get $i)) + (i32.const 0xC0)) + (then (local.set $n (i32.add (local.get $n) (i32.const 1))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $count)))) + (if (i32.eqz (local.get $n)) (then (return (local.get $s')))) + (local.set $s'' + (array.new $string (i32.const 0) + (i32.sub (local.get $i) (local.get $n)))) + (local.set $i (i32.const 0)) + (local.set $n (i32.const 0)) + (loop $fill + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (local.set $c + (array.get_u $string (local.get $s') (local.get $i))) + (if (i32.lt_u (local.get $c) (i32.const 0xC0)) + (then + (array.set $string + (local.get $s'') (local.get $n) (local.get $c)) + (local.set $i (i32.add (local.get $i) (i32.const 1)))) + (else + (array.set $string (local.get $s'') + (local.get $n) + (i32.sub + (i32.add + (i32.shl (local.get $c) (i32.const 6)) + (array.get_u $string (local.get $s') + (i32.add (local.get $i) (i32.const 1)))) + (i32.const 0x3080))) + (local.set $i (i32.add (local.get $i) (i32.const 2))))) + (local.set $n (i32.add (local.get $n) (i32.const 1))) + (br $fill)))) + (local.get $s'')) + + (func (export "caml_list_to_js_array") + (param (ref eq)) (result (ref eq)) + (local $i i32) + (local $a (ref extern)) + (local $l (ref eq)) + (local $b (ref $block)) + (local.set $i (i32.const 0)) + (local.set $l (local.get 0)) + (drop (block $done (result (ref eq)) + (loop $compute_length + (local.set $l + (array.get $block + (br_on_cast_fail $done (ref eq) (ref $block) (local.get $l)) + (i32.const 2))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $compute_length)))) + (local.set $a (call $new_array (local.get $i))) + (local.set $i (i32.const 0)) + (local.set $l (local.get 0)) + (drop (block $exit (result (ref eq)) + (loop $loop + (local.set $b + (br_on_cast_fail $exit (ref eq) (ref $block) (local.get $l))) + (call $array_set (local.get $a) (local.get $i) + (call $unwrap (array.get $block (local.get $b) (i32.const 1)))) + (local.set $l (array.get $block (local.get $b) (i32.const 2))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (struct.new $js (any.convert_extern (local.get $a)))) + + (func (export "caml_list_of_js_array") + (param (ref eq)) (result (ref eq)) + (local $l (ref eq)) + (local $i i32) + (local $len i32) + (local $a (ref extern)) + (local.set $a + (ref.as_non_null (extern.convert_any (call $unwrap (local.get 0))))) + (local.set $len (call $array_length (local.get $a))) + (local.set $i (i32.const 0)) + (local.set $l (ref.i31 (i32.const 0))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $l + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (call $wrap + (call $array_get (local.get $a) (local.get $i))) + (local.get $l))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $l)) + + (global $jsError (ref $string) + (array.new_fixed $string 7 ;; 'jsError' + (i32.const 106) (i32.const 115) (i32.const 69) (i32.const 114) + (i32.const 114) (i32.const 111) (i32.const 114))) + + (data $toString "toString") + + (func (export "caml_wrap_exception") (param externref) (result (ref eq)) + (local $exn anyref) + (local.set $exn (any.convert_extern (local.get 0))) + ;; ZZZ special case for stack overflows? + (block $undef + (return + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (br_on_null $undef + (call $caml_named_value (global.get $jsError))) + (call $wrap (local.get $exn))))) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (call $caml_failwith_tag) + (call $caml_string_of_jsstring + (call $wrap + (call $meth_call + (local.get $exn) + (call $unwrap + (call $caml_jsstring_of_string + (array.new_data $string $toString + (i32.const 0) (i32.const 8)))) + (any.convert_extern (call $new_array (i32.const 0)))))))) + + (func (export "caml_js_error_option_of_exception") + (param (ref eq)) (result (ref eq)) + (local $exn (ref $block)) + (local.set $exn (ref.cast (ref $block) (local.get 0))) + (if (ref.eq (array.get $block (local.get $exn) (i32.const 0)) + (ref.i31 (i32.const 0))) + (then + (if (ref.eq (array.get $block (local.get $exn) (i32.const 1)) + (call $caml_named_value (global.get $jsError))) + (then + (return + (array.new_fixed $block 2 (ref.i31 (i32.const 0)) + (array.get $block (local.get $exn) (i32.const 2)))))))) + (ref.i31 (i32.const 0))) + + (func (export "caml_js_error_of_exception") + (param (ref eq)) (result (ref eq)) + (local $exn (ref $block)) + (local.set $exn (ref.cast (ref $block) (local.get 0))) + (if (ref.eq (array.get $block (local.get $exn) (i32.const 0)) + (ref.i31 (i32.const 0))) + (then + (if (ref.eq (array.get $block (local.get $exn) (i32.const 1)) + (call $caml_named_value (global.get $jsError))) + (then + (return + (array.get $block (local.get $exn) (i32.const 2))))))) + (call $wrap (ref.null any))) + + (func (export "log_str") (param $s (ref $string)) + (call $log_js + (call $unwrap (call $caml_jsstring_of_string (local.get $s))))) +) diff --git a/runtime/wasm/jslib_js_of_ocaml.wat b/runtime/wasm/jslib_js_of_ocaml.wat new file mode 100644 index 0000000000..7c3b161c77 --- /dev/null +++ b/runtime/wasm/jslib_js_of_ocaml.wat @@ -0,0 +1,64 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "jslib" "caml_js_global" + (func $caml_js_global (param (ref eq)) (result (ref eq)))) + (import "jslib" "caml_js_get" + (func $caml_js_get (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "jslib" "caml_js_new" + (func $caml_js_new (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "jslib" "caml_js_from_array" + (func $caml_js_from_array (param (ref eq)) (result (ref eq)))) + (import "js" "caml_js_on_ie" (func $caml_js_on_ie (result i32))) + (import "js" "caml_js_html_escape" + (func $caml_js_html_escape (param anyref) (result anyref))) + (import "js" "caml_js_html_entities" + (func $caml_js_html_entities (param anyref) (result anyref))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + + (func (export "caml_js_on_ie") (param (ref eq)) (result (ref eq)) + (ref.i31 (call $caml_js_on_ie))) + + (func (export "caml_js_html_escape") (param (ref eq)) (result (ref eq)) + (return_call $wrap + (call $caml_js_html_escape (call $unwrap (local.get 0))))) + + (func (export "caml_js_html_entities") (param (ref eq)) (result (ref eq)) + (return_call $wrap + (call $caml_js_html_entities (call $unwrap (local.get 0))))) + + (data $console "console") + + (func (export "caml_js_get_console") (param (ref eq)) (result (ref eq)) + (return_call $caml_js_get (call $caml_js_global (ref.i31 (i32.const 0))) + (array.new_data $string $console (i32.const 0) (i32.const 7)))) + + (data $XMLHttpRequest "XMLHttpRequest") + + (func (export "caml_xmlhttprequest_create") (param (ref eq)) (result (ref eq)) + (return_call $caml_js_new + (call $caml_js_get + (call $caml_js_global (ref.i31 (i32.const 0))) + (array.new_data $string $XMLHttpRequest + (i32.const 0) (i32.const 14))) + (array.new_fixed $block 1 (ref.i31 (i32.const 0))))) +) diff --git a/runtime/wasm/jsstring.wat b/runtime/wasm/jsstring.wat new file mode 100644 index 0000000000..93956d3282 --- /dev/null +++ b/runtime/wasm/jsstring.wat @@ -0,0 +1,260 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "wasm:js-string" "compare" + (func $compare_strings (param externref externref) (result i32))) + (import "wasm:js-string" "test" + (func $is_string (param externref) (result i32))) + (import "wasm:js-string" "hash" + (func $hash_string (param i32) (param anyref) (result i32))) + (import "wasm:js-string" "fromCharCodeArray" + (func $fromCharCodeArray + (param (ref null $wstring)) (param i32) (param i32) + (result (ref extern)))) + + (import "wasm:text-decoder" "decodeStringFromUTF8Array" + (func $decodeStringFromUTF8Array + (param (ref null $string)) (param i32) (param i32) + (result (ref extern)))) + (import "wasm:text-encoder" "encodeStringToUTF8Array" + (func $encodeStringToUTF8Array + (param externref) (result (ref $string)))) + + (import "bindings" "read_string" + (func $read_string (param i32) (result anyref))) + (import "bindings" "read_string_stream" + (func $read_string_stream (param i32) (param i32) (result anyref))) + (import "bindings" "write_string" + (func $write_string (param anyref) (result i32))) + (import "bindings" "append_string" + (func $append_string (param anyref) (param anyref) (result anyref))) + + (type $string (array (mut i8))) + (type $wstring (array (mut i16))) + + (global $text_converters_available (mut i32) (i32.const 0)) + (global $string_builtins_available (mut i32) (i32.const 0)) + + (global $utf16_buffer_size i32 (i32.const 32768)) + (global $buffer (mut (ref $wstring)) + (array.new $wstring (i32.const 0) (i32.const 0))) + + (start $init) + + (func $init + ;; Our dummy implementation of string conversion always returns + ;; the empty string. + (global.set $text_converters_available + (i32.ne + (i32.const 0) + (call $compare_strings + (call $decodeStringFromUTF8Array + (array.new_fixed $string 1 (i32.const 0)) + (i32.const 0) (i32.const 1)) + (call $decodeStringFromUTF8Array + (array.new_fixed $string 1 (i32.const 1)) + (i32.const 0) (i32.const 1))))) + (global.set $string_builtins_available + (i32.ne + (i32.const 0) + (call $compare_strings + (call $fromCharCodeArray + (array.new_fixed $wstring 1 (i32.const 0)) + (i32.const 0) (i32.const 1)) + (call $fromCharCodeArray + (array.new_fixed $wstring 1 (i32.const 1)) + (i32.const 0) (i32.const 1))))) + (if (i32.eqz (global.get $text_converters_available)) + (then + (if (global.get $string_builtins_available) + (then + (global.set $buffer + (array.new $wstring (i32.const 0) + (global.get $utf16_buffer_size)))))))) + + (func (export "jsstring_compare") + (param $s anyref) (param $s' anyref) (result i32) + (return_call $compare_strings + (extern.convert_any (local.get $s)) + (extern.convert_any (local.get $s')))) + + (func (export "jsstring_test") (param $s anyref) (result i32) + (return_call $is_string (extern.convert_any (local.get $s)))) + + (export "jsstring_hash" (func $hash_string)) + + ;; Used by package zarith_stubs_js + (func $jsstring_of_substring (export "jsstring_of_substring") + (param $s (ref $string)) (param $pos i32) (param $len i32) + (result anyref) + (local $i i32) (local $c i32) + (if (global.get $text_converters_available) + (then + (return + (any.convert_extern + (call $decodeStringFromUTF8Array (local.get $s) + (local.get $pos) + (i32.add (local.get $pos) (local.get $len))))))) + (if $continue + (i32.and (global.get $string_builtins_available) + (i32.le_u (local.get $len) (global.get $utf16_buffer_size))) + (then + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $c + (array.get $string (local.get $s) + (i32.add (local.get $pos) (local.get $i)))) + (br_if $continue + (i32.ge_u (local.get $c) (i32.const 128))) + (array.set $wstring (global.get $buffer) (local.get $i) + (local.get $c)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return + (any.convert_extern + (call $fromCharCodeArray (global.get $buffer) + (i32.const 0) (local.get $len)))))) + (return_call $jsstring_of_substring_fallback + (local.get $s) (local.get $pos) (local.get $len))) + + (func (export "jsstring_of_string") (param $s (ref $string)) (result anyref) + (return_call $jsstring_of_substring + (local.get $s) (i32.const 0) (array.len (local.get $s)))) + + (func (export "string_of_jsstring") (param $s anyref) (result (ref $string)) + (if (global.get $text_converters_available) + (then + (return_call $encodeStringToUTF8Array + (extern.convert_any (local.get $s))))) + (return_call $string_of_jsstring_fallback (local.get $s))) + + ;; Fallback implementation of string conversion functions + + (memory (export "caml_buffer") 1) + + (global $buffer_size i32 (i32.const 65536)) + + (func $write_to_buffer + (param $s (ref $string)) (param $pos i32) (param $len i32) + (local $i i32) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (i32.store8 (local.get $i) + (array.get_u $string (local.get $s) + (i32.add (local.get $pos) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func $jsstring_of_substring_fallback + (param $s (ref $string)) (param $pos i32) (param $len i32) + (result anyref) + (local $s' anyref) + (local $continued i32) + (if (i32.le_u (local.get $len) (global.get $buffer_size)) + (then + (call $write_to_buffer + (local.get $s) (local.get $pos) (local.get $len)) + (return_call $read_string (local.get $len)))) + (call $write_to_buffer + (local.get $s) (local.get $pos) (global.get $buffer_size)) + (local.set $s' + (call $read_string_stream (global.get $buffer_size) (i32.const 1))) + (loop $loop + (local.set $len (i32.sub (local.get $len) (global.get $buffer_size))) + (local.set $pos (i32.add (local.get $pos) (global.get $buffer_size))) + (local.set $continued + (i32.gt_u (local.get $len) (global.get $buffer_size))) + (call $write_to_buffer + (local.get $s) (local.get $pos) + (select (global.get $buffer_size) (local.get $len) + (local.get $continued))) + (local.set $s' + (call $append_string (local.get $s') + (call $read_string_stream + (select (global.get $buffer_size) (local.get $len) + (local.get $continued)) + (local.get $continued)))) + (br_if $loop (local.get $continued))) + (local.get $s')) + + (func $read_from_buffer + (param $s (ref $string)) (param $pos i32) (param $len i32) + (local $i i32) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $string (local.get $s) + (i32.add (local.get $pos) (local.get $i)) + (i32.load8_u (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (type $stack + (struct (field $s (ref $string)) (field $next (ref null $stack)))) + (global $stack (mut (ref null $stack)) (ref.null $stack)) + + (func $string_of_jsstring_fallback (param $s anyref) (result (ref $string)) + (local $ofs i32) (local $len i32) + (local $s' (ref $string)) (local $s'' (ref $string)) + (local $item (ref $stack)) + (local.set $len (call $write_string (local.get $s))) + (if (ref.is_null (global.get $stack)) + (then + (local.set $s' + (array.new $string (i32.const 0) (local.get $len))) + (call $read_from_buffer + (local.get $s') (i32.const 0) (local.get $len)) + (return (local.get $s')))) + (block $done + (local.set $item (br_on_null $done (global.get $stack))) + (loop $loop + (local.set $ofs + (i32.add (local.get $ofs) + (array.len (struct.get $stack $s (local.get $item))))) + (local.set $item + (br_on_null $done (struct.get $stack $next (local.get $item)))) + (br $loop))) + (local.set $s' + (array.new $string (i32.const 0) + (i32.add (local.get $len) (local.get $ofs)))) + (call $read_from_buffer + (local.get $s') (local.get $ofs) (local.get $len)) + (block $done + (local.set $item (br_on_null $done (global.get $stack))) + (global.set $stack (ref.null $stack)) + (loop $loop + (local.set $s'' (struct.get $stack $s (local.get $item))) + (local.set $len (array.len (local.get $s''))) + (local.set $ofs (i32.sub (local.get $ofs) (local.get $len))) + (array.copy $string $string + (local.get $s') (local.get $ofs) + (local.get $s'') (i32.const 0) + (local.get $len)) + (local.set $item + (br_on_null $done (struct.get $stack $next (local.get $item)))) + (br $loop))) + (local.get $s')) + + (func (export "caml_extract_string") (param $len i32) + (local $s (ref $string)) + (local.set $s (array.new $string (i32.const 0) (local.get $len))) + (call $read_from_buffer (local.get $s) (i32.const 0) (local.get $len)) + (global.set $stack (struct.new $stack (local.get $s) (global.get $stack)))) +) diff --git a/runtime/wasm/lexing.wat b/runtime/wasm/lexing.wat new file mode 100644 index 0000000000..eb9b94b1ad --- /dev/null +++ b/runtime/wasm/lexing.wat @@ -0,0 +1,394 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + + (func $get (param $a (ref eq)) (param $i i32) (result i32) + (local $s (ref $string)) + (local.set $s (ref.cast (ref $string) (local.get $a))) + (local.set $i (i32.add (local.get $i) (local.get $i))) + (i32.extend16_s + (i32.or (array.get_u $string (local.get $s) (local.get $i)) + (i32.shl + (array.get_u $string (local.get $s) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8))))) + + (global $lex_buffer i32 (i32.const 2)) + (global $lex_buffer_len i32 (i32.const 3)) + (global $lex_start_pos i32 (i32.const 5)) + (global $lex_curr_pos i32 (i32.const 6)) + (global $lex_last_pos i32 (i32.const 7)) + (global $lex_last_action i32 (i32.const 8)) + (global $lex_eof_reached i32 (i32.const 9)) + (global $lex_mem i32 (i32.const 10)) + (global $lex_base i32 (i32.const 1)) + (global $lex_backtrk i32 (i32.const 2)) + (global $lex_default i32 (i32.const 3)) + (global $lex_trans i32 (i32.const 4)) + (global $lex_check i32 (i32.const 5)) + (global $lex_base_code i32 (i32.const 6)) + (global $lex_backtrk_code i32 (i32.const 7)) + (global $lex_default_code i32 (i32.const 8)) + (global $lex_trans_code i32 (i32.const 9)) + (global $lex_check_code i32 (i32.const 10)) + (global $lex_code i32 (i32.const 11)) + + (data $lexing_empty_token "lexing: empty token") + + (func (export "caml_lex_engine") + (param $vtbl (ref eq)) (param $start_state (ref eq)) + (param $vlexbuf (ref eq)) + (result (ref eq)) + (local $tbl (ref $block)) + (local $lexbuf (ref $block)) + (local $c i32) + (local $state i32) + (local $buffer (ref $string)) + (local $vpos (ref eq)) (local $action (ref eq)) + (local $pos i32) (local $base i32) (local $backtrk i32) + (local $lex_base (ref $string)) + (local $lex_backtrk (ref $string)) + (local $lex_check (ref $string)) + (local $lex_check_code (ref $string)) + (local $lex_trans (ref $string)) + (local $lex_default (ref $string)) + (local.set $tbl (ref.cast (ref $block) (local.get $vtbl))) + (local.set $lexbuf (ref.cast (ref $block) (local.get $vlexbuf))) + (local.set $state + (i31.get_s (ref.cast (ref i31) (local.get $start_state)))) + (local.set $buffer + (ref.cast (ref $string) + (array.get $block (local.get $lexbuf) (global.get $lex_buffer)))) + (if (i32.ge_s (local.get $state) (i32.const 0)) + (then + (local.set $vpos + (array.get $block (local.get $lexbuf) (global.get $lex_curr_pos))) + (array.set $block (local.get $lexbuf) (global.get $lex_last_pos) + (local.get $vpos)) + (array.set $block (local.get $lexbuf) (global.get $lex_start_pos) + (local.get $vpos)) + (array.set $block (local.get $lexbuf) (global.get $lex_last_action) + (ref.i31 (i32.const -1)))) + (else + (local.set $state (i32.sub (i32.const -1) (local.get $state))))) + (local.set $lex_base + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_base)))) + (local.set $lex_backtrk + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_backtrk)))) + (local.set $lex_check + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_check)))) + (local.set $lex_check_code + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_check_code)))) + (local.set $lex_trans + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_trans)))) + (local.set $lex_default + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_default)))) + (loop $loop + (local.set $base (call $get (local.get $lex_base) (local.get $state))) + (if (i32.lt_s (local.get $base) (i32.const 0)) + (then + (return (ref.i31 (i32.sub (i32.const -1) (local.get $base)))))) + (local.set $backtrk + (call $get (local.get $lex_backtrk) (local.get $state))) + (if (i32.ge_s (local.get $backtrk) (i32.const 0)) + (then + (array.set $block (local.get $lexbuf) (global.get $lex_last_pos) + (array.get $block (local.get $lexbuf) + (global.get $lex_curr_pos))) + (array.set $block (local.get $lexbuf) + (global.get $lex_last_action) + (ref.i31 (local.get $backtrk))))) + (if (i32.ge_s + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $lexbuf) + (global.get $lex_curr_pos)))) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $lexbuf) + (global.get $lex_buffer_len))))) + (then + (if (ref.eq + (array.get $block (local.get $lexbuf) + (global.get $lex_eof_reached)) + (ref.i31 (i32.const 0))) + (then + (return + (ref.i31 (i32.sub (i32.const -1) (local.get $state))))) + (else + (local.set $c (i32.const 256))))) + (else + (local.set $pos + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $lexbuf) + (global.get $lex_curr_pos))))) + (local.set $c + (array.get_u $string (local.get $buffer) (local.get $pos))) + (array.set $block (local.get $lexbuf) (global.get $lex_curr_pos) + (ref.i31 (i32.add (local.get $pos) (i32.const 1)))))) + (if (i32.eq + (call $get (local.get $lex_check) + (i32.add (local.get $base) (local.get $c))) + (local.get $state)) + (then + (local.set $state + (call $get (local.get $lex_trans) + (i32.add (local.get $base) (local.get $c))))) + (else + (local.set $state + (call $get (local.get $lex_default) (local.get $state))))) + (if (i32.lt_s (local.get $state) (i32.const 0)) + (then + (array.set $block (local.get $lexbuf) (global.get $lex_curr_pos) + (array.get $block (local.get $lexbuf) + (global.get $lex_last_pos))) + (local.set $action + (array.get $block (local.get $lexbuf) + (global.get $lex_last_action))) + (if (ref.eq (local.get $action) (ref.i31 (i32.const -1))) + (then + (call $caml_failwith + (array.new_data $string $lexing_empty_token + (i32.const 0) (i32.const 19))))) + (return (local.get $action)))) + (if (i32.eq (local.get $c) (i32.const 256)) + (then + (array.set $block (local.get $lexbuf) + (global.get $lex_eof_reached) + (ref.i31 (i32.const 0))))) + (br $loop))) + + (func $run_mem + (param $s (ref $string)) (param $i i32) (param $lexbuf (ref $block)) + (param $curr_pos (ref eq)) + (local $dst i32) (local $src i32) + (local $mem (ref $block)) + (local.set $mem + (ref.cast (ref $block) + (array.get $block (local.get $lexbuf) (global.get $lex_mem)))) + (loop $loop + (local.set $dst (array.get_u $string (local.get $s) (local.get $i))) + (if (i32.eq (local.get $dst) (i32.const 0xff)) + (then (return))) + (local.set $src + (array.get_u $string (local.get $s) + (i32.add (local.get $i) (i32.const 1)))) + (local.set $i (i32.add (local.get $i) (i32.const 2))) + (array.set $block (local.get $mem) + (i32.add (local.get $dst) (i32.const 1)) + (if (result (ref eq)) (i32.eq (local.get $src) (i32.const 0xff)) + (then + (local.get $curr_pos)) + (else + (array.get $block (local.get $mem) + (i32.add (local.get $src) (i32.const 1)))))) + (br $loop))) + + (func $run_tag + (param $s (ref $string)) (param $i i32) (param $lexbuf (ref $block)) + (return_call $run_mem (local.get $s) (local.get $i) (local.get $lexbuf) + (ref.i31 (i32.const -1)))) + + (func (export "caml_new_lex_engine") + (param $vtbl (ref eq)) (param $start_state (ref eq)) + (param $vlexbuf (ref eq)) + (result (ref eq)) + (local $tbl (ref $block)) + (local $lexbuf (ref $block)) + (local $c i32) + (local $state i32) (local $pstate i32) + (local $buffer (ref $string)) + (local $vpos (ref eq)) (local $action (ref eq)) + (local $pos i32) (local $base i32) (local $backtrk i32) + (local $pc_off i32) (local $base_code i32) + (local $lex_code (ref $string)) + (local $lex_base (ref $string)) + (local $lex_base_code (ref $string)) + (local $lex_backtrk (ref $string)) + (local $lex_backtrk_code (ref $string)) + (local $lex_check (ref $string)) + (local $lex_check_code (ref $string)) + (local $lex_trans (ref $string)) + (local $lex_trans_code (ref $string)) + (local $lex_default (ref $string)) + (local $lex_default_code (ref $string)) + (local.set $tbl (ref.cast (ref $block) (local.get $vtbl))) + (local.set $lexbuf (ref.cast (ref $block) (local.get $vlexbuf))) + (local.set $state + (i31.get_s (ref.cast (ref i31) (local.get $start_state)))) + (local.set $buffer + (ref.cast (ref $string) + (array.get $block (local.get $lexbuf) (global.get $lex_buffer)))) + (if (i32.ge_s (local.get $state) (i32.const 0)) + (then + (local.set $vpos + (array.get $block (local.get $lexbuf) (global.get $lex_curr_pos))) + (array.set $block (local.get $lexbuf) (global.get $lex_last_pos) + (local.get $vpos)) + (array.set $block (local.get $lexbuf) (global.get $lex_start_pos) + (local.get $vpos)) + (array.set $block (local.get $lexbuf) (global.get $lex_last_action) + (ref.i31 (i32.const -1)))) + (else + (local.set $state (i32.sub (i32.const -1) (local.get $state))))) + (local.set $lex_code + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_code)))) + (local.set $lex_base + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_base)))) + (local.set $lex_base_code + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_base_code)))) + (local.set $lex_backtrk + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_backtrk)))) + (local.set $lex_backtrk_code + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_backtrk_code)))) + (local.set $lex_check + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_check)))) + (local.set $lex_check_code + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_check_code)))) + (local.set $lex_trans + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_trans)))) + (local.set $lex_trans_code + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_trans_code)))) + (local.set $lex_default + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_default)))) + (local.set $lex_default_code + (ref.cast (ref $string) + (array.get $block (local.get $tbl) (global.get $lex_default_code)))) + (loop $loop + (local.set $base (call $get (local.get $lex_base) (local.get $state))) + (if (i32.lt_s (local.get $base) (i32.const 0)) + (then + (local.set $pc_off + (call $get (local.get $lex_base_code) (local.get $state))) + (call $run_tag (local.get $lex_code) (local.get $pc_off) + (local.get $lexbuf)) + (return (ref.i31 (i32.sub (i32.const -1) (local.get $base)))))) + (local.set $backtrk + (call $get (local.get $lex_backtrk) (local.get $state))) + (if (i32.ge_s (local.get $backtrk) (i32.const 0)) + (then + (local.set $pc_off + (call $get (local.get $lex_backtrk_code) (local.get $state))) + (call $run_tag (local.get $lex_code) (local.get $pc_off) + (local.get $lexbuf)) + (array.set $block (local.get $lexbuf) (global.get $lex_last_pos) + (array.get $block (local.get $lexbuf) + (global.get $lex_curr_pos))) + (array.set $block (local.get $lexbuf) + (global.get $lex_last_action) + (ref.i31 (local.get $backtrk))))) + (if (i32.ge_s + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $lexbuf) + (global.get $lex_curr_pos)))) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $lexbuf) + (global.get $lex_buffer_len))))) + (then + (if (ref.eq + (array.get $block (local.get $lexbuf) + (global.get $lex_eof_reached)) + (ref.i31 (i32.const 0))) + (then + (return + (ref.i31 (i32.sub (i32.const -1) (local.get $state))))) + (else + (local.set $c (i32.const 256))))) + (else + (local.set $pos + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $lexbuf) + (global.get $lex_curr_pos))))) + (local.set $c + (array.get_u $string (local.get $buffer) (local.get $pos))) + (array.set $block (local.get $lexbuf) (global.get $lex_curr_pos) + (ref.i31 (i32.add (local.get $pos) (i32.const 1)))))) + (local.set $pstate (local.get $state)) + (if (i32.eq + (call $get (local.get $lex_check) + (i32.add (local.get $base) (local.get $c))) + (local.get $state)) + (then + (local.set $state + (call $get (local.get $lex_trans) + (i32.add (local.get $base) (local.get $c))))) + (else + (local.set $state + (call $get (local.get $lex_default) (local.get $state))))) + (if (i32.lt_s (local.get $state) (i32.const 0)) + (then + (array.set $block (local.get $lexbuf) (global.get $lex_curr_pos) + (array.get $block (local.get $lexbuf) + (global.get $lex_last_pos))) + (local.set $action + (array.get $block (local.get $lexbuf) + (global.get $lex_last_action))) + (if (ref.eq (local.get $action) (ref.i31 (i32.const -1))) + (then + (call $caml_failwith + (array.new_data $string $lexing_empty_token + (i32.const 0) (i32.const 19))))) + (return (local.get $action)))) + (local.set $base_code + (call $get (local.get $lex_base_code) (local.get $pstate))) + (local.set $pc_off + (if (result i32) + (i32.eq + (call $get (local.get $lex_check_code) + (i32.add (local.get $base_code) (local.get $c))) + (local.get $pstate)) + (then + (call $get (local.get $lex_trans_code) + (i32.add (local.get $base_code) (local.get $c)))) + (else + (call $get (local.get $lex_default_code) + (local.get $pstate))))) + (call $run_mem (local.get $lex_code) (local.get $pc_off) + (local.get $lexbuf) + (array.get $block (local.get $lexbuf) (global.get $lex_curr_pos))) + (if (i32.eq (local.get $c) (i32.const 256)) + (then + (array.set $block (local.get $lexbuf) + (global.get $lex_eof_reached) + (ref.i31 (i32.const 0))))) + (br $loop))) +) diff --git a/runtime/wasm/marshal.wat b/runtime/wasm/marshal.wat new file mode 100644 index 0000000000..46373b2bf7 --- /dev/null +++ b/runtime/wasm/marshal.wat @@ -0,0 +1,1446 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + (import "fail" "caml_raise_end_of_file" (func $caml_raise_end_of_file)) + (import "obj" "double_array_tag" (global $double_array_tag i32)) + (import "string" "caml_string_concat" + (func $caml_string_concat + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "obj" "caml_is_closure" + (func $caml_is_closure (param (ref eq)) (result i32))) + (import "effect" "caml_is_continuation" + (func $caml_is_continuation (param (ref eq)) (result i32))) + (import "bindings" "map_new" (func $map_new (result (ref any)))) + (import "bindings" "map_get" + (func $map_get (param (ref any)) (param (ref eq)) (result i31ref))) + (import "bindings" "map_set" + (func $map_set (param (ref any)) (param (ref eq)) (param (ref i31)))) + (import "io" "caml_really_putblock" + (func $caml_really_putblock + (param (ref eq)) (param (ref $string)) (param i32) (param i32))) + (import "io" "caml_really_getblock" + (func $caml_really_getblock + (param (ref eq)) (param (ref $string)) (param i32) (param i32) + (result i32))) + (import "io" "caml_flush_if_unbuffered" + (func $caml_flush_if_unbuffered (param (ref eq)))) + (import "custom" "caml_init_custom_operations" + (func $caml_init_custom_operations)) + (import "custom" "caml_find_custom_operations" + (func $caml_find_custom_operations + (param (ref $string)) (result (ref null $custom_operations)))) + + (import "version-dependent" "caml_marshal_header_size" + (global $caml_marshal_header_size i32)) + + (global $input_val_from_string (ref $string) + (array.new_fixed $string 21 + (i32.const 105) (i32.const 110) (i32.const 112) (i32.const 117) + (i32.const 116) (i32.const 95) (i32.const 118) (i32.const 97) + (i32.const 108) (i32.const 95) (i32.const 102) (i32.const 114) + (i32.const 111) (i32.const 109) (i32.const 95) (i32.const 115) + (i32.const 116) (i32.const 114) (i32.const 105) (i32.const 110) + (i32.const 103))) + + (export "caml_input_value_from_string" (func $caml_input_value_from_bytes)) + (func $caml_input_value_from_bytes (export "caml_input_value_from_bytes") + (param $vstr (ref eq)) (param $vofs (ref eq)) (result (ref eq)) + (local $str (ref $string)) + (local $ofs i32) + (local $s (ref $intern_state)) + (local $h (ref $marshal_header)) + (local.set $str (ref.cast (ref $string) (local.get $vstr))) + (local.set $ofs (i31.get_u (ref.cast (ref i31) (local.get $vofs)))) + (local.set $s + (call $get_intern_state (local.get $str) (local.get $ofs))) + (local.set $h + (call $parse_header (local.get $s) (global.get $input_val_from_string))) + (if (i32.gt_s + (i32.add (local.get $ofs) + (i32.add (struct.get $marshal_header $data_len (local.get $h)) + (i32.const 20))) + (array.len (local.get $str))) + (then + (call $bad_length (global.get $input_val_from_string)))) + (return_call $intern_rec (local.get $s) (local.get $h))) + + (data $truncated_obj "input_value: truncated object") + + (global $input_value (ref $string) + (array.new_fixed $string 11 + (i32.const 105) (i32.const 110) (i32.const 112) (i32.const 117) + (i32.const 116) (i32.const 95) (i32.const 118) (i32.const 97) + (i32.const 108) (i32.const 117) (i32.const 101))) + + (func (export "caml_input_value") (param $ch (ref eq)) (result (ref eq)) + ;; ZZZ check binary channel? + (local $r i32) (local $len i32) + (local $header (ref $string)) (local $buf (ref $string)) + (local $s (ref $intern_state)) (local $h (ref $marshal_header)) + (local.set $header (array.new $string (i32.const 0) (i32.const 20))) + (local.set $r + (call $caml_really_getblock + (local.get $ch) (local.get $header) (i32.const 0) (i32.const 20))) + (if (i32.eqz (local.get $r)) + (then (call $caml_raise_end_of_file))) + (if (i32.lt_u (local.get $r) (i32.const 20)) + (then + (call $caml_failwith + (array.new_data $string $truncated_obj + (i32.const 0) (i32.const 29))))) + (local.set $s + (call $get_intern_state (local.get $header) (i32.const 0))) + (local.set $h + (call $parse_header (local.get $s) (global.get $input_value))) + (local.set $len (struct.get $marshal_header $data_len (local.get $h))) + (local.set $buf (array.new $string (i32.const 0) (local.get $len))) + (if (i32.lt_u + (call $caml_really_getblock (local.get $ch) + (local.get $buf) (i32.const 0) (local.get $len)) + (local.get $len)) + (then + (call $caml_failwith + (array.new_data $string $truncated_obj + (i32.const 0) (i32.const 29))))) + (local.set $s (call $get_intern_state (local.get $buf) (i32.const 0))) + (return_call $intern_rec (local.get $s) (local.get $h))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $float (struct (field f64))) + (type $float_array (array (mut f64))) + (type $js (struct (field anyref))) + + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $dup (func (param (ref eq)) (result (ref eq)))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)) + (field $dup (ref null $dup)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + + (global $Intext_magic_number_small i32 (i32.const 0x8495A6BE)) + (global $Intext_magic_number_big i32 (i32.const 0x8495A6BF)) + + (global $PREFIX_SMALL_BLOCK i32 (i32.const 0x80)) + (global $PREFIX_SMALL_INT i32 (i32.const 0x40)) + (global $PREFIX_SMALL_STRING i32 (i32.const 0x20)) + (global $CODE_INT8 i32 (i32.const 0x00)) + (global $CODE_INT16 i32 (i32.const 0x01)) + (global $CODE_INT32 i32 (i32.const 0x02)) + (global $CODE_INT64 i32 (i32.const 0x03)) + (global $CODE_SHARED8 i32 (i32.const 0x04)) + (global $CODE_SHARED16 i32 (i32.const 0x05)) + (global $CODE_SHARED32 i32 (i32.const 0x06)) + (global $CODE_BLOCK32 i32 (i32.const 0x08)) + (global $CODE_BLOCK64 i32 (i32.const 0x13)) + (global $CODE_STRING8 i32 (i32.const 0x09)) + (global $CODE_STRING32 i32 (i32.const 0x0A)) + (global $CODE_DOUBLE_BIG i32 (i32.const 0x0B)) + (global $CODE_DOUBLE_LITTLE i32 (i32.const 0x0C)) + (global $CODE_DOUBLE_ARRAY8_BIG i32 (i32.const 0x0D)) + (global $CODE_DOUBLE_ARRAY8_LITTLE i32 (i32.const 0x0E)) + (global $CODE_DOUBLE_ARRAY32_BIG i32 (i32.const 0x0F)) + (global $CODE_DOUBLE_ARRAY32_LITTLE i32 (i32.const 0x07)) + (global $CODE_CODEPOINTER i32 (i32.const 0x10)) + (global $CODE_INFIXPOINTER i32 (i32.const 0x11)) + (global $CODE_CUSTOM i32 (i32.const 0x12)) + (global $CODE_CUSTOM_LEN i32 (i32.const 0x18)) + (global $CODE_CUSTOM_FIXED i32 (i32.const 0x19)) + + (type $intern_state + (struct + (field $src (ref $string)) + (field $pos (mut i32)) + (field $obj_table (mut (ref null $block))) + (field $obj_counter (mut i32)))) + + (func $get_intern_state + (param $src (ref $string)) (param $pos i32) (result (ref $intern_state)) + (struct.new $intern_state + (local.get $src) (local.get $pos) (ref.null $block) (i32.const 0))) + + (func $read8u (param $s (ref $intern_state)) (result i32) + (local $pos i32) (local $res i32) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (array.get_u $string + (struct.get $intern_state $src (local.get $s)) + (local.get $pos))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 1))) + (local.get $res)) + + (func $read8s (param $s (ref $intern_state)) (result i32) + (local $pos i32) (local $res i32) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (array.get_s $string + (struct.get $intern_state $src (local.get $s)) + (local.get $pos))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 1))) + (local.get $res)) + + (func $read16u (param $s (ref $intern_state)) (result i32) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (i32.or + (i32.shl + (array.get_u $string (local.get $src) (local.get $pos)) + (i32.const 8)) + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 1))))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 2))) + (local.get $res)) + + (func $read16s (param $s (ref $intern_state)) (result i32) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (i32.or + (i32.shl + (array.get_s $string (local.get $src) (local.get $pos)) + (i32.const 8)) + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 1))))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 2))) + (local.get $res)) + + (func $read32 (param $s (ref $intern_state)) (result i32) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (local.set $res + (i32.or + (i32.or + (i32.shl + (array.get_u $string (local.get $src) (local.get $pos)) + (i32.const 24)) + (i32.shl + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 1))) + (i32.const 16))) + (i32.or + (i32.shl + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 2))) + (i32.const 8)) + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (i32.const 3)))))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 4))) + (local.get $res)) + + (func $readblock (param $s (ref $intern_state)) (param $str (ref $string)) + (local $len i32) (local $pos i32) + (local.set $len (array.len (local.get $str))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (array.copy $string $string + (local.get $str) (i32.const 0) + (struct.get $intern_state $src (local.get $s)) (local.get $pos) + (local.get $len)) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (local.get $len)))) + + (func $readstr (param $s (ref $intern_state)) (result (ref $string)) + (local $len i32) (local $pos i32) (local $res (ref $string)) + (local $src (ref $string)) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (loop $loop + (if (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (local.get $len))) + (then + (local.set $len (i32.add (local.get $len) (i32.const 1))) + (br $loop)))) + (local.set $res (array.new $string (i32.const 0) (local.get $len))) + (array.copy $string $string + (local.get $res) (i32.const 0) + (local.get $src) (local.get $pos) + (local.get $len)) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.add (local.get $len) (i32.const 1)))) + (local.get $res)) + + (func $readfloat + (param $s (ref $intern_state)) (param $code i32) (result f64) + (local $src (ref $string)) (local $pos i32) (local $res i32) + (local $d i64) + (local $i i32) + (local $v (ref eq)) + (local.set $src (struct.get $intern_state $src (local.get $s))) + (local.set $pos (struct.get $intern_state $pos (local.get $s))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (local.get $pos) (i32.const 8))) + (if (i32.eq (local.get $code) (global.get $CODE_DOUBLE_BIG)) + (then + (loop $loop + (local.set $d + (i64.or + (i64.shl (local.get $d) (i64.const 8)) + (i64.extend_i32_u + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (local.get $i)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 8))))) + (else + (loop $loop + (local.set $d + (i64.rotr + (i64.or (local.get $d) + (i64.extend_i32_u + (array.get_u $string (local.get $src) + (i32.add (local.get $pos) (local.get $i))))) + (i64.const 8))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 8)))))) + (f64.reinterpret_i64 (local.get $d))) + + (func $readfloats + (param $s (ref $intern_state)) (param $code i32) (param $len i32) + (result (ref eq)) + (local $dest (ref $float_array)) + (local $i i32) + (local.set $code + (select (global.get $CODE_DOUBLE_BIG) (global.get $CODE_DOUBLE_LITTLE) + (i32.or + (i32.eq (local.get $code) (global.get $CODE_DOUBLE_ARRAY8_BIG)) + (i32.eq (local.get $code) + (global.get $CODE_DOUBLE_ARRAY32_BIG))))) + (local.set $dest (array.new $float_array (f64.const 0) (local.get $len))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $float_array (local.get $dest) (local.get $i) + (call $readfloat (local.get $s) (local.get $code))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $dest)) + + (func (export "caml_deserialize_uint_1") (param $s (ref eq)) (result i32) + (return_call $read8u (ref.cast (ref $intern_state) (local.get $s)))) + + (func (export "caml_deserialize_sint_1") (param $s (ref eq)) (result i32) + (return_call $read8s (ref.cast (ref $intern_state) (local.get $s)))) + + (func (export "caml_deserialize_uint_2") (param $s (ref eq)) (result i32) + (return_call $read16u (ref.cast (ref $intern_state) (local.get $s)))) + + (func (export "caml_deserialize_sint_2") (param $s (ref eq)) (result i32) + (return_call $read16s (ref.cast (ref $intern_state) (local.get $s)))) + + (func (export "caml_deserialize_int_4") (param $s (ref eq)) (result i32) + (return_call $read32 (ref.cast (ref $intern_state) (local.get $s)))) + + (func (export "caml_deserialize_int_8") (param $vs (ref eq)) (result i64) + (local $s (ref $intern_state)) + (local.set $s (ref.cast (ref $intern_state) (local.get $vs))) + (i64.or (i64.shl (i64.extend_i32_u (call $read32 (local.get $s))) + (i64.const 32)) + (i64.extend_i32_u (call $read32 (local.get $s))))) + + (func $register_object (param $s (ref $intern_state)) (param $v (ref eq)) + (local $obj_table (ref $block)) + (local $p i32) + (block $exit + (local.set $obj_table + (br_on_null $exit + (struct.get $intern_state $obj_table (local.get $s)))) + (local.set $p (struct.get $intern_state $obj_counter (local.get $s))) + (array.set $block (local.get $obj_table) (local.get $p) (local.get $v)) + (struct.set $intern_state $obj_counter (local.get $s) + (i32.add (local.get $p) (i32.const 1))))) + + (type $stack_item + (struct + (field $blk (ref $block)) + (field $pos (mut i32)) + (field $next (ref null $stack_item)))) + + (data $integer_too_large "input_value: integer too large") + (data $code_pointer "input_value: code pointer") + (data $ill_formed "input_value: ill-formed message") + + (data $unknown_custom "input_value: unknown custom block identifier") + (data $expected_size "input_value: expected a fixed-size custom block") + (data $incorrect_size + "input_value: incorrect length of serialized custom block") + + (func $intern_custom + (param $s (ref $intern_state)) (param $code i32) (result (ref eq)) + (local $ops (ref $custom_operations)) + (local $expected_size i32) + (local $r (tuple (ref eq) i32)) + (block $unknown + (local.set $ops + (br_on_null $unknown + (call + $caml_find_custom_operations + (call $readstr + (local.get $s))))) + (block $no_length + (if (i32.eq (local.get $code) (global.get $CODE_CUSTOM_FIXED)) + (then + (local.set $expected_size + (struct.get $fixed_length $bsize_32 + (br_on_null $no_length + (struct.get $custom_operations $fixed_length + (local.get $ops)))))) + (else + (if (i32.eq (local.get $code) (global.get $CODE_CUSTOM_LEN)) + (then + (local.set $expected_size (call $read32 (local.get $s))) + (struct.set $intern_state $pos (local.get $s) + (i32.add (struct.get $intern_state $pos (local.get $s)) + (i32.const 8))))))) + (local.set $r + (call_ref $deserialize (local.get $s) + (struct.get $custom_operations $deserialize (local.get $ops)))) + (if (i32.and + (i32.ne (tuple.extract 2 1 (local.get $r)) + (local.get $expected_size)) + (i32.ne (local.get $code) (global.get $CODE_CUSTOM))) + (then + (call $caml_failwith + (array.new_data $string $incorrect_size + (i32.const 0) (i32.const 56))))) + (return (tuple.extract 2 0 (local.get $r)))) + (call $caml_failwith + (array.new_data $string $expected_size + (i32.const 0) (i32.const 47)))) + (call $caml_failwith + (array.new_data $string $unknown_custom + (i32.const 0) (i32.const 44))) + (ref.i31 (i32.const 0))) + + (func $intern_rec + (param $s (ref $intern_state)) (param $h (ref $marshal_header)) + (result (ref eq)) + (local $res (ref $block)) (local $dest (ref $block)) + (local $sp (ref null $stack_item)) + (local $item (ref $stack_item)) + (local $code i32) + (local $header i32) (local $tag i32) (local $size i32) + (local $len i32) (local $pos i32) (local $pos' i32) (local $ofs i32) + (local $b (ref $block)) + (local $str (ref $string)) + (local $v (ref eq)) + (call $caml_init_custom_operations) + (local.set $res (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + (local.set $sp + (struct.new $stack_item + (local.get $res) (i32.const 0) (ref.null $stack_item))) + (local.set $size (struct.get $marshal_header $num_objects (local.get $h))) + (if (local.get $size) + (then + (struct.set $intern_state $obj_table (local.get $s) + (array.new $block (ref.i31 (i32.const 0)) (local.get $size))))) + (local.set $v (ref.i31 (i32.const 0))) ;; keep validator happy + (block $exit + (loop $loop + (local.set $item (br_on_null $exit (local.get $sp))) + (local.set $dest (struct.get $stack_item $blk (local.get $item))) + (local.set $pos (struct.get $stack_item $pos (local.get $item))) + (local.set $pos' (i32.add (local.get $pos) (i32.const 1))) + (struct.set $stack_item $pos (local.get $item) (local.get $pos')) + (if (i32.eq (local.get $pos') (array.len (local.get $dest))) + (then + (local.set $sp + (struct.get $stack_item $next (local.get $item))))) + (block $done + (block $read_block + (block $read_string + (block $read_double_array + (block $read_shared + (local.set $code (call $read8u (local.get $s))) + (if (i32.ge_u (local.get $code) (global.get $PREFIX_SMALL_INT)) + (then + (if (i32.ge_u (local.get $code) (global.get $PREFIX_SMALL_BLOCK)) + (then + ;; Small block + (local.set $tag + (i32.and (local.get $code) (i32.const 0xF))) + (local.set $size + (i32.and (i32.shr_u (local.get $code) (i32.const 4)) + (i32.const 0x7))) + (br $read_block)) + (else + ;; Small int + (local.set $v + (ref.i31 + (i32.and (local.get $code) (i32.const 0x3F)))) + (br $done)))) + (else + (if (i32.ge_u (local.get $code) + (global.get $PREFIX_SMALL_STRING)) + (then + (local.set $len + (i32.and (local.get $code) (i32.const 0x1F))) + (br $read_string)) + (else + (block $INT8 + (block $INT16 + (block $INT32 + (block $INT64 + (block $SHARED8 + (block $SHARED16 + (block $SHARED32 + (block $BLOCK32 + (block $STRING8 + (block $STRING32 + (block $DOUBLE + (block $DOUBLE_ARRAY8 + (block $DOUBLE_ARRAY32 + (block $CODEPOINTER + (block $CUSTOM + (block $default + (br_table $INT8 $INT16 $INT32 $INT64 + $SHARED8 $SHARED16 $SHARED32 + $DOUBLE_ARRAY32 $BLOCK32 $STRING8 + $STRING32 $DOUBLE $DOUBLE + $DOUBLE_ARRAY8 $DOUBLE_ARRAY8 + $DOUBLE_ARRAY32 $CODEPOINTER + $CODEPOINTER $CUSTOM $default + $default $default $default $default + $CUSTOM $CUSTOM $default + (local.get $code))) + ;; default + (call $caml_failwith + (array.new_data $string $ill_formed + (i32.const 0) (i32.const 31))) + (br $done)) + ;; CUSTOM + (local.set $v + (call $intern_custom (local.get $s) + (local.get $code))) + (call $register_object (local.get $s) + (local.get $v)) + (br $done)) + ;; CODEPOINTER + (call $caml_failwith + (array.new_data $string $code_pointer + (i32.const 0) (i32.const 25))) + (br $done)) + ;; DOUBLE_ARRAY32 + (local.set $len + (call $read32 (local.get $s))) + (br $read_double_array)) + ;; DOUBLE_ARRAY8 + (local.set $len + (call $read8u (local.get $s))) + (br $read_double_array)) + ;; DOUBLE + (local.set $v + (struct.new $float + (call $readfloat + (local.get $s) (local.get $code)))) + (call $register_object + (local.get $s) (local.get $v)) + (br $done)) + ;; STRING32 + (local.set $len (call $read32 (local.get $s))) + (br $read_string)) + ;; STRING8 + (local.set $len (call $read8u (local.get $s))) + (br $read_string)) + ;; BLOCK32 + (local.set $header (call $read32 (local.get $s))) + (local.set $tag + (i32.and (local.get $header) + (i32.const 0xFF))) + (local.set $size + (i32.shr_u (local.get $header) + (i32.const 10))) + (br $read_block)) + ;; SHARED32 + (local.set $ofs (call $read32 (local.get $s))) + (br $read_shared)) + ;; SHARED16 + (local.set $ofs (call $read16u (local.get $s))) + (br $read_shared)) + ;; SHARED8 + (local.set $ofs (call $read8u (local.get $s))) + (br $read_shared)) + ;; INT64 + (call $caml_failwith + (array.new_data $string $integer_too_large + (i32.const 0) (i32.const 30))) + (br $done)) + ;; INT32 + (local.set $v (ref.i31 (call $read32 (local.get $s)))) + (br $done)) + ;; INT16 + (local.set $v (ref.i31 (call $read16s (local.get $s)))) + (br $done)) + ;; INT8 + (local.set $v (ref.i31 (call $read8s (local.get $s)))) + (br $done)) + )))) + ;; read_shared + (local.set $ofs + (i32.sub + (struct.get $intern_state $obj_counter (local.get $s)) + (local.get $ofs))) + (local.set $v + (array.get $block + (ref.as_non_null + (struct.get $intern_state $obj_table + (local.get $s))) + (local.get $ofs))) + (br $done)) + ;; read_double_array + (local.set $v + (call $readfloats + (local.get $s) (local.get $code) (local.get $len))) + (call $register_object (local.get $s) (local.get $v)) + (br $done)) + ;; read_string + (local.set $str (array.new $string (i32.const 0) (local.get $len))) + (call $readblock (local.get $s) (local.get $str)) + (local.set $v (local.get $str)) + (call $register_object (local.get $s) (local.get $v)) + (br $done)) + ;; read_block + (local.set $b + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $size) (i32.const 1)))) + (array.set $block (local.get $b) (i32.const 0) + (ref.i31 (local.get $tag))) + (if (local.get $size) + (then + (call $register_object (local.get $s) (local.get $b)) + (local.set $sp + (struct.new $stack_item + (local.get $b) (i32.const 1) (local.get $sp))))) + (local.set $v (local.get $b)) + (br $done)) + ;; done + (array.set $block (local.get $dest) (local.get $pos) (local.get $v)) + (br $loop))) + (array.get $block (local.get $res) (i32.const 0))) + + (data $too_large ": object too large to be read back on a 32-bit platform") + + (func $too_large (param $prim (ref $string)) + (call $caml_failwith + (call $caml_string_concat (local.get $prim) + (array.new_data $string $too_large (i32.const 0) (i32.const 55))))) + + (data $bad_object ": bad object") + + (func $bad_object (param $prim (ref $string)) + (call $caml_failwith + (call $caml_string_concat (local.get $prim) + (array.new_data $string $bad_object (i32.const 0) (i32.const 12))))) + + (data $bad_length ": bad length") + + (func $bad_length (param $prim (ref $string)) + (call $caml_failwith + (call $caml_string_concat (local.get $prim) + (array.new_data $string $bad_length (i32.const 0) (i32.const 12))))) + + (type $marshal_header + (struct + (field $data_len i32) + (field $num_objects i32))) + + (func $parse_header + (param $s (ref $intern_state)) (param $prim (ref $string)) + (result (ref $marshal_header)) + (local $magic i32) + (local $data_len i32) (local $num_objects i32) (local $whsize i32) + (local.set $magic (call $read32 (local.get $s))) + (if (i32.eq (local.get $magic) (global.get $Intext_magic_number_big)) + (then + (call $too_large (local.get $prim)))) + (if (i32.ne (local.get $magic) (global.get $Intext_magic_number_small)) + (then + (call $bad_object (local.get $prim)))) + (local.set $data_len (call $read32 (local.get $s))) + (local.set $num_objects (call $read32 (local.get $s))) + (drop (call $read32 (local.get $s))) + (drop (call $read32 (local.get $s))) + (struct.new $marshal_header + (local.get $data_len) + (local.get $num_objects))) + + (data $marshal_data_size "Marshal.data_size") + + (func (export "caml_marshal_data_size") + (param $buf (ref eq)) (param $ofs (ref eq)) (result (ref eq)) + (local $s (ref $intern_state)) + (local $magic i32) + (local.set $s + (call $get_intern_state + (ref.cast (ref $string) (local.get $buf)) + (i31.get_u (ref.cast (ref i31) (local.get $ofs))))) + (local.set $magic (call $read32 (local.get $s))) + (if (i32.eq (local.get $magic) (global.get $Intext_magic_number_big)) + (then + (call $too_large + (array.new_data $string $marshal_data_size + (i32.const 0) (i32.const 17))))) + (if (i32.ne (local.get $magic) (global.get $Intext_magic_number_small)) + (then + (call $bad_object + (array.new_data $string $marshal_data_size + (i32.const 0) (i32.const 17))))) + (ref.i31 + (i32.add + (i32.sub (i32.const 20) + (global.get $caml_marshal_header_size)) + (call $read32 (local.get $s))))) + + (type $output_block + (struct + (field $next (mut (ref null $output_block))) + (field $end (mut i32)) + (field $data (ref $string)))) + + (type $extern_state + (struct + ;; Flags + (field $no_sharing i32) + (field $user_provided_output i32) + ;; Header information + (field $obj_counter (mut i32)) + (field $size_32 (mut i32)) + (field $size_64 (mut i32)) + ;; Position of already marshalled objects + (field $pos_table (ref any)) + ;; Buffers + (field $buf (mut (ref $string))) + (field $pos (mut i32)) + (field $limit (mut i32)) + (field $output_first (ref $output_block)) + (field $output_last (mut (ref $output_block))))) + + (func $init_extern_state + (param $flags (ref eq)) (param $output (ref $output_block)) + (param $pos i32) (param $user_provided_output i32) + (result (ref $extern_state)) + (local $b (ref $block)) + (local $no_sharing i32) + (loop $parse_flags + (drop (block $done (result (ref eq)) + (local.set $b + (br_on_cast_fail $done (ref eq) (ref $block) (local.get $flags))) + (if (ref.eq (array.get $block (local.get $b) (i32.const 1)) + (ref.i31 (i32.const 0))) + (then (local.set $no_sharing (i32.const 1)))) + (local.set $flags (array.get $block (local.get $b) (i32.const 2))) + (br $parse_flags)))) + (struct.new $extern_state + (local.get $no_sharing) + (local.get $user_provided_output) + (i32.const 0) + (i32.const 0) + (i32.const 0) + (call $map_new) + (struct.get $output_block $data (local.get $output)) + (local.get $pos) + (struct.get $output_block $end (local.get $output)) + (local.get $output) + (local.get $output))) + + (data $buffer_overflow "Marshal.to_buffer: buffer overflow") + + (global $SIZE_EXTERN_OUTPUT_BLOCK i32 (i32.const 8100)) + + (func $reserve_extern_output + (param $s (ref $extern_state)) (param $required i32) (result i32) + (local $last (ref $output_block)) (local $blk (ref $output_block)) + (local $pos i32) (local $extra i32) + (local $buf (ref $string)) + (local.set $pos (struct.get $extern_state $pos (local.get $s))) + (if (i32.le_u (i32.add (local.get $pos) (local.get $required)) + (struct.get $extern_state $limit (local.get $s))) + (then + (struct.set $extern_state $pos (local.get $s) + (i32.add (local.get $pos) (local.get $required))) + (return (local.get $pos)))) + (if (struct.get $extern_state $user_provided_output (local.get $s)) + (then + (call $caml_failwith + (array.new_data $string $buffer_overflow + (i32.const 0) (i32.const 34))))) + (local.set $last (struct.get $extern_state $output_last (local.get $s))) + (struct.set $output_block $end (local.get $last) + (struct.get $extern_state $pos (local.get $s))) + (if (i32.gt_s (local.get $required) + (i32.shr_u (global.get $SIZE_EXTERN_OUTPUT_BLOCK) (i32.const 1))) + (then + (local.set $extra (local.get $required)))) + (local.set $buf + (array.new $string (i32.const 0) + (i32.add (global.get $SIZE_EXTERN_OUTPUT_BLOCK) (local.get $extra)))) + (local.set $blk + (struct.new $output_block + (ref.null $output_block) + (i32.const 0) + (local.get $buf))) + (struct.set $output_block $next (local.get $last) (local.get $blk)) + (struct.set $extern_state $output_last (local.get $s) (local.get $blk)) + (struct.set $extern_state $buf (local.get $s) (local.get $buf)) + (struct.set $extern_state $pos (local.get $s) (local.get $required)) + (struct.set $extern_state $limit (local.get $s) + (array.len (local.get $buf))) + (i32.const 0)) + + (func $store16 (param $s (ref $string)) (param $pos i32) (param $n i32) + (array.set $string (local.get $s) (local.get $pos) + (i32.shr_u (local.get $n) (i32.const 8))) + (array.set $string (local.get $s) + (i32.add (local.get $pos) (i32.const 1)) (local.get $n))) + + (func $store32 (param $s (ref $string)) (param $pos i32) (param $n i32) + (array.set $string (local.get $s) (local.get $pos) + (i32.shr_u (local.get $n) (i32.const 24))) + (array.set $string (local.get $s) + (i32.add (local.get $pos) (i32.const 1)) + (i32.shr_u (local.get $n) (i32.const 16))) + (array.set $string (local.get $s) + (i32.add (local.get $pos) (i32.const 2)) + (i32.shr_u (local.get $n) (i32.const 8))) + (array.set $string (local.get $s) + (i32.add (local.get $pos) (i32.const 3)) (local.get $n))) + + (func $store64 (param $s (ref $string)) (param $pos i32) (param $n i64) + (call $store32 (local.get $s) (local.get $pos) + (i32.wrap_i64 (i64.shr_u (local.get $n) (i64.const 32)))) + (call $store32 (local.get $s) (i32.add (local.get $pos) (i32.const 4)) + (i32.wrap_i64 (local.get $n)))) + + (func $write (param $s (ref $extern_state)) (param $c i32) + (local $pos i32) + (local.set $pos + (call $reserve_extern_output (local.get $s) (i32.const 1))) + (array.set $string (struct.get $extern_state $buf (local.get $s)) + (local.get $pos) (local.get $c))) + + (func $writecode8 + (param $s (ref $extern_state)) (param $c i32) (param $v i32) + (local $pos i32) (local $buf (ref $string)) + (local.set $pos + (call $reserve_extern_output (local.get $s) (i32.const 2))) + (local.set $buf (struct.get $extern_state $buf (local.get $s))) + (array.set $string (local.get $buf) (local.get $pos) (local.get $c)) + (array.set $string (local.get $buf) + (i32.add (local.get $pos) (i32.const 1)) (local.get $v))) + + (func $writecode16 + (param $s (ref $extern_state)) (param $c i32) (param $v i32) + (local $pos i32) (local $buf (ref $string)) + (local.set $pos + (call $reserve_extern_output (local.get $s) (i32.const 3))) + (local.set $buf (struct.get $extern_state $buf (local.get $s))) + (array.set $string (local.get $buf) (local.get $pos) (local.get $c)) + (call $store16 (local.get $buf) (i32.add (local.get $pos) (i32.const 1)) + (local.get $v))) + + (func $writecode32 + (param $s (ref $extern_state)) (param $c i32) (param $v i32) + (local $pos i32) (local $buf (ref $string)) + (local.set $pos + (call $reserve_extern_output (local.get $s) (i32.const 5))) + (local.set $buf (struct.get $extern_state $buf (local.get $s))) + (array.set $string (local.get $buf) (local.get $pos) (local.get $c)) + (call $store32 (local.get $buf) (i32.add (local.get $pos) (i32.const 1)) + (local.get $v))) + + (func $writeblock + (param $s (ref $extern_state)) (param $str (ref $string)) + (local $len i32) (local $pos i32) + (local.set $len (array.len (local.get $str))) + (local.set $pos + (call $reserve_extern_output (local.get $s) (local.get $len))) + (array.copy $string $string + (struct.get $extern_state $buf (local.get $s)) (local.get $pos) + (local.get $str) (i32.const 0) (local.get $len))) + + (func $writefloat + (param $s (ref $extern_state)) (param $f f64) + (local $pos i32) (local $buf (ref $string)) (local $d i64) (local $i i32) + (local.set $pos + (call $reserve_extern_output (local.get $s) (i32.const 8))) + (local.set $buf (struct.get $extern_state $buf (local.get $s))) + (local.set $d (i64.reinterpret_f64 (local.get $f))) + (loop $loop + (array.set $string (local.get $buf) + (i32.add (local.get $pos) (local.get $i)) + (i32.wrap_i64 + (i64.shr_u (local.get $d) + (i64.extend_i32_u (i32.shl (local.get $i) (i32.const 3)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 8))))) + + (func $writefloats + (param $s (ref $extern_state)) (param $b (ref $float_array)) + (local $pos i32) (local $sz i32) (local $buf (ref $string)) (local $d i64) + (local $i i32) (local $j i32) + (local.set $sz (array.len (local.get $b))) + (local.set $pos + (call $reserve_extern_output + (local.get $s) (i32.shl (local.get $sz) (i32.const 3)))) + (local.set $buf (struct.get $extern_state $buf (local.get $s))) + (local.set $j (i32.const 0)) + (loop $loop2 + (if (i32.lt_u (local.get $j) (local.get $sz)) + (then + (local.set $d + (i64.reinterpret_f64 + (array.get $float_array (local.get $b) (local.get $j)))) + (local.set $i (i32.const 0)) + (loop $loop + (array.set $string (local.get $buf) + (i32.add (local.get $pos) (local.get $i)) + (i32.wrap_i64 + (i64.shr_u (local.get $d) + (i64.extend_i32_u + (i32.shl (local.get $i) (i32.const 3)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 8)))) + (local.set $pos (i32.add (local.get $pos) (i32.const 8))) + (local.set $j (i32.add (local.get $j) (i32.const 1))) + (br $loop2))))) + + (func $extern_lookup_position + (param $s (ref $extern_state)) (param $obj (ref eq)) (result i32) + (block $not_found + (br_if $not_found (struct.get $extern_state $no_sharing (local.get $s))) + (return + (i31.get_s + (br_on_null $not_found + (call $map_get + (struct.get $extern_state $pos_table (local.get $s)) + (local.get $obj)))))) + (i32.const -1)) + + (func $extern_record_location + (param $s (ref $extern_state)) (param $obj (ref eq)) + (local $pos i32) + (if (struct.get $extern_state $no_sharing (local.get $s)) + (then (return))) + (local.set $pos (struct.get $extern_state $obj_counter (local.get $s))) + (struct.set $extern_state $obj_counter (local.get $s) + (i32.add (local.get $pos) (i32.const 1))) + (call $map_set + (struct.get $extern_state $pos_table (local.get $s)) + (local.get $obj) (ref.i31 (local.get $pos)))) + + (func $extern_size + (param $s (ref $extern_state)) (param $s32 i32) (param $s64 i32) + (struct.set $extern_state $size_32 (local.get $s) + (i32.add (struct.get $extern_state $size_32 (local.get $s)) + (i32.add (local.get $s32) (i32.const 1)))) + (struct.set $extern_state $size_64 (local.get $s) + (i32.add (struct.get $extern_state $size_64 (local.get $s)) + (i32.add (local.get $s64) (i32.const 1))))) + + (func $extern_int (param $s (ref $extern_state)) (param $n i32) + (if (i32.and (i32.ge_s (local.get $n) (i32.const 0)) + (i32.lt_s (local.get $n) (i32.const 0x40))) + (then + (call $write (local.get $s) + (i32.add (global.get $PREFIX_SMALL_INT) (local.get $n)))) + (else (if (i32.and (i32.ge_s (local.get $n) (i32.const -128)) + (i32.lt_s (local.get $n) (i32.const 128))) + (then + (call $writecode8 (local.get $s) (global.get $CODE_INT8) + (local.get $n))) + (else (if (i32.and (i32.ge_s (local.get $n) (i32.const -32768)) + (i32.lt_s (local.get $n) (i32.const 32768))) + (then + (call $writecode16 (local.get $s) (global.get $CODE_INT16) + (local.get $n))) + (else + (call $writecode32 (local.get $s) (global.get $CODE_INT32) + (local.get $n))))))))) + + (func $extern_shared_reference (param $s (ref $extern_state)) (param $d i32) + (if (i32.lt_u (local.get $d) (i32.const 0x100)) + (then + (call $writecode8 (local.get $s) (global.get $CODE_SHARED8) + (local.get $d))) + (else (if (i32.lt_u (local.get $d) (i32.const 0x10000)) + (then + (call $writecode16 (local.get $s) (global.get $CODE_SHARED16) + (local.get $d))) + (else + (call $writecode32 (local.get $s) (global.get $CODE_SHARED32) + (local.get $d))))))) + + (func $extern_header + (param $s (ref $extern_state)) (param $sz i32) (param $tag i32) + (if (i32.and (i32.lt_u (local.get $tag) (i32.const 16)) + (i32.lt_u (local.get $sz) (i32.const 8))) + (then + (call $write (local.get $s) + (i32.add (global.get $PREFIX_SMALL_BLOCK) + (i32.or (local.get $tag) + (i32.shl (local.get $sz) (i32.const 4)))))) + (else + (call $writecode32 (local.get $s) (global.get $CODE_BLOCK32) + (i32.or (local.get $tag) + (i32.shl (local.get $sz) (i32.const 10))))))) + + (func $extern_string (param $s (ref $extern_state)) (param $v (ref $string)) + (local $len i32) + (local.set $len (array.len (local.get $v))) + (if (i32.lt_u (local.get $len) (i32.const 0x20)) + (then + (call $write (local.get $s) + (i32.add (global.get $PREFIX_SMALL_STRING) (local.get $len)))) + (else (if (i32.lt_u (local.get $len) (i32.const 0x100)) + (then + (call $writecode8 (local.get $s) (global.get $CODE_STRING8) + (local.get $len))) + (else + (call $writecode32 (local.get $s) (global.get $CODE_STRING32) + (local.get $len)))))) + (call $writeblock (local.get $s) (local.get $v))) + + (func $extern_float (param $s (ref $extern_state)) (param $v f64) + (call $write (local.get $s) (global.get $CODE_DOUBLE_LITTLE)) + (call $writefloat (local.get $s) (local.get $v))) + + (func $extern_float_array + (param $s (ref $extern_state)) (param $v (ref $float_array)) + (local $nfloats i32) + (local.set $nfloats (array.len (local.get $v))) + (if (i32.lt_u (local.get $nfloats) (i32.const 0x100)) + (then + (call $writecode8 (local.get $s) + (global.get $CODE_DOUBLE_ARRAY8_LITTLE) (local.get $nfloats))) + (else + (call $writecode32 (local.get $s) + (global.get $CODE_DOUBLE_ARRAY32_LITTLE) (local.get $nfloats)))) + (call $writefloats (local.get $s) (local.get $v))) + + (data $incorrect_sizes "output_value: incorrect fixed sizes specified by ") + + (func $extern_custom + (param $s (ref $extern_state)) (param $v (ref $custom)) (result i32 i32) + (local $ops (ref $custom_operations)) + (local $serialize (ref $serialize)) + (local $fixed_length (ref $fixed_length)) + (local $pos i32) (local $buf (ref $string)) + (local $r (tuple i32 i32)) + (local.set $ops (struct.get $custom 0 (local.get $v))) + (block $abstract + (local.set $serialize + (br_on_null $abstract + (struct.get $custom_operations $serialize (local.get $ops)))) + (block $variable_length + (local.set $fixed_length + (br_on_null $variable_length + (struct.get $custom_operations $fixed_length + (local.get $ops)))) + (call $write (local.get $s) (global.get $CODE_CUSTOM_FIXED)) + (call $writeblock (local.get $s) + (struct.get $custom_operations $id (local.get $ops))) + (call $write (local.get $s) (i32.const 0)) + (local.set $r + (call_ref $serialize + (local.get $s) (local.get $v) (local.get $serialize))) + (if (i32.or + (i32.ne (tuple.extract 2 0 (local.get $r)) + (struct.get $fixed_length $bsize_32 + (local.get $fixed_length))) + (i32.ne (tuple.extract 2 1 (local.get $r)) + (struct.get $fixed_length $bsize_64 + (local.get $fixed_length)))) + (then + (call $caml_failwith + (call $caml_string_concat + (array.new_data $string $incorrect_sizes + (i32.const 0) (i32.const 49)) + (struct.get $custom_operations $id + (local.get $ops)))))) + (return (local.get $r))) + ;; variable length + (call $write (local.get $s) (global.get $CODE_CUSTOM_LEN)) + (call $writeblock (local.get $s) + (struct.get $custom_operations $id (local.get $ops))) + (call $write (local.get $s) (i32.const 0)) + (local.set $pos + (call $reserve_extern_output (local.get $s) (i32.const 12))) + (local.set $buf (struct.get $extern_state $buf (local.get $s))) + (local.set $r + (call_ref $serialize + (local.get $s) (local.get $v) (local.get $serialize))) + (call $store32 (local.get $buf) (local.get $pos) + (tuple.extract 2 0 (local.get $r))) + (call $store32 (local.get $buf) (i32.add (local.get $pos) (i32.const 8)) + (tuple.extract 2 1 (local.get $r))) + (return (local.get $r))) + (call $caml_invalid_argument + (array.new_data $string $cust_value (i32.const 0) (i32.const 37))) + (return (tuple.make 2 (i32.const 0) (i32.const 0)))) + + (data $func_value "output_value: functional value") + (data $cont_value "output_value: continuation value") + (data $js_value "output_value: abstract value (JavaScript value)") + (data $abstract_value "output_value: abstract value") + (data $cust_value "output_value: abstract value (Custom)") + + (func $extern_rec (param $s (ref $extern_state)) (param $v (ref eq)) + (local $sp (ref null $stack_item)) + (local $item (ref $stack_item)) + (local $b (ref $block)) (local $str (ref $string)) + (local $fa (ref $float_array)) + (local $hd i32) (local $tag i32) (local $sz i32) + (local $pos i32) + (local $r (tuple i32 i32)) + (loop $loop + (block $next_item + (drop (block $not_int (result (ref eq)) + (call $extern_int (local.get $s) + (i31.get_s + (br_on_cast_fail $not_int (ref eq) (ref i31) + (local.get $v)))) + (br $next_item))) + (drop (block $not_block (result (ref eq)) + (local.set $b + (br_on_cast_fail $not_block (ref eq) (ref $block) + (local.get $v))) + (local.set $tag + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $b) (i32.const 0))))) + (local.set $sz (i32.sub (array.len (local.get $b)) (i32.const 1))) + (if (i32.eqz (local.get $sz)) + (then + (call $extern_header + (local.get $s) (i32.const 0) (local.get $tag)) + (br $next_item))) + (local.set $pos + (call $extern_lookup_position (local.get $s) (local.get $v))) + (if (i32.ge_s (local.get $pos) (i32.const 0)) + (then + (call $extern_shared_reference (local.get $s) + (i32.sub + (struct.get $extern_state $obj_counter (local.get $s)) + (local.get $pos))) + (br $next_item))) + (call $extern_record_location (local.get $s) (local.get $v)) + (call $extern_header + (local.get $s) (local.get $sz) (local.get $tag)) + (call $extern_size + (local.get $s) (local.get $sz) (local.get $sz)) + (if (i32.gt_u (local.get $sz) (i32.const 1)) + (then + (local.set $sp + (struct.new $stack_item + (local.get $b) + (i32.const 2) + (local.get $sp))))) + (local.set $v (array.get $block (local.get $b) (i32.const 1))) + (br $loop))) + (local.set $pos + (call $extern_lookup_position (local.get $s) (local.get $v))) + (if (i32.ge_s (local.get $pos) (i32.const 0)) + (then + (call $extern_shared_reference (local.get $s) + (i32.sub + (struct.get $extern_state $obj_counter (local.get $s)) + (local.get $pos))) + (br $next_item))) + (call $extern_record_location (local.get $s) (local.get $v)) + (drop (block $not_string (result (ref eq)) + (local.set $str + (br_on_cast_fail $not_string (ref eq) (ref $string) + (local.get $v))) + (call $extern_string (local.get $s) (local.get $str)) + (local.set $sz (array.len (local.get $str))) + (call $extern_size (local.get $s) + (i32.add (i32.const 1) + (i32.shr_u (local.get $sz) (i32.const 2))) + (i32.add (i32.const 1) + (i32.shr_u (local.get $sz) (i32.const 3)))) + (br $next_item))) + (drop (block $not_float (result (ref eq)) + (call $extern_float (local.get $s) + (struct.get $float 0 + (br_on_cast_fail $not_float (ref eq) (ref $float) + (local.get $v)))) + (call $extern_size (local.get $s) (i32.const 2) (i32.const 1)) + (br $next_item))) + (drop (block $not_float_array (result (ref eq)) + (local.set $fa + (br_on_cast_fail $not_float_array (ref eq) (ref $float_array) + (local.get $v))) + (local.set $sz (array.len (local.get $fa))) + (call $extern_float_array (local.get $s) (local.get $fa)) + (call $extern_size (local.get $s) + (i32.mul (local.get $sz) (i32.const 2)) + (local.get $sz)) + (br $next_item))) + (drop (block $not_custom (result (ref eq)) + (local.set $r + (call $extern_custom (local.get $s) + (br_on_cast_fail $not_custom (ref eq) (ref $custom) + (local.get $v)))) + (call $extern_size (local.get $s) + (i32.shr_u + (i32.add (tuple.extract 2 0 (local.get $r)) (i32.const 7)) + (i32.const 2)) + (i32.shr_u + (i32.add (tuple.extract 2 1 (local.get $r)) (i32.const 15)) + (i32.const 3))) + (br $next_item))) + (if (call $caml_is_closure (local.get $v)) + (then + (call $caml_invalid_argument + (array.new_data $string $func_value + (i32.const 0) (i32.const 30))))) + (if (call $caml_is_continuation (local.get $v)) + (then + (call $caml_invalid_argument + (array.new_data $string $cont_value + (i32.const 0) (i32.const 32))))) + (if (ref.test (ref $js) (local.get $v)) + (then + (call $caml_invalid_argument + (array.new_data $string $js_value + (i32.const 0) (i32.const 47))))) + (call $caml_invalid_argument + (array.new_data $string $abstract_value + (i32.const 0) (i32.const 28))) + ) + ;; next_item + (block $done + (local.set $item (br_on_null $done (local.get $sp))) + (local.set $b (struct.get $stack_item $blk (local.get $item))) + (local.set $pos (struct.get $stack_item $pos (local.get $item))) + (local.set $v (array.get $block (local.get $b) (local.get $pos))) + (local.set $pos (i32.add (local.get $pos) (i32.const 1))) + (struct.set $stack_item $pos (local.get $item) (local.get $pos)) + (if (i32.eq (local.get $pos) (array.len (local.get $b))) + (then + (local.set $sp + (struct.get $stack_item $next (local.get $item))))) + (br $loop)))) + + (func $extern_output_length + (param $s (ref $extern_state)) (param $pos i32) (result i32) + (local $len i32) + (local $output_block (ref $output_block)) + (if (struct.get $extern_state $user_provided_output (local.get $s)) + (then + (return + (i32.sub (struct.get $extern_state $pos (local.get $s)) + (local.get $pos)))) + (else + (struct.set $output_block $end + (struct.get $extern_state $output_last (local.get $s)) + (struct.get $extern_state $pos (local.get $s))) + (local.set $output_block + (struct.get $extern_state $output_first (local.get $s))) + (loop $loop + (block $done + (local.set $len + (i32.add (local.get $len) + (struct.get $output_block $end + (local.get $output_block)))) + (local.set $output_block + (br_on_null $done + (struct.get $output_block $next + (local.get $output_block)))) + (br $loop))) + (return (local.get $len))))) + + (func $extern_value + (param $flags (ref eq)) (param $output (ref $output_block)) + (param $pos i32) (param $user_provided_output i32) (param $v (ref eq)) + (result i32 (ref $string) (ref $extern_state)) + (local $s (ref $extern_state)) (local $len i32) + (local $header (ref $string)) + (local.set $s + (call $init_extern_state + (local.get $flags) (local.get $output) (local.get $pos) + (local.get $user_provided_output))) + (call $extern_rec (local.get $s) (local.get $v)) + (local.set $len + (call $extern_output_length (local.get $s) (local.get $pos))) + (local.set $header (array.new $string (i32.const 0) (i32.const 20))) + (call $store32 (local.get $header) (i32.const 0) + (global.get $Intext_magic_number_small)) + (call $store32 (local.get $header) (i32.const 4) (local.get $len)) + (call $store32 (local.get $header) (i32.const 8) + (struct.get $extern_state $obj_counter (local.get $s))) + (call $store32 (local.get $header) (i32.const 12) + (struct.get $extern_state $size_32 (local.get $s))) + (call $store32 (local.get $header) (i32.const 16) + (struct.get $extern_state $size_64 (local.get $s))) + (tuple.make 3 (local.get $len) (local.get $header) (local.get $s))) + + (func (export "caml_output_value_to_string") + (param $v (ref eq)) (param $flags (ref eq)) (result (ref eq)) + (local $r (tuple i32 (ref $string) (ref $extern_state))) + (local $blk (ref $output_block)) (local $pos i32) (local $len i32) + (local $res (ref $string)) + (local.set $blk + (struct.new $output_block + (ref.null $output_block) + (global.get $SIZE_EXTERN_OUTPUT_BLOCK) + (array.new $string (i32.const 0) + (global.get $SIZE_EXTERN_OUTPUT_BLOCK)))) + (local.set $r + (call $extern_value + (local.get $flags) (local.get $blk) + (i32.const 0) (i32.const 0) (local.get $v))) + (local.set $res + (array.new $string (i32.const 0) + (i32.add (tuple.extract 3 0 (local.get $r)) (i32.const 20)))) + (array.copy $string $string + (local.get $res) (i32.const 0) + (tuple.extract 3 1 (local.get $r)) (i32.const 0) (i32.const 20)) + (local.set $pos (i32.const 20)) + (loop $loop + (block $done + (local.set $len (struct.get $output_block $end (local.get $blk))) + (array.copy $string $string + (local.get $res) (local.get $pos) + (struct.get $output_block $data (local.get $blk)) (i32.const 0) + (local.get $len)) + (local.set $pos (i32.add (local.get $pos) (local.get $len))) + (local.set $blk + (br_on_null $done + (struct.get $output_block $next (local.get $blk)))) + (br $loop))) + (local.get $res)) + + (func (export "caml_output_value_to_buffer") + (param $vbuf (ref eq)) (param $vpos (ref eq)) (param $vlen (ref eq)) + (param $v (ref eq)) (param $flags (ref eq)) (result (ref eq)) + (local $buf (ref $string)) (local $pos i32) (local $len i32) + (local $r (tuple i32 (ref $string) (ref $extern_state))) + (local $blk (ref $output_block)) + (local.set $buf (ref.cast (ref $string) (local.get $vbuf))) + (local.set $pos (i31.get_u (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (local.set $blk + (struct.new $output_block + (ref.null $output_block) + (i32.add (local.get $pos) (local.get $len)) + (local.get $buf))) + (local.set $r + (call $extern_value + (local.get $flags) + (local.get $blk) + (i32.add (local.get $pos) (i32.const 20)) + (i32.const 1) + (local.get $v))) + (array.copy $string $string + (local.get $buf) (local.get $pos) + (tuple.extract 3 1 (local.get $r)) (i32.const 0) (i32.const 20)) + (ref.i31 (i32.const 0))) + + (func (export "caml_output_value") + (param $ch (ref eq)) (param $v (ref eq)) (param $flags (ref eq)) + (result (ref eq)) + (local $r (tuple i32 (ref $string) (ref $extern_state))) + (local $blk (ref $output_block)) (local $len i32) + (local $res (ref $string)) + ;; ZZZ check if binary channel? + (local.set $blk + (struct.new $output_block + (ref.null $output_block) + (global.get $SIZE_EXTERN_OUTPUT_BLOCK) + (array.new $string (i32.const 0) + (global.get $SIZE_EXTERN_OUTPUT_BLOCK)))) + (local.set $r + (call $extern_value + (local.get $flags) (local.get $blk) + (i32.const 0) (i32.const 0) (local.get $v))) + (call $caml_really_putblock (local.get $ch) + (tuple.extract 3 1 (local.get $r)) (i32.const 0) (i32.const 20)) + (loop $loop + (block $done + (local.set $len (struct.get $output_block $end (local.get $blk))) + (call $caml_really_putblock (local.get $ch) + (struct.get $output_block $data (local.get $blk)) + (i32.const 0) + (struct.get $output_block $end (local.get $blk))) + (local.set $blk + (br_on_null $done + (struct.get $output_block $next (local.get $blk)))) + (br $loop))) + (call $caml_flush_if_unbuffered (local.get $ch)) + (ref.i31 (i32.const 0))) + + (func (export "caml_serialize_int_1") (param $vs (ref eq)) (param $i i32) + (local $s (ref $extern_state)) + (local $pos i32) + (local.set $s (ref.cast (ref $extern_state) (local.get $vs))) + (local.set $pos + (call $reserve_extern_output (local.get $s) (i32.const 1))) + (array.set $string (struct.get $extern_state $buf (local.get $s)) + (local.get $pos) (local.get $i))) + + (func (export "caml_serialize_int_2") (param $vs (ref eq)) (param $i i32) + (local $s (ref $extern_state)) + (local $pos i32) + (local.set $s (ref.cast (ref $extern_state) (local.get $vs))) + (local.set $pos + (call $reserve_extern_output (local.get $s) (i32.const 2))) + (call $store16 (struct.get $extern_state $buf (local.get $s)) + (local.get $pos) (local.get $i))) + + (func (export "caml_serialize_int_4") (param $vs (ref eq)) (param $i i32) + (local $s (ref $extern_state)) + (local $pos i32) + (local.set $s (ref.cast (ref $extern_state) (local.get $vs))) + (local.set $pos + (call $reserve_extern_output (local.get $s) (i32.const 4))) + (call $store32 (struct.get $extern_state $buf (local.get $s)) + (local.get $pos) (local.get $i))) + + (func (export "caml_serialize_int_8") (param $vs (ref eq)) (param $i i64) + (local $s (ref $extern_state)) + (local $pos i32) + (local.set $s (ref.cast (ref $extern_state) (local.get $vs))) + (local.set $pos + (call $reserve_extern_output (local.get $s) (i32.const 8))) + (call $store64 (struct.get $extern_state $buf (local.get $s)) + (local.get $pos) (local.get $i))) +) diff --git a/runtime/wasm/md5.wat b/runtime/wasm/md5.wat new file mode 100644 index 0000000000..c8149eca6b --- /dev/null +++ b/runtime/wasm/md5.wat @@ -0,0 +1,551 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "io" "caml_getblock" + (func $caml_getblock + (param (ref eq)) (param (ref $string)) (param i32) (param i32) + (result i32))) + (import "fail" "caml_raise_end_of_file" (func $caml_raise_end_of_file)) + + (type $string (array (mut i8))) + (type $int_array (array (mut i32))) + + (type $context + (struct + (field (ref $int_array)) ;; w + (field (mut i64)) ;; len + (field (ref $int_array)) ;; buffer + (field (ref $string)))) ;; intermediate buffer + + (func (export "caml_md5_string") (export "caml_md5_bytes") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local $ctx (ref $context)) + (local.set $ctx (call $MD5Init)) + (call $MD5Update (local.get $ctx) (ref.cast (ref $string) (local.get 0)) + (i31.get_u (ref.cast (ref i31) (local.get 1))) + (i31.get_u (ref.cast (ref i31) (local.get 2)))) + (return_call $MD5Final (local.get $ctx))) + + (func (export "caml_md5_chan") + (param $ch (ref eq)) (param $vlen (ref eq)) (result (ref eq)) + (local $len i32) (local $read i32) + (local $buf (ref $string)) + (local $ctx (ref $context)) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (local.set $buf (array.new $string (i32.const 0) (i32.const 4096))) + (local.set $ctx (call $MD5Init)) + (if (i32.lt_s (local.get $len) (i32.const 0)) + (then + (loop $loop + (local.set $read + (call $caml_getblock (local.get $ch) (local.get $buf) + (i32.const 0) (i32.const 4096))) + (if (local.get $read) + (then + (call $MD5Update (local.get $ctx) (local.get $buf) + (i32.const 0) (local.get $read)) + (br $loop))))) + (else + (loop $loop + (if (local.get $len) + (then + (local.set $read + (call $caml_getblock (local.get $ch) (local.get $buf) + (i32.const 0) + (select (local.get $len) (i32.const 4096) + (i32.le_u (local.get $len) (i32.const 4096))))) + (if (i32.eqz (local.get $read)) + (then (call $caml_raise_end_of_file))) + (call $MD5Update (local.get $ctx) (local.get $buf) + (i32.const 0) (local.get $read)) + (local.set $len + (i32.sub (local.get $len) (local.get $read))) + (br $loop)))))) + (return_call $MD5Final (local.get $ctx))) + + (func $xx + (param $q i32) (param $a i32) (param $b i32) (param $x i32) (param $s i32) + (param $t i32) (result i32) + (i32.add + (i32.rotl + (i32.add + (i32.add (local.get $a) (local.get $q)) + (i32.add (local.get $x) (local.get $t))) + (local.get $s)) + (local.get $b))) + + (func $ff + (param $a i32) (param $b i32) (param $c i32) (param $d i32) (param $x i32) + (param $s i32) (param $t i32) (result i32) + (call $xx + (i32.xor (local.get $d) + (i32.and (local.get $b) (i32.xor (local.get $c) (local.get $d)))) + (local.get $a) (local.get $b) + (local.get $x) (local.get $s) (local.get $t))) + + (func $gg + (param $a i32) (param $b i32) (param $c i32) (param $d i32) (param $x i32) + (param $s i32) (param $t i32) (result i32) + (call $xx + (i32.xor (local.get $c) + (i32.and (local.get $d) (i32.xor (local.get $b) (local.get $c)))) + (local.get $a) (local.get $b) + (local.get $x) (local.get $s) (local.get $t))) + + (func $hh + (param $a i32) (param $b i32) (param $c i32) (param $d i32) (param $x i32) + (param $s i32) (param $t i32) (result i32) + (call $xx + (i32.xor (local.get $b) (i32.xor (local.get $c) (local.get $d))) + (local.get $a) (local.get $b) + (local.get $x) (local.get $s) (local.get $t))) + + (func $ii + (param $a i32) (param $b i32) (param $c i32) (param $d i32) (param $x i32) + (param $s i32) (param $t i32) (result i32) + (call $xx + (i32.xor (local.get $c) + (i32.or (local.get $b) (i32.xor (local.get $d) (i32.const -1)))) + (local.get $a) (local.get $b) + (local.get $x) (local.get $s) (local.get $t))) + + (func $get_32 (param $s (ref $string)) (param $p i32) (result i32) + (i32.or + (i32.or + (array.get_u $string (local.get $s) (local.get $p)) + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 1))) + (i32.const 8))) + (i32.or + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 2))) + (i32.const 16)) + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 3))) + (i32.const 24))))) + + (func $MD5Transform + (param $w (ref $int_array)) (param $buffer (ref $int_array)) + (param $buffer' (ref $string)) (param $p i32) + (local $i i32) + (local $a i32) (local $b i32) (local $c i32) (local $d i32) + (loop $loop + (array.set $int_array (local.get $buffer) (local.get $i) + (call $get_32 (local.get $buffer') (local.get $p))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (local.set $p (i32.add (local.get $p) (i32.const 4))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 16)))) + (local.set $a (array.get $int_array (local.get $w) (i32.const 0))) + (local.set $b (array.get $int_array (local.get $w) (i32.const 1))) + (local.set $c (array.get $int_array (local.get $w) (i32.const 2))) + (local.set $d (array.get $int_array (local.get $w) (i32.const 3))) + (local.set $a + (call $ff (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 0)) + (i32.const 7) (i32.const 0xD76AA478))) + (local.set $d + (call $ff (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 1)) + (i32.const 12) (i32.const 0xE8C7B756))) + (local.set $c + (call $ff (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 2)) + (i32.const 17) (i32.const 0x242070DB))) + (local.set $b + (call $ff (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 3)) + (i32.const 22) (i32.const 0xC1BDCEEE))) + (local.set $a + (call $ff (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 4)) + (i32.const 7) (i32.const 0xF57C0FAF))) + (local.set $d + (call $ff (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 5)) + (i32.const 12) (i32.const 0x4787C62A))) + (local.set $c + (call $ff (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 6)) + (i32.const 17) (i32.const 0xA8304613))) + (local.set $b + (call $ff (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 7)) + (i32.const 22) (i32.const 0xFD469501))) + (local.set $a + (call $ff (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 8)) + (i32.const 7) (i32.const 0x698098D8))) + (local.set $d + (call $ff (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 9)) + (i32.const 12) (i32.const 0x8B44F7AF))) + (local.set $c + (call $ff (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 10)) + (i32.const 17) (i32.const 0xFFFF5BB1))) + (local.set $b + (call $ff (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 11)) + (i32.const 22) (i32.const 0x895CD7BE))) + (local.set $a + (call $ff (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 12)) + (i32.const 7) (i32.const 0x6B901122))) + (local.set $d + (call $ff (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 13)) + (i32.const 12) (i32.const 0xFD987193))) + (local.set $c + (call $ff (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 14)) + (i32.const 17) (i32.const 0xA679438E))) + (local.set $b + (call $ff (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 15)) + (i32.const 22) (i32.const 0x49B40821))) + (local.set $a + (call $gg (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 1)) + (i32.const 5) (i32.const 0xF61E2562))) + (local.set $d + (call $gg (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 6)) + (i32.const 9) (i32.const 0xC040B340))) + (local.set $c + (call $gg (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 11)) + (i32.const 14) (i32.const 0x265E5A51))) + (local.set $b + (call $gg (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 0)) + (i32.const 20) (i32.const 0xE9B6C7AA))) + (local.set $a + (call $gg (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 5)) + (i32.const 5) (i32.const 0xD62F105D))) + (local.set $d + (call $gg (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 10)) + (i32.const 9) (i32.const 0x02441453))) + (local.set $c + (call $gg (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 15)) + (i32.const 14) (i32.const 0xD8A1E681))) + (local.set $b + (call $gg (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 4)) + (i32.const 20) (i32.const 0xE7D3FBC8))) + (local.set $a + (call $gg (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 9)) + (i32.const 5) (i32.const 0x21E1CDE6))) + (local.set $d + (call $gg (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 14)) + (i32.const 9) (i32.const 0xC33707D6))) + (local.set $c + (call $gg (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 3)) + (i32.const 14) (i32.const 0xF4D50D87))) + (local.set $b + (call $gg (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 8)) + (i32.const 20) (i32.const 0x455A14ED))) + (local.set $a + (call $gg (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 13)) + (i32.const 5) (i32.const 0xA9E3E905))) + (local.set $d + (call $gg (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 2)) + (i32.const 9) (i32.const 0xFCEFA3F8))) + (local.set $c + (call $gg (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 7)) + (i32.const 14) (i32.const 0x676F02D9))) + (local.set $b + (call $gg (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 12)) + (i32.const 20) (i32.const 0x8D2A4C8A))) + (local.set $a + (call $hh (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 5)) + (i32.const 4) (i32.const 0xFFFA3942))) + (local.set $d + (call $hh (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 8)) + (i32.const 11) (i32.const 0x8771F681))) + (local.set $c + (call $hh (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 11)) + (i32.const 16) (i32.const 0x6D9D6122))) + (local.set $b + (call $hh (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 14)) + (i32.const 23) (i32.const 0xFDE5380C))) + (local.set $a + (call $hh (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 1)) + (i32.const 4) (i32.const 0xA4BEEA44))) + (local.set $d + (call $hh (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 4)) + (i32.const 11) (i32.const 0x4BDECFA9))) + (local.set $c + (call $hh (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 7)) + (i32.const 16) (i32.const 0xF6BB4B60))) + (local.set $b + (call $hh (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 10)) + (i32.const 23) (i32.const 0xBEBFBC70))) + (local.set $a + (call $hh (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 13)) + (i32.const 4) (i32.const 0x289B7EC6))) + (local.set $d + (call $hh (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 0)) + (i32.const 11) (i32.const 0xEAA127FA))) + (local.set $c + (call $hh (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 3)) + (i32.const 16) (i32.const 0xD4EF3085))) + (local.set $b + (call $hh (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 6)) + (i32.const 23) (i32.const 0x04881D05))) + (local.set $a + (call $hh (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 9)) + (i32.const 4) (i32.const 0xD9D4D039))) + (local.set $d + (call $hh (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 12)) + (i32.const 11) (i32.const 0xE6DB99E5))) + (local.set $c + (call $hh (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 15)) + (i32.const 16) (i32.const 0x1FA27CF8))) + (local.set $b + (call $hh (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 2)) + (i32.const 23) (i32.const 0xC4AC5665))) + (local.set $a + (call $ii (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 0)) + (i32.const 6) (i32.const 0xF4292244))) + (local.set $d + (call $ii (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 7)) + (i32.const 10) (i32.const 0x432AFF97))) + (local.set $c + (call $ii (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 14)) + (i32.const 15) (i32.const 0xAB9423A7))) + (local.set $b + (call $ii (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 5)) + (i32.const 21) (i32.const 0xFC93A039))) + (local.set $a + (call $ii (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 12)) + (i32.const 6) (i32.const 0x655B59C3))) + (local.set $d + (call $ii (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 3)) + (i32.const 10) (i32.const 0x8F0CCC92))) + (local.set $c + (call $ii (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 10)) + (i32.const 15) (i32.const 0xFFEFF47D))) + (local.set $b + (call $ii (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 1)) + (i32.const 21) (i32.const 0x85845DD1))) + (local.set $a + (call $ii (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 8)) + (i32.const 6) (i32.const 0x6FA87E4F))) + (local.set $d + (call $ii (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 15)) + (i32.const 10) (i32.const 0xFE2CE6E0))) + (local.set $c + (call $ii (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 6)) + (i32.const 15) (i32.const 0xA3014314))) + (local.set $b + (call $ii (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 13)) + (i32.const 21) (i32.const 0x4E0811A1))) + (local.set $a + (call $ii (local.get $a) (local.get $b) (local.get $c) (local.get $d) + (array.get $int_array (local.get $buffer) (i32.const 4)) + (i32.const 6) (i32.const 0xF7537E82))) + (local.set $d + (call $ii (local.get $d) (local.get $a) (local.get $b) (local.get $c) + (array.get $int_array (local.get $buffer) (i32.const 11)) + (i32.const 10) (i32.const 0xBD3AF235))) + (local.set $c + (call $ii (local.get $c) (local.get $d) (local.get $a) (local.get $b) + (array.get $int_array (local.get $buffer) (i32.const 2)) + (i32.const 15) (i32.const 0x2AD7D2BB))) + (local.set $b + (call $ii (local.get $b) (local.get $c) (local.get $d) (local.get $a) + (array.get $int_array (local.get $buffer) (i32.const 9)) + (i32.const 21) (i32.const 0xEB86D391))) + (array.set $int_array (local.get $w) (i32.const 0) + (i32.add (array.get $int_array (local.get $w) (i32.const 0)) + (local.get $a))) + (array.set $int_array (local.get $w) (i32.const 1) + (i32.add (array.get $int_array (local.get $w) (i32.const 1)) + (local.get $b))) + (array.set $int_array (local.get $w) (i32.const 2) + (i32.add (array.get $int_array (local.get $w) (i32.const 2)) + (local.get $c))) + (array.set $int_array (local.get $w) (i32.const 3) + (i32.add (array.get $int_array (local.get $w) (i32.const 3)) + (local.get $d)))) + + (func $MD5Init (result (ref $context)) + (struct.new $context + (array.new_fixed $int_array 4 + (i32.const 0x67452301) (i32.const 0xEFCDAB89) + (i32.const 0x98BADCFE) (i32.const 0x10325476)) + (i64.const 0) + (array.new $int_array (i32.const 0) (i32.const 16)) + (array.new $string (i32.const 0) (i32.const 64)))) + + (func $MD5Update + (param $ctx (ref $context)) (param $input (ref $string)) + (param $input_pos i32) (param $input_len i32) + (local $in_buf i32) (local $len i64) + (local $missing i32) + (local.set $len (struct.get $context 1 (local.get $ctx))) + (local.set $in_buf + (i32.and (i32.wrap_i64 (local.get $len)) (i32.const 0x3f))) + (struct.set $context 1 (local.get $ctx) + (i64.add (local.get $len) (i64.extend_i32_u (local.get $input_len)))) + (if (local.get $in_buf) + (then + (local.set $missing (i32.sub (i32.const 64) (local.get $in_buf))) + (if (i32.lt_u (local.get $input_len) (local.get $missing)) + (then + (array.copy $string $string + (struct.get $context 3 (local.get $ctx)) + (local.get $missing) + (local.get $input) (local.get $input_pos) + (local.get $input_len)) + (return))) + (array.copy $string $string + (struct.get $context 3 (local.get $ctx)) + (local.get $missing) + (local.get $input) (local.get $input_pos) (local.get $missing)) + (call $MD5Transform (struct.get $context 0 (local.get $ctx)) + (struct.get $context 2 (local.get $ctx)) + (struct.get $context 3 (local.get $ctx)) + (i32.const 0)) + (local.set $input_pos + (i32.add (local.get $input_pos) (local.get $missing))) + (local.set $input_len + (i32.sub (local.get $input_len) (local.get $missing))))) + (loop $loop + (if (i32.ge_u (local.get $input_len) (i32.const 64)) + (then + (call $MD5Transform (struct.get $context 0 (local.get $ctx)) + (struct.get $context 2 (local.get $ctx)) + (local.get $input) + (local.get $input_pos)) + (local.set $input_pos + (i32.add (local.get $input_pos) (i32.const 64))) + (local.set $input_len + (i32.sub (local.get $input_len) (i32.const 64))) + (br $loop)))) + (if (local.get $input_len) + (then + (array.copy $string $string + (struct.get $context 3 (local.get $ctx)) (i32.const 0) + (local.get $input) (local.get $input_pos) + (local.get $input_len))))) + + (func $MD5Final (param $ctx (ref $context)) (result (ref $string)) + (local $in_buf i32) (local $i i32) (local $len i64) + (local $w (ref $int_array)) + (local $buffer (ref $string)) (local $res (ref $string)) + (local.set $len (struct.get $context 1 (local.get $ctx))) + (local.set $in_buf + (i32.and (i32.wrap_i64 (local.get $len)) (i32.const 0x3f))) + (local.set $buffer (struct.get $context 3 (local.get $ctx))) + (array.set $string (local.get $buffer) (local.get $in_buf) + (i32.const 0x80)) + (local.set $in_buf (i32.add (local.get $in_buf) (i32.const 1))) + (if (i32.gt_u (local.get $in_buf) (i32.const 56)) + (then + (local.set $i (local.get $in_buf)) + (loop $loop + (if (i32.lt_u (local.get $i) (i32.const 64)) + (then + (array.set $string + (local.get $buffer) (local.get $i) (i32.const 0)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (call $MD5Transform (struct.get $context 0 (local.get $ctx)) + (struct.get $context 2 (local.get $ctx)) + (local.get $buffer) + (i32.const 0)) + (local.set $in_buf (i32.const 0)))) + (local.set $i (local.get $in_buf)) + (loop $loop + (array.set $string (local.get $buffer) (local.get $i) (i32.const 0)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 56)))) + (local.set $len (i64.shl (local.get $len) (i64.const 3))) + (array.set $string (local.get $buffer) (i32.const 56) + (i32.wrap_i64 (local.get $len))) + (array.set $string (local.get $buffer) (i32.const 57) + (i32.wrap_i64 (i64.shr_u (local.get $len) (i64.const 8)))) + (array.set $string (local.get $buffer) (i32.const 58) + (i32.wrap_i64 (i64.shr_u (local.get $len) (i64.const 16)))) + (array.set $string (local.get $buffer) (i32.const 59) + (i32.wrap_i64 (i64.shr_u (local.get $len) (i64.const 24)))) + (array.set $string (local.get $buffer) (i32.const 60) + (i32.wrap_i64 (i64.shr_u (local.get $len) (i64.const 32)))) + (array.set $string (local.get $buffer) (i32.const 61) + (i32.wrap_i64 (i64.shr_u (local.get $len) (i64.const 40)))) + (array.set $string (local.get $buffer) (i32.const 62) + (i32.wrap_i64 (i64.shr_u (local.get $len) (i64.const 48)))) + (array.set $string (local.get $buffer) (i32.const 63) + (i32.wrap_i64 (i64.shr_u (local.get $len) (i64.const 56)))) + (call $MD5Transform (struct.get $context 0 (local.get $ctx)) + (struct.get $context 2 (local.get $ctx)) + (local.get $buffer) + (i32.const 0)) + (local.set $res (array.new $string (i32.const 0) (i32.const 16))) + (local.set $i (i32.const 0)) + (local.set $w (struct.get $context 0 (local.get $ctx))) + (loop $loop + (array.set $string (local.get $res) (local.get $i) + (i32.shr_u + (array.get $int_array (local.get $w) + (i32.shr_u (local.get $i) (i32.const 2))) + (i32.shl (local.get $i) (i32.const 3)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop (i32.lt_u (local.get $i) (i32.const 16)))) + (local.get $res)) +) diff --git a/runtime/wasm/nat.wat b/runtime/wasm/nat.wat new file mode 100644 index 0000000000..e2aafb3b36 --- /dev/null +++ b/runtime/wasm/nat.wat @@ -0,0 +1,37 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (func (export "initialize_nat") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "create_nat") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "set_to_zero_nat") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "set_digit_nat") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "incr_nat") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (param (ref eq)) + (result (ref eq)) + (ref.i31 (i32.const 0))) +) diff --git a/runtime/wasm/obj.wat b/runtime/wasm/obj.wat new file mode 100644 index 0000000000..f0057eee2a --- /dev/null +++ b/runtime/wasm/obj.wat @@ -0,0 +1,490 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "custom" "caml_is_custom" + (func $caml_is_custom (param (ref eq)) (result i32))) + (import "custom" "caml_dup_custom" + (func $caml_dup_custom (param (ref eq)) (result (ref eq)))) + (import "effect" "caml_is_continuation" + (func $caml_is_continuation (param (ref eq)) (result i32))) + (import "effect" "caml_trampoline_ref" + (global $caml_trampoline_ref (mut (ref null $function_1)))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $float (struct (field f64))) + (type $float_array (array (mut f64))) + (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) + (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) + (type $closure_last_arg + (sub $closure (struct (;(field i32);) (field (ref $function_1))))) + (type $function_2 + (func (param (ref eq) (ref eq) (ref eq)) (result (ref eq)))) + (type $cps_closure (sub (struct (field (ref $function_2))))) + (type $cps_closure_last_arg + (sub $cps_closure (struct (field (ref $function_2))))) + + (type $int_array (array (mut i32))) + + (type $dummy_closure_1 + (sub final $closure_last_arg + (struct (field (ref $function_1)) (field (mut (ref null $closure)))))) + + (type $closure_2 + (sub $closure + (struct (field (ref $function_1)) (field (ref $function_2))))) + + (type $dummy_closure_2 + (sub final $closure_2 + (struct (field (ref $function_1)) (field (ref $function_2)) + (field (mut (ref null $closure_2)))))) + + (type $function_3 + (func (param (ref eq) (ref eq) (ref eq) (ref eq)) (result (ref eq)))) + + (type $closure_3 + (sub $closure + (struct (field (ref $function_1)) (field (ref $function_3))))) + + (type $dummy_closure_3 + (sub final $closure_3 + (struct (field (ref $function_1)) (field (ref $function_3)) + (field (mut (ref null $closure_3)))))) + + (type $function_4 + (func (param (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (result (ref eq)))) + + (type $closure_4 + (sub $closure + (struct (field (ref $function_1)) (field (ref $function_4))))) + + (type $dummy_closure_4 + (sub final $closure_4 + (struct (field (ref $function_1)) (field (ref $function_4)) + (field (mut (ref null $closure_4)))))) + + (type $cps_dummy_closure + (sub final $cps_closure_last_arg + (struct + (field (ref $function_2)) + (field (mut (ref null $cps_closure)))))) + + (global $forcing_tag i32 (i32.const 244)) + (global $cont_tag (export "cont_tag") i32 (i32.const 245)) + (global $lazy_tag (export "lazy_tag") i32 (i32.const 246)) + (global $closure_tag i32 (i32.const 247)) + (global $object_tag (export "object_tag") i32 (i32.const 248)) + (global $forward_tag (export "forward_tag") i32 (i32.const 250)) + (global $abstract_tag (export "abstract_tag") i32 (i32.const 251)) + (global $string_tag i32 (i32.const 252)) + (global $float_tag i32 (i32.const 253)) + (global $double_array_tag (export "double_array_tag") i32 (i32.const 254)) + (global $custom_tag i32 (i32.const 255)) + + (func $caml_is_closure (export "caml_is_closure") + (param $v (ref eq)) (result i32) + (i32.or (ref.test (ref $closure) (local.get $v)) + (ref.test (ref $cps_closure) (local.get $v)))) + + (func (export "caml_is_last_arg") + (param $v (ref eq)) (result i32) + (i32.or (ref.test (ref $closure_last_arg) (local.get $v)) + (ref.test (ref $cps_closure_last_arg) (local.get $v)))) + + (func (export "caml_alloc_dummy") (param $size (ref eq)) (result (ref eq)) + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (i31.get_u (ref.cast (ref i31) (local.get $size))) + (i32.const 1)))) + + (func (export "caml_alloc_dummy_float") + (param $size (ref eq)) (result (ref eq)) + (array.new $float_array (f64.const 0) + (i31.get_u (ref.cast (ref i31) (local.get $size))))) + + (func (export "caml_update_dummy") + (param $dummy (ref eq)) (param $newval (ref eq)) (result (ref eq)) + (local $i i32) + (local $dst (ref $block)) (local $fdst (ref $float_array)) + (local $src (ref $block)) + (drop (block $not_block (result (ref eq)) + (local.set $dst + (br_on_cast_fail $not_block (ref eq) (ref $block) + (local.get $dummy))) + (local.set $src (ref.cast (ref $block) (local.get $newval))) + (array.copy $block $block + (local.get $dst) (i32.const 0) (local.get $src) (i32.const 0) + (array.len (local.get $dst))) + (return (ref.i31 (i32.const 0))))) + (drop (block $not_float_array (result (ref eq)) + (local.set $fdst + (br_on_cast_fail $not_float_array (ref eq) (ref $float_array) + (local.get $dummy))) + (array.copy $float_array $float_array + (local.get $fdst) (i32.const 0) + (ref.cast (ref $float_array) (local.get $newval)) (i32.const 0) + (array.len (local.get $fdst))) + (return (ref.i31 (i32.const 0))))) + (drop (block $not_closure_1 (result (ref eq)) + (struct.set $dummy_closure_1 1 + (br_on_cast_fail $not_closure_1 (ref eq) (ref $dummy_closure_1) + (local.get $dummy)) + (ref.cast (ref $closure) (local.get $newval))) + (return (ref.i31 (i32.const 0))))) + (drop (block $not_closure_2 (result (ref eq)) + (struct.set $dummy_closure_2 2 + (br_on_cast_fail $not_closure_2 (ref eq) (ref $dummy_closure_2) + (local.get $dummy)) + (ref.cast (ref $closure_2) (local.get $newval))) + (return (ref.i31 (i32.const 0))))) + (drop (block $not_closure_3 (result (ref eq)) + (struct.set $dummy_closure_3 2 + (br_on_cast_fail $not_closure_3 (ref eq) (ref $dummy_closure_3) + (local.get $dummy)) + (ref.cast (ref $closure_3) (local.get $newval))) + (return (ref.i31 (i32.const 0))))) + (drop (block $not_closure_4 (result (ref eq)) + (struct.set $dummy_closure_4 2 + (br_on_cast_fail $not_closure_4 (ref eq) (ref $dummy_closure_4) + (local.get $dummy)) + (ref.cast (ref $closure_4) (local.get $newval))) + (return (ref.i31 (i32.const 0))))) + (drop (block $not_cps_closure (result (ref eq)) + (struct.set $cps_dummy_closure 1 + (br_on_cast_fail $not_cps_closure (ref eq) (ref $cps_dummy_closure) + (local.get $dummy)) + (ref.cast (ref $cps_closure) (local.get $newval))) + (return (ref.i31 (i32.const 0))))) + (unreachable)) + + (func $caml_obj_dup (export "caml_obj_dup") + (param (ref eq)) (result (ref eq)) + (local $orig (ref $block)) (local $res (ref $block)) + (local $forig (ref $float_array)) (local $fres (ref $float_array)) + (local $s (ref $string)) (local $s' (ref $string)) + (local $len i32) + (drop (block $not_block (result (ref eq)) + (local.set $orig (br_on_cast_fail $not_block (ref eq) (ref $block) + (local.get 0))) + (local.set $len (array.len (local.get $orig))) + (local.set $res + (array.new $block (array.get $block (local.get $orig) (i32.const 0)) + (local.get $len))) + (array.copy $block $block + (local.get $res) (i32.const 1) (local.get $orig) (i32.const 1) + (i32.sub (local.get $len) (i32.const 1))) + (return (local.get $res)))) + (drop (block $not_float_array (result (ref eq)) + (local.set $forig + (br_on_cast_fail $not_float_array (ref eq) (ref $float_array) + (local.get 0))) + (local.set $len (array.len (local.get $forig))) + (local.set $fres + (array.new $float_array (f64.const 0) (local.get $len))) + (array.copy $float_array $float_array + (local.get $fres) (i32.const 0) (local.get $forig) (i32.const 0) + (local.get $len)) + (return (local.get $fres)))) + (drop (block $not_string (result (ref eq)) + (local.set $s (br_on_cast_fail $not_string (ref eq) (ref $string) + (local.get 0))) + (local.set $len (array.len (local.get $s))) + (local.set $s' (array.new $string (i32.const 0) (local.get $len))) + (array.copy $string $string + (local.get $s') (i32.const 0) (local.get $s) (i32.const 0) + (local.get $len)) + (return (local.get $s')))) + (drop (block $not_float (result (ref eq)) + (return + (struct.new $float + (struct.get $float 0 + (br_on_cast_fail $not_float (ref eq) (ref $float) + (local.get 0))))))) + (call $caml_dup_custom (local.get 0))) + + (func (export "caml_obj_with_tag") + (param $tag (ref eq)) (param (ref eq)) (result (ref eq)) + (local $res (ref eq)) + (local.set $res (call $caml_obj_dup (local.get 1))) + (array.set $block (ref.cast (ref $block) (local.get $res)) (i32.const 0) + (local.get $tag)) + (local.get $res)) + + (func (export "caml_obj_block") + (param $tag (ref eq)) (param $size (ref eq)) (result (ref eq)) + (local $res (ref $block)) + ;; ZZZ float array / specific types? + (local.set $res + (array.new $block + (ref.i31 (i32.const 0)) + (i32.add (i31.get_s (ref.cast (ref i31) (local.get $size))) + (i32.const 1)))) + (array.set $block (local.get $res) (i32.const 0) (local.get $tag)) + (local.get $res)) + + (func (export "caml_obj_tag") (param $v (ref eq)) (result (ref eq)) + (if (ref.test (ref i31) (local.get $v)) + (then (return (ref.i31 (i32.const 1000))))) + (drop (block $not_block (result (ref eq)) + (return + (array.get $block + (br_on_cast_fail $not_block (ref eq) (ref $block) (local.get $v)) + (i32.const 0))))) + (if (ref.test (ref $string) (local.get $v)) + (then (return (ref.i31 (global.get $string_tag))))) + (if (ref.test (ref $float) (local.get $v)) + (then (return (ref.i31 (global.get $float_tag))))) + (if (ref.test (ref $float_array) (local.get $v)) + (then (return (ref.i31 (global.get $double_array_tag))))) + (if (call $caml_is_custom (local.get $v)) + (then (return (ref.i31 (global.get $custom_tag))))) + (if (call $caml_is_closure (local.get $v)) + (then (return (ref.i31 (global.get $closure_tag))))) + (if (call $caml_is_continuation (local.get $v)) + (then (return (ref.i31 (global.get $cont_tag))))) + (ref.i31 (global.get $abstract_tag))) + + (func (export "caml_obj_make_forward") + (param $b (ref eq)) (param $v (ref eq)) (result (ref eq)) + (local $block (ref $block)) + (local.set $block (ref.cast (ref $block) (local.get $b))) + (array.set $block (local.get $block) + (i32.const 0) (ref.i31 (global.get $forward_tag))) + (array.set $block (local.get $block) (i32.const 1) (local.get $v)) + (ref.i31 (i32.const 0))) + + (func (export "caml_lazy_make_forward") + (param (ref eq)) (result (ref eq)) + (array.new_fixed $block 2 (ref.i31 (global.get $forward_tag)) + (local.get 0))) + + (func $obj_update_tag + (param (ref eq)) (param $o i32) (param $n i32) (result i32) + (local $b (ref $block)) + (local.set $b (ref.cast (ref $block) (local.get 0))) + (if (result i32) (ref.eq (array.get $block (local.get $b) (i32.const 0)) + (ref.i31 (local.get $o))) + (then + (array.set $block (local.get $b) (i32.const 0) + (ref.i31 (local.get $n))) + (i32.const 1)) + (else + (i32.const 0)))) + + (func (export "caml_lazy_reset_to_lazy") (param (ref eq)) (result (ref eq)) + (drop (call $obj_update_tag (local.get 0) + (global.get $forcing_tag) (global.get $lazy_tag))) + (ref.i31 (i32.const 0))) + + (func (export "caml_lazy_update_to_forward") (param (ref eq)) (result (ref eq)) + (drop (call $obj_update_tag (local.get 0) + (global.get $forcing_tag) (global.get $forward_tag))) + (ref.i31 (i32.const 0))) + + (func (export "caml_lazy_update_to_forcing") + (param (ref eq)) (result (ref eq)) + (if (ref.test (ref $block) (local.get 0)) + (then + (if (call $obj_update_tag (local.get 0) + (global.get $lazy_tag) (global.get $forcing_tag)) + (then (return (ref.i31 (i32.const 0))))))) + (ref.i31 (i32.const 1))) + + (func (export "caml_obj_compare_and_swap") + (param (ref eq)) (param (ref eq)) + (param $old (ref eq)) (param $new (ref eq)) (result (ref eq)) + (local $b (ref $block)) + (local $i i32) + (local.set $b (ref.cast (ref $block) (local.get 0))) + (local.set $i + (i32.add (i31.get_u (ref.cast (ref i31) (local.get 1))) (i32.const 1))) + (if (result (ref eq)) + (ref.eq + (array.get $block (local.get $b) (local.get $i)) (local.get $old)) + (then + (array.set $block (local.get $b) (local.get $i) (local.get $new)) + (ref.i31 (i32.const 1))) + (else + (ref.i31 (i32.const 0))))) + + (func (export "caml_obj_is_shared") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 1))) + + (func (export "caml_obj_raw_field") + (param $o (ref eq)) (param $i (ref eq)) (result (ref eq)) + (array.get $block (ref.cast (ref $block) (local.get $o)) + (i32.add + (i31.get_u (ref.cast (ref i31) (local.get $i))) (i32.const 1)))) + + (func (export "caml_obj_set_raw_field") + (param $o (ref eq)) (param $i (ref eq)) (param $v (ref eq)) + (result (ref eq)) + (array.set $block (ref.cast (ref $block) (local.get $o)) + (i32.add (i31.get_u (ref.cast (ref i31) (local.get $i))) (i32.const 1)) + (local.get $v)) + (ref.i31 (i32.const 0))) + + (data $not_implemented "Obj.add_offset is not supported") + + (func (export "caml_obj_add_offset") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (call $caml_failwith + (array.new_data $string $not_implemented (i32.const 0) (i32.const 31))) + (ref.i31 (i32.const 0))) + + (data $truncate_not_implemented "Obj.truncate is not supported") + + (func (export "caml_obj_truncate") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (call $caml_failwith + (array.new_data $string $truncate_not_implemented + (i32.const 0) (i32.const 29))) + (ref.i31 (i32.const 0))) + + (global $method_cache (mut (ref $int_array)) + (array.new $int_array (i32.const 0) (i32.const 8))) + + (func (export "caml_get_public_method") + (param $obj (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local $meths (ref $block)) + (local $tag i32) (local $cacheid i32) (local $ofs i32) + (local $li i32) (local $mi i32) (local $hi i32) + (local $a (ref $int_array)) (local $len i32) + (local.set $meths + (ref.cast (ref $block) + (array.get $block + (ref.cast (ref $block) (local.get $obj)) (i32.const 1)))) + (local.set $tag (i31.get_s (ref.cast (ref i31) (local.get 1)))) + (local.set $cacheid (i31.get_u (ref.cast (ref i31) (local.get 2)))) + (local.set $len (array.len (global.get $method_cache))) + (if (i32.ge_s (local.get $cacheid) (local.get $len)) + (then + (loop $size + (local.set $len (i32.shl (local.get $len) (i32.const 1))) + (br_if $size (i32.ge_s (local.get $cacheid) (local.get $len)))) + (local.set $a (array.new $int_array (i32.const 0) (local.get $len))) + (array.copy $int_array $int_array + (local.get $a) (i32.const 0) + (global.get $method_cache) (i32.const 0) + (array.len (global.get $method_cache))) + (global.set $method_cache (local.get $a)))) + (local.set $ofs + (array.get $int_array (global.get $method_cache) (local.get $cacheid))) + (if (i32.eq (local.get $tag) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $meths) (local.get $ofs))))) + (then + (return + (array.get $block + (local.get $meths) (i32.sub (local.get $ofs) (i32.const 1)))))) + (local.set $li (i32.const 3)) + (local.set $hi + (i32.add + (i32.shl + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $meths) (i32.const 1)))) + (i32.const 1)) + (i32.const 1))) + (loop $loop + (if (i32.lt_u (local.get $li) (local.get $hi)) + (then + (local.set $mi + (i32.or (i32.shr_u (i32.add (local.get $li) (local.get $hi)) + (i32.const 1)) + (i32.const 1))) + (if (i32.lt_s + (local.get $tag) + (i31.get_s + (ref.cast (ref i31) + (array.get $block + (local.get $meths) + (i32.add (local.get $mi) (i32.const 1)))))) + (then + (local.set $hi (i32.sub (local.get $mi) (i32.const 2)))) + (else + (local.set $li (local.get $mi)))) + (br $loop)))) + (array.set $int_array (global.get $method_cache) (local.get $cacheid) + (i32.add (local.get $li) (i32.const 1))) + (if (result (ref eq)) + (i32.eq (local.get $tag) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $meths) + (i32.add (local.get $li) (i32.const 1)))))) + (then + (array.get $block (local.get $meths) (local.get $li))) + (else + (ref.i31 (i32.const 0))))) + + (global $caml_oo_last_id (mut i32) (i32.const 0)) + + (func (export "caml_set_oo_id") (param (ref eq)) (result (ref eq)) + (local $id i32) + (local.set $id (global.get $caml_oo_last_id)) + (array.set $block (ref.cast (ref $block) (local.get 0)) (i32.const 2) + (ref.i31 (local.get $id))) + (global.set $caml_oo_last_id (i32.add (local.get $id) (i32.const 1))) + (local.get 0)) + + (func (export "caml_fresh_oo_id") (param (ref eq)) (result (ref eq)) + (local $id i32) + (local.set $id (global.get $caml_oo_last_id)) + (global.set $caml_oo_last_id (i32.add (local.get $id) (i32.const 1))) + (ref.i31 (local.get $id))) + + (func (export "caml_obj_reachable_words") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func $caml_callback_1 (export "caml_callback_1") + (param $f (ref eq)) (param $x (ref eq)) (result (ref eq)) + (drop (block $cps (result (ref eq)) + (return_call_ref $function_1 (local.get $x) + (local.get $f) + (struct.get $closure 0 + (br_on_cast_fail $cps (ref eq) (ref $closure) + (local.get $f)))))) + (return_call_ref $function_1 + (local.get $f) + (array.new_fixed $block 2 (ref.i31 (i32.const 0)) (local.get $x)) + (ref.as_non_null (global.get $caml_trampoline_ref)))) + + (func (export "caml_callback_2") + (param $f (ref eq)) (param $x (ref eq)) (param $y (ref eq)) + (result (ref eq)) + (drop (block $not_direct (result (ref eq)) + (return_call_ref $function_2 (local.get $x) (local.get $y) + (local.get $f) + (struct.get $closure_2 1 + (br_on_cast_fail $not_direct (ref eq) (ref $closure_2) + (local.get $f)))))) + (if (ref.test (ref $closure) (local.get $f)) + (then + (return_call $caml_callback_1 + (call $caml_callback_1 (local.get $f) (local.get $x)) + (local.get $y))) + (else + (return_call_ref $function_1 + (local.get $f) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (local.get $x) (local.get $y)) + (ref.as_non_null (global.get $caml_trampoline_ref)))))) +) diff --git a/runtime/wasm/parsing.wat b/runtime/wasm/parsing.wat new file mode 100644 index 0000000000..4e4a0bb29b --- /dev/null +++ b/runtime/wasm/parsing.wat @@ -0,0 +1,695 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (import "jslib" "caml_string_of_jsstring" + (func $caml_string_of_jsstring (param (ref eq)) (result (ref eq)))) + (import "io" "caml_stderr" (global $caml_stderr (mut (ref eq)))) + (import "io" "caml_ml_open_descriptor_out" + (func $caml_ml_open_descriptor_out (param (ref eq)) (result (ref eq)))) + (import "io" "caml_ml_output" + (func $caml_ml_output + (param (ref eq)) (param (ref eq)) (param (ref eq)) (param (ref eq)) + (result (ref eq)))) + (import "io" "caml_ml_flush" + (func $caml_ml_flush (param (ref eq)) (result (ref eq)))) + (import "ints" "caml_format_int" + (func $caml_format_int + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "float" "caml_format_float" + (func $caml_format_float + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + + (type $float (struct (field f64))) + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + + (func $get (param $a (ref eq)) (param $i i32) (result i32) + (local $s (ref $string)) + (local.set $s (ref.cast (ref $string) (local.get $a))) + (local.set $i (i32.add (local.get $i) (local.get $i))) + (i32.extend16_s + (i32.or (array.get_u $string (local.get $s) (local.get $i)) + (i32.shl + (array.get_u $string (local.get $s) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8))))) + + (global $caml_parser_trace (mut i32) (i32.const 0)) + + (global $ERRCODE i32 (i32.const 256)) + + (global $START i32 (i32.const 0)) + (global $TOKEN_READ i32 (i32.const 1)) + (global $STACKS_GROWN_1 i32 (i32.const 2)) + (global $STACKS_GROWN_2 i32 (i32.const 3)) + (global $SEMANTIC_ACTION_COMPUTED i32 (i32.const 4)) + (global $ERROR_DETECTED i32 (i32.const 5)) + (global $loop i32 (i32.const 6)) + (global $testshift i32 (i32.const 7)) + (global $shift i32 (i32.const 8)) + (global $shift_recover i32 (i32.const 9)) + (global $reduce i32 (i32.const 10)) + + (global $READ_TOKEN i32 (i32.const 0)) + (global $RAISE_PARSE_ERROR i32 (i32.const 1)) + (global $GROW_STACKS_1 i32 (i32.const 2)) + (global $GROW_STACKS_2 i32 (i32.const 3)) + (global $COMPUTE_SEMANTIC_ACTION i32 (i32.const 4)) + (global $CALL_ERROR_FUNCTION i32 (i32.const 5)) + + (global $env_s_stack i32 (i32.const 1)) + (global $env_v_stack i32 (i32.const 2)) + (global $env_symb_start_stack i32 (i32.const 3)) + (global $env_symb_end_stack i32 (i32.const 4)) + (global $env_stacksize i32 (i32.const 5)) + (global $env_stackbase i32 (i32.const 6)) + (global $env_curr_char i32 (i32.const 7)) + (global $env_lval i32 (i32.const 8)) + (global $env_symb_start i32 (i32.const 9)) + (global $env_symb_end i32 (i32.const 10)) + (global $env_asp i32 (i32.const 11)) + (global $env_rule_len i32 (i32.const 12)) + (global $env_rule_number i32 (i32.const 13)) + (global $env_sp i32 (i32.const 14)) + (global $env_state i32 (i32.const 15)) + (global $env_errflag i32 (i32.const 16)) + + (global $tbl_transl_const i32 (i32.const 2)) + (global $tbl_transl_block i32 (i32.const 3)) + (global $tbl_lhs i32 (i32.const 4)) + (global $tbl_len i32 (i32.const 5)) + (global $tbl_defred i32 (i32.const 6)) + (global $tbl_dgoto i32 (i32.const 7)) + (global $tbl_sindex i32 (i32.const 8)) + (global $tbl_rindex i32 (i32.const 9)) + (global $tbl_gindex i32 (i32.const 10)) + (global $tbl_tablesize i32 (i32.const 11)) + (global $tbl_table i32 (i32.const 12)) + (global $tbl_check i32 (i32.const 13)) + (global $tbl_names_const i32 (i32.const 15)) + (global $tbl_names_block i32 (i32.const 16)) + + (func $strlen (param $s (ref $string)) (param $p i32) (result i32) + (local $i i32) + (local.set $i (local.get $p)) + (loop $loop + (if (i32.ne (array.get_u $string (local.get $s) (local.get $i)) + (i32.const 0)) + (then + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (i32.sub (local.get $i) (local.get $p))) + + (data $unknown_token "") + (func $token_name + (param $vnames (ref eq)) (param $number i32) (result (ref eq)) + (local $names (ref $string)) (local $i i32) (local $len i32) + (local $name (ref $string)) + (local.set $names (ref.cast (ref $string) (local.get $vnames))) + (loop $loop + (if (i32.eqz (array.get_u $string (local.get $names) (local.get $i))) + (then + (return + (array.new_data $string $unknown_token + (i32.const 0) (i32.const 15))))) + (if (i32.ne (local.get $number) (i32.const 0)) + (then + (local.set $i + (i32.add (local.get $i) + (i32.add (call $strlen (local.get $names) (local.get $i)) + (i32.const 1)))) + (local.set $number (i32.sub (local.get $number) (i32.const 1))) + (br $loop)))) + (local.set $len (call $strlen (local.get $names) (local.get $i))) + (local.set $name (array.new $string (i32.const 0) (local.get $len))) + (array.copy $string $string + (local.get $name) (i32.const 0) + (local.get $names) (local.get $i) (local.get $len)) + (local.get $name)) + + (func $output (param (ref eq)) + (local $s (ref $string)) + (local.set $s (ref.cast (ref $string) (local.get 0))) + (drop + (call $caml_ml_output (global.get $caml_stderr) + (local.get $s) (ref.i31 (i32.const 0)) + (ref.i31 (array.len (local.get $s)))))) + + (func $output_nl + (drop + (call $caml_ml_output (global.get $caml_stderr) + (array.new_fixed $string 1 (i32.const 10)) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 1)))) + (drop (call $caml_ml_flush (global.get $caml_stderr)))) + + (func $output_int (param i32) + (call $output + (call $caml_format_int + (array.new_fixed $string 2 (i32.const 37) (i32.const 100)) + (ref.i31 (local.get 0))))) + + (data $State "State ") + (data $read_token ": read token ") + + (func $print_token + (param $tables (ref $block)) (param $state i32) (param $tok (ref eq)) + (local $b (ref $block)) + (local $v (ref eq)) + (if (ref.test (ref i31) (local.get $tok)) + (then + (call $output + (array.new_data $string $State (i32.const 0) (i32.const 6))) + (call $output_int (local.get $state)) + (call $output + (array.new_data $string $read_token (i32.const 0) (i32.const 13))) + (call $output + (call $token_name + (array.get $block (local.get $tables) + (global.get $tbl_names_const)) + (i31.get_u (ref.cast (ref i31) (local.get $tok))))) + (call $output_nl)) + (else + (call $output + (array.new_data $string $State (i32.const 0) (i32.const 6))) + (call $output_int (local.get $state)) + (call $output + (array.new_data $string $read_token (i32.const 0) (i32.const 13))) + (local.set $b (ref.cast (ref $block) (local.get $tok))) + (call $output + (call $token_name + (array.get $block (local.get $tables) + (global.get $tbl_names_block)) + (i31.get_u + (ref.cast (ref i31) + (array.get $block (local.get $b) (i32.const 0)))))) + (call $output (array.new_fixed $string 1 (i32.const 40))) ;; "(" + (local.set $v (array.get $block (local.get $b) (i32.const 1))) + (if (ref.test (ref i31) (local.get $v)) + (then + (call $output_int + (i31.get_s (ref.cast (ref i31) (local.get $v))))) + (else (if (ref.test (ref $string) (local.get $v)) + (then (call $output (local.get $v))) + (else (if (ref.test (ref $float) (local.get $v)) + (then + (call $output + (call $caml_format_float + (array.new_fixed $string 2 + (i32.const 37) (i32.const 103)) + (local.get $v)))) + (else + (call $output + (array.new_fixed $string 1 (i32.const 95))))))))) ;; '_' + (call $output (array.new_fixed $string 1 (i32.const 41))) ;; ")" + (call $output_nl)))) + + (data $recovering_in_state "Recovering in state ") + (data $discarding_state "Discarding state ") + (data $no_more_states_to_discard "No more states to discard") + (data $discarding_last_token_read "Discarding last token read") + (data $shift_to_state ": shift to state ") + (data $reduce_by_rule ": reduce by rule ") + + (func (export "caml_parse_engine") + (param $vtables (ref eq)) (param $venv (ref eq)) (param $vcmd (ref eq)) + (param $varg (ref eq)) (result (ref eq)) + (local $res i32) (local $n i32) (local $n1 i32) (local $n2 i32) + (local $m i32) + (local $state1 i32) (local $sp i32) (local $asp i32) (local $state i32) + (local $errflag i32) + (local $tables (ref $block)) (local $env (ref $block)) (local $cmd i32) + (local $arg (ref $block)) + (local $tbl_defred (ref $string)) + (local $tbl_sindex (ref $string)) + (local $tbl_check (ref $string)) + (local $tbl_rindex (ref $string)) + (local $tbl_table (ref $string)) + (local $tbl_len (ref $string)) + (local $tbl_lhs (ref $string)) + (local $tbl_gindex (ref $string)) + (local $tbl_dgoto (ref $string)) + (local.set $tables (ref.cast (ref $block) (local.get $vtables))) + (local.set $tbl_defred + (ref.cast (ref $string) + (array.get $block (local.get $tables) (global.get $tbl_defred)))) + (local.set $tbl_sindex + (ref.cast (ref $string) + (array.get $block (local.get $tables) (global.get $tbl_sindex)))) + (local.set $tbl_check + (ref.cast (ref $string) + (array.get $block (local.get $tables) (global.get $tbl_check)))) + (local.set $tbl_rindex + (ref.cast (ref $string) + (array.get $block (local.get $tables) (global.get $tbl_rindex)))) + (local.set $tbl_table + (ref.cast (ref $string) + (array.get $block (local.get $tables) (global.get $tbl_table)))) + (local.set $tbl_len + (ref.cast (ref $string) + (array.get $block (local.get $tables) (global.get $tbl_len)))) + (local.set $tbl_lhs + (ref.cast (ref $string) + (array.get $block (local.get $tables) (global.get $tbl_lhs)))) + (local.set $tbl_gindex + (ref.cast (ref $string) + (array.get $block (local.get $tables) (global.get $tbl_gindex)))) + (local.set $tbl_dgoto + (ref.cast (ref $string) + (array.get $block (local.get $tables) (global.get $tbl_dgoto)))) + (local.set $env (ref.cast (ref $block) (local.get $venv))) + (local.set $cmd (i31.get_s (ref.cast (ref i31) (local.get $vcmd)))) + (local.set $sp + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $env) (global.get $env_sp))))) + (local.set $state + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $env) (global.get $env_state))))) + (local.set $errflag + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $env) (global.get $env_errflag))))) + (block $exit + (loop $next + (block $default + (block $SEMANTIC_ACTION_COMPUTED + (block $STACKS_GROWN_2 + (block $reduce + (block $STACKS_GROWN_1 + (block $shift_recover + (block $shift + (block $ERROR_DETECTED + (block $testshift + (block $TOKEN_READ + (block $loop + (block $START + (br_table $START $TOKEN_READ $STACKS_GROWN_1 $STACKS_GROWN_2 + $SEMANTIC_ACTION_COMPUTED $ERROR_DETECTED $loop + $testshift $shift $shift_recover $reduce $default + (local.get $cmd))) + ;; START: + (local.set $state (i32.const 0)) + (local.set $errflag (i32.const 0))) + ;; Fall through + ;; loop: + (local.set $n + (call $get (local.get $tbl_defred) (local.get $state))) + (if (i32.ne (local.get $n) (i32.const 0)) + (then + (local.set $cmd (global.get $reduce)) + (br $next))) + (if (i32.ge_s + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $env) + (global.get $env_curr_char)))) + (i32.const 0)) + (then + (local.set $cmd (global.get $testshift)) + (br $next))) + (local.set $res (global.get $READ_TOKEN)) + (br $exit)) + ;; TOKEN_READ: + (block $cont + (drop (block $not_block (result (ref eq)) + (local.set $arg + (br_on_cast_fail $not_block (ref eq) (ref $block) + (local.get $varg))) + (array.set $block (local.get $env) + (global.get $env_curr_char) + (array.get $block + (ref.cast (ref $block) + (array.get $block (local.get $tables) + (global.get $tbl_transl_block))) + (i32.add + (i31.get_u + (ref.cast (ref i31) + (array.get $block + (local.get $arg) (i32.const 0)))) + (i32.const 1)))) + (array.set $block (local.get $env) (global.get $env_lval) + (array.get $block (local.get $arg) (i32.const 1))) + (br $cont))) + (array.set $block (local.get $env) + (global.get $env_curr_char) + (array.get $block + (ref.cast (ref $block) + (array.get $block (local.get $tables) + (global.get $tbl_transl_const))) + (i32.add + (i31.get_u (ref.cast (ref i31) (local.get $varg))) + (i32.const 1)))) + (array.set $block (local.get $env) (global.get $env_lval) + (ref.i31 (i32.const 0)))) + (if (global.get $caml_parser_trace) + (then (call $print_token (local.get $tables) + (local.get $state) (local.get $varg))))) + ;; Fall through + ;; testshift: + (local.set $n1 + (call $get (local.get $tbl_sindex) (local.get $state))) + (local.set $n2 + (i32.add (local.get $n1) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $env) + (global.get $env_curr_char)))))) + (if (i32.and + (i32.ne (local.get $n1) (i32.const 0)) + (i32.ge_s (local.get $n2) (i32.const 0))) + (then + (if (i32.le_s (local.get $n2) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $tables) + (global.get $tbl_tablesize))))) + (then + (if (ref.eq + (ref.i31 + (call $get (local.get $tbl_check) + (local.get $n2))) + (array.get $block (local.get $env) + (global.get $env_curr_char))) + (then + (local.set $cmd (global.get $shift)) + (br $next))))))) + (local.set $n1 + (call $get (local.get $tbl_rindex) (local.get $state))) + (local.set $n2 + (i32.add (local.get $n1) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $env) + (global.get $env_curr_char)))))) + (if (i32.and + (i32.ne (local.get $n1) (i32.const 0)) + (i32.ge_s (local.get $n2) (i32.const 0))) + (then + (if (i32.le_s (local.get $n2) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $tables) + (global.get $tbl_tablesize))))) + (then + (if (ref.eq + (ref.i31 + (call $get (local.get $tbl_check) + (local.get $n2))) + (array.get $block (local.get $env) + (global.get $env_curr_char))) + (then + (local.set $n + (call $get (local.get $tbl_table) + (local.get $n2))) + (local.set $cmd (global.get $reduce)) + (br $next))))))) + (if (i32.le_s (local.get $errflag) (i32.const 0)) + (then + (local.set $res (global.get $CALL_ERROR_FUNCTION)) + (br $exit)))) + ;; Fall through + ;; ERROR_DETECTED: + (if (i32.lt_s (local.get $errflag) (i32.const 3)) + (then + (local.set $errflag (i32.const 3)) + (loop $loop2 + (local.set $state1 + (i31.get_s + (ref.cast (ref i31) + (array.get $block + (ref.cast (ref $block) + (array.get $block (local.get $env) + (global.get $env_s_stack))) + (i32.add (local.get $sp) (i32.const 1)))))) + (local.set $n1 + (call $get (local.get $tbl_sindex) + (local.get $state1))) + (local.set $n2 + (i32.add (local.get $n1) (global.get $ERRCODE))) + (if (i32.and + (i32.ne (local.get $n1) (i32.const 0)) + (i32.ge_s (local.get $n2) (i32.const 0))) + (then + (if (i32.le_s (local.get $n2) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $tables) + (global.get $tbl_tablesize))))) + (then + (if (i32.eq + (call $get (local.get $tbl_check) + (local.get $n2)) + (global.get $ERRCODE)) + (then + (if (global.get $caml_parser_trace) + (then + (call $output + (array.new_data $string + $recovering_in_state + (i32.const 0) + (i32.const 20))) + (call $output_int + (local.get $state1)) + (call $output_nl))) + (local.set $cmd + (global.get $shift_recover)) + (br $next))))))) + (if (global.get $caml_parser_trace) + (then + (call $output + (array.new_data $string $discarding_state + (i32.const 0) (i32.const 17))) + (call $output_int (local.get $state1)) + (call $output_nl))) + (if (i32.le_s (local.get $sp) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $env) + (global.get $env_stackbase))))) + (then + (if (global.get $caml_parser_trace) + (then + (call $output + (array.new_data $string + $no_more_states_to_discard + (i32.const 0) (i32.const 25))) + (call $output_nl))) + (return (ref.i31 (global.get $RAISE_PARSE_ERROR))))) + (local.set $sp (i32.sub (local.get $sp) (i32.const 1))) + (br $loop2))) + (else + (if (ref.eq + (array.get $block (local.get $env) + (global.get $env_curr_char)) + (ref.i31 (i32.const 0))) + (then + (return (ref.i31 (global.get $RAISE_PARSE_ERROR))))) + (if (global.get $caml_parser_trace) + (then + (call $output + (array.new_data $string $discarding_last_token_read + (i32.const 0) (i32.const 26))) + (call $output_nl))) + (array.set $block (local.get $env) + (global.get $env_curr_char) + (ref.i31 (i32.const -1))) + (local.set $cmd (global.get $loop)) + (br $next)))) + ;; shift: + (array.set $block (local.get $env) (global.get $env_curr_char) + (ref.i31 (i32.const -1))) + (if (i32.gt_s (local.get $errflag) (i32.const 0)) + (then + (local.set $errflag + (i32.sub (local.get $errflag) (i32.const 1)))))) + ;; Fall through + ;; shift_recover: + (if (global.get $caml_parser_trace) + (then + (call $output + (array.new_data $string $State + (i32.const 0) (i32.const 6))) + (call $output_int (local.get $state)) + (call $output + (array.new_data $string $shift_to_state + (i32.const 0) (i32.const 17))) + (call $output_int + (call $get (local.get $tbl_table) (local.get $n2))) + (call $output_nl))) + (local.set $state + (call $get (local.get $tbl_table) (local.get $n2))) + (local.set $sp (i32.add (local.get $sp) (i32.const 1))) + (if (i32.ge_s (local.get $sp) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $env) + (global.get $env_stacksize))))) + (then + (local.set $res (global.get $GROW_STACKS_1)) + (br $exit)))) + ;; Fall through + ;; STACKS_GROWN_1: + (array.set $block + (ref.cast (ref $block) + (array.get $block (local.get $env) (global.get $env_s_stack))) + (i32.add (local.get $sp) (i32.const 1)) + (ref.i31 (local.get $state))) + (array.set $block + (ref.cast (ref $block) + (array.get $block (local.get $env) (global.get $env_v_stack))) + (i32.add (local.get $sp) (i32.const 1)) + (array.get $block (local.get $env) (global.get $env_lval))) + (array.set $block + (ref.cast (ref $block) + (array.get $block (local.get $env) + (global.get $env_symb_start_stack))) + (i32.add (local.get $sp) (i32.const 1)) + (array.get $block (local.get $env) (global.get $env_symb_start))) + (array.set $block + (ref.cast (ref $block) + (array.get $block (local.get $env) + (global.get $env_symb_end_stack))) + (i32.add (local.get $sp) (i32.const 1)) + (array.get $block (local.get $env) (global.get $env_symb_end))) + (local.set $cmd (global.get $loop)) + (br $next)) + ;; reduce: + (if (global.get $caml_parser_trace) + (then + (call $output + (array.new_data $string $State (i32.const 0) (i32.const 6))) + (call $output_int (local.get $state)) + (call $output + (array.new_data $string $reduce_by_rule + (i32.const 0) (i32.const 17))) + (call $output_int (local.get $n)) + (call $output_nl))) + (local.set $m (call $get (local.get $tbl_len) (local.get $n))) + (array.set $block (local.get $env) (global.get $env_asp) + (ref.i31 (local.get $sp))) + (array.set $block (local.get $env) (global.get $env_rule_number) + (ref.i31 (local.get $n))) + (array.set $block (local.get $env) (global.get $env_rule_len) + (ref.i31 (local.get $m))) + (local.set $sp + (i32.add (local.get $sp) (i32.sub (i32.const 1) (local.get $m)))) + (local.set $m (call $get (local.get $tbl_lhs) (local.get $n))) + (local.set $state1 + (i31.get_s + (ref.cast (ref i31) + (array.get $block + (ref.cast (ref $block) + (array.get $block (local.get $env) + (global.get $env_s_stack))) + (local.get $sp))))) + (local.set $n1 (call $get (local.get $tbl_gindex) (local.get $m))) + (local.set $n2 (i32.add (local.get $n1) (local.get $state1))) + (block $cont + (if (i32.and + (i32.ne (local.get $n1) (i32.const 0)) + (i32.ge_s (local.get $n2) (i32.const 0))) + (then + (if (i32.le_s (local.get $n2) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $tables) + (global.get $tbl_tablesize))))) + (then + (if (i32.eq + (call $get (local.get $tbl_check) + (local.get $n2)) + (local.get $state1)) + (then + (local.set $state + (call $get (local.get $tbl_table) + (local.get $n2))) + (br $cont))))))) + (local.set $state + (call $get (local.get $tbl_dgoto) (local.get $m)))) + (if (i32.ge_s (local.get $sp) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $env) + (global.get $env_stacksize))))) + (then + (local.set $res (global.get $GROW_STACKS_2)) + (br $exit)))) + ;; Fall through + ;; STACKS_GROWN_2: + (local.set $res (global.get $COMPUTE_SEMANTIC_ACTION)) + (br $exit)) + ;; SEMANTIC_ACTION_COMPUTED: + (array.set $block + (ref.cast (ref $block) + (array.get $block (local.get $env) (global.get $env_s_stack))) + (i32.add (local.get $sp) (i32.const 1)) + (ref.i31 (local.get $state))) + (array.set $block + (ref.cast (ref $block) + (array.get $block (local.get $env) (global.get $env_v_stack))) + (i32.add (local.get $sp) (i32.const 1)) + (local.get $varg)) + (local.set $asp + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $env) (global.get $env_asp))))) + (array.set $block + (ref.cast (ref $block) + (array.get $block (local.get $env) + (global.get $env_symb_end_stack))) + (i32.add (local.get $sp) (i32.const 1)) + (array.get $block + (ref.cast (ref $block) + (array.get $block (local.get $env) + (global.get $env_symb_end_stack))) + (i32.add (local.get $asp) (i32.const 1)))) + (if (i32.gt_s (local.get $sp) (local.get $asp)) + (then + ;; This is an epsilon production. Take symb_start equal to symb_end. + (array.set $block + (ref.cast (ref $block) + (array.get $block (local.get $env) + (global.get $env_symb_start_stack))) + (i32.add (local.get $sp) (i32.const 1)) + (array.get $block + (ref.cast (ref $block) + (array.get $block (local.get $env) + (global.get $env_symb_end_stack))) + (i32.add (local.get $asp) (i32.const 1)))))) + (local.set $cmd (global.get $loop)) + (br $next)) + ;; default: + (return (ref.i31 (global.get $RAISE_PARSE_ERROR))))) + ;; SAVE + (array.set $block (local.get $env) (global.get $env_sp) + (ref.i31 (local.get $sp))) + (array.set $block (local.get $env) (global.get $env_state) + (ref.i31 (local.get $state))) + (array.set $block (local.get $env) (global.get $env_errflag) + (ref.i31 (local.get $errflag))) + (ref.i31 (local.get $res))) + + (func (export "caml_set_parser_trace") (param (ref eq)) (result (ref eq)) + (local $oldflag i32) + (local.set $oldflag (global.get $caml_parser_trace)) + (global.set $caml_parser_trace + (i31.get_s (ref.cast (ref i31) (local.get 0)))) + (ref.i31 (local.get $oldflag))) +) diff --git a/runtime/wasm/printexc.wat b/runtime/wasm/printexc.wat new file mode 100644 index 0000000000..84b616829d --- /dev/null +++ b/runtime/wasm/printexc.wat @@ -0,0 +1,155 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "jslib" "caml_jsstring_of_string" + (func $caml_jsstring_of_string (param (ref eq)) (result (ref eq)))) + (import "fail" "caml_is_special_exception" + (func $caml_is_special_exception (param (ref eq)) (result i32))) + (import "ints" "caml_format_int" + (func $caml_format_int + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + + (type $buffer + (struct + (field (mut i32)) + (field (ref $string)))) + + (func $add_char (param $buf (ref $buffer)) (param $c i32) + (local $pos i32) + (local $data (ref $string)) + (local.set $pos (struct.get $buffer 0 (local.get $buf))) + (local.set $data (struct.get $buffer 1 (local.get $buf))) + (if (i32.lt_u (local.get $pos) (array.len (local.get $data))) + (then + (array.set $string (local.get $data) (local.get $pos) (local.get $c)) + (struct.set $buffer 0 (local.get $buf) + (i32.add (local.get $pos) (i32.const 1)))))) + + (func $add_string (param $buf (ref $buffer)) (param $v (ref eq)) + (local $pos i32) (local $len i32) + (local $data (ref $string)) + (local $s (ref $string)) + (local.set $pos (struct.get $buffer 0 (local.get $buf))) + (local.set $data (struct.get $buffer 1 (local.get $buf))) + (local.set $s (ref.cast (ref $string) (local.get $v))) + (local.set $len (array.len (local.get $s))) + (if (i32.gt_u (i32.add (local.get $pos) (local.get $len)) + (array.len (local.get $data))) + (then + (local.set $len + (i32.sub (array.len (local.get $data)) (local.get $pos))))) + (array.copy $string $string + (local.get $data) (local.get $pos) + (local.get $s) (i32.const 0) + (local.get $len)) + (struct.set $buffer 0 (local.get $buf) + (i32.add (local.get $pos) (local.get $len)))) + + (func (export "caml_format_exception") (param (ref eq)) (result (ref eq)) + (local $exn (ref $block)) + (local $buf (ref $buffer)) + (local $v (ref eq)) + (local $bucket (ref $block)) + (local $i i32) (local $len i32) + (local $s (ref $string)) + (local.set $exn (ref.cast (ref $block) (local.get 0))) + (if (result (ref eq)) + (ref.eq (array.get $block (local.get $exn) (i32.const 0)) + (ref.i31 (i32.const 0))) + (then + (local.set $buf + (struct.new $buffer + (i32.const 0) + (array.new $string (i32.const 0) (i32.const 256)))) + (call $add_string + (local.get $buf) + (array.get $block + (ref.cast (ref $block) + (array.get $block (local.get $exn) (i32.const 1))) + (i32.const 1))) + (local.set $bucket + (block $continue (result (ref $block)) + (block $default + (br_if $default + (i32.ne (array.len (local.get $exn)) (i32.const 3))) + (br_if $default + (i32.eqz + (call $caml_is_special_exception + (array.get $block (local.get $exn) (i32.const 1))))) + (local.set $v + (array.get $block (local.get $exn) (i32.const 2))) + (br_if $default + (i32.eqz (ref.test (ref $block) (local.get $v)))) + (local.set $bucket (ref.cast (ref $block) (local.get $v))) + (br_if $default + (i32.eqz + (ref.eq + (array.get $block (local.get $bucket) (i32.const 0)) + (ref.i31 (i32.const 0))))) + (local.set $i (i32.const 1)) + (br $continue (local.get $bucket))) + (local.set $i (i32.const 2)) + (local.get $exn))) + (local.set $len (array.len (local.get $bucket))) + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $add_char (local.get $buf) (i32.const 40)) ;; '\(' + (loop $loop + (local.set $v + (array.get $block (local.get $bucket) (local.get $i))) + (if (ref.test (ref i31) (local.get $v)) + (then + (call $add_string (local.get $buf) + (call $caml_format_int + (array.new_fixed $string 2 + (i32.const 37) (i32.const 100)) ;; %d + (ref.cast (ref i31) (local.get $v))))) + (else (if (ref.test (ref $string) (local.get $v)) + (then + (call $add_char (local.get $buf) + (i32.const 34)) ;; '\"' + (call $add_string (local.get $buf) (local.get $v)) + (call $add_char (local.get $buf) + (i32.const 34))) ;; '\"' + (else + (call $add_char (local.get $buf) + (i32.const 95)))))) ;; '_' + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (call $add_char (local.get $buf) + (i32.const 44)) ;; ',' + (call $add_char (local.get $buf) + (i32.const 32)) ;; ' ' + (br $loop)))) + (call $add_char (local.get $buf) (i32.const 41)))) ;; '\)' + (local.set $s + (array.new $string (i32.const 0) + (struct.get $buffer 0 (local.get $buf)))) + (array.copy $string $string + (local.get $s) (i32.const 0) + (struct.get $buffer 1 (local.get $buf)) (i32.const 0) + (struct.get $buffer 0 (local.get $buf))) + (local.get $s)) + (else + (array.get $block (local.get $exn) (i32.const 1))))) +) diff --git a/runtime/wasm/prng.wat b/runtime/wasm/prng.wat new file mode 100644 index 0000000000..4918eaa0bf --- /dev/null +++ b/runtime/wasm/prng.wat @@ -0,0 +1,95 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "bindings" "ta_get_i32" + (func $ta_get_i32 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "ta_set_i32" + (func $ta_set_i32 (param (ref extern)) (param i32) (param i32))) + (import "bigarray" "caml_ba_get_data" + (func $caml_ba_get_data (param (ref eq)) (result (ref extern)))) + + (func (export "caml_lxm_next") (param $v (ref eq)) (result i64) + (local $data (ref extern)) + (local $a i64) (local $s i64) (local $q0 i64) (local $q1 i64) + (local $z i64) + (local.set $data (call $caml_ba_get_data (local.get $v))) + (local.set $a + (i64.or + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) (i32.const 0))) + (i64.shl + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) (i32.const 1))) + (i64.const 32)))) + (local.set $s + (i64.or + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) (i32.const 2))) + (i64.shl + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) (i32.const 3))) + (i64.const 32)))) + (local.set $q0 + (i64.or + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) (i32.const 4))) + (i64.shl + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) (i32.const 5))) + (i64.const 32)))) + (local.set $q1 + (i64.or + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) (i32.const 6))) + (i64.shl + (i64.extend_i32_u + (call $ta_get_i32 (local.get $data) (i32.const 7))) + (i64.const 32)))) + (local.set $z (i64.add (local.get $s) (local.get $q0))) + (local.set $z + (i64.mul (i64.xor (local.get $z) + (i64.shr_u (local.get $z) (i64.const 32))) + (i64.const 0xdaba0b6eb09322e3))) + (local.set $z + (i64.mul (i64.xor (local.get $z) + (i64.shr_u (local.get $z) (i64.const 32))) + (i64.const 0xdaba0b6eb09322e3))) + (local.set $z + (i64.xor (local.get $z) (i64.shr_u (local.get $z) (i64.const 32)))) + (local.set $s + (i64.add (i64.mul (local.get $s) (i64.const 0xd1342543de82ef95)) + (local.get $a))) + (call $ta_set_i32 (local.get $data) (i32.const 2) + (i32.wrap_i64 (local.get $s))) + (call $ta_set_i32 (local.get $data) (i32.const 3) + (i32.wrap_i64 (i64.shr_u (local.get $s) (i64.const 32)))) + (local.set $q1 (i64.xor (local.get $q1) (local.get $q0))) + (local.set $q0 (i64.rotl (local.get $q0) (i64.const 24))) + (local.set $q0 (i64.xor (i64.xor (local.get $q0) (local.get $q1)) + (i64.shl (local.get $q1) (i64.const 16)))) + (local.set $q1 (i64.rotl (local.get $q1) (i64.const 37))) + (call $ta_set_i32 (local.get $data) (i32.const 4) + (i32.wrap_i64 (local.get $q0))) + (call $ta_set_i32 (local.get $data) (i32.const 5) + (i32.wrap_i64 (i64.shr_u (local.get $q0) (i64.const 32)))) + (call $ta_set_i32 (local.get $data) (i32.const 6) + (i32.wrap_i64 (local.get $q1))) + (call $ta_set_i32 (local.get $data) (i32.const 7) + (i32.wrap_i64 (i64.shr_u (local.get $q1) (i64.const 32)))) + (return (local.get $z))) +) diff --git a/runtime/wasm/runtime.js b/runtime/wasm/runtime.js new file mode 100644 index 0000000000..03a88e629f --- /dev/null +++ b/runtime/wasm/runtime.js @@ -0,0 +1,565 @@ +// Wasm_of_ocaml runtime support +// http://www.ocsigen.org/js_of_ocaml/ +// +// 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. + +(js) => async (args) => { + // biome-ignore lint/suspicious/noRedundantUseStrict: + "use strict"; + const { link, src, generated } = args; + + const isNode = globalThis?.process?.versions?.node; + + const math = { + cos: Math.cos, + sin: Math.sin, + tan: Math.tan, + acos: Math.acos, + asin: Math.asin, + atan: Math.atan, + cosh: Math.cosh, + sinh: Math.sinh, + tanh: Math.tanh, + acosh: Math.acosh, + asinh: Math.asinh, + atanh: Math.atanh, + cbrt: Math.cbrt, + exp: Math.exp, + expm1: Math.expm1, + log: Math.log, + log1p: Math.log1p, + log2: Math.log2, + log10: Math.log10, + atan2: Math.atan2, + hypot: Math.hypot, + pow: Math.pow, + fmod: (x, y) => x % y, + }; + + const typed_arrays = [ + Float32Array, + Float64Array, + Int8Array, + Uint8Array, + Int16Array, + Uint16Array, + Int32Array, + Int32Array, + Int32Array, + Int32Array, + Float32Array, + Float64Array, + Uint8Array, + Uint8ClampedArray, + ]; + + const fs = isNode && require("node:fs"); + + const fs_cst = fs?.constants; + + const open_flags = fs + ? [ + fs_cst.RDONLY, + fs_cst.O_WRONLY, + fs_cst.O_APPEND, + fs_cst.O_CREAT, + fs_cst.O_TRUNC, + fs_cst.O_EXCL, + fs_cst.O_NONBLOCK, + ] + : []; + + var out_channels = { + map: new WeakMap(), + set: new Set(), + finalization: new FinalizationRegistry((ref) => + out_channels.set.delete(ref), + ), + }; + + function register_channel(ch) { + const ref = new WeakRef(ch); + out_channels.map.set(ch, ref); + out_channels.set.add(ref); + out_channels.finalization.register(ch, ref, ch); + } + + function unregister_channel(ch) { + const ref = out_channels.map.get(ch); + if (ref) { + out_channels.map.delete(ch); + out_channels.set.delete(ref); + out_channels.finalization.unregister(ch); + } + } + + function channel_list() { + return [...out_channels.set].map((ref) => ref.deref()).filter((ch) => ch); + } + + var start_fiber; + + function make_suspending(f) { + return WebAssembly?.Suspending ? new WebAssembly.Suspending(f) : f; + } + function make_promising(f) { + return WebAssembly?.promising && f ? WebAssembly.promising(f) : f; + } + + const decoder = new TextDecoder("utf-8", { ignoreBOM: 1 }); + const encoder = new TextEncoder(); + + function hash_int(h, d) { + d = Math.imul(d, 0xcc9e2d51 | 0); + d = (d << 15) | (d >>> 17); // ROTL32(d, 15); + d = Math.imul(d, 0x1b873593); + h ^= d; + h = (h << 13) | (h >>> 19); //ROTL32(h, 13); + return (((h + (h << 2)) | 0) + (0xe6546b64 | 0)) | 0; + } + function hash_string(h, s) { + for (var i = 0; i < s.length; i++) h = hash_int(h, s.charCodeAt(i)); + return h ^ s.length; + } + + const bindings = { + jstag: + WebAssembly.JSTag || + // ZZZ not supported in Firefox yet + new WebAssembly.Tag({ parameters: ["externref"], results: [] }), + identity: (x) => x, + from_bool: (x) => !!x, + get: (x, y) => x[y], + set: (x, y, z) => (x[y] = z), + delete: (x, y) => delete x[y], + instanceof: (x, y) => x instanceof y, + typeof: (x) => typeof x, + // biome-ignore lint/suspicious/noDoubleEquals: + equals: (x, y) => x == y, + strict_equals: (x, y) => x === y, + fun_call: (f, o, args) => f.apply(o, args), + meth_call: (o, f, args) => o[f].apply(o, args), + new_array: (n) => new Array(n), + new_obj: () => ({}), + new: (c, args) => new c(...args), + global_this: globalThis, + iter_props: (o, f) => { + for (var nm in o) if (Object.hasOwn(o, nm)) f(nm); + }, + array_length: (a) => a.length, + array_get: (a, i) => a[i], + array_set: (a, i, v) => (a[i] = v), + read_string: (l) => decoder.decode(new Uint8Array(buffer, 0, l)), + read_string_stream: (l, stream) => + decoder.decode(new Uint8Array(buffer, 0, l), { stream }), + append_string: (s1, s2) => s1 + s2, + write_string: (s) => { + var start = 0, + len = s.length; + for (;;) { + const { read, written } = encoder.encodeInto( + s.slice(start), + out_buffer, + ); + len -= read; + if (!len) return written; + caml_extract_string(written); + start += read; + } + }, + ta_create: (k, sz) => new typed_arrays[k](sz), + ta_normalize: (a) => + a instanceof Uint32Array + ? new Int32Array(a.buffer, a.byteOffset, a.length) + : a, + ta_kind: (a) => typed_arrays.findIndex((c) => a instanceof c), + ta_length: (a) => a.length, + ta_get_f64: (a, i) => a[i], + ta_get_f32: (a, i) => a[i], + ta_get_i32: (a, i) => a[i], + ta_get_i16: (a, i) => a[i], + ta_get_ui16: (a, i) => a[i], + ta_get_i8: (a, i) => a[i], + ta_get_ui8: (a, i) => a[i], + ta_get16_ui8: (a, i) => a[i] | (a[i + 1] << 8), + ta_get32_ui8: (a, i) => + a[i] | (a[i + 1] << 8) | (a[i + 2] << 16) | (a[i + 3] << 24), + ta_set_f64: (a, i, v) => (a[i] = v), + ta_set_f32: (a, i, v) => (a[i] = v), + ta_set_i32: (a, i, v) => (a[i] = v), + ta_set_i16: (a, i, v) => (a[i] = v), + ta_set_ui16: (a, i, v) => (a[i] = v), + ta_set_i8: (a, i, v) => (a[i] = v), + ta_set_ui8: (a, i, v) => (a[i] = v), + ta_set16_ui8: (a, i, v) => { + a[i] = v; + a[i + 1] = v >> 8; + }, + ta_set32_ui8: (a, i, v) => { + a[i] = v; + a[i + 1] = v >> 8; + a[i + 2] = v >> 16; + a[i + 3] = v >> 24; + }, + ta_fill: (a, v) => a.fill(v), + ta_blit: (s, d) => d.set(s), + ta_subarray: (a, i, j) => a.subarray(i, j), + ta_set: (a, b, i) => a.set(b, i), + ta_new: (len) => new Uint8Array(len), + ta_copy: (ta, t, s, n) => ta.copyWithin(t, s, n), + ta_bytes: (a) => + new Uint8Array(a.buffer, a.byteOffset, a.length * a.BYTES_PER_ELEMENT), + ta_blit_from_string: (s, p1, a, p2, l) => { + for (let i = 0; i < l; i++) a[p2 + i] = string_get(s, p1 + i); + }, + ta_blit_to_string: (a, p1, s, p2, l) => { + for (let i = 0; i < l; i++) string_set(s, p2 + i, a[p1 + i]); + }, + wrap_callback: (f) => + function () { + var n = arguments.length; + if (n > 0) { + var args = new Array(n); + for (var i = 0; i < n; i++) args[i] = arguments[i]; + } else { + args = [undefined]; + } + return caml_callback(f, args.length, args, 1); + }, + wrap_callback_args: (f) => + function () { + var n = arguments.length; + var args = new Array(n); + for (var i = 0; i < n; i++) args[i] = arguments[i]; + return caml_callback(f, 1, [args], 0); + }, + wrap_callback_strict: (arity, f) => + function () { + var n = arguments.length; + var args = new Array(arity); + var len = Math.min(arguments.length, arity); + for (var i = 0; i < len; i++) args[i] = arguments[i]; + return caml_callback(f, arity, args, 0); + }, + wrap_callback_unsafe: (f) => + function () { + var n = arguments.length; + var args = new Array(n); + for (var i = 0; i < n; i++) args[i] = arguments[i]; + return caml_callback(f, args.length, args, 2); + }, + wrap_meth_callback: (f) => + function () { + var n = arguments.length; + var args = new Array(n + 1); + args[0] = this; + for (var i = 0; i < n; i++) args[i + 1] = arguments[i]; + return caml_callback(f, args.length, args, 1); + }, + wrap_meth_callback_args: (f) => + function () { + var n = arguments.length; + var args = new Array(n); + for (var i = 0; i < n; i++) args[i] = arguments[i]; + return caml_callback(f, 2, [this, args], 0); + }, + wrap_meth_callback_strict: (arity, f) => + function () { + var args = new Array(arity + 1); + var len = Math.min(arguments.length, arity); + args[0] = this; + for (var i = 0; i < len; i++) args[i + 1] = arguments[i]; + return caml_callback(f, args.length, args, 0); + }, + wrap_meth_callback_unsafe: (f) => + function () { + var n = arguments.length; + var args = new Array(n + 1); + args[0] = this; + for (var i = 0; i < n; i++) args[i + 1] = arguments[i]; + return caml_callback(f, args.length, args, 2); + }, + wrap_fun_arguments: (f) => + function () { + return f(arguments); + }, + format_float: (prec, conversion, pad, x) => { + function toFixed(x, dp) { + if (Math.abs(x) < 1.0) { + return x.toFixed(dp); + } else { + var e = Number.parseInt(x.toString().split("+")[1]); + if (e > 20) { + e -= 20; + x /= Math.pow(10, e); + x += new Array(e + 1).join("0"); + if (dp > 0) { + x = x + "." + new Array(dp + 1).join("0"); + } + return x; + } else return x.toFixed(dp); + } + } + switch (conversion) { + case 0: + var s = x.toExponential(prec); + // exponent should be at least two digits + var i = s.length; + if (s.charAt(i - 3) === "e") + s = s.slice(0, i - 1) + "0" + s.slice(i - 1); + break; + case 1: + s = toFixed(x, prec); + break; + case 2: + prec = prec ? prec : 1; + s = x.toExponential(prec - 1); + var j = s.indexOf("e"); + var exp = +s.slice(j + 1); + if (exp < -4 || x >= 1e21 || x.toFixed(0).length > prec) { + // remove trailing zeroes + var i = j - 1; + while (s.charAt(i) === "0") i--; + if (s.charAt(i) === ".") i--; + s = s.slice(0, i + 1) + s.slice(j); + i = s.length; + if (s.charAt(i - 3) === "e") + s = s.slice(0, i - 1) + "0" + s.slice(i - 1); + break; + } else { + var p = prec; + if (exp < 0) { + p -= exp + 1; + s = x.toFixed(p); + } else while (((s = x.toFixed(p)), s.length > prec + 1)) p--; + if (p) { + // remove trailing zeroes + var i = s.length - 1; + while (s.charAt(i) === "0") i--; + if (s.charAt(i) === ".") i--; + s = s.slice(0, i + 1); + } + } + break; + } + return pad ? " " + s : s; + }, + gettimeofday: () => new Date().getTime() / 1000, + gmtime: (t) => { + var d = new Date(t * 1000); + var d_num = d.getTime(); + var januaryfirst = new Date(Date.UTC(d.getUTCFullYear(), 0, 1)).getTime(); + var doy = Math.floor((d_num - januaryfirst) / 86400000); + return caml_alloc_tm( + d.getUTCSeconds(), + d.getUTCMinutes(), + d.getUTCHours(), + d.getUTCDate(), + d.getUTCMonth(), + d.getUTCFullYear() - 1900, + d.getUTCDay(), + doy, + false, + ); + }, + localtime: (t) => { + var d = new Date(t * 1000); + var d_num = d.getTime(); + var januaryfirst = new Date(d.getFullYear(), 0, 1).getTime(); + var doy = Math.floor((d_num - januaryfirst) / 86400000); + var jan = new Date(d.getFullYear(), 0, 1); + var jul = new Date(d.getFullYear(), 6, 1); + var stdTimezoneOffset = Math.max( + jan.getTimezoneOffset(), + jul.getTimezoneOffset(), + ); + return caml_alloc_tm( + d.getSeconds(), + d.getMinutes(), + d.getHours(), + d.getDate(), + d.getMonth(), + d.getFullYear() - 1900, + d.getDay(), + doy, + d.getTimezoneOffset() < stdTimezoneOffset, + ); + }, + mktime: (year, month, day, h, m, s) => + new Date(year, month, day, h, m, s).getTime(), + random_seed: () => crypto.getRandomValues(new Int32Array(12)), + open: (p, flags, perm) => + fs.openSync( + p, + open_flags.reduce((f, v, i) => (flags & (1 << i) ? f | v : f), 0), + perm, + ), + close: (fd) => fs.closeSync(fd), + write: (fd, b, o, l, p) => + fs + ? fs.writeSync(fd, b, o, l, p === null ? p : Number(p)) + : (console[fd === 2 ? "error" : "log"]( + typeof b === "string" ? b : decoder.decode(b.slice(o, o + l)), + ), + l), + read: (fd, b, o, l, p) => fs.readSync(fd, b, o, l, p), + file_size: (fd) => fs.fstatSync(fd, { bigint: true }).size, + register_channel, + unregister_channel, + channel_list, + exit: (n) => isNode && process.exit(n), + argv: () => (isNode ? process.argv.slice(1) : ["a.out"]), + getenv: (n) => (isNode ? process.env[n] : null), + system: (c) => { + var res = require("node:child_process").spawnSync(c, { + shell: true, + stdio: "inherit", + }); + if (res.error) throw res.error; + return res.signal ? 255 : res.status; + }, + time: () => performance.now(), + getcwd: () => (isNode ? process.cwd() : "/static"), + chdir: (x) => process.chdir(x), + mkdir: (p, m) => fs.mkdirSync(p, m), + unlink: (p) => fs.unlinkSync(p), + readdir: (p) => fs.readdirSync(p), + file_exists: (p) => +fs.existsSync(p), + is_directory: (p) => +fs.lstatSync(p).isDirectory(), + rename: (o, n) => fs.renameSync(o, n), + throw: (e) => { + throw e; + }, + start_fiber: (x) => start_fiber(x), + suspend_fiber: make_suspending((f, env) => new Promise((k) => f(k, env))), + resume_fiber: (k, v) => k(v), + weak_new: (v) => new WeakRef(v), + weak_deref: (w) => { + var v = w.deref(); + return v === undefined ? null : v; + }, + weak_map_new: () => new WeakMap(), + map_new: () => new Map(), + map_get: (m, x) => { + var v = m.get(x); + return v === undefined ? null : v; + }, + map_set: (m, x, v) => m.set(x, v), + map_delete: (m, x) => m.delete(x), + log: (x) => console.log(x), + }; + const string_ops = { + test: (v) => +(typeof v === "string"), + compare: (s1, s2) => (s1 < s2 ? -1 : +(s1 > s2)), + hash: hash_string, + decodeStringFromUTF8Array: () => "", + encodeStringToUTF8Array: () => 0, + fromCharCodeArray: () => "", + }; + const imports = Object.assign( + { + Math: math, + bindings, + js, + "wasm:js-string": string_ops, + "wasm:text-decoder": string_ops, + "wasm:text-encoder": string_ops, + env: {}, + }, + generated, + ); + const options = { builtins: ["js-string", "text-decoder", "text-encoder"] }; + + function loadRelative(src) { + const path = require("node:path"); + const f = path.join(path.dirname(require.main.filename), src); + return require("node:fs/promises").readFile(f); + } + const fetchBase = globalThis?.document?.currentScript?.src; + function fetchRelative(src) { + const url = fetchBase ? new URL(src, fetchBase) : 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 = []; + async function loadModule(module, isRuntime) { + 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( + isRuntime ? imports.env : imports.OCaml, + wasmModule.instance.exports, + ); + } + const promise = instantiate(); + deps.push(promise); + return promise; + } + async function loadModules(lst) { + for (const module of lst) { + await loadModule(module); + } + } + await loadModule(link[0], 1); + if (link.length > 1) { + await loadModule(link[1]); + const workers = new Array(20) + .fill(link.slice(2).values()) + .map(loadModules); + await Promise.all(workers); + } + return { instance: { exports: Object.assign(imports.env, imports.OCaml) } }; + } + const wasmModule = await instantiateFromDir(); + + var { + caml_callback, + caml_alloc_tm, + caml_start_fiber, + caml_handle_uncaught_exception, + caml_buffer, + caml_extract_string, + string_get, + string_set, + _initialize, + } = wasmModule.instance.exports; + + var buffer = caml_buffer?.buffer; + var out_buffer = buffer && new Uint8Array(buffer, 0, buffer.length); + + start_fiber = make_promising(caml_start_fiber); + var _initialize = make_promising(_initialize); + var process = globalThis.process; + if (process && process.on) { + process.on("uncaughtException", (err, origin) => + caml_handle_uncaught_exception(err), + ); + } else if (globalThis.addEventListener) { + globalThis.addEventListener( + "error", + (event) => event.error && caml_handle_uncaught_exception(event.error), + ); + } + await _initialize(); +}; diff --git a/runtime/wasm/runtime_events.wat b/runtime/wasm/runtime_events.wat new file mode 100644 index 0000000000..9ac0f5f2f9 --- /dev/null +++ b/runtime/wasm/runtime_events.wat @@ -0,0 +1,69 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + + (type $block (array (mut (ref eq)))) + + (global $caml_custom_event_index (mut i32) (i32.const 0)) + + (func (export "caml_runtime_events_user_register") + (param $evname (ref eq)) (param $evtag (ref eq)) (param $evtype (ref eq)) + (result (ref eq)) + (global.set $caml_custom_event_index + (i32.add (global.get $caml_custom_event_index) (i32.const 1))) + (array.new_fixed $block 5 + (ref.i31 (i32.const 0)) + (ref.i31 (global.get $caml_custom_event_index)) + (local.get $evname) + (local.get $evtag) + (local.get $evtype))) + + (func (export "caml_runtime_events_user_resolve") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_runtime_events_start") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_runtime_events_pause") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_runtime_events_resume") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_runtime_events_are_active") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + ;; TODO: use Javascript function + ;;(func (export "caml_runtime_events_create_cursor") + ;; (param (ref eq)) (result (ref eq)) + ;; (ref.i31 (i32.const 0))) + + (func (export "caml_runtime_events_free_cursor") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_runtime_events_read_poll") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_runtime_events_path") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) diff --git a/runtime/wasm/stdlib.wat b/runtime/wasm/stdlib.wat new file mode 100644 index 0000000000..89ca56e627 --- /dev/null +++ b/runtime/wasm/stdlib.wat @@ -0,0 +1,240 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "hash" "caml_string_hash" + (func $caml_string_hash + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "string" "caml_string_equal" + (func $caml_string_equal + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "jslib" "caml_string_of_jsstring" + (func $caml_string_of_jsstring (param (ref eq)) (result (ref eq)))) + (import "jslib" "caml_jsstring_of_string" + (func $caml_jsstring_of_string (param (ref eq)) (result (ref eq)))) + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "obj" "caml_callback_1" + (func $caml_callback_1 + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "obj" "caml_callback_2" + (func $caml_callback_2 + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "bindings" "write" (func $write (param i32) (param anyref))) + (import "string" "caml_string_concat" + (func $caml_string_concat + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "printexc" "caml_format_exception" + (func $caml_format_exception (param (ref eq)) (result (ref eq)))) + (import "sys" "ocaml_exit" (tag $ocaml_exit (param i32))) + (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) + (import "bindings" "exit" (func $exit (param i32))) + (import "bindings" "throw" (func $throw (param externref))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + + (type $assoc + (struct + (field (ref $string)) + (field (mut (ref eq))) + (field (mut (ref null $assoc))))) + + (type $assoc_array (array (mut (ref null $assoc)))) + + (global $Named_value_size i32 (i32.const 13)) + + (global $named_value_table (ref $assoc_array) + (array.new $assoc_array (ref.null $assoc) (global.get $Named_value_size))) + + (func $find_named_value + (param $s (ref eq)) (param $l (ref null $assoc)) (result (ref null $assoc)) + (local $a (ref $assoc)) + (block $tail (result (ref null $assoc)) + (loop $loop + (local.set $a + (br_on_cast_fail $tail (ref null eq) (ref $assoc) (local.get $l))) + (if (i31.get_u + (ref.cast (ref i31) + (call $caml_string_equal + (local.get $s) + (struct.get $assoc 0 (local.get $a))))) + (then + (return (local.get $a)))) + (local.set $l (struct.get $assoc 2 (local.get $a))) + (br $loop)))) + + (func $caml_named_value (export "caml_named_value") + (param $s (ref $string)) (result (ref null eq)) + (block $not_found + (return + (struct.get $assoc 1 + (br_on_null $not_found + (call $find_named_value + (local.get $s) + (array.get $assoc_array (global.get $named_value_table) + (i32.rem_u + (i31.get_s + (ref.cast (ref i31) + (call $caml_string_hash + (ref.i31 (i32.const 0)) (local.get $s)))) + (global.get $Named_value_size)))))))) + (return (ref.null eq))) + + (func (export "caml_register_named_value") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (local $h i32) + (local $r (ref null $assoc)) + (local.set $h + (i32.rem_u + (i31.get_s + (ref.cast (ref i31) + (call $caml_string_hash + (ref.i31 (i32.const 0)) (local.get 0)))) + (global.get $Named_value_size))) + (local.set $r + (array.get $assoc_array + (global.get $named_value_table) (local.get $h))) + (block $not_found + (struct.set $assoc 1 + (br_on_null $not_found + (call $find_named_value (local.get 0) (local.get $r))) + (local.get 1)) + (return (ref.i31 (i32.const 0)))) + (array.set $assoc_array + (global.get $named_value_table) (local.get $h) + (struct.new $assoc + (ref.cast (ref $string) (local.get 0)) + (local.get 1) (local.get $r))) + (ref.i31 (i32.const 0))) + + ;; Used only for testing (tests-jsoo/bin), but inconvenient to pull out + (func (export "caml_unregister_named_value") + (param $name (ref eq)) (result (ref eq)) + (local $h i32) + (local $r (ref null $assoc)) (local $a (ref $assoc)) + (local.set $h + (i32.rem_u + (i31.get_s + (ref.cast (ref i31) + (call $caml_string_hash + (ref.i31 (i32.const 0)) (local.get $name)))) + (global.get $Named_value_size))) + (local.set $r + (array.get $assoc_array + (global.get $named_value_table) (local.get $h))) + (block $done + (local.set $a (br_on_null $done (local.get $r))) + (local.set $r (struct.get $assoc 2 (local.get $a))) + (if (i31.get_u + (ref.cast (ref i31) + (call $caml_string_equal + (local.get $name) + (struct.get $assoc 0 (local.get $a))))) + (then + (array.set $assoc_array + (global.get $named_value_table) (local.get $h) + (local.get $r)) + (br $done))) + (loop $loop + (local.set $a (br_on_null $done (local.get $r))) + (if (i31.get_u + (ref.cast (ref i31) + (call $caml_string_equal + (local.get $name) + (struct.get $assoc 0 (local.get $a))))) + (then + (struct.set $assoc 2 (local.get $r) + (struct.get $assoc 2 (local.get $a))) + (br $done))) + (local.set $r (struct.get $assoc 2 (local.get $a))) + (br $loop))) + (ref.i31 (i32.const 0))) + + (global $caml_global_data (export "caml_global_data") (mut (ref $block)) + (array.new $block (ref.i31 (i32.const 0)) (i32.const 12))) + + (func (export "caml_register_global") + (param (ref eq)) (param $v (ref eq)) (param (ref eq)) (result (ref eq)) + (local $i i32) + (local.set $i (i31.get_u (ref.cast (ref i31) (local.get 0)))) + (if (i32.lt_u (local.get $i) (array.len (global.get $caml_global_data))) + (then + (array.set $block (global.get $caml_global_data) + (local.get $i) (local.get $v)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_get_global_data") (param (ref eq)) (result (ref eq)) + (global.get $caml_global_data)) + + (type $func (func (result (ref eq)))) + + (data $fatal_error "Fatal error: exception ") + (data $handle_uncaught_exception "Printexc.handle_uncaught_exception") + (data $do_at_exit "Pervasives.do_at_exit") + + (global $uncaught_exception (mut externref) (ref.null extern)) + + (func $reraise_exception (result (ref eq)) + (call $throw (global.get $uncaught_exception)) + (ref.i31 (i32.const 0))) + + (func (export "caml_handle_uncaught_exception") (param $exn externref) + (global.set $uncaught_exception (local.get $exn)) + (call $caml_main (ref.func $reraise_exception))) + + (func $caml_main (export "caml_main") (param $start (ref func)) + (local $exn (ref eq)) + (try + (do + (drop (call_ref $func (ref.cast (ref $func) (local.get $start))))) + (catch $ocaml_exit + (call $exit (pop i32))) + (catch $ocaml_exception + (local.set $exn (pop (ref eq))) + (block $exit + (block $not_registered + (drop + (call $caml_callback_2 + (br_on_null $not_registered + (call $caml_named_value + (array.new_data $string + $handle_uncaught_exception + (i32.const 0) (i32.const 34)))) + (local.get $exn) + (ref.i31 (i32.const 0)))) + (br $exit)) + (block $null + (drop + (call $caml_callback_1 + (br_on_null $null + (call $caml_named_value + (array.new_data $string $do_at_exit + (i32.const 0) (i32.const 21)))) + (ref.i31 (i32.const 0))))) + (call $write (i32.const 2) + (call $unwrap + (call $caml_jsstring_of_string + (call $caml_string_concat + (array.new_data $string $fatal_error + (i32.const 0) (i32.const 23)) + (call $caml_string_concat + (call $caml_format_exception (local.get $exn)) + (array.new_fixed $string 1 + (i32.const 10)))))))) ;; `\n` + (call $exit (i32.const 2))))) +) diff --git a/runtime/wasm/str.wat b/runtime/wasm/str.wat new file mode 100644 index 0000000000..4fa9409ee7 --- /dev/null +++ b/runtime/wasm/str.wat @@ -0,0 +1,743 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + + (type $string (array (mut i8))) + (type $block (array (mut (ref eq)))) + + (type $char_table (array i8)) + (type $int_array (array (mut i32))) + + (global $re_word_letters (ref $char_table) + (array.new_fixed $char_table 32 + (i32.const 0x00) (i32.const 0x00) + (i32.const 0x00) (i32.const 0x00) ;; 0x00-0x1F: none + (i32.const 0x00) (i32.const 0x00) + (i32.const 0xFF) (i32.const 0x03) ;; 0x20-0x3F: digits 0-9 + (i32.const 0xFE) (i32.const 0xFF) + (i32.const 0xFF) (i32.const 0x87) ;; 0x40-0x5F: A to Z, _ + (i32.const 0xFE) (i32.const 0xFF) + (i32.const 0xFF) (i32.const 0x07) ;; 0x60-0x7F: a to z + (i32.const 0x00) (i32.const 0x00) + (i32.const 0x00) (i32.const 0x00) ;; 0x80-0x9F: none + (i32.const 0x00) (i32.const 0x00) + (i32.const 0x00) (i32.const 0x00) ;; 0xA0-0xBF: none + (i32.const 0xFF) (i32.const 0xFF) ;; 0xC0-0xDF: + (i32.const 0x7F) (i32.const 0xFF) ;; Latin-1 accented uppercase + (i32.const 0xFF) (i32.const 0xFF) ;; 0xE0-0xFF: + (i32.const 0x7F) (i32.const 0xFF))) ;; Latin-1 accented lowercase + + (type $stack (sub (struct (field (ref null $stack))))) + (type $pos + (sub final $stack + (struct + (field $pos_previous (ref null $stack)) + (field $pc i32) + (field $pos i32)))) + (type $undo + (sub final $stack + (struct + (field $undo_previous (ref null $stack)) + (field $tbl (ref $int_array)) + (field $idx i32) + (field $val i32)))) + + (func $is_word_letter (param $c i32) (result i32) + (i32.and (i32.const 1) + (i32.shr_u + (array.get_u $char_table (global.get $re_word_letters) + (i32.shr_u (local.get $c) (i32.const 3))) + (i32.and (local.get $c) (i32.const 7))))) + + (func $in_bitset (param $s (ref $string)) (param $c i32) (result i32) + (i32.and (i32.const 1) + (i32.shr_u + (array.get_u $string (local.get $s) + (i32.shr_u (local.get $c) (i32.const 3))) + (i32.and (local.get $c) (i32.const 7))))) + + (func $re_match + (param $vre (ref eq)) (param $s (ref $string)) (param $pos i32) + (param $accept_partial_match i32) (result (ref eq)) + (local $res (ref $block)) + (local $s' (ref $string)) (local $set (ref $string)) + (local $len i32) (local $instr i32) (local $arg i32) (local $i i32) + (local $j i32) (local $l i32) + (local $re (ref $block)) + (local $prog (ref $block)) + (local $cpool (ref $block)) + (local $normtable (ref $string)) + (local $numgroups i32) + (local $numregisters i32) + (local $group_start (ref $int_array)) + (local $group_end (ref $int_array)) + (local $re_register (ref $int_array)) + (local $pc i32) + (local $stack (ref null $stack)) + (local $u (ref $undo)) + (local $p (ref $pos)) + (local.set $len (array.len (local.get $s))) + (local.set $re (ref.cast (ref $block) (local.get $vre))) + (local.set $prog + (ref.cast (ref $block) + (array.get $block (local.get $re) (i32.const 1)))) + (local.set $cpool + (ref.cast (ref $block) + (array.get $block (local.get $re) (i32.const 2)))) + (local.set $normtable + (ref.cast (ref $string) + (array.get $block (local.get $re) (i32.const 3)))) + (local.set $numgroups + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $re) (i32.const 4))))) + (local.set $numregisters + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $re) (i32.const 5))))) + (local.set $group_start + (array.new $int_array (i32.const -1) (local.get $numgroups))) + (local.set $group_end + (array.new $int_array (i32.const -1) (local.get $numgroups))) + (local.set $re_register + (array.new $int_array (i32.const -1) (local.get $numregisters))) + (local.set $pc (i32.const 1)) + (array.set $int_array (local.get $group_start) (i32.const 0) + (local.get $pos)) + (block $reject + (block $ACCEPT + (loop $continue + (block $backtrack + (block $prefix_match + (block $CHECKPROGRESS + (block $SETMARK + (block $PUSHBACK + (block $GOTO + (block $SIMPLEPLUS + (block $SIMPLESTAR + (block $SIMPLEOPT + (block $REFGROUP + (block $ENDGROUP + (block $BEGGROUP + (block $WORDBOUNDARY + (block $EOL + (block $BOL + (block $CHARCLASS + (block $STRINGNORM + (block $STRING + (block $CHARNORM + (block $CHAR + (local.set $instr + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $prog) + (local.get $pc))))) + (local.set $pc + (i32.add (local.get $pc) (i32.const 1))) + (br_table + $CHAR $CHARNORM $STRING $STRINGNORM $CHARCLASS + $BOL $EOL $WORDBOUNDARY $BEGGROUP $ENDGROUP + $REFGROUP $ACCEPT $SIMPLEOPT $SIMPLESTAR + $SIMPLEPLUS $GOTO $PUSHBACK $SETMARK + $CHECKPROGRESS + (i32.and (local.get $instr) (i32.const 0xff)))) + ;; CHAR + (br_if $prefix_match + (i32.eq (local.get $pos) (local.get $len))) + (local.set $arg + (i32.shr_u (local.get $instr) (i32.const 8))) + (br_if $backtrack + (i32.ne (local.get $arg) + (array.get_u $string + (local.get $s) (local.get $pos)))) + (local.set $pos + (i32.add (local.get $pos) (i32.const 1))) + (br $continue)) + ;; CHARNORM + (br_if $prefix_match + (i32.eq (local.get $pos) (local.get $len))) + (local.set $arg + (i32.shr_u (local.get $instr) (i32.const 8))) + (br_if $backtrack + (i32.ne (local.get $arg) + (array.get_u $string + (local.get $normtable) + (array.get_u $string + (local.get $s) (local.get $pos))))) + (local.set $pos + (i32.add (local.get $pos) (i32.const 1))) + (br $continue)) + ;; STRING + (local.set $arg + (i32.shr_u (local.get $instr) (i32.const 8))) + (local.set $s' + (ref.cast (ref $string) + (array.get $block (local.get $cpool) + (i32.add (local.get $arg) (i32.const 1))))) + (local.set $i (i32.const 0)) + (local.set $l (array.len (local.get $s'))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (br_if $prefix_match + (i32.eq + (local.get $pos) (local.get $len))) + (br_if $backtrack + (i32.ne + (array.get_u $string (local.get $s') + (local.get $i)) + (array.get_u $string (local.get $s) + (local.get $pos)))) + (local.set $pos + (i32.add (local.get $pos) (i32.const 1))) + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $continue)) + ;; STRINGNORM + (local.set $arg + (i32.shr_u (local.get $instr) (i32.const 8))) + (local.set $s' + (ref.cast (ref $string) + (array.get $block (local.get $cpool) + (i32.add (local.get $arg) (i32.const 1))))) + (local.set $i (i32.const 0)) + (local.set $l (array.len (local.get $s'))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (br_if $prefix_match + (i32.eq + (local.get $pos) (local.get $len))) + (br_if $backtrack + (i32.ne + (array.get_u $string (local.get $s') + (local.get $i)) + (array.get_u $string + (local.get $normtable) + (array.get_u $string (local.get $s) + (local.get $pos))))) + (local.set $pos + (i32.add (local.get $pos) (i32.const 1))) + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $continue)) + ;; CHARCLASS + (br_if $prefix_match + (i32.eq (local.get $pos) (local.get $len))) + (local.set $arg + (i32.shr_u (local.get $instr) (i32.const 8))) + (br_if $backtrack + (i32.eqz + (call $in_bitset + (ref.cast (ref $string) + (array.get $block (local.get $cpool) + (i32.add (local.get $arg) + (i32.const 1)))) + (array.get_u $string (local.get $s) + (local.get $pos))))) + (local.set $pos + (i32.add (local.get $pos) (i32.const 1))) + (br $continue)) + ;; BOL + (br_if $continue (i32.eqz (local.get $pos))) + (br_if $continue + (i32.eq (i32.const 10) ;; '\n' + (array.get_u $string (local.get $s) + (i32.sub (local.get $pos) (i32.const 1))))) + (br $backtrack)) + ;; EOL + (br_if $continue + (i32.eq (local.get $pos) (local.get $len))) + (br_if $continue + (i32.eq (i32.const 10) ;; '\n' + (array.get_u $string (local.get $s) + (local.get $pos)))) + (br $backtrack)) + ;; WORDBOUNDARY + (if (i32.eqz (local.get $pos)) + (then + (br_if $prefix_match + (i32.eq (local.get $pos) (local.get $len))) + (br_if $continue + (call $is_word_letter + (array.get_u $string (local.get $s) + (local.get $pos)))) + (br $backtrack)) + (else + (if (i32.eq (local.get $pos) (local.get $len)) + (then + (br_if $continue + (call $is_word_letter + (array.get_u $string (local.get $s) + (i32.sub (local.get $pos) + (i32.const 1))))) + (br $backtrack)) + (else + (br_if $continue + (i32.ne + (call $is_word_letter + (array.get_u $string (local.get $s) + (i32.sub (local.get $pos) + (i32.const 1)))) + (call $is_word_letter + (array.get_u $string (local.get $s) + (local.get $pos))))) + (br $backtrack)))))) + ;; BEGGROUP + (local.set $arg + (i32.shr_u (local.get $instr) (i32.const 8))) + (local.set $stack + (struct.new $undo + (local.get $stack) + (local.get $group_start) + (local.get $arg) + (array.get $int_array + (local.get $group_start) (local.get $arg)))) + (array.set $int_array (local.get $group_start) + (local.get $arg) (local.get $pos)) + (br $continue)) + ;; ENDGROUP + (local.set $arg + (i32.shr_u (local.get $instr) (i32.const 8))) + (local.set $stack + (struct.new $undo + (local.get $stack) + (local.get $group_end) + (local.get $arg) + (array.get $int_array + (local.get $group_end) (local.get $arg)))) + (array.set $int_array (local.get $group_end) + (local.get $arg) (local.get $pos)) + (br $continue)) + ;; REFGROUP + (local.set $arg + (i32.shr_u (local.get $instr) (i32.const 8))) + (local.set $i + (array.get $int_array (local.get $group_start) + (local.get $arg))) + (local.set $j + (array.get $int_array (local.get $group_end) + (local.get $arg))) + (br_if $backtrack + (i32.or (i32.lt_s (local.get $i) (i32.const 0)) + (i32.lt_s (local.get $j) (i32.const 0)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $j)) + (then + (br_if $prefix_match + (i32.eq (local.get $pos) (local.get $len))) + (br_if $backtrack + (i32.ne + (array.get_u $string (local.get $s) + (local.get $i)) + (array.get_u $string (local.get $s) + (local.get $pos)))) + (local.set $pos + (i32.add (local.get $pos) (i32.const 1))) + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (br $continue)) + ;; SIMPLEOPT + (local.set $arg (i32.shr_u (local.get $instr) (i32.const 8))) + (if (i32.lt_u (local.get $pos) (local.get $len)) + (then + (if (call $in_bitset + (ref.cast (ref $string) + (array.get $block (local.get $cpool) + (i32.add (local.get $arg) (i32.const 1)))) + (array.get_u $string (local.get $s) + (local.get $pos))) + (then + (local.set $pos + (i32.add (local.get $pos) (i32.const 1))))))) + (br $continue)) + ;; SIMPLESTAR + (local.set $arg (i32.shr_u (local.get $instr) (i32.const 8))) + (local.set $set + (ref.cast (ref $string) + (array.get $block (local.get $cpool) + (i32.add (local.get $arg) (i32.const 1))))) + (loop $loop + (if (i32.lt_u (local.get $pos) (local.get $len)) + (then + (if (call $in_bitset (local.get $set) + (array.get_u $string (local.get $s) + (local.get $pos))) + (then + (local.set $pos + (i32.add (local.get $pos) (i32.const 1))) + (br $loop)))))) + (br $continue)) + ;; SIMPLEPLUS + (br_if $prefix_match (i32.eq (local.get $pos) (local.get $len))) + (local.set $arg (i32.shr_u (local.get $instr) (i32.const 8))) + (local.set $set + (ref.cast (ref $string) + (array.get $block (local.get $cpool) + (i32.add (local.get $arg) (i32.const 1))))) + (br_if $backtrack + (i32.eqz + (call $in_bitset (local.get $set) + (array.get_u $string (local.get $s) (local.get $pos))))) + (loop $loop + (local.set $pos (i32.add (local.get $pos) (i32.const 1))) + (if (i32.lt_u (local.get $pos) (local.get $len)) + (then + (br_if $loop + (call $in_bitset (local.get $set) + (array.get_u $string (local.get $s) + (local.get $pos))))))) + (br $continue)) + ;; GOTO + (local.set $pc + (i32.add + (local.get $pc) + (i32.shr_s (local.get $instr) (i32.const 8)))) + (br $continue)) + ;; PUSHBACK + (local.set $stack + (struct.new $pos + (local.get $stack) + (i32.add (local.get $pc) + (i32.shr_s (local.get $instr) (i32.const 8))) + (local.get $pos))) + (br $continue)) + ;; SETMARK + (local.set $arg (i32.shr_u (local.get $instr) (i32.const 8))) + (local.set $stack + (struct.new $undo + (local.get $stack) + (local.get $re_register) + (local.get $arg) + (array.get $int_array + (local.get $re_register) (local.get $arg)))) + (array.set $int_array (local.get $re_register) (local.get $arg) + (local.get $pos)) + (br $continue)) + ;; CHECKPROGRESS + (local.set $arg (i32.shr_u (local.get $instr) (i32.const 8))) + (br_if $backtrack + (i32.eq (local.get $pos) + (array.get $int_array (local.get $re_register) + (local.get $arg)))) + (br $continue)) + ;; prefix_match + (br_if $ACCEPT (local.get $accept_partial_match))) + ;; backtrack + (loop $loop + (local.set $u + (ref.cast (ref $undo) + (block $undo (result (ref $stack)) + (local.set $p + (br_on_cast_fail $undo (ref eq) (ref $pos) + (br_on_null $reject (local.get $stack)))) + (local.set $pc (struct.get $pos $pc (local.get $p))) + (local.set $pos (struct.get $pos $pos (local.get $p))) + (local.set $stack + (struct.get $pos $pos_previous (local.get $p))) + (br $continue)))) + (array.set $int_array (struct.get $undo $tbl (local.get $u)) + (struct.get $undo $idx (local.get $u)) + (struct.get $undo $val (local.get $u))) + (local.set $stack (struct.get $undo $undo_previous (local.get $u))) + (br $loop)))) + ;; ACCEPT + (array.set $int_array + (local.get $group_end) (i32.const 0) (local.get $pos)) + (local.set $res + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (i32.shl (local.get $numgroups) (i32.const 1)) + (i32.const 1)))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $numgroups)) + (then + (local.set $j (i32.shl (local.get $i) (i32.const 1))) + (if (i32.or + (i32.lt_s + (array.get $int_array (local.get $group_start) + (local.get $i)) + (i32.const 0)) + (i32.lt_s + (array.get $int_array (local.get $group_end) + (local.get $i)) + (i32.const 0))) + (then + (array.set $block (local.get $res) + (i32.add (local.get $j) (i32.const 1)) + (ref.i31 (i32.const -1))) + (array.set $block (local.get $res) + (i32.add (local.get $j) (i32.const 2)) + (ref.i31 (i32.const -1)))) + (else + (array.set $block (local.get $res) + (i32.add (local.get $j) (i32.const 1)) + (ref.i31 + (array.get $int_array (local.get $group_start) + (local.get $i)))) + (array.set $block (local.get $res) + (i32.add (local.get $j) (i32.const 2)) + (ref.i31 + (array.get $int_array (local.get $group_end) + (local.get $i)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (local.get $res))) + ;; reject + (ref.i31 (i32.const 0))) + + (data $search_forward "Str.search_forward") + + (func (export "re_search_forward") + (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) + (result (ref eq)) + ;; ZZZ startchars + (local $s (ref $string)) + (local $pos i32) (local $len i32) + (local $res (ref eq)) + (local.set $s (ref.cast (ref $string) (local.get $vs))) + (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (array.len (local.get $s))) + (if (i32.gt_u (local.get $pos) (local.get $len)) + (then + (call $caml_invalid_argument + (array.new_data $string $search_forward + (i32.const 0) (i32.const 18))))) + (loop $loop + (local.set $res + (call $re_match + (local.get $re) (local.get $s) (local.get $pos) (i32.const 0))) + (if (ref.test (ref $block) (local.get $res)) + (then + (return (local.get $res)))) + (local.set $pos (i32.add (local.get $pos) (i32.const 1))) + (br_if $loop (i32.le_u (local.get $pos) (local.get $len)))) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (data $search_backward "Str.search_backward") + + (func (export "re_search_backward") + (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) + (result (ref eq)) + ;; ZZZ startchars + (local $s (ref $string)) + (local $pos i32) (local $len i32) + (local $res (ref eq)) + (local.set $s (ref.cast (ref $string) (local.get $vs))) + (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (array.len (local.get $s))) + (if (i32.gt_u (local.get $pos) (local.get $len)) + (then + (call $caml_invalid_argument + (array.new_data $string $search_backward + (i32.const 0) (i32.const 19))))) + (loop $loop + (local.set $res + (call $re_match + (local.get $re) (local.get $s) (local.get $pos) (i32.const 0))) + (if (ref.test (ref $block) (local.get $res)) + (then + (return (local.get $res)))) + (local.set $pos (i32.sub (local.get $pos) (i32.const 1))) + (br_if $loop (i32.ge_s (local.get $pos) (i32.const 0)))) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (data $string_match "Str.string_match") + + (func (export "re_string_match") + (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) + (result (ref eq)) + ;; ZZZ startchars + (local $s (ref $string)) + (local $pos i32) (local $len i32) + (local $res (ref eq)) + (local.set $s (ref.cast (ref $string) (local.get $vs))) + (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (array.len (local.get $s))) + (if (i32.gt_u (local.get $pos) (local.get $len)) + (then + (call $caml_invalid_argument + (array.new_data $string $string_match + (i32.const 0) (i32.const 16))))) + (local.set $res + (call $re_match + (local.get $re) (local.get $s) (local.get $pos) (i32.const 0))) + (if (ref.test (ref $block) (local.get $res)) + (then + (return (local.get $res)))) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (data $string_partial_match "Str.string_partial_match") + + (func (export "re_partial_match") + (param $re (ref eq)) (param $vs (ref eq)) (param $vpos (ref eq)) + (result (ref eq)) + ;; ZZZ startchars + (local $s (ref $string)) + (local $pos i32) (local $len i32) + (local $res (ref eq)) + (local.set $s (ref.cast (ref $string) (local.get $vs))) + (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (array.len (local.get $s))) + (if (i32.gt_u (local.get $pos) (local.get $len)) + (then + (call $caml_invalid_argument + (array.new_data $string $string_partial_match + (i32.const 0) (i32.const 24))))) + (local.set $res + (call $re_match + (local.get $re) (local.get $s) (local.get $pos) (i32.const 1))) + (if (ref.test (ref $block) (local.get $res)) + (then + (return (local.get $res)))) + (array.new_fixed $block 1 (ref.i31 (i32.const 0)))) + + (data $illegal_backslash "Str.replace: illegal backslash sequence") + (data $unmatched_group "Str.replace: reference to unmatched group") + + (func (export "re_replacement_text") + (param $vrepl (ref eq)) (param $vgroups (ref eq)) (param $vorig (ref eq)) + (result (ref eq)) + (local $repl (ref $string)) + (local $groups (ref $block)) + (local $orig (ref $string)) + (local $res (ref $string)) + (local $i i32) (local $j i32) (local $l i32) (local $len i32) + (local $c i32) (local $start i32) (local $end i32) + (local.set $repl (ref.cast (ref $string) (local.get $vrepl))) + (local.set $l (array.len (local.get $repl))) + (local.set $groups (ref.cast (ref $block) (local.get $vgroups))) + (local.set $orig (ref.cast (ref $string) (local.get $vorig))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (local.set $c + (array.get_u $string (local.get $repl) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.ne (local.get $c) (i32.const 92)) ;; '\\' + (then + (local.set $len (i32.add (local.get $len) (i32.const 1))) + (br $loop))) + (if (i32.eq (local.get $i) (local.get $l)) + (then + (call $caml_failwith + (array.new_data $string $illegal_backslash + (i32.const 0) (i32.const 39))))) + (local.set $c + (array.get_u $string (local.get $repl) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.eq (local.get $c) (i32.const 92)) ;; '\\' + (then + (local.set $len (i32.add (local.get $len) (i32.const 1))) + (br $loop))) + (local.set $c (i32.sub (local.get $c) (i32.const 48))) ;; '0' + (if (i32.gt_u (local.get $c) (i32.const 9)) + (then + (local.set $len (i32.add (local.get $len) (i32.const 2))) + (br $loop))) + (local.set $c (i32.shl (local.get $c) (i32.const 1))) + (if (i32.gt_u (i32.add (local.get $c) (i32.const 1)) + (array.len (local.get $groups))) + (then + (call $caml_failwith + (array.new_data $string $unmatched_group + (i32.const 0) (i32.const 41))))) + (local.set $start + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $groups) + (i32.add (local.get $c) (i32.const 1)))))) + (local.set $end + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $groups) + (i32.add (local.get $c) (i32.const 2)))))) + (if (i32.eq (local.get $start) (i32.const -1)) + (then + (call $caml_failwith + (array.new_data $string $unmatched_group + (i32.const 0) (i32.const 41))))) + (local.set $len + (i32.add (local.get $len) + (i32.sub (local.get $end) (local.get $start)))) + (br $loop)))) + (local.set $res (array.new $string (i32.const 0) (local.get $len))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $l)) + (then + (local.set $c + (array.get_u $string (local.get $repl) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.ne (local.get $c) (i32.const 92)) ;; '\\' + (then + (array.set $string (local.get $res) (local.get $j) + (local.get $c)) + (local.set $j (i32.add (local.get $j) (i32.const 1))) + (br $loop))) + (local.set $c + (array.get_u $string (local.get $repl) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.eq (local.get $c) (i32.const 92)) ;; '\\' + (then + (array.set $string (local.get $res) (local.get $j) + (local.get $c)) + (local.set $j (i32.add (local.get $j) (i32.const 1))) + (br $loop))) + (local.set $c (i32.sub (local.get $c) (i32.const 48))) ;; '0' + (if (i32.gt_u (local.get $c) (i32.const 9)) + (then + (array.set $string (local.get $res) (local.get $j) + (i32.const 92)) + (array.set $string (local.get $res) + (i32.add (local.get $j) (i32.const 1)) + (i32.add (local.get $c) (i32.const 48))) + (local.set $j (i32.add (local.get $j) (i32.const 2))) + (br $loop))) + (local.set $c (i32.shl (local.get $c) (i32.const 1))) + (if (i32.gt_u (i32.add (local.get $c) (i32.const 1)) + (array.len (local.get $groups))) + (then + (call $caml_failwith + (array.new_data $string $unmatched_group + (i32.const 0) (i32.const 41))))) + (local.set $start + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $groups) + (i32.add (local.get $c) (i32.const 1)))))) + (local.set $end + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $groups) + (i32.add (local.get $c) (i32.const 2)))))) + (local.set $len (i32.sub (local.get $end) (local.get $start))) + (array.copy $string $string + (local.get $res) (local.get $j) + (local.get $orig) (local.get $start) + (local.get $len)) + (local.set $j (i32.add (local.get $j) (local.get $len))) + (br $loop)))) + (local.get $res)) +) diff --git a/runtime/wasm/string.wat b/runtime/wasm/string.wat new file mode 100644 index 0000000000..bf43b2f9e4 --- /dev/null +++ b/runtime/wasm/string.wat @@ -0,0 +1,342 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_bound_error" (func $caml_bound_error)) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param $arg (ref eq)))) + + (type $string (array (mut i8))) + + (export "caml_bytes_equal" (func $caml_string_equal)) + (func $caml_string_equal (export "caml_string_equal") + (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) + (local $s1 (ref $string)) (local $s2 (ref $string)) + (local $len i32) (local $i i32) + (if (ref.eq (local.get $p1) (local.get $p2)) + (then (return (ref.i31 (i32.const 1))))) + (local.set $s1 (ref.cast (ref $string) (local.get $p1))) + (local.set $s2 (ref.cast (ref $string) (local.get $p2))) + (local.set $len (array.len (local.get $s1))) + (if (i32.ne (local.get $len) (array.len (local.get $s2))) + (then (return (ref.i31 (i32.const 0))))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_s (local.get $i) (local.get $len)) + (then + (if (i32.ne (array.get_u $string (local.get $s1) (local.get $i)) + (array.get_u $string (local.get $s2) (local.get $i))) + (then (return (ref.i31 (i32.const 0))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (ref.i31 (i32.const 1))) + + (export "caml_bytes_notequal" (func $caml_string_notequal)) + (func $caml_string_notequal (export "caml_string_notequal") + (param $p1 (ref eq)) (param $p2 (ref eq)) (result (ref eq)) + (return + (ref.i31 (i32.eqz (i31.get_u (ref.cast (ref i31) + (call $caml_string_equal (local.get $p1) (local.get $p2)))))))) + + (func $string_compare + (param $p1 (ref eq)) (param $p2 (ref eq)) (result i32) + (local $s1 (ref $string)) (local $s2 (ref $string)) + (local $l1 i32) (local $l2 i32) (local $len i32) (local $i i32) + (local $c1 i32) (local $c2 i32) + (if (ref.eq (local.get $p1) (local.get $p2)) + (then (return (i32.const 0)))) + (local.set $s1 (ref.cast (ref $string) (local.get $p1))) + (local.set $s2 (ref.cast (ref $string) (local.get $p2))) + (local.set $l1 (array.len (local.get $s1))) + (local.set $l2 (array.len (local.get $s2))) + (local.set $len (select (local.get $l1) (local.get $l2) + (i32.le_u (local.get $l1) (local.get $l2)))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_s (local.get $i) (local.get $len)) + (then + (local.set $c1 + (array.get_u $string (local.get $s1) (local.get $i))) + (local.set $c2 + (array.get_u $string (local.get $s2) (local.get $i))) + (if (i32.lt_u (local.get $c1) (local.get $c2)) + (then (return (i32.const -1)))) + (if (i32.gt_u (local.get $c1) (local.get $c2)) + (then (return (i32.const 1)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (if (i32.lt_u (local.get $l1) (local.get $l2)) + (then (return (i32.const -1)))) + (if (i32.gt_u (local.get $l1) (local.get $l2)) + (then (return (i32.const 1)))) + (i32.const 0)) + + (export "caml_bytes_compare" (func $caml_string_compare)) + (func $caml_string_compare (export "caml_string_compare") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (call $string_compare (local.get 0) (local.get 1)))) + + (export "caml_bytes_lessequal" (func $caml_string_lessequal)) + (func $caml_string_lessequal (export "caml_string_lessequal") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.le_s (call $string_compare (local.get 0) (local.get 1)) + (i32.const 0)))) + + (export "caml_bytes_lessthan" (func $caml_string_lessthan)) + (func $caml_string_lessthan (export "caml_string_lessthan") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.lt_s (call $string_compare (local.get 0) (local.get 1)) + (i32.const 0)))) + + (export "caml_bytes_greaterequal" (func $caml_string_greaterequal)) + (func $caml_string_greaterequal (export "caml_string_greaterequal") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.ge_s (call $string_compare (local.get 0) (local.get 1)) + (i32.const 0)))) + + (export "caml_bytes_greaterthan" (func $caml_string_greaterthan)) + (func $caml_string_greaterthan (export "caml_string_greaterthan") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.gt_s (call $string_compare (local.get 0) (local.get 1)) + (i32.const 0)))) + + (export "caml_bytes_of_string" (func $caml_string_of_bytes)) + (func $caml_string_of_bytes (export "caml_string_of_bytes") + (param $v (ref eq)) (result (ref eq)) + (local.get $v)) + + (data $Bytes_create "Bytes.create") + + (func (export "caml_create_bytes") + (param $len (ref eq)) (result (ref eq)) + (local $l i32) + (local.set $l (i31.get_s (ref.cast (ref i31) (local.get $len)))) + (if (i32.lt_s (local.get $l) (i32.const 0)) + (then + (call $caml_invalid_argument + (array.new_data $string $Bytes_create + (i32.const 0) (i32.const 12))))) + (array.new $string (i32.const 0) (local.get $l))) + + (export "caml_blit_bytes" (func $caml_blit_string)) + (func $caml_blit_string (export "caml_blit_string") + (param $v1 (ref eq)) (param $i1 (ref eq)) + (param $v2 (ref eq)) (param $i2 (ref eq)) + (param $n (ref eq)) (result (ref eq)) + (array.copy $string $string + (ref.cast (ref $string) (local.get $v2)) + (i31.get_s (ref.cast (ref i31) (local.get $i2))) + (ref.cast (ref $string) (local.get $v1)) + (i31.get_s (ref.cast (ref i31) (local.get $i1))) + (i31.get_s (ref.cast (ref i31) (local.get $n)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_fill_bytes") + (param $v (ref eq)) (param $offset (ref eq)) + (param $len (ref eq)) (param $init (ref eq)) + (result (ref eq)) + (array.fill $string (ref.cast (ref $string) (local.get $v)) + (i31.get_u (ref.cast (ref i31) (local.get $offset))) + (i31.get_u (ref.cast (ref i31) (local.get $init))) + (i31.get_u (ref.cast (ref i31) (local.get $len)))) + (ref.i31 (i32.const 0))) + + (export "caml_string_get16" (func $caml_bytes_get16)) + (func $caml_bytes_get16 (export "caml_bytes_get16") + (param $v (ref eq)) (param $i (ref eq)) (result (ref eq)) + (local $s (ref $string)) (local $p i32) + (local.set $s (ref.cast (ref $string) (local.get $v))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 1)) + (array.len (local.get $s))) + (then (call $caml_bound_error))) + (ref.i31 (i32.or + (array.get_u $string (local.get $s) (local.get $p)) + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 1))) + (i32.const 8))))) + + (export "caml_string_get32" (func $caml_bytes_get32)) + (func $caml_bytes_get32 (export "caml_bytes_get32") + (param $v (ref eq)) (param $i (ref eq)) (result i32) + (local $s (ref $string)) (local $p i32) + (local.set $s (ref.cast (ref $string) (local.get $v))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 3)) + (array.len (local.get $s))) + (then (call $caml_bound_error))) + (i32.or + (i32.or + (array.get_u $string (local.get $s) (local.get $p)) + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 1))) + (i32.const 8))) + (i32.or + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 2))) + (i32.const 16)) + (i32.shl (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 3))) + (i32.const 24))))) + + (export "caml_string_get64" (func $caml_bytes_get64)) + (func $caml_bytes_get64 (export "caml_bytes_get64") + (param $v (ref eq)) (param $i (ref eq)) (result i64) + (local $s (ref $string)) (local $p i32) + (local.set $s (ref.cast (ref $string) (local.get $v))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get $i)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 7)) + (array.len (local.get $s))) + (then (call $caml_bound_error))) + (i64.or + (i64.or + (i64.or + (i64.extend_i32_u + (array.get_u $string (local.get $s) (local.get $p))) + (i64.shl (i64.extend_i32_u + (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 1)))) + (i64.const 8))) + (i64.or + (i64.shl (i64.extend_i32_u + (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 2)))) + (i64.const 16)) + (i64.shl (i64.extend_i32_u + (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 3)))) + (i64.const 24)))) + (i64.or + (i64.or + (i64.shl (i64.extend_i32_u + (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 4)))) + (i64.const 32)) + (i64.shl (i64.extend_i32_u + (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 5)))) + (i64.const 40))) + (i64.or + (i64.shl (i64.extend_i32_u + (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 6)))) + (i64.const 48)) + (i64.shl (i64.extend_i32_u + (array.get_u $string (local.get $s) + (i32.add (local.get $p) (i32.const 7)))) + (i64.const 56)))))) + + (func (export "caml_bytes_set16") + (param (ref eq) (ref eq) (ref eq)) (result (ref eq)) + (local $s (ref $string)) (local $p i32) (local $v i32) + (local.set $s (ref.cast (ref $string) (local.get 0))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get 1)))) + (local.set $v (i31.get_s (ref.cast (ref i31) (local.get 2)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 1)) + (array.len (local.get $s))) + (then (call $caml_bound_error))) + (array.set $string (local.get $s) (local.get $p) (local.get $v)) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 1)) + (i32.shr_u (local.get $v) (i32.const 8))) + (ref.i31 (i32.const 0))) + + (func (export "caml_bytes_set32") + (param (ref eq)) (param (ref eq)) (param $v i32) (result (ref eq)) + (local $s (ref $string)) (local $p i32) + (local.set $s (ref.cast (ref $string) (local.get 0))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get 1)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 3)) + (array.len (local.get $s))) + (then (call $caml_bound_error))) + (array.set $string (local.get $s) (local.get $p) (local.get $v)) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 1)) + (i32.shr_u (local.get $v) (i32.const 8))) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 2)) + (i32.shr_u (local.get $v) (i32.const 16))) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 3)) + (i32.shr_u (local.get $v) (i32.const 24))) + (ref.i31 (i32.const 0))) + + (func (export "caml_bytes_set64") + (param (ref eq)) (param (ref eq)) (param $v i64) (result (ref eq)) + (local $s (ref $string)) (local $p i32) + (local.set $s (ref.cast (ref $string) (local.get 0))) + (local.set $p (i31.get_s (ref.cast (ref i31) (local.get 1)))) + (if (i32.lt_s (local.get $p) (i32.const 0)) + (then (call $caml_bound_error))) + (if (i32.ge_u (i32.add (local.get $p) (i32.const 7)) + (array.len (local.get $s))) + (then (call $caml_bound_error))) + (array.set $string (local.get $s) (local.get $p) + (i32.wrap_i64 (local.get $v))) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 1)) + (i32.wrap_i64 (i64.shr_u (local.get $v) (i64.const 8)))) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 2)) + (i32.wrap_i64 (i64.shr_u (local.get $v) (i64.const 16)))) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 3)) + (i32.wrap_i64 (i64.shr_u (local.get $v) (i64.const 24)))) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 4)) + (i32.wrap_i64 (i64.shr_u (local.get $v) (i64.const 32)))) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 5)) + (i32.wrap_i64 (i64.shr_u (local.get $v) (i64.const 40)))) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 6)) + (i32.wrap_i64 (i64.shr_u (local.get $v) (i64.const 48)))) + (array.set $string (local.get $s) + (i32.add (local.get $p) (i32.const 7)) + (i32.wrap_i64 (i64.shr_u (local.get $v) (i64.const 56)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_string_concat") + (param $vs1 (ref eq)) (param $vs2 (ref eq)) (result (ref eq)) + (local $s1 (ref $string)) (local $s2 (ref $string)) + (local $s (ref $string)) + (local $l1 i32) (local $l2 i32) + (local.set $s1 (ref.cast (ref $string) (local.get $vs1))) + (local.set $s2 (ref.cast (ref $string) (local.get $vs2))) + (local.set $l1 (array.len (local.get $s1))) + (local.set $l2 (array.len (local.get $s2))) + (local.set $s + (array.new $string (i32.const 0) + (i32.add (local.get $l1) (local.get $l2)))) + (array.copy $string $string + (local.get $s) (i32.const 0) (local.get $s1) (i32.const 0) + (local.get $l1)) + (array.copy $string $string + (local.get $s) (local.get $l1) (local.get $s2) (i32.const 0) + (local.get $l2)) + (local.get $s)) +) diff --git a/runtime/wasm/sync.wat b/runtime/wasm/sync.wat new file mode 100644 index 0000000000..cd14209dd1 --- /dev/null +++ b/runtime/wasm/sync.wat @@ -0,0 +1,124 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) + (import "custom" "custom_compare_id" + (func $custom_compare_id + (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (import "custom" "custom_hash_id" + (func $custom_hash_id (param (ref eq)) (result i32))) + (import "custom" "custom_next_id" (func $custom_next_id (result i64))) + + (type $string (array (mut i8))) + (type $compare + (func (param (ref eq)) (param (ref eq)) (param i32) (result i32))) + (type $hash + (func (param (ref eq)) (result i32))) + (type $fixed_length (struct (field $bsize_32 i32) (field $bsize_64 i32))) + (type $serialize + (func (param (ref eq)) (param (ref eq)) (result i32) (result i32))) + (type $deserialize (func (param (ref eq)) (result (ref eq)) (result i32))) + (type $dup (func (param (ref eq)) (result (ref eq)))) + (type $custom_operations + (struct + (field $id (ref $string)) + (field $compare (ref null $compare)) + (field $compare_ext (ref null $compare)) + (field $hash (ref null $hash)) + (field $fixed_length (ref null $fixed_length)) + (field $serialize (ref null $serialize)) + (field $deserialize (ref null $deserialize)) + (field $dup (ref null $dup)))) + (type $custom (sub (struct (field (ref $custom_operations))))) + (type $custom_with_id + (sub $custom + (struct + (field (ref $custom_operations)) + (field $id i64)))) + + (global $mutex_ops (ref $custom_operations) + (struct.new $custom_operations + (array.new_fixed $string 6 ;; "_mutex" + (i32.const 95) (i32.const 109) (i32.const 117) (i32.const 116) + (i32.const 101) (i32.const 120)) + (ref.func $custom_compare_id) + (ref.null $compare) + (ref.func $custom_hash_id) + (ref.null $fixed_length) + (ref.null $serialize) + (ref.null $deserialize) + (ref.null $dup))) + + (type $mutex + (sub final $custom_with_id + (struct + (field (ref $custom_operations)) + (field i64) + (field $state (mut i32))))) + + (func (export "caml_ml_mutex_new") (param (ref eq)) (result (ref eq)) + (struct.new $mutex + (global.get $mutex_ops) (call $custom_next_id) (i32.const 0))) + + (data $lock_failure "Mutex.lock: mutex already locked. Cannot wait.") + + (func (export "caml_ml_mutex_lock") (param (ref eq)) (result (ref eq)) + (local $t (ref $mutex)) + (local.set $t (ref.cast (ref $mutex) (local.get 0))) + (if (struct.get $mutex $state (local.get $t)) + (then + (call $caml_failwith + (array.new_data $string $lock_failure + (i32.const 0) (i32.const 46))))) + (struct.set $mutex $state (local.get $t) (i32.const 1)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_mutex_try_lock") (param (ref eq)) (result (ref eq)) + (local $t (ref $mutex)) + (local.set $t (ref.cast (ref $mutex) (local.get 0))) + (if (result (ref eq)) (struct.get $mutex $state (local.get $t)) + (then + (ref.i31 (i32.const 0))) + (else + (struct.set $mutex $state (local.get $t) (i32.const 1)) + (ref.i31 (i32.const 1))))) + + (func (export "caml_ml_mutex_unlock") (param (ref eq)) (result (ref eq)) + (struct.set $mutex $state + (ref.cast (ref $mutex) (local.get 0)) (i32.const 0)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_condition_new") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (data $condition_failure "Condition.wait: cannot wait") + + (func (export "caml_ml_condition_wait") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (call $caml_failwith + (array.new_data $string $condition_failure + (i32.const 0) (i32.const 27))) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_condition_signal") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_condition_broadcast") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) diff --git a/runtime/wasm/sys.wat b/runtime/wasm/sys.wat new file mode 100644 index 0000000000..b397c89a82 --- /dev/null +++ b/runtime/wasm/sys.wat @@ -0,0 +1,198 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "bindings" "ta_length" + (func $ta_length (param (ref extern)) (result i32))) + (import "bindings" "ta_get_i32" + (func $ta_get_i32 (param (ref extern)) (param i32) (result i32))) + (import "bindings" "random_seed" (func $random_seed (result (ref extern)))) + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (import "jslib" "caml_jsstring_of_string" + (func $caml_jsstring_of_string (param (ref eq)) (result (ref eq)))) + (import "jslib" "caml_string_of_jsstring" + (func $caml_string_of_jsstring (param (ref eq)) (result (ref eq)))) + (import "jslib" "caml_js_to_string_array" + (func $caml_js_to_string_array (param $a (ref extern)) (result (ref eq)))) + (import "jslib" "caml_js_meth_call" + (func $caml_js_meth_call + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "fail" "caml_raise_sys_error" + (func $caml_raise_sys_error (param (ref eq)))) + (import "fail" "caml_raise_not_found" (func $caml_raise_not_found)) + (import "bindings" "argv" (func $argv (result (ref extern)))) + (import "bindings" "system" (func $system (param anyref) (result (ref eq)))) + (import "bindings" "getenv" (func $getenv (param anyref) (result anyref))) + (import "bindings" "time" (func $time (result f64))) + (import "bindings" "array_length" + (func $array_length (param (ref extern)) (result i32))) + (import "bindings" "array_get" + (func $array_get (param (ref extern)) (param i32) (result anyref))) + (import "fail" "javascript_exception" + (tag $javascript_exception (param externref))) + (import "jsstring" "jsstring_test" + (func $jsstring_test (param anyref) (result i32))) + + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $float (struct (field f64))) + + (tag $ocaml_exit (export "ocaml_exit") (param i32)) + + (func (export "caml_sys_exit") (param (ref eq)) (result (ref eq)) + (throw $ocaml_exit (i31.get_s (ref.cast (ref i31) (local.get 0))))) + + (export "caml_sys_unsafe_getenv" (func $caml_sys_getenv)) + (func $caml_sys_getenv (export "caml_sys_getenv") + (param (ref eq)) (result (ref eq)) + (local $res anyref) + (local.set $res + (call $getenv + (call $unwrap (call $caml_jsstring_of_string (local.get 0))))) + (if (i32.eqz (call $jsstring_test (local.get $res))) + (then + (call $caml_raise_not_found))) + (return_call $caml_string_of_jsstring (call $wrap (local.get $res)))) + + (func (export "caml_sys_argv") (param (ref eq)) (result (ref eq)) + ;; ZZZ + (call $caml_js_to_string_array (call $argv))) + + (func (export "caml_sys_executable_name") + (param (ref eq)) (result (ref eq)) + (array.get $block + (ref.cast (ref $block) (call $caml_js_to_string_array (call $argv))) + (i32.const 1))) + + (export "caml_sys_time_include_children" (func $caml_sys_time)) + (func $caml_sys_time (export "caml_sys_time") + (param (ref eq)) (result (ref eq)) + (struct.new $float (f64.mul (call $time) (f64.const 0.001)))) + + (func (export "caml_sys_system_command") + (param (ref eq)) (result (ref eq)) + ;; ZZZ + (try + (do + (return + (call $system + (call $unwrap (call $caml_jsstring_of_string (local.get 0)))))) + (catch $javascript_exception + (call $caml_handle_sys_error (pop externref)) + (return (ref.i31 (i32.const 0)))))) + + (func (export "caml_sys_random_seed") + (param (ref eq)) (result (ref eq)) + (local $r (ref extern)) + (local $a (ref $block)) + (local $i i32) (local $n i32) + (local.set $r (call $random_seed)) + (local.set $n (call $ta_length (local.get $r))) + (local.set $a + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $n) (i32.const 1)))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $n)) + (then + (array.set $block + (local.get $a) (i32.add (local.get $i) (i32.const 1)) + (ref.i31 (call $ta_get_i32 (local.get $r) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $a)) + + (func (export "caml_sys_const_bigendian") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_sys_const_word_size") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 32))) + + (func (export "caml_sys_const_int_size") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 31))) + + (func (export "caml_sys_const_max_wosize") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0xfffffff))) + + (func (export "caml_sys_const_ostype_unix") + (param (ref eq)) (result (ref eq)) + ;; ZZZ + (ref.i31 (i32.const 1))) + + (func (export "caml_sys_const_ostype_win32") + (param (ref eq)) (result (ref eq)) + ;; ZZZ + (ref.i31 (i32.const 0))) + + (func (export "caml_sys_const_ostype_cygwin") + (param (ref eq)) (result (ref eq)) + ;; ZZZ + (ref.i31 (i32.const 0))) + + (data $Unix "Unix") + + (func (export "caml_sys_get_config") + (param (ref eq)) (result (ref eq)) + ;; ZZZ + ;; (call $log_js (string.const "caml_sys_get_config")) + (array.new_fixed $block 4 (ref.i31 (i32.const 0)) + (array.new_data $string $Unix (i32.const 0) (i32.const 4)) + (ref.i31 (i32.const 32)) + (ref.i31 (i32.const 0)))) + + (func (export "caml_sys_isatty") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_runtime_variant") (param (ref eq)) (result (ref eq)) + (array.new_fixed $string 0)) + + (func (export "caml_runtime_parameters") (param (ref eq)) (result (ref eq)) + (array.new_fixed $string 0)) + + (func (export "caml_install_signal_handler") + (param (ref eq) (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (global $caml_runtime_warnings (mut i32) (i32.const 0)) + + (func (export "caml_ml_enable_runtime_warnings") + (param (ref eq)) (result (ref eq)) + (global.set $caml_runtime_warnings + (i31.get_u (ref.cast (ref i31) (local.get 0)))) + (ref.i31 (i32.const 0))) + + (func (export "caml_ml_runtime_warnings_enabled") + (param (ref eq)) (result (ref eq)) + (ref.i31 (global.get $caml_runtime_warnings))) + + (data $toString "toString") + + (func $caml_handle_sys_error (export "caml_handle_sys_error") + (param $exn externref) + (call $caml_raise_sys_error + (call $caml_string_of_jsstring + (call $caml_js_meth_call + (call $wrap (any.convert_extern (local.get $exn))) + (array.new_data $string $toString (i32.const 0) (i32.const 8)) + (array.new_fixed $block 1 (ref.i31 (i32.const 0))))))) +) diff --git a/runtime/wasm/toplevel.wat b/runtime/wasm/toplevel.wat new file mode 100644 index 0000000000..c187ff9eb0 --- /dev/null +++ b/runtime/wasm/toplevel.wat @@ -0,0 +1,22 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (func (export "caml_terminfo_rows") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) diff --git a/runtime/wasm/unix.wat b/runtime/wasm/unix.wat new file mode 100644 index 0000000000..797a3b3f3f --- /dev/null +++ b/runtime/wasm/unix.wat @@ -0,0 +1,102 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "bindings" "gettimeofday" (func $gettimeofday (result f64))) + (import "bindings" "gmtime" (func $gmtime (param f64) (result (ref eq)))) + (import "bindings" "localtime" + (func $localtime (param f64) (result (ref eq)))) + (import "bindings" "mktime" + (func $mktime + (param i32) (param i32) (param i32) (param i32) (param i32) (param i32) + (result f64))) + + (type $block (array (mut (ref eq)))) + (type $float (struct (field f64))) + + (export "caml_unix_gettimeofday" (func $unix_gettimeofday)) + (func $unix_gettimeofday (export "unix_gettimeofday") + (param (ref eq)) (result (ref eq)) + (struct.new $float (call $gettimeofday))) + + (func (export "caml_alloc_tm") + (param $sec i32) (param $min i32) (param $hour i32) (param $mday i32) + (param $mon i32) (param $year i32) (param $wday i32) (param $yday i32) + (param $isdst i32) (result (ref eq)) + (array.new_fixed $block 10 (ref.i31 (i32.const 0)) + (ref.i31 (local.get $sec)) + (ref.i31 (local.get $min)) + (ref.i31 (local.get $hour)) + (ref.i31 (local.get $mday)) + (ref.i31 (local.get $mon)) + (ref.i31 (local.get $year)) + (ref.i31 (local.get $wday)) + (ref.i31 (local.get $yday)) + (ref.i31 (local.get $isdst)))) + + (export "caml_unix_gmtime" (func $unix_gmtime)) + (func $unix_gmtime (export "unix_gmtime") (param (ref eq)) (result (ref eq)) + (call $gmtime + (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) + + (export "caml_unix_localtime" (func $unix_localtime)) + (func $unix_localtime (export "unix_localtime") + (param (ref eq)) (result (ref eq)) + (call $localtime + (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) + + (export "caml_unix_time" (func $unix_time)) + (func $unix_time (export "unix_time") (param (ref eq)) (result (ref eq)) + (struct.new $float (f64.floor (call $gettimeofday)))) + + (export "caml_unix_mktime" (func $unix_mktime)) + (func $unix_mktime (export "unix_mktime") (param (ref eq)) (result (ref eq)) + (local $tm (ref $block)) (local $t f64) + (local.set $tm (ref.cast (ref $block) (local.get 0))) + (local.set $t + (f64.div + (call $mktime + (i32.add + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $tm) (i32.const 6)))) + (i32.const 1900)) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $tm) (i32.const 5)))) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $tm) (i32.const 4)))) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $tm) (i32.const 3)))) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $tm) (i32.const 2)))) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $tm) (i32.const 1))))) + (f64.const 1000))) + (array.new_fixed $block 3 (ref.i31 (i32.const 0)) + (struct.new $float (local.get $t)) + (call $localtime (local.get $t)))) + + (export "caml_unix_inet_addr_of_string" (func $unix_inet_addr_of_string)) + (func $unix_inet_addr_of_string (export "unix_inet_addr_of_string") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) diff --git a/runtime/wasm/version-dependent/post-5.1.wat b/runtime/wasm/version-dependent/post-5.1.wat new file mode 100644 index 0000000000..258505a5e9 --- /dev/null +++ b/runtime/wasm/version-dependent/post-5.1.wat @@ -0,0 +1,46 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "obj" "caml_callback_1" + (func $caml_callback_1 + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "sync" "caml_ml_mutex_unlock" + (func $caml_ml_mutex_unlock (param (ref eq)) (result (ref eq)))) + (import "domain" "caml_domain_latest_id" + (global $caml_domain_latest_id (mut i32))) + (import "domain" "caml_domain_id" + (global $caml_domain_id (mut i32))) + + (func (export "caml_runtime_events_user_write") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_domain_spawn") + (param $f (ref eq)) (param $mutex (ref eq)) (result (ref eq)) + (local $id i32) (local $old i32) + (local.set $id (global.get $caml_domain_latest_id)) + (global.set $caml_domain_latest_id + (i32.add (local.get $id) (i32.const 1))) + (local.set $old (global.get $caml_domain_id)) + (drop (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) + (global.set $caml_domain_id (local.get $old)) + (drop (call $caml_ml_mutex_unlock (local.get $mutex))) + (ref.i31 (local.get $id))) + + (global (export "caml_marshal_header_size") i32 (i32.const 16)) +) diff --git a/runtime/wasm/version-dependent/post-5.2.wat b/runtime/wasm/version-dependent/post-5.2.wat new file mode 100644 index 0000000000..b4183d2dcb --- /dev/null +++ b/runtime/wasm/version-dependent/post-5.2.wat @@ -0,0 +1,59 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (type $block (array (mut (ref eq)))) + (import "obj" "caml_callback_1" + (func $caml_callback_1 + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "sync" "caml_ml_mutex_unlock" + (func $caml_ml_mutex_unlock (param (ref eq)) (result (ref eq)))) + (import "domain" "caml_domain_latest_id" + (global $caml_domain_latest_id (mut i32))) + (import "domain" "caml_domain_id" + (global $caml_domain_id (mut i32))) + + (func (export "caml_runtime_events_user_write") + (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_domain_spawn") + (param $f (ref eq)) (param $term_sync_v (ref eq)) (result (ref eq)) + (local $id i32) (local $old i32) (local $ts (ref $block)) (local $res (ref eq)) + (local.set $id (global.get $caml_domain_latest_id)) + (global.set $caml_domain_latest_id + (i32.add (local.get $id) (i32.const 1))) + (local.set $old (global.get $caml_domain_id)) + (local.set $res + (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) + (global.set $caml_domain_id (local.get $old)) + (local.set $ts (ref.cast (ref $block) (local.get $term_sync_v))) + (drop (call $caml_ml_mutex_unlock (array.get $block (local.get $ts) (i32.const 2)))) + ;; TODO: fix exn case + (array.set + $block + (local.get $ts) + (i32.const 1) + (array.new_fixed + $block + 2 + (ref.i31 (i32.const 0)) + (array.new_fixed $block 2 (ref.i31 (i32.const 0)) (local.get $res)))) + (ref.i31 (local.get $id))) + + (global (export "caml_marshal_header_size") i32 (i32.const 16)) +) diff --git a/runtime/wasm/version-dependent/pre-5.1.wat b/runtime/wasm/version-dependent/pre-5.1.wat new file mode 100644 index 0000000000..cc23b90ad7 --- /dev/null +++ b/runtime/wasm/version-dependent/pre-5.1.wat @@ -0,0 +1,46 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "obj" "caml_callback_1" + (func $caml_callback_1 + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "sync" "caml_ml_mutex_unlock" + (func $caml_ml_mutex_unlock (param (ref eq)) (result (ref eq)))) + (import "domain" "caml_domain_latest_id" + (global $caml_domain_latest_id (mut i32))) + (import "domain" "caml_domain_id" + (global $caml_domain_id (mut i32))) + + (func (export "caml_runtime_events_user_write") + (param (ref eq)) (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) + + (func (export "caml_domain_spawn") + (param $f (ref eq)) (param $mutex (ref eq)) (result (ref eq)) + (local $id i32) (local $old i32) + (local.set $id (global.get $caml_domain_latest_id)) + (global.set $caml_domain_latest_id + (i32.add (local.get $id) (i32.const 1))) + (local.set $old (global.get $caml_domain_id)) + (drop (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) + (global.set $caml_domain_id (local.get $old)) + (drop (call $caml_ml_mutex_unlock (local.get $mutex))) + (ref.i31 (local.get $id))) + + (global (export "caml_marshal_header_size") i32 (i32.const 20)) +) diff --git a/runtime/wasm/weak.wat b/runtime/wasm/weak.wat new file mode 100644 index 0000000000..5b54df26e0 --- /dev/null +++ b/runtime/wasm/weak.wat @@ -0,0 +1,332 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + (import "obj" "abstract_tag" (global $abstract_tag i32)) + (import "obj" "caml_obj_dup" + (func $caml_obj_dup (param (ref eq)) (result (ref eq)))) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param $arg (ref eq)))) + (import "bindings" "weak_new" + (func $weak_new (param (ref eq)) (result anyref))) + (import "bindings" "weak_deref" + (func $weak_deref (param anyref) (result eqref))) + (import "bindings" "weak_map_new" (func $weak_map_new (result (ref any)))) + (import "bindings" "map_get" + (func $map_get (param (ref any)) (param (ref eq)) (result anyref))) + (import "bindings" "map_set" + (func $map_set (param (ref any)) (param (ref eq)) (param (ref any)))) + (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) + (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) + (type $block (array (mut (ref eq)))) + (type $string (array (mut i8))) + (type $js (struct (field anyref))) + + ;; A weak array is a an abstract value composed of possibly some + ;; data and an array of keys. + ;; Keys are either caml_ephe_none (unset), a 31-bit integer, or a + ;; weak reference. + ;; To access the data, we need to traverse a series of weak maps + ;; indexed by the keys (omitting integers). + + (global $caml_ephe_data_offset i32 (i32.const 2)) + (global $caml_ephe_key_offset i32 (i32.const 3)) + + (global $caml_ephe_none (ref eq) + (array.new_fixed $block 1 (ref.i31 (global.get $abstract_tag)))) + + (func $caml_ephe_get_data (export "caml_ephe_get_data") + (param $vx (ref eq)) (result (ref eq)) + (local $x (ref $block)) + (local $d (ref eq)) (local $v (ref eq)) + (local $m (ref any)) + (local $i i32) (local $len i32) + (local.set $x (ref.cast (ref $block) (local.get $vx))) + (local.set $d + (array.get $block (local.get $x) (global.get $caml_ephe_data_offset))) + (block $no_data + (block $released + (br_if $no_data + (ref.eq (local.get $d) (global.get $caml_ephe_none))) + (local.set $i (global.get $caml_ephe_key_offset)) + (local.set $len (array.len (local.get $x))) + (local.set $m (ref.as_non_null (call $unwrap (local.get $d)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $v + (array.get $block (local.get $x) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br_if $loop + (ref.eq (local.get $v) (global.get $caml_ephe_none))) + (br_if $loop (ref.test (ref i31) (local.get $v))) + (local.set $v + (br_on_null $released + (call $weak_deref (call $unwrap (local.get $v))))) + (local.set $m + (br_on_null $released + (call $map_get (local.get $m) (local.get $v)))) + (br $loop)))) + (return + (array.new_fixed $block 2 (ref.i31 (i32.const 0)) + (ref.cast (ref eq) (local.get $m))))) + (array.set $block (local.get $x) (global.get $caml_ephe_data_offset) + (global.get $caml_ephe_none))) + (ref.i31 (i32.const 0))) + + (func (export "caml_ephe_get_data_copy") + (param $x (ref eq)) (result (ref eq)) + (local $r (ref eq)) + (local.set $r (call $caml_ephe_get_data (local.get $x))) + (drop (block $no_copy (result (ref eq)) + (return + (array.new_fixed $block 2 (ref.i31 (i32.const 0)) + (call $caml_obj_dup + (br_on_cast_fail $no_copy (ref eq) (ref $block) + (array.get $block + (br_on_cast_fail $no_copy (ref eq) (ref $block) + (local.get $r)) + (i32.const 1)))))))) + (local.get $r)) + + (func $caml_ephe_set_data (export "caml_ephe_set_data") + (param $vx (ref eq)) (param $data (ref eq)) (result (ref eq)) + (local $x (ref $block)) + (local $v (ref eq)) + (local $m (ref any)) (local $m' (ref any)) + (local $i i32) + (local.set $x (ref.cast (ref $block) (local.get $vx))) + (local.set $i (array.len (local.get $x))) + (local.set $m (local.get $data)) + (loop $loop + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (if (i32.ge_u (local.get $i) (global.get $caml_ephe_key_offset)) + (then + (local.set $v + (array.get $block (local.get $x) (local.get $i))) + (br_if $loop + (ref.eq (local.get $v) (global.get $caml_ephe_none))) + (br_if $loop (ref.test (ref i31) (local.get $v))) + (block $released + (local.set $v + (br_on_null $released + (call $weak_deref (call $unwrap (local.get $v))))) + (local.set $m' (call $weak_map_new)) + (call $map_set (local.get $m') (local.get $v) + (local.get $m)) + (local.set $m (local.get $m')) + (br $loop)) + (array.set $block (local.get $x) (local.get $i) + (global.get $caml_ephe_none)) + (br $loop)))) + (array.set $block (local.get $x) (global.get $caml_ephe_data_offset) + (call $wrap (local.get $m))) + (ref.i31 (i32.const 0))) + + (func (export "caml_ephe_unset_data") + (param $vx (ref eq)) (result (ref eq)) + (local $x (ref $block)) + (local.set $x (ref.cast (ref $block) (local.get $vx))) + (array.set $block (local.get $x) (global.get $caml_ephe_data_offset) + (global.get $caml_ephe_none)) + (ref.i31 (i32.const 0))) + + (func (export "caml_ephe_check_data") + (param $x (ref eq)) (result (ref eq)) + (ref.i31 + (i32.eqz + (ref.eq (call $caml_ephe_get_data (local.get $x)) + (ref.i31 (i32.const 0)))))) + + (func $caml_ephe_set_data_opt + (param $x (ref eq)) (param $opt_data (ref eq)) + (drop (block $no_data (result (ref eq)) + (call $caml_ephe_set_data (local.get $x) + (array.get $block + (br_on_cast_fail $no_data (ref eq) (ref $block) + (local.get $opt_data)) + (i32.const 1)))))) + + (export "caml_weak_get" (func $caml_ephe_get_key)) + (func $caml_ephe_get_key (export "caml_ephe_get_key") + (param $vx (ref eq)) (param $vi (ref eq)) (result (ref eq)) + (local $x (ref $block)) + (local $i i32) + (local $v (ref eq)) + (local.set $x (ref.cast (ref $block) (local.get $vx))) + (local.set $i + (i32.add (global.get $caml_ephe_key_offset) + (i31.get_s (ref.cast (ref i31) (local.get $vi))))) + (local.set $v (array.get $block (local.get $x) (local.get $i))) + (block $value + (block $no_value + (br_if $no_value + (ref.eq (local.get $v) (global.get $caml_ephe_none))) + (br_if $value (ref.test (ref i31) (local.get $v))) + (block $released + (local.set $v + (br_on_null $released + (call $weak_deref (call $unwrap (local.get $v))))) + (br $value)) + (array.set $block (local.get $x) (local.get $i) + (global.get $caml_ephe_none)) + (array.set $block (local.get $x) (global.get $caml_ephe_data_offset) + (global.get $caml_ephe_none))) + (return (ref.i31 (i32.const 0)))) + (array.new_fixed $block 2 (ref.i31 (i32.const 0)) (local.get $v))) + + (export "caml_weak_get_copy" (func $caml_ephe_get_key_copy)) + (func $caml_ephe_get_key_copy (export "caml_ephe_get_key_copy") + (param $x (ref eq)) (param $i (ref eq)) (result (ref eq)) + (local $r (ref eq)) + (local.set $r (call $caml_ephe_get_key (local.get $x) (local.get $i))) + (drop (block $no_copy (result (ref eq)) + (return + (array.new_fixed $block 2 (ref.i31 (i32.const 0)) + (call $caml_obj_dup + (br_on_cast_fail $no_copy (ref eq) (ref $block) + (array.get $block + (br_on_cast_fail $no_copy (ref eq) (ref $block) + (local.get $r)) + (i32.const 1)))))))) + (local.get $r)) + + (export "caml_weak_check" (func $caml_ephe_check_key)) + (func $caml_ephe_check_key (export "caml_ephe_check_key") + (param $vx (ref eq)) (param $vi (ref eq)) (result (ref eq)) + (local $x (ref $block)) + (local $i i32) + (local $v (ref eq)) + (local.set $x (ref.cast (ref $block) (local.get $vx))) + (local.set $i + (i32.add (i31.get_s (ref.cast (ref i31) (local.get $vi))) + (global.get $caml_ephe_key_offset))) + (local.set $v (array.get $block (local.get $x) (local.get $i))) + (block $value + (block $no_value + (br_if $no_value + (ref.eq (local.get $v) (global.get $caml_ephe_none))) + (br_if $value (ref.test (ref i31) (local.get $v))) + (br_if $value + (i32.eqz + (ref.is_null + (call $weak_deref (call $unwrap (local.get $v)))))) + (array.set $block (local.get $x) (local.get $i) + (global.get $caml_ephe_none)) + (array.set $block (local.get $x) (global.get $caml_ephe_data_offset) + (global.get $caml_ephe_none))) + (return (ref.i31 (i32.const 0)))) + (ref.i31 (i32.const 1))) + + (func $caml_ephe_set_key (export "caml_ephe_set_key") + (param $vx (ref eq)) (param $vi (ref eq)) (param $v (ref eq)) + (result (ref eq)) + (local $x (ref $block)) + (local $d (ref eq)) + (local $i i32) + (local.set $x (ref.cast (ref $block) (local.get $vx))) + (local.set $i + (i32.add (i31.get_s (ref.cast (ref i31) (local.get $vi))) + (global.get $caml_ephe_key_offset))) + (local.set $d (ref.i31 (i32.const 0))) + (if (ref.test (ref i31) (local.get $v)) + (then + (if (ref.test (ref $js) + (array.get $block (local.get $x) (local.get $i))) + (then + (local.set $d (call $caml_ephe_get_data (local.get $vx))))) + (array.set $block (local.get $x) (local.get $i) (local.get $v))) + (else + (local.set $d (call $caml_ephe_get_data (local.get $vx))) + (array.set $block (local.get $x) (local.get $i) + (call $wrap (call $weak_new (local.get $v)))))) + (call $caml_ephe_set_data_opt (local.get $vx) (local.get $d)) + (ref.i31 (i32.const 0))) + + (func $caml_ephe_unset_key (export "caml_ephe_unset_key") + (param $vx (ref eq)) (param $vi (ref eq)) (result (ref eq)) + (local $x (ref $block)) + (local $d (ref eq)) + (local $i i32) + (local.set $x (ref.cast (ref $block) (local.get $vx))) + (local.set $i + (i32.add (i31.get_s (ref.cast (ref i31) (local.get $vi))) + (global.get $caml_ephe_key_offset))) + (local.set $d (ref.i31 (i32.const 0))) + (if (ref.test (ref $js) (array.get $block (local.get $x) (local.get $i))) + (then + (local.set $d (call $caml_ephe_get_data (local.get $vx))))) + (array.set $block (local.get $x) (local.get $i) + (global.get $caml_ephe_none)) + (call $caml_ephe_set_data_opt (local.get $vx) (local.get $d)) + (ref.i31 (i32.const 0))) + + (data $Weak_create "Weak.create") + + (export "caml_weak_create" (func $caml_ephe_create)) + (func $caml_ephe_create (export "caml_ephe_create") + (param $vlen (ref eq)) (result (ref eq)) + (local $len i32) + (local $res (ref $block)) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) + (if (i32.lt_s (local.get $len) (i32.const 0)) + (then + (call $caml_invalid_argument + (array.new_data $string $Weak_create + (i32.const 0) (i32.const 11))))) + (local.set $res + (array.new $block (global.get $caml_ephe_none) + (i32.add (local.get $len) (global.get $caml_ephe_key_offset)))) + (array.set $block (local.get $res) (i32.const 0) + (ref.i31 (global.get $abstract_tag))) + (local.get $res)) + + (func (export "caml_ephe_blit_data") + (param $x (ref eq)) (param $y (ref eq)) (result (ref eq)) + (call $caml_ephe_set_data_opt + (local.get $y) (call $caml_ephe_get_data (local.get $x))) + (ref.i31 (i32.const 0))) + + (export "caml_weak_blit" (func $caml_ephe_blit_key)) + (func $caml_ephe_blit_key (export "caml_ephe_blit_key") + (param $x (ref eq)) (param $i (ref eq)) + (param $y (ref eq)) (param $j (ref eq)) + (param $l (ref eq)) (result (ref eq)) + (local $d (ref eq)) + (local.set $d (call $caml_ephe_get_data (local.get $y))) + (array.copy $block $block + (ref.cast (ref $block) (local.get $y)) + (i32.add (i31.get_s (ref.cast (ref i31) (local.get $j))) + (global.get $caml_ephe_key_offset)) + (ref.cast (ref $block) (local.get $x)) + (i32.add (i31.get_s (ref.cast (ref i31) (local.get $i))) + (global.get $caml_ephe_key_offset)) + (i31.get_s (ref.cast (ref i31) (local.get $l)))) + (call $caml_ephe_set_data_opt (local.get $y) (local.get $d)) + (ref.i31 (i32.const 0))) + + (func (export "caml_weak_set") + (param $x (ref eq)) (param $i (ref eq)) (param $v (ref eq)) + (result (ref eq)) + (drop (block $unset (result (ref eq)) + (return_call $caml_ephe_set_key + (local.get $x) (local.get $i) + (array.get $block + (br_on_cast_fail $unset (ref eq) (ref $block) (local.get $v)) + (i32.const 1))))) + (return_call $caml_ephe_unset_key (local.get $x) (local.get $i))) +) diff --git a/runtime/wasm/zstd.wat b/runtime/wasm/zstd.wat new file mode 100644 index 0000000000..09aa888bad --- /dev/null +++ b/runtime/wasm/zstd.wat @@ -0,0 +1,22 @@ +;; Wasm_of_ocaml runtime support +;; http://www.ocsigen.org/js_of_ocaml/ +;; +;; 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. + +(module + + (func (export "caml_zstd_initialize") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) diff --git a/tools/ci_setup.ml b/tools/ci_setup.ml new file mode 100644 index 0000000000..2425ad78f0 --- /dev/null +++ b/tools/ci_setup.ml @@ -0,0 +1,296 @@ +#use "topfind" + +#require "opam-format" + +#require "unix" + +#require "str" + +module StringSet = Set.Make (String) + +(****) + +let repo = "jane-street/opam-repository/packages" + +let roots = [ "bonsai"; "string_dict" ] + +let omitted_others = StringSet.of_list [ "cohttp-async"; "cohttp"; "uri"; "uri-sexp" ] + +let omitted_js = StringSet.of_list [ "sexplib0" ] + +let do_not_pin = + StringSet.of_list + [ "wasocaml"; "wasm_of_ocaml"; "dune"; "ezjs"; "ezjs_blockies"; "fmlib"; "graphv" ] + +let do_pin = StringSet.of_list [ "base"; "ppx_expect"; "ppx_inline_test"; "time_now" ] + +let aliases = [ "ocaml-cstruct", "cstruct" ] + +let dune_workspace = + {|(lang dune 3.17) +(env + (_ + (env-vars (TESTING_FRAMEWORK inline-test)) + (js_of_ocaml (enabled_if false)) + (flags :standard -warn-error -8-32-34-49-52-55 -w -67-69))) +|} + +let patches = + [ ( "sexp_grammar" + , {| +diff --git a/sexp_grammar_validation.opam b/sexp_grammar_validation.opam +new file mode 100644 +index 0000000..e69de29 +diff --git a/validation/src/dune b/validation/src/dune +index 91933ec..849e4d7 100644 +--- a/validation/src/dune ++++ b/validation/src/dune +@@ -1,5 +1,6 @@ + (library + (name sexp_grammar_validation) ++ (public_name sexp_grammar_validation) + (libraries bignum.bigint core + expect_test_helpers_core.expect_test_helpers_base sexp_grammar) + (preprocess +|} + ) + ; ( "bignum" + , {bignum| +diff --git a/dune-project b/dune-project +index e563d7e..b87e356 100644 +--- a/dune-project ++++ b/dune-project +@@ -1,3 +1,3 @@ +-(lang dune 2.0) ++(lang dune 3.17) + + (formatting disabled) +diff --git a/test/src/dune b/test/src/dune +index f93ae3f..3f00557 100644 +--- a/test/src/dune ++++ b/test/src/dune +@@ -2,5 +2,6 @@ + (name bignum_test) + (libraries bigint bignum core expect_test_helpers_core + sexp_grammar_validation) ++ (inline_tests (flags -drop-tag no-js -drop-tag no-wasm -drop-tag 64-bits-only) (modes js wasm)) + (preprocess + (pps ppx_jane))) +diff --git a/test/src/test_bignum.ml b/test/src/test_bignum.ml +index c6d09fb..61b1e5b 100644 +--- a/test/src/test_bignum.ml ++++ b/test/src/test_bignum.ml +@@ -3,6 +3,11 @@ open! Expect_test_helpers_core + open Bignum + open Bignum.For_testing + ++module Zarith = struct ++ module Q = Q ++ module Z = Z ++end ++ + let%expect_test "Bignum.abs" = + let test t = + let t' = require_no_allocation [%here] (fun () -> abs t) in +@@ -71,7 +76,7 @@ let%expect_test "Bignum.sexp_of_t does use Scientific Notation" = + let compare_floats ~of_float x = + let x' = x |> of_float |> Bignum.to_float in + if not (Float.( = ) x x' || (Float.is_nan x && Float.is_nan x')) +- then raise_s [%message "mismatch" (x : float) (x' : float)] ++ then raise_s [%message "mismatch" (x : float) (x' : float) (x |> of_float : Bignum.t)] + ;; + + let%expect_test "roundtrip: f |> Bignum.of_float_decimal |> Bignum.to_float" = +@@ -783,7 +788,7 @@ let%test_module _ = + -1073741825 -> ( 6) \001\253\255\255\255\191 |}] + ;; + +- let%expect_test ("bin_io serialization V2 (javascript)" [@tags "js-only"]) = ++ let%expect_test ("bin_io serialization V2 (javascript)" [@tags "js-only", "no-wasm"]) = + bin_io_tests (module V2); + [%expect + {| +@@ -811,6 +816,34 @@ let%test_module _ = + -1073741825 -> ( 6) \001\253\255\255\255\191 |}] + ;; + ++ let%expect_test ("bin_io serialization V2 (Wasm)" [@tags "wasm-only"]) = ++ bin_io_tests (module V2); ++ [%expect ++ {| ++ 0 -> ( 1) \000 ++ 1 -> ( 2) \001\001 ++ -1 -> ( 3) \001\255\255 ++ 100000001 -> ( 6) \001\253\001\225\245\005 ++ 1000000.1 -> ( 6) \002\253\129\150\152\000 ++ 100000.01 -> ( 6) \003\253\129\150\152\000 ++ 10000.001 -> ( 6) \004\253\129\150\152\000 ++ 1000.0001 -> ( 6) \005\253\129\150\152\000 ++ 100.00001 -> ( 6) \006\253\129\150\152\000 ++ 10.000001 -> ( 6) \007\253\129\150\152\000 ++ 1.0000001 -> ( 6) \008\253\129\150\152\000 ++ 0.10000001 -> ( 6) \009\253\129\150\152\000 ++ 0.010000001 -> (11) \010\253\129\150\152\000\253\000\202\154\059 ++ 0.0010000001 -> (22) \011\02010000001\04710000000000 ++ 10000000000000 -> (16) \011\01410000000000000 ++ -10000000000000 -> (17) \011\015\04510000000000000 ++12345678901234567.12345678901234567 -> (55) \01151234567890123456712345678901234567\047100000000000000000 ++ 1099511627775 -> (15) \011\0131099511627775 ++ 1073741823 -> ( 6) \001\253\255\255\255\063 ++ -1073741824 -> ( 6) \001\253\000\000\000\192 ++ 1073741824 -> (12) \011\0101073741824 ++ -1073741825 -> (13) \011\011\0451073741825 |}] ++ ;; ++ + let%expect_test "bin_io de-serialization V2" = +|bignum} + ) + ] + +(****) + +let read_opam_file filename = + OpamPp.parse + OpamPp.Op.(OpamFormat.I.file -| OpamPp.map_snd OpamFile.OPAM.pp_raw_fields) + ~pos:{ filename; start = 0, 0; stop = 0, 0 } + (OpamParser.FullPos.file (Filename.concat (Filename.concat repo filename) "opam")) + +let dependencies (_, { OpamFile.OPAM.depends }) = + let open OpamFormula in + depends + |> map (fun (nm, _) -> Atom (nm, None)) + |> of_atom_formula + |> atoms + |> List.map fst + |> List.map OpamPackage.Name.to_string + +let packages = + repo + |> Sys.readdir + |> Array.to_list + |> List.map (fun s -> String.sub s 0 (String.index s '.'), read_opam_file s) + +let rec traverse visited p = + if StringSet.mem p visited + then visited + else + let visited = StringSet.add p visited in + match List.assoc p packages with + | exception Not_found -> visited + | opam -> + let l = dependencies opam in + List.fold_left traverse visited l + +let forked_packages = + let ch = + Unix.open_process_in + "curl -L -H 'Accept: application/vnd.github+json' -H 'X-GitHub-Api-Version: \ + 2022-11-28' https://api.github.com/orgs/ocaml-wasm/repos 2> /dev/null | jq -r \ + '.[] | .name'" + in + let l = Str.(split (regexp "\n")) (In_channel.input_all ch) in + close_in ch; + StringSet.of_list l + +let is_forked p = StringSet.mem p forked_packages + +let exec_async ~delay cmd = + let p = + Unix.open_process_out (Printf.sprintf "sleep %f; %s" (float delay /. 10.) cmd) + in + fun () -> ignore (Unix.close_process_out p) + +let ( let* ) (f : unit -> 'a) (g : 'a -> unit -> 'b) : unit -> 'b = fun () -> g (f ()) () + +let sync_exec f l = + let l = List.mapi f l in + List.iter (fun f -> f ()) l + +let pin delay nm = + exec_async + ~delay + (Printf.sprintf + "opam pin add -n %s https://github.com/ocaml-wasm/%s.git#wasm" + (try List.assoc nm aliases + with Not_found -> if List.mem_assoc nm packages then nm ^ ".v0.16.0" else nm) + nm) + +let pin_packages js = + sync_exec + pin + (StringSet.elements + (StringSet.union + (StringSet.diff (StringSet.diff forked_packages js) do_not_pin) + do_pin)) + +let install_others others = + let others = StringSet.elements (StringSet.diff others omitted_others) in + ignore (Sys.command ("opam install -y " ^ String.concat " " others)) + +let clone delay ?branch ?(depth = 1) nm src = + exec_async + ~delay + (Printf.sprintf + "git clone -q --depth %d %s%s jane-street/lib/%s" + depth + (match branch with + | None -> "" + | Some b -> Printf.sprintf "-b %s " b) + src + nm) + +let clone' delay ?branch ?commit nm src = + match commit with + | None -> clone delay ?branch nm src + | Some commit -> + let* () = clone delay ?branch ~depth:100 nm src in + exec_async + ~delay:0 + (Printf.sprintf "cd jane-street/lib/%s && git checkout -b wasm %s" nm commit) + +let () = + Out_channel.( + with_open_bin "jane-street/dune-workspace" + @@ fun ch -> output_string ch dune_workspace) + +let () = + let js, others = + List.fold_left traverse StringSet.empty roots + |> StringSet.partition (fun p -> List.mem_assoc p packages) + in + pin_packages js; + install_others others; + sync_exec (fun i () -> clone i "ocaml-uri" "https://github.com/mirage/ocaml-uri") [ () ]; + sync_exec + (fun i nm -> + let branch = if is_forked nm then Some "wasm" else None in + let commit = + if is_forked nm + then None + else + Some + (let _, opam = List.assoc nm packages in + let url = OpamUrl.to_string (Option.get (OpamFile.OPAM.get_url opam)) in + let tar_file = Filename.basename url in + String.sub tar_file 0 (String.index tar_file '.')) + in + clone' + i + ?branch + ?commit + nm + (Printf.sprintf + "https://github.com/%s/%s" + (if is_forked nm then "ocaml-wasm" else "janestreet") + nm)) + (StringSet.elements (StringSet.diff js omitted_js)) + +let () = + List.iter + (fun (dir, patch) -> + let ch = + Unix.open_process_out (Printf.sprintf "cd jane-street/lib/%s && patch -p 1" dir) + in + output_string ch patch; + ignore (Unix.close_process_out ch)) + patches diff --git a/tools/node_wrapper.sh b/tools/node_wrapper.sh new file mode 100755 index 0000000000..9912795db0 --- /dev/null +++ b/tools/node_wrapper.sh @@ -0,0 +1,3 @@ +#!/bin/sh +export PATH=$(echo $PATH | cut -d : -f 2-) # Do not call oneself recursively +exec node --experimental-wasm-imported-strings --experimental-wasm-stack-switching --stack-size=10000 "$@" diff --git a/toplevel/examples/eval/dune b/toplevel/examples/eval/dune index a9f4c6827d..76fc91026c 100644 --- a/toplevel/examples/eval/dune +++ b/toplevel/examples/eval/dune @@ -1,5 +1,6 @@ (executables (names eval) + (enabled_if %{env:js-enabled=}) (libraries js_of_ocaml-compiler js_of_ocaml-toplevel) (link_flags (:standard -linkall)) @@ -9,12 +10,14 @@ (rule (targets export.txt) + (enabled_if %{env:js-enabled=}) (deps eval.bc) (action (run jsoo_listunits -o %{targets} stdlib))) (rule (targets eval.js) + (enabled_if %{env:js-enabled=}) (action (run %{bin:js_of_ocaml} @@ -28,4 +31,5 @@ (alias (name default) + (enabled_if %{env:js-enabled=}) (deps eval.js index.html)) diff --git a/toplevel/examples/lwt_toplevel/dune b/toplevel/examples/lwt_toplevel/dune index 65a80eba6e..13a6048862 100644 --- a/toplevel/examples/lwt_toplevel/dune +++ b/toplevel/examples/lwt_toplevel/dune @@ -1,5 +1,6 @@ (executables (names toplevel) + (enabled_if %{env:js-enabled=}) (libraries js_of_ocaml-compiler js_of_ocaml-tyxml @@ -156,6 +157,7 @@ (rule (targets toplevel.js) + (enabled_if %{env:js-enabled=}) (action (run %{bin:js_of_ocaml} @@ -184,4 +186,5 @@ (alias (name default) + (enabled_if %{env:js-enabled=}) (deps toplevel.js toplevel.bc.js index.html)) diff --git a/toplevel/test/dune b/toplevel/test/dune index 648bc9eeee..b56071400e 100644 --- a/toplevel/test/dune +++ b/toplevel/test/dune @@ -36,5 +36,6 @@ (rule (alias runtest) + (enabled_if %{env:js-enabled=}) (action (diff test_toplevel.expected test_toplevel.actual))) diff --git a/wasm_of_ocaml-compiler.opam b/wasm_of_ocaml-compiler.opam new file mode 100644 index 0000000000..b145d310e0 --- /dev/null +++ b/wasm_of_ocaml-compiler.opam @@ -0,0 +1,50 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Compiler from OCaml bytecode to WebAssembly" +description: + "Wasm_of_ocaml is a compiler from OCaml bytecode to WebAssembly. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js" +maintainer: ["Ocsigen team "] +authors: ["Ocsigen team "] +license: [ + "GPL-2.0-or-later" "LGPL-2.1-or-later WITH OCaml-LGPL-linking-exception" +] +homepage: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" +doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" +bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" +depends: [ + "dune" {>= "3.17"} + "ocaml" {>= "4.14"} + "js_of_ocaml" {= version} + "num" {with-test} + "ppx_expect" {>= "v0.14.2" & with-test} + "ppxlib" {>= "0.15.0"} + "re" {with-test} + "cmdliner" {>= "1.1.0"} + "sedlex" {>= "2.3"} + "menhir" + "menhirLib" + "menhirSdk" + "yojson" {>= "2.1"} + "binaryen-bin" + "odoc" {with-doc} +] +depopts: ["ocamlfind"] +conflicts: [ + "ocamlfind" {< "1.5.1"} + "js_of_ocaml" {< "3.0"} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] +] +dev-repo: "git+https://github.com/ocsigen/js_of_ocaml.git"