diff --git a/.github/workflows/js_of_ocaml.yml b/.github/workflows/js_of_ocaml.yml index d123e315bc..988277ff7b 100644 --- a/.github/workflows/js_of_ocaml.yml +++ b/.github/workflows/js_of_ocaml.yml @@ -24,7 +24,6 @@ jobs: ocaml-name: - "" ocaml-compiler: - - "4.13" - "5.0" - "5.1" - "5.2" diff --git a/.github/workflows/lint.yml b/.github/workflows/lint.yml index 00cdd669fe..714b254e23 100644 --- a/.github/workflows/lint.yml +++ b/.github/workflows/lint.yml @@ -26,6 +26,7 @@ jobs: with: token: ${{ github.token }} - run: sh tools/make_opam_dune_lint_dir.sh + - run: opam pin -n opam-dune-lint --dev-repo - uses: ocaml/setup-ocaml/lint-opam@v3 lint-fmt: diff --git a/.github/workflows/wasm_of_ocaml.yml b/.github/workflows/wasm_of_ocaml.yml index 6be447a240..3584c62919 100644 --- a/.github/workflows/wasm_of_ocaml.yml +++ b/.github/workflows/wasm_of_ocaml.yml @@ -34,6 +34,8 @@ jobs: - false all_jane_street_tests: - false + wasi: + - false include: - os: macos-latest os-name: MacOS @@ -41,6 +43,7 @@ jobs: separate_compilation: true jane_street_tests: false all_jane_street_tests: false + wasi: false - os: windows-latest os-name: Windows ocaml-compiler: "5.3" @@ -54,23 +57,33 @@ jobs: separate_compilation: true jane_street_tests: true all_jane_street_tests: true + wasi: false - os: ubuntu-latest os-name: Ubuntu ocaml-compiler: "5.3" separate_compilation: false jane_street_tests: true all_jane_street_tests: false + wasi: false - os: ubuntu-latest os-name: Ubuntu ocaml-compiler: "ocaml-variants.5.2.0+ox" separate_compilation: true jane_street_tests: true all_jane_street_tests: true + wasi: false + - os: ubuntu-latest + os-name: Ubuntu + ocaml-compiler: "5.3" + separate_compilation: true + jane_street_tests: false + all_jane_street_tests: false + wasi: true runs-on: ${{ matrix.os }} name: - ${{ (! matrix.separate_compilation) && 'Whole program / ' || ''}}${{ matrix.ocaml-compiler }} / ${{ matrix.os-name }}${{ matrix.all_jane_street_tests && ' / Jane Street tests' || ''}} + ${{ matrix.wasi && 'WASI / ' || '' }}${{ (! matrix.separate_compilation) && 'Whole program / ' || ''}}${{ matrix.ocaml-compiler }} / ${{ matrix.os-name }}${{ matrix.all_jane_street_tests && ' / Jane Street tests' || ''}} steps: - name: Update apt cache @@ -101,7 +114,55 @@ jobs: - name: Set-up Node.js uses: actions/setup-node@v6 with: - node-version: latest + node-version: ${{ matrix.os == 'windows-latest' && 'latest' || 'v26.0.0-v8-canary20260216631fb6e5ef' }} + + - name: Set-up Rust toolchain + if: matrix.wasi + uses: actions-rust-lang/setup-rust-toolchain@v1 + + - name: Checkout Wasmtime + if: matrix.wasi + uses: actions/checkout@v4 + with: + repository: bytecodealliance/wasmtime + path: wasmtime + submodules: true + + - name: Build Wasmtime + if: matrix.wasi + working-directory: ./wasmtime + run: | + cargo build + echo `pwd`/target/debug >> "$GITHUB_PATH" + + - name: Checkout Virgil + if: matrix.wasi + uses: actions/checkout@v4 + with: + repository: titzer/virgil + path: virgil + + - name: Build Virgil + if: matrix.wasi + working-directory: ./virgil + run: | + export PATH=$PATH:`pwd`/bin + echo `pwd`/bin >> "$GITHUB_PATH" + make + + - name: Checkout Wizard engine + if: matrix.wasi + uses: actions/checkout@v4 + with: + repository: titzer/wizard-engine + path: wizard-engine + + - name: Build Wizard engine + if: matrix.wasi + working-directory: ./wizard-engine + run: | + make -j 4 + echo `pwd`/bin >> "$GITHUB_PATH" - name: Set-up OCaml ${{ matrix.ocaml-compiler }} uses: ocaml/setup-ocaml@v3 @@ -169,7 +230,7 @@ jobs: opam install . -t - name: Run tests - if: ${{ matrix.separate_compilation }} + if: ${{ matrix.separate_compilation && ! matrix.wasi }} working-directory: ./wasm_of_ocaml run: opam exec -- dune build @runtest-wasm @@ -178,11 +239,36 @@ jobs: # See https://github.com/libuv/libuv/issues/3622 - name: Run tests with CPS effects - if: ${{ matrix.ocaml-compiler >= '5.' && matrix.separate_compilation }} + if: ${{ matrix.ocaml-compiler >= '5.' && matrix.separate_compilation && ! matrix.wasi }} continue-on-error: ${{ matrix.os == 'windows-latest' }} working-directory: ./wasm_of_ocaml run: opam exec -- dune build @runtest-wasm --profile with-effects + - name: Run tests with native effects + if: ${{ matrix.ocaml-compiler >= '5.' && matrix.separate_compilation && matrix.os != 'windows-latest' }} + working-directory: ./wasm_of_ocaml + run: opam exec -- dune build @runtest-wasm --profile with-native-effects + + - name: Run tests (WASI runtime - node) + if: ${{ matrix.wasi }} + working-directory: ./wasm_of_ocaml + run: opam exec -- dune build @runtest-wasm --profile wasi + + - name: Run tests (WASI runtime - Wizard engine) + if: ${{ matrix.wasi }} + working-directory: ./wasm_of_ocaml + env: + WASM_ENGINE: wizard-fast + run: opam exec -- dune build @runtest-wasm --profile wasi + + - name: Run tests (WASI runtime - wasmtime) + if: ${{ matrix.wasi }} + working-directory: ./wasm_of_ocaml + env: + WASM_ENGINE: wasmtime + WASI_FLAGS: --enable exnref + run: opam exec -- dune build @runtest-wasm --profile wasi + - name: Run Base tests if: matrix.all_jane_street_tests continue-on-error: ${{ matrix.os == 'windows-latest' }} diff --git a/CHANGES.md b/CHANGES.md index e7481e2973..9a5ded6e0a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -10,6 +10,8 @@ * Compiler: improved shape computation (#2198) * Add the --build-config and --apply-build-config flags (#2177) * Runtime/wasm: optimized some bigstring primitives (#2144) +* Wasm_of_ocaml: alternative effect implementation based on the Stack Switching proposal (#2189) +* Compiler/wasm: WASI 0.1 support (#1831) ## Bug fixes * Compiler: fix reference unboxing (#2210) diff --git a/CLAUDE.md b/CLAUDE.md index e3455ec5e9..51a9802692 100644 --- a/CLAUDE.md +++ b/CLAUDE.md @@ -80,7 +80,7 @@ opam install odoc lwt_log yojson ocp-indent graphics higlo ``` **Requirements:** -- OCaml 4.13 to 5.4 +- OCaml 4.14 to 5.4 - Dune 3.19+ - For wasm_of_ocaml: Binaryen 119+ diff --git a/VERSION b/VERSION index 91e4a9f262..ed2ca09d46 100644 --- a/VERSION +++ b/VERSION @@ -1 +1 @@ -6.3.2 +6.4.0~alpha~dev diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.ml b/compiler/bin-wasm_of_ocaml/cmd_arg.ml index e6c8602f6b..402249b8c0 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.ml +++ b/compiler/bin-wasm_of_ocaml/cmd_arg.ml @@ -38,7 +38,7 @@ let trim_trailing_dir_sep s = let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep -let normalize_effects (effects : [ `Disabled | `Cps | `Jspi ] option) common : +let normalize_effects (effects : [ `Disabled | `Cps | `Jspi | `Native ] option) common : Config.effects_backend = match effects with | None -> @@ -46,8 +46,10 @@ let normalize_effects (effects : [ `Disabled | `Cps | `Jspi ] option) common : [--effects cps] *) if List.mem ~eq:String.equal "effects" common.Jsoo_cmdline.Arg.optim.enable then `Cps + else if List.mem ~eq:String.equal "wasi" common.Jsoo_cmdline.Arg.optim.enable + then `Disabled else `Jspi - | Some ((`Disabled | `Cps | `Jspi) as e) -> e + | Some ((`Disabled | `Cps | `Jspi | `Native) as e) -> e type t = { common : Jsoo_cmdline.Arg.t @@ -182,11 +184,15 @@ let options () = let effects = let doc = "Select an implementation of effect handlers. [$(docv)] should be one of $(b,jspi) \ - (the default), $(b,cps), or $(b,disabled)." + (the default), $(b,cps), $(b,native) or $(b,disabled)." in Arg.( value - & opt (some (enum [ "jspi", `Jspi; "cps", `Cps; "disabled", `Disabled ])) None + & opt + (some + (enum + [ "jspi", `Jspi; "cps", `Cps; "native", `Native; "disabled", `Disabled ])) + None & info [ "effects" ] ~docv:"KIND" ~doc) in let build_t @@ -330,11 +336,15 @@ let options_runtime_only () = let effects = let doc = "Select an implementation of effect handlers. [$(docv)] should be one of $(b,jspi) \ - (the default), $(b,cps), or $(b,disabled)." + (the default), $(b,cps), $(b,native) or $(b,disabled)." in Arg.( value - & opt (some (enum [ "jspi", `Jspi; "cps", `Cps; "disabled", `Disabled ])) None + & opt + (some + (enum + [ "jspi", `Jspi; "cps", `Cps; "native", `Native; "disabled", `Disabled ])) + None & info [ "effects" ] ~docv:"KIND" ~doc) in let build_config = Jsoo_cmdline.Arg.build_config in diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 73d6df565b..95bdc72793 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -81,9 +81,13 @@ let preprocessor_variables () = [ ( "effects" , Wat_preprocess.String (match Config.effects () with - | `Disabled | `Jspi -> "jspi" + | `Disabled -> "disabled" + | `Jspi -> "jspi" | `Cps -> "cps" + | `Native -> "native" | `Double_translation -> assert false) ) + ; "wasi", Wat_preprocess.Bool (Config.Flag.wasi ()) + ; "exnref", Wat_preprocess.Bool (Config.Flag.exnref ()) ] let with_runtime_files ~runtime_wasm_files f = @@ -115,7 +119,9 @@ let build_runtime ~runtime_file = ; file = module_name ^ ".wat" ; source = Contents contents }) - Runtime_files.wat_files + (if Config.Flag.wasi () + then ("libc", Runtime_files.wasi_libc) :: Runtime_files.wat_files + else Runtime_files.wat_files) in Runtime.build ~link_options:[ "-g" ] @@ -123,13 +129,16 @@ let build_runtime ~runtime_file = ~variables ~allowed_imports: (Some - [ "bindings" - ; "Math" - ; "js" - ; "wasm:js-string" - ; "wasm:text-encoder" - ; "wasm:text-decoder" - ]) + (if Config.Flag.wasi () + then [ "wasi_snapshot_preview1"; "OCaml" ] + else + [ "bindings" + ; "Math" + ; "js" + ; "wasm:js-string" + ; "wasm:text-encoder" + ; "wasm:text-decoder" + ])) ~inputs ~output_file:runtime_file @@ -210,7 +219,10 @@ let link_and_optimize let t = Timer.make ~get_time:Unix.time () in let primitives = Binaryen.dead_code_elimination - ~dependencies:Runtime_files.dependencies + ~dependencies: + (if Config.Flag.wasi () + then Runtime_files.wasi_dependencies + else Runtime_files.dependencies) ~opt_input_sourcemap:opt_temp_sourcemap ~opt_output_sourcemap:opt_temp_sourcemap' ~input_file:temp_file @@ -318,7 +330,14 @@ let build_js_runtime ~primitives ?runtime_arguments () = | _ -> assert false in let init_fun = - match Parse_js.parse `Script (Parse_js.Lexer.of_string Runtime_files.js_runtime) with + match + Parse_js.parse + `Script + (Parse_js.Lexer.of_string + (if Config.Flag.wasi () + then Runtime_files.js_wasi_launcher + else Runtime_files.js_launcher)) + with | [ (Expression_statement f, _) ] -> f | _ -> assert false in @@ -682,9 +701,12 @@ let run if binaryen_times () then Format.eprintf " link_and_optimize: %a@." Timer.print t2; let wasm_name = - Printf.sprintf - "code-%s" - (String.sub (Digest.to_hex (Digest.file tmp_wasm_file)) ~pos:0 ~len:20) + if Config.Flag.wasi () + then "code" + else + 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'; diff --git a/compiler/bin-wasm_of_ocaml/dune b/compiler/bin-wasm_of_ocaml/dune index e6354ae606..e3b43e1be0 100644 --- a/compiler/bin-wasm_of_ocaml/dune +++ b/compiler/bin-wasm_of_ocaml/dune @@ -28,6 +28,9 @@ gen/gen.exe ../../runtime/wasm/runtime.js ../../runtime/wasm/deps.json + ../../runtime/wasm/runtime-wasi.js + ../../runtime/wasm/deps-wasi.json + ../../runtime/wasm/libc.wasm (glob_files ../../runtime/wasm/*.wat) (glob_files ../../runtime/wasm/runtime-*.wasm)) (action diff --git a/compiler/bin-wasm_of_ocaml/gen/gen.ml b/compiler/bin-wasm_of_ocaml/gen/gen.ml index 513c7a062d..a72e5dece1 100644 --- a/compiler/bin-wasm_of_ocaml/gen/gen.ml +++ b/compiler/bin-wasm_of_ocaml/gen/gen.ml @@ -75,15 +75,28 @@ let check_js_file fname = (* Keep the two variables below in sync with function build_runtime in ../compile.ml *) -let default_flags = [] +let default_flags = [ "exnref", `B false ] -let interesting_runtimes = [ [ "effects", `S "jspi" ]; [ "effects", `S "cps" ] ] +let interesting_runtimes = + [ [ "effects", `S "jspi"; "wasi", `B false ] + ; [ "effects", `S "cps"; "wasi", `B false ] + ; [ "effects", `S "disabled"; "wasi", `B true ] + ; [ "effects", `S "cps"; "wasi", `B true ] + ] + +let defaults = [ "effects", "disabled" ] let name_runtime standard l = let flags = List.filter_map l ~f:(fun (k, v) -> match v with - | `S s -> Some s + | `S s -> + if + List.exists + ~f:(fun (k', s') -> String.equal k k' && String.equal s s') + defaults + then None + else Some s | `B b -> if b then Some k else None) in String.concat ~sep:"-" ("runtime" :: (if standard then [ "standard" ] else flags)) @@ -110,11 +123,13 @@ let print_flags f flags = let () = let () = set_binary_mode_out stdout true in - let js_runtime, deps, wat_files, runtimes = + let js_launcher, deps, js_wasi_launcher, wasi_deps, wasi_libc, wat_files, runtimes = match Array.to_list Sys.argv with - | _ :: js_runtime :: deps :: rest -> - assert (Filename.check_suffix js_runtime ".js"); + | _ :: js_launcher :: deps :: js_wasi_launcher :: wasi_deps :: wasi_libc :: rest -> + assert (Filename.check_suffix js_launcher ".js"); + assert (Filename.check_suffix js_wasi_launcher ".js"); assert (Filename.check_suffix deps ".json"); + assert (Filename.check_suffix wasi_deps ".json"); let wat_files, rest = List.partition rest ~f:(fun f -> Filename.check_suffix f ".wat") in @@ -122,13 +137,17 @@ let () = List.partition rest ~f:(fun f -> Filename.check_suffix f ".wasm") in assert (List.is_empty rest); - js_runtime, deps, wat_files, wasm_files + js_launcher, deps, js_wasi_launcher, wasi_deps, wasi_libc, wat_files, wasm_files | _ -> assert false in - check_js_file js_runtime; + check_js_file js_launcher; + check_js_file js_wasi_launcher; Format.printf "open Wasm_of_ocaml_compiler@."; - Format.printf "let js_runtime = {|\n%s\n|}@." (Fs.read_file js_runtime); + Format.printf "let js_launcher = {|\n%s\n|}@." (Fs.read_file js_launcher); Format.printf "let dependencies = {|\n%s\n|}@." (Fs.read_file deps); + Format.printf "let js_wasi_launcher = {|\n%s\n|}@." (Fs.read_file js_wasi_launcher); + Format.printf "let wasi_dependencies = {|\n%s\n|}@." (Fs.read_file wasi_deps); + Format.printf "let wasi_libc = %S@." (Fs.read_file wasi_libc); Format.printf "let wat_files = [%a]@." (Format.pp_print_list (fun f file -> diff --git a/compiler/bin-wasm_of_ocaml/link_wasm.ml b/compiler/bin-wasm_of_ocaml/link_wasm.ml index 07032da073..47e185b2f2 100644 --- a/compiler/bin-wasm_of_ocaml/link_wasm.ml +++ b/compiler/bin-wasm_of_ocaml/link_wasm.ml @@ -32,6 +32,7 @@ type options = ; variables : Preprocess.variables ; allowed_imports : string list option ; binaryen_options : binaryen_options + ; effects_backend : Js_of_ocaml_compiler.Config.effects_backend } let options = @@ -71,13 +72,30 @@ let options = let allowed_imports = if List.is_empty allowed_imports then None else Some (List.concat allowed_imports) in - `Ok - { input_modules - ; output_file - ; variables - ; allowed_imports - ; binaryen_options = { common; opt; merge } - } + let effects_backend = + match + List.find_map + ~f:(fun (k, v) -> if String.equal k "effects" then Some v else None) + variables.Preprocess.set + with + | Some "native" -> Ok (`Native : Js_of_ocaml_compiler.Config.effects_backend) + | Some "cps" -> Ok `Cps + | Some "jspi" | None -> Ok `Jspi + | Some "double-translation" -> Ok `Double_translation + | Some "disabled" -> Ok `Disabled + | Some other -> Error other + in + match effects_backend with + | Ok effects_backend -> + `Ok + { input_modules + ; output_file + ; variables + ; allowed_imports + ; binaryen_options = { common; opt; merge } + ; effects_backend + } + | Error other -> `Error (false, Printf.sprintf "unknown effects backend %s" other) in let t = Term.( @@ -98,7 +116,11 @@ let link ; variables ; allowed_imports ; binaryen_options = { common; merge; opt } + ; effects_backend } = + (* So that the --enable-stack-switching option is passed to Binaryen + tools for native effects. *) + Js_of_ocaml_compiler.Config.set_effects_backend effects_backend; let inputs = List.map ~f:(fun (module_name, file) -> { Wat_preprocess.module_name; file; source = File }) diff --git a/compiler/lib-wasm/binaryen.ml b/compiler/lib-wasm/binaryen.ml index 1089330ef2..a77d52298f 100644 --- a/compiler/lib-wasm/binaryen.ml +++ b/compiler/lib-wasm/binaryen.ml @@ -38,8 +38,14 @@ let common_options () = ; "--enable-bulk-memory" ; "--enable-nontrapping-float-to-int" ; "--enable-strings" + ; "--enable-multimemory" (* To keep wasm-merge happy *) ] in + let l = + match Config.effects () with + | `Native -> "--enable-stack-switching" :: l + | `Disabled | `Jspi | `Cps | `Double_translation -> l + in let l = if Config.Flag.pretty () then "-g" :: l else l in let l = if times () then "--no-validation" :: l else l in l @@ -135,11 +141,11 @@ let optimize ~output_file () = command - ("wasm-opt" - :: (common_options () - @ (match options with - | Some o -> o - | None -> optimization_options profile) - @ [ Filename.quote input_file; "-o"; Filename.quote output_file ]) + (("wasm-opt" :: (if Config.Flag.exnref () then [ "--emit-exnref" ] else [])) + @ common_options () + @ (match options with + | Some o -> o + | None -> optimization_options profile) + @ [ 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/gc_target.ml b/compiler/lib-wasm/gc_target.ml index b7261ab74a..adfc41f86a 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -1380,8 +1380,8 @@ module Math = struct let unary name x = let* f = register_import - ~allow_tail_call:false - ~import_module:"Math" + ~allow_tail_call:(Config.Flag.wasi ()) + ~import_module:(if Config.Flag.wasi () then "env" else "Math") ~name (Fun (float_func_type 1)) in @@ -1429,8 +1429,8 @@ module Math = struct let binary name x y = let* f = register_import - ~allow_tail_call:false - ~import_module:"Math" + ~allow_tail_call:(Config.Flag.wasi ()) + ~import_module:(if Config.Flag.wasi () then "env" else "Math") ~name (Fun (float_func_type 2)) in @@ -1457,6 +1457,18 @@ module Bigarray = struct (Memory.wasm_struct_get ty (Memory.wasm_cast ty a) 3) (Arith.const (Int32.of_int n)) + let little_endian () = + if Config.Flag.wasi () + then Arith.(const 1l) + else + let* le = + register_import + ~import_module:"bindings" + ~name:"littleEndian" + (Global { mut = false; typ = I32 }) + in + return (W.GlobalGet le) + let get_at_offset ~(kind : Typing.Bigarray.kind) a i = let name, (typ : Wasm_ast.value_type), size, box = match kind with @@ -1498,19 +1510,14 @@ module Bigarray = struct return (W.F64PromoteF32 x) ) | Complex64 -> "dv_get_f64", F64, 4, Fun.id in - let* little_endian = - register_import - ~import_module:"bindings" - ~name:"littleEndian" - (Global { mut = false; typ = I32 }) - in + let* little_endian = little_endian () in let* f = register_import - ~import_module:"bindings" + ~import_module:(if Config.Flag.wasi () then "env" else "bindings") ~name (Fun { W.params = - Ref { nullable = true; typ = Extern } + Ref { nullable = not (Config.Flag.wasi ()); typ = Extern } :: I32 :: (if size = 0 then [] else [ I32 ]) ; result = [ typ ] @@ -1533,14 +1540,12 @@ module Bigarray = struct | Nativeint | Float16 -> box - (return - (W.Call - (f, ta :: ofs :: (if size = 0 then [] else [ W.GlobalGet little_endian ])))) + (return (W.Call (f, ta :: ofs :: (if size = 0 then [] else [ little_endian ])))) | Complex32 | Complex64 -> let delta = Int32.shift_left 1l (size - 1) in let* ofs' = Arith.(return ofs + const delta) in - let* x = box (return (W.Call (f, [ ta; ofs; W.GlobalGet little_endian ]))) in - let* y = box (return (W.Call (f, [ ta; ofs'; W.GlobalGet little_endian ]))) in + let* x = box (return (W.Call (f, [ ta; ofs; little_endian ]))) in + let* y = box (return (W.Call (f, [ ta; ofs'; little_endian ]))) in let* ty = Type.float_array_type in return (W.ArrayNewFixed (ty, [ x; y ])) @@ -1586,19 +1591,14 @@ module Bigarray = struct let* ty = Type.bigarray_type in let* ta = Memory.wasm_struct_get ty (Memory.wasm_cast ty a) 2 in let* ofs = Arith.(i lsl const (Int32.of_int size)) in - let* little_endian = - register_import - ~import_module:"bindings" - ~name:"littleEndian" - (Global { mut = false; typ = I32 }) - in + let* little_endian = little_endian () in let* f = register_import - ~import_module:"bindings" + ~import_module:(if Config.Flag.wasi () then "env" else "bindings") ~name (Fun { W.params = - Ref { nullable = true; typ = Extern } + Ref { nullable = not (Config.Flag.wasi ()); typ = Extern } :: I32 :: typ :: (if size = 0 then [] else [ I32 ]) @@ -1620,18 +1620,15 @@ module Bigarray = struct | Float16 -> let* v = unbox v in instr - (W.CallInstr - ( f - , ta :: ofs :: v :: (if size = 0 then [] else [ W.GlobalGet little_endian ]) - )) + (W.CallInstr (f, ta :: ofs :: v :: (if size = 0 then [] else [ little_endian ]))) | Complex32 | Complex64 -> let delta = Int32.shift_left 1l (size - 1) in let* ofs' = Arith.(return ofs + const delta) in let ty = Type.float_array_type in let* x = unbox (Memory.wasm_array_get ~ty v (Arith.const 0l)) in - let* () = instr (W.CallInstr (f, [ ta; ofs; x; W.GlobalGet little_endian ])) in + let* () = instr (W.CallInstr (f, [ ta; ofs; x; little_endian ])) in let* y = unbox (Memory.wasm_array_get ~ty v (Arith.const 1l)) in - instr (W.CallInstr (f, [ ta; ofs'; y; W.GlobalGet little_endian ])) + instr (W.CallInstr (f, [ ta; ofs'; y; little_endian ])) let offset ~bound_error_index ~(layout : Typing.Bigarray.layout) ta ~indices = let l = @@ -2022,21 +2019,34 @@ let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler = x (block_expr { params = []; result = [ Type.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, Type.value; js_tag, 0, externref ] - in - instr (W.Push e)) - in - instr (W.CallInstr (f, [ exn ])))) + (if Config.Flag.wasi () + then + let* e = + try_expr + { params = []; result = [ Type.value ] } + (body + ~result_typ:[ Type.value ] + ~fall_through:`Skip + ~context:(`Skip :: `Catch :: context)) + [ ocaml_tag, 0, Type.value ] + in + instr (W.Push e) + else + 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, Type.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) diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index 9a049ab9aa..6ef4dd5db6 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -26,7 +26,7 @@ let times = Debug.find "times" let effects_cps () = match Config.effects () with | `Cps -> true - | `Disabled | `Jspi -> false + | `Disabled | `Jspi | `Native -> false | `Double_translation -> assert false module Generate (Target : Target_sig.S) = struct @@ -255,7 +255,7 @@ module Generate (Target : Target_sig.S) = struct (if negate then Arith.( <> ) else Arith.( = )) Arith.(transl_prim_arg ctx ~typ:(Int Unnormalized) x lsl const 1l) Arith.(transl_prim_arg ctx ~typ:(Int Unnormalized) y lsl const 1l) - | Top, Top -> + | Top, Top when not (Config.Flag.wasi ()) -> Value.js_eqeqeq ~negate (transl_prim_arg ctx ~typ:Top x) @@ -266,7 +266,8 @@ module Generate (Target : Target_sig.S) = struct (transl_prim_arg ctx ~typ:Top x) (transl_prim_arg ctx ~typ:Top y) | (Int _ | Number _ | Tuple _ | Bigarray _ | Null), _ - | _, (Int _ | Number _ | Tuple _ | Bigarray _ | Null) -> + | _, (Int _ | Number _ | Tuple _ | Bigarray _ | Null) + | Top, Top (* when wasi is enabled *) -> (* Only Top may contain JavaScript values *) (if negate then Value.phys_neq else Value.phys_eq) (transl_prim_arg ctx ~typ:Top x) @@ -2379,6 +2380,38 @@ module Generate (Target : Target_sig.S) = struct :: context.other_fields; name + let add_missing_primitives ~context l = + let failwith_desc = W.Fun { params = [ Type.value ]; result = [] } in + List.iter l ~f:(fun (exported_name, arity) -> + let name = Code.Var.fresh_n exported_name in + let locals, body = + function_body + ~context + ~param_names:[] + ~body: + (let* failwith = + register_import ~import_module:"env" ~name:"caml_failwith" failwith_desc + in + let* msg = + Constant.translate + ~unboxed:false + (String (exported_name ^ " not implemented")) + in + let* () = instr (CallInstr (failwith, [ msg ])) in + push Value.unit) + in + context.other_fields <- + W.Function + { name + ; exported_name = Some exported_name + ; typ = None + ; signature = Type.primitive_type arity + ; param_names = [] + ; locals + ; body + } + :: context.other_fields) + let entry_point context toplevel_fun entry_name = let signature, param_names, body = entry_point ~toplevel_fun in let locals, body = function_body ~context ~param_names ~body in @@ -2568,6 +2601,10 @@ let add_start_function = G.add_start_function let add_init_function = G.add_init_function +let add_missing_primitives = + let module G = Generate (Gc_target) in + G.add_missing_primitives + let output ch ~context = let t = Timer.make () in let fields = G.output ~context in diff --git a/compiler/lib-wasm/generate.mli b/compiler/lib-wasm/generate.mli index 47cfb17095..8c777e9250 100644 --- a/compiler/lib-wasm/generate.mli +++ b/compiler/lib-wasm/generate.mli @@ -34,6 +34,9 @@ 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 add_missing_primitives : + context:Code_generation.context -> (string * int) list -> unit + val output : out_channel -> context:Code_generation.context -> unit val wasm_output : diff --git a/compiler/lib-wasm/link.ml b/compiler/lib-wasm/link.ml index 6df7065435..0110d01627 100644 --- a/compiler/lib-wasm/link.ml +++ b/compiler/lib-wasm/link.ml @@ -193,7 +193,20 @@ module Wasm_binary = struct let reftype' i ch = match i with - | 0x6a | 0x6b | 0x6c | 0x6d | 0x6e | 0x6f | 0x70 | 0x71 | 0x72 | 0x73 -> () + | 0x68 + | 0x69 + | 0x6a + | 0x6b + | 0x6c + | 0x6d + | 0x6e + | 0x6f + | 0x70 + | 0x71 + | 0x72 + | 0x73 + | 0x74 + | 0x75 -> () | 0x63 | 0x64 -> heaptype ch | _ -> Format.eprintf "Unknown reftype %x@." i; @@ -201,12 +214,13 @@ module Wasm_binary = struct let reftype ch = reftype' (input_byte ch) ch - let valtype ch = - let i = read_uint ch in + let valtype' i ch = match i with - | 0x7b | 0x7c | 0x7d | 0x7e | 0x7f -> () + | 0x7B | 0x7C | 0x7D | 0x7E | 0x7F -> () | _ -> reftype' i ch + let valtype ch = valtype' (read_uint ch) ch + let limits ch = match input_byte ch with | 0 -> ignore (read_uint ch) @@ -221,32 +235,99 @@ module Wasm_binary = struct reftype ch; limits ch + type comptype = + | Func of { arity : int } + | Struct + | Array + | Cont + + let supertype ch = + match input_byte ch with + | 0 -> () + | 1 -> ignore (read_uint ch) + | _ -> assert false + + let storagetype ch = + let i = read_uint ch in + match i with + | 0x78 | 0x77 -> () + | _ -> valtype' i ch + + let fieldtype ch = + storagetype ch; + ignore (input_byte ch) + + let comptype i ch = + match i with + | 0x5D -> + ignore (read_sint ch); + Cont + | 0x5E -> + fieldtype ch; + Array + | 0x5F -> + ignore (vec fieldtype ch); + Struct + | 0x60 -> + let params = vec valtype ch in + let _ = vec valtype ch in + Func { arity = List.length params } + | c -> failwith (Printf.sprintf "Unknown comptype %d" c) + + let subtype i ch = + match i with + | 0x50 -> + supertype ch; + comptype (input_byte ch) ch + | 0x4F -> + supertype ch; + comptype (input_byte ch) ch + | _ -> comptype i ch + + let rectype ch = + match input_byte ch with + | 0x4E -> vec (fun ch -> subtype (input_byte ch) ch) ch + | i -> [ subtype i ch ] + + type importdesc = + | Func of int + | Table + | Mem + | Global + | Tag + type import = { module_ : string ; name : string + ; desc : importdesc } let import ch = let module_ = name ch in let name = name ch in let d = read_uint ch in - let _ = + let desc = match d with - | 0 -> ignore (read_uint ch) - | 1 -> tabletype ch - | 2 -> memtype ch + | 0 -> Func (read_uint ch) + | 1 -> + tabletype ch; + Table + | 2 -> + memtype ch; + Mem | 3 -> let _typ = valtype ch in let _mut = input_byte ch in - () + Global | 4 -> assert (read_uint ch = 0); - ignore (read_uint ch) + ignore (read_uint ch); + Tag | _ -> Format.eprintf "Unknown import %x@." d; assert false in - { module_; name } + { module_; name; desc } let export ch = let name = name ch in @@ -276,6 +357,7 @@ module Wasm_binary = struct type interface = { imports : import list ; exports : string list + ; types : comptype array } let read_interface ch = @@ -283,7 +365,11 @@ module Wasm_binary = struct match next_section ch with | None -> i | Some s -> - if s.id = 2 + if s.id = 1 + then + find_sections + { i with types = Array.of_list (List.flatten (vec rectype ch.ch)) } + else 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 } @@ -291,7 +377,7 @@ module Wasm_binary = struct skip_section ch s; find_sections i) in - find_sections { imports = []; exports = [] } + find_sections { imports = []; exports = []; types = [||] } let append_source_map_section ~file ~url = let ch = open_out_gen [ Open_wronly; Open_append; Open_binary ] 0o666 file in @@ -403,6 +489,13 @@ let generate_start_function ~to_link ~out_file = Generate.wasm_output ch ~opt_source_map_file:None ~context; if times () then Format.eprintf " generate start: %a@." Timer.print t1 +let generate_missing_primitives ~missing_primitives ~out_file = + Filename.gen_file out_file + @@ fun ch -> + let context = Generate.start () in + Generate.add_missing_primitives ~context missing_primitives; + Generate.wasm_output ch ~opt_source_map_file:None ~context + let output_js js = let js = Driver.simplify_js js in let js = Driver.name_variables js in @@ -550,7 +643,7 @@ let build_runtime_arguments let props = match Config.effects () with | `Disabled -> ("disable_effects", Javascript.EBool true) :: props - | `Jspi | `Cps -> props + | `Jspi | `Cps | `Native -> props | `Double_translation -> assert false in let props = @@ -661,17 +754,20 @@ let compute_dependencies ~files_to_link ~files = let compute_missing_primitives (runtime_intf, intfs) = let provided_primitives = StringSet.of_list runtime_intf.Wasm_binary.exports in - StringSet.elements + StringMap.bindings @@ List.fold_left - ~f:(fun s { Wasm_binary.imports; _ } -> + ~f:(fun s { Wasm_binary.imports; types; _ } -> 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) + ~f:(fun s { Wasm_binary.module_; name; desc } -> + match module_, desc with + | "env", Func idx when not (StringSet.mem name provided_primitives) -> ( + match types.(idx) with + | Func { arity } -> StringMap.add name arity s + | _ -> s) + | _ -> s) ~init:s imports) - ~init:StringSet.empty + ~init:StringMap.empty intfs let load_information files = @@ -744,6 +840,72 @@ let read_embedded_files file = then Marshal.from_string (Zip.read_entry z ~name:"embedded_files") 0 else []) +let link_to_module ~to_link ~files_to_link ~files ~enable_source_maps:_ ~dir = + let process_file ~name ~module_name file = + Zip.with_open_in file + @@ fun z -> + let intf = + let ch, pos, len, _ = Zip.get_entry z ~name in + Wasm_binary.read_interface (Wasm_binary.from_channel ~name ch pos len) + in + ( { Wasm_link.module_name + ; file + ; code = Some (Zip.read_entry z ~name) + ; opt_source_map = None + } + , intf ) + in + let runtime_file = fst (List.hd files) in + let z = Zip.open_in runtime_file in + let runtime, runtime_intf = + process_file ~name:"runtime.wasm" ~module_name:"env" runtime_file + in + let prelude = + { Wasm_link.module_name = "OCaml" + ; file = runtime_file + ; code = Some (Zip.read_entry z ~name:"prelude.wasm") + ; opt_source_map = None + } + in + Zip.close_in z; + let lst = + List.tl files + |> List.filter_map ~f:(fun (file, _) -> + if StringSet.mem file files_to_link + then Some (process_file ~name:"code.wasm" ~module_name:"OCaml" file) + else None) + in + let missing_primitives = + if Config.Flag.genprim () + then compute_missing_primitives (runtime_intf, List.map ~f:snd lst) + else [] + in + Fs.with_intermediate_file (Filename.temp_file "start" ".wasm") + @@ fun start_module -> + generate_start_function ~to_link ~out_file:start_module; + let start = + { Wasm_link.module_name = "OCaml" + ; file = start_module + ; code = None + ; opt_source_map = None + } + in + Fs.with_intermediate_file (Filename.temp_file "stubs" ".wasm") + @@ fun stubs_module -> + generate_missing_primitives ~missing_primitives ~out_file:stubs_module; + let missing_primitives = + { Wasm_link.module_name = "env" + ; file = stubs_module + ; code = None + ; opt_source_map = None + } + in + ignore + (Wasm_link.f + (runtime :: prelude :: missing_primitives :: start :: List.map ~f:fst lst) + ~filter_export:(fun nm -> String.equal nm "_start" || String.equal nm "memory") + ~output_file:(Filename.concat dir "code.wasm")) + let link ~output_file ~linkall ~enable_source_maps ~embedded_files ~files = if times () then Format.eprintf "linking@."; let t = Timer.make () in @@ -842,42 +1004,47 @@ let link ~output_file ~linkall ~enable_source_maps ~embedded_files ~files = 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 missing_primitives, 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 - let all_primitives = - List.fold_left files ~init:StringSet.empty ~f:(fun acc (_, (_, units)) -> - List.fold_left units ~init:acc ~f:(fun acc { unit_info; _ } -> - List.fold_left unit_info.Unit_info.primitives ~init:acc ~f:(fun acc p -> - StringSet.add p acc))) - in - let link_info_wasm = build_dynlink_init ~to_link ~all_primitives in - let link_info_module = "_link_info" in - let out = Filename.concat tmp_dir (link_info_module ^ ".wasm") in - Fs.write_file ~name:out ~contents:link_info_wasm; - let start_to_link = link_info_module :: to_link in - generate_start_function - ~to_link:start_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) - @ [ link_info_module, None; start_module, None ] ) + if not (Config.Flag.wasi ()) + then ( + let start_module = + "start-" + ^ String.sub + (Digest.to_hex (Digest.string (String.concat ~sep:"/" to_link))) + ~pos:0 + ~len:8 + in + let all_primitives = + List.fold_left files ~init:StringSet.empty ~f:(fun acc (_, (_, units)) -> + List.fold_left units ~init:acc ~f:(fun acc { unit_info; _ } -> + List.fold_left unit_info.Unit_info.primitives ~init:acc ~f:(fun acc p -> + StringSet.add p acc))) + in + let link_info_wasm = build_dynlink_init ~to_link ~all_primitives in + let link_info_module = "_link_info" in + let out = Filename.concat tmp_dir (link_info_module ^ ".wasm") in + Fs.write_file ~name:out ~contents:link_info_wasm; + let start_to_link = link_info_module :: to_link in + let module_names, interfaces = + link_to_directory ~files_to_link ~files ~enable_source_maps ~dir:tmp_dir + in + let missing_primitives = compute_missing_primitives interfaces in + generate_start_function + ~to_link:start_to_link + ~out_file:(Filename.concat tmp_dir (start_module ^ ".wasm")); + ( List.map ~f:fst missing_primitives + , dir + , let to_link = compute_dependencies ~files_to_link ~files in + List.combine module_names (None :: None :: to_link) + @ [ link_info_module, None; start_module, None ] )) + else ( + link_to_module ~to_link ~files_to_link ~files ~enable_source_maps ~dir:tmp_dir; + [], dir, [ "code", 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 = diff --git a/compiler/lib-wasm/link.mli b/compiler/lib-wasm/link.mli index 0b0c9434ae..38e58ab710 100644 --- a/compiler/lib-wasm/link.mli +++ b/compiler/lib-wasm/link.mli @@ -19,9 +19,17 @@ open! Stdlib module Wasm_binary : sig + type importdesc = + | Func of int + | Table + | Mem + | Global + | Tag + type import = { module_ : string ; name : string + ; desc : importdesc } val check : contents:string -> bool diff --git a/compiler/lib-wasm/runtime.ml b/compiler/lib-wasm/runtime.ml index f20560d2da..8e6925ad3d 100644 --- a/compiler/lib-wasm/runtime.ml +++ b/compiler/lib-wasm/runtime.ml @@ -49,7 +49,7 @@ let build ~allowed_imports ~link_options ~opt_options ~variables ~inputs ~output then ( Format.eprintf "The runtime contains unknown imports:@."; List.iter - ~f:(fun { Link.Wasm_binary.module_; name } -> + ~f:(fun { Link.Wasm_binary.module_; name; _ } -> Format.eprintf " %s %s@." module_ name) missing_imports; exit 2)) diff --git a/compiler/lib-wasm/wasm_link.ml b/compiler/lib-wasm/wasm_link.ml index 8502268a11..9e61437bd1 100644 --- a/compiler/lib-wasm/wasm_link.ml +++ b/compiler/lib-wasm/wasm_link.ml @@ -23,6 +23,10 @@ type heaptype = | Nofunc | Extern | Noextern + | Exn + | Noexn + | Cont + | Nocont | Any | Eq | I31 @@ -66,6 +70,7 @@ type comptype = } | Struct of fieldtype array | Array of fieldtype + | Cont of int type subtype = { final : bool @@ -164,6 +169,8 @@ module Write = struct let heaptype st ch typ = match (typ : heaptype) with + | Nocont -> byte ch 0x75 + | Noexn -> byte ch 0x74 | Nofunc -> byte ch 0x73 | Noextern -> byte ch 0x72 | None_ -> byte ch 0x71 @@ -174,6 +181,8 @@ module Write = struct | I31 -> byte ch 0x6C | Struct -> byte ch 0x6B | Array -> byte ch 0x6A + | Exn -> byte ch 0x69 + | Cont -> byte ch 0x68 | Type idx -> sint ch (typeidx st idx) let reftype st ch { nullable; typ } = @@ -219,6 +228,9 @@ module Write = struct byte ch 1; uint ch (typeidx st supertype)); match typ with + | Cont idx -> + byte ch 0x5D; + sint ch (typeidx st idx) | Array field_type -> byte ch 0x5E; fieldtype st ch field_type @@ -571,7 +583,9 @@ module Read = struct let heaptype st ch = let i = sint ch in match i + 128 with - | 0X73 -> Nofunc + | 0x75 -> Nocont + | 0x74 -> Noexn + | 0x73 -> Nofunc | 0x72 -> Noextern | 0x71 -> None_ | 0x70 -> Func @@ -581,6 +595,8 @@ module Read = struct | 0x6C -> I31 | 0x6B -> Struct | 0x6A -> Array + | 0x69 -> Exn + | 0x68 -> Cont | _ -> if i < 0 then failwith (Printf.sprintf "Unknown heaptype %x@." i); let i = @@ -598,7 +614,9 @@ module Read = struct let reftype' st i ch = match i with - | 0X73 -> nullable Nofunc + | 0x75 -> nullable Nocont + | 0x74 -> nullable Noexn + | 0x73 -> nullable Nofunc | 0x72 -> nullable Noextern | 0x71 -> nullable None_ | 0x70 -> nullable Func @@ -608,6 +626,8 @@ module Read = struct | 0x6C -> nullable I31 | 0x6B -> nullable Struct | 0x6A -> nullable Array + | 0x69 -> nullable Exn + | 0x68 -> nullable Cont | 0x63 -> nullable (heaptype st ch) | 0x64 -> { nullable = false; typ = heaptype st ch } | _ -> failwith (Printf.sprintf "Unknown reftype %x@." i) @@ -654,6 +674,14 @@ module Read = struct let comptype st i ch = match i with + | 0x5D -> + let i = sint ch in + let i = + if i >= st.type_index_count + then lnot (i - st.type_index_count) + else st.type_mapping.(i) + in + Cont i | 0x5E -> Array (fieldtype st ch) | 0x5F -> Struct (vec (fieldtype st) ch) | 0x60 -> @@ -1260,6 +1288,13 @@ module Scan = struct | 0xD1 (* ref.is_null *) | 0xD3 (* ref.eq *) | 0xD4 (* ref.as_non_null *) -> pos + 1 |> instructions | 0xD2 (* ref.func *) -> pos + 1 |> funcidx |> instructions + | 0xE0 (* cont.new *) -> pos + 1 |> typeidx |> instructions + | 0xE1 (* cont.bind *) -> pos + 1 |> typeidx |> typeidx |> instructions + | 0xE2 (* suspend *) -> pos + 1 |> tagidx |> instructions + | 0xE3 (* resume *) -> pos + 1 |> typeidx |> vector on_clause |> instructions + | 0xE4 (* resume_throw *) -> + pos + 1 |> typeidx |> tagidx |> vector on_clause |> instructions + | 0xE5 (* switch *) -> pos + 1 |> typeidx |> tagidx |> instructions | 0xFB -> pos + 1 |> gc_instruction | 0xFC -> ( if debug then Format.eprintf " %d@." (get (pos + 1)); @@ -1393,7 +1428,12 @@ module Scan = struct 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) + | c -> failwith (Printf.sprintf "bad catch 0x%02x@." c) + and on_clause pos = + match get pos with + | 0 (* on *) -> pos + 1 |> tagidx |> labelidx + | 1 (* on .. switch *) -> pos + 1 |> tagidx + | c -> failwith (Printf.sprintf "bad on clause 0x%02x@." c) and block_end pos = if debug then Format.eprintf "0x%02X (@%d) block end@." (get pos) pos; match get pos with @@ -1552,6 +1592,10 @@ let heap_subtype (subtyping_info : subtype array) (ty : heaptype) (ty' : heaptyp | Nofunc, Nofunc | (Extern | Noextern), Extern | Noextern, Noextern + | (Exn | Noexn), Exn + | Noexn, Noexn + | (Cont | Nocont), Cont + | Nocont, Nocont | (Any | Eq | I31 | Struct | Array | None_), Any | (Eq | I31 | Struct | Array | None_), Eq | (I31 | None_), I31 @@ -1561,27 +1605,35 @@ let heap_subtype (subtyping_info : subtype array) (ty : heaptype) (ty' : heaptyp | Type i, (Any | Eq) -> ( match subtyping_info.(i).typ with | Struct _ | Array _ -> true - | Func _ -> false) + | Func _ | Cont _ -> false) | Type i, Struct -> ( match subtyping_info.(i).typ with | Struct _ -> true - | Array _ | Func _ -> false) + | Array _ | Func _ | Cont _ -> false) | Type i, Array -> ( match subtyping_info.(i).typ with | Array _ -> true - | Struct _ | Func _ -> false) + | Struct _ | Func _ | Cont _ -> false) | Type i, Func -> ( match subtyping_info.(i).typ with | Func _ -> true - | Struct _ | Array _ -> false) + | Struct _ | Array _ | Cont _ -> false) + | Type i, Cont -> ( + match subtyping_info.(i).typ with + | Cont _ -> true + | Struct _ | Array _ | Func _ -> false) | None_, Type i -> ( match subtyping_info.(i).typ with | Struct _ | Array _ -> true - | Func _ -> false) + | Func _ | Cont _ -> false) | Nofunc, Type i -> ( match subtyping_info.(i).typ with | Func _ -> true - | Struct _ | Array _ -> false) + | Struct _ | Array _ | Cont _ -> false) + | Nocont, Type i -> ( + match subtyping_info.(i).typ with + | Cont _ -> true + | Struct _ | Array _ | Func _ -> false) | Type i, Type i' -> subtype subtyping_info i i' | _ -> false @@ -1899,7 +1951,7 @@ type input = ; opt_source_map : Source_map.Standard.t option } -let f files ~output_file = +let f ?(filter_export = fun _ -> true) files ~output_file = let files = Array.map ~f:(fun { module_name; file; code; opt_source_map } -> @@ -2153,20 +2205,28 @@ let f files ~output_file = Array.iter ~f:Scan.clear_position_data positions; (* 7: export *) + let exports = + Array.map + ~f:(fun intf -> + map_exportable_info + (fun _ exports -> List.filter ~f:(fun (nm, _) -> filter_export nm) exports) + intf.Read.exports) + intfs + in let export_count = Array.fold_left - ~f:(fun count intf -> + ~f:(fun count exports -> fold_exportable_info (fun _ exports count -> List.length exports + count) count - intf.Read.exports) + exports) ~init:0 - intfs + exports in Write.uint buf export_count; - let exports = String.Hashtbl.create 128 in + let export_tbl = String.Hashtbl.create 128 in Array.iteri - ~f:(fun i intf -> + ~f:(fun i exports -> iter_exportable_info (fun kind lst -> let map = @@ -2179,7 +2239,7 @@ let f files ~output_file = in List.iter ~f:(fun (name, idx) -> - match String.Hashtbl.find exports name with + match String.Hashtbl.find export_tbl name with | i' -> failwith (Printf.sprintf @@ -2188,11 +2248,11 @@ let f files ~output_file = files.(i').file files.(i).file) | exception Not_found -> - String.Hashtbl.add exports name i; + String.Hashtbl.add export_tbl name i; Write.export buf kind name map.(idx)) lst) - intf.Read.exports) - intfs; + exports) + exports; add_section out_ch ~id:7 buf; (* 8: start *) @@ -2465,7 +2525,6 @@ let f files ~output_file = (* LATER - testsuite : import/export matching, source maps, multiple start functions, ... -- missing instructions ==> typed continuations (?) - check features? MAYBE diff --git a/compiler/lib-wasm/wasm_link.mli b/compiler/lib-wasm/wasm_link.mli index 0c0ed0a582..4cbd769668 100644 --- a/compiler/lib-wasm/wasm_link.mli +++ b/compiler/lib-wasm/wasm_link.mli @@ -23,4 +23,5 @@ type input = ; opt_source_map : Source_map.Standard.t option } -val f : input list -> output_file:string -> Source_map.t +val f : + ?filter_export:(string -> bool) -> input list -> output_file:string -> Source_map.t diff --git a/compiler/lib/build_info.ml b/compiler/lib/build_info.ml index eba95dfd9e..ca61690712 100644 --- a/compiler/lib/build_info.ml +++ b/compiler/lib/build_info.ml @@ -41,12 +41,14 @@ let string_of_effects_backend : Config.effects_backend -> string = function | `Cps -> "cps" | `Double_translation -> "double-translation" | `Jspi -> "jspi" + | `Native -> "native" let effects_backend_of_string = function | "disabled" -> `Disabled | "cps" -> `Cps | "double-translation" -> `Double_translation | "jspi" -> `Jspi + | "native" -> `Native | _ -> invalid_arg "effects_backend_of_string" type config_key = @@ -73,7 +75,7 @@ let config_keys target = ( [ "disabled"; "cps"; "double-translation" ] , fun () -> string_of_effects_backend (Config.effects ()) ) | `Wasm -> - ( [ "disabled"; "cps"; "jspi" ] + ( [ "disabled"; "cps"; "jspi"; "native" ] , fun () -> string_of_effects_backend (Config.effects ()) ) in [ Enum_key @@ -90,6 +92,11 @@ let config_keys target = ; Bool_key { name = "toplevel"; get = Config.Flag.toplevel; set = Config.Flag.set "toplevel" } ] + @ + match target with + | `Wasm -> + [ Bool_key { name = "wasi"; get = Config.Flag.wasi; set = Config.Flag.set "wasi" } ] + | `JavaScript -> [] let config_key_values = function | Bool_key _ -> [ "true"; "false" ] diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 69db92887d..57210ab2aa 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -112,6 +112,10 @@ module Flag = struct let load_shapes_auto = o ~name:"load-shapes-auto" ~default:false let toplevel = o ~name:"toplevel" ~default:false + + let exnref = o ~name:"exnref" ~default:false + + let wasi = o ~name:"wasi" ~default:false end module Param = struct @@ -236,6 +240,7 @@ type effects_backend = | `Cps | `Double_translation | `Jspi + | `Native ] let effects_ : [< `None | effects_backend ] ref = ref `None @@ -243,7 +248,7 @@ let effects_ : [< `None | effects_backend ] ref = ref `None let effects () = match !effects_ with | `None -> failwith "effects was not set" - | (`Jspi | `Cps | `Disabled | `Double_translation) as b -> b + | (`Jspi | `Cps | `Native | `Disabled | `Double_translation) as b -> b let set_effects_backend (backend : effects_backend) = effects_ := (backend :> [ `None | effects_backend ]) diff --git a/compiler/lib/config.mli b/compiler/lib/config.mli index 2a540f68bc..e99dd27e5c 100644 --- a/compiler/lib/config.mli +++ b/compiler/lib/config.mli @@ -82,6 +82,10 @@ module Flag : sig val toplevel : unit -> bool + val exnref : unit -> bool + + val wasi : unit -> bool + val enable : string -> unit val disable : string -> unit @@ -128,6 +132,7 @@ type effects_backend = | `Cps | `Double_translation | `Jspi + | `Native ] val effects : unit -> effects_backend diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 5573acae27..bb712eee16 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -178,7 +178,7 @@ let effects_and_exact_calls | `JavaScript -> Lambda_lifting.f p in p, trampolined_calls, in_cps, None, shapes - | `Disabled | `Jspi -> + | `Disabled | `Jspi | `Native -> let p = Specialize.f ~shape:(fun f -> @@ -719,9 +719,9 @@ let optimize ~shapes ~profile ~keep_flow_data p = +> map_fst5 (match Config.target (), Config.effects () with | `JavaScript, `Disabled -> Generate_closure.f - | `JavaScript, (`Cps | `Double_translation) | `Wasm, (`Disabled | `Jspi | `Cps) - -> Fun.id - | `JavaScript, `Jspi | `Wasm, `Double_translation -> assert false) + | `JavaScript, (`Cps | `Double_translation) + | `Wasm, (`Disabled | `Jspi | `Cps | `Native) -> Fun.id + | `JavaScript, (`Jspi | `Native) | `Wasm, `Double_translation -> assert false) +> map_fst5 deadcode' in if times () then Format.eprintf "Start Optimizing...@."; diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index fbb90c9aa4..d5e1b9dfdf 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -40,7 +40,7 @@ let debug = Debug.find "effects" let double_translate () = match Config.effects () with - | `Disabled | `Jspi -> assert false + | `Disabled | `Jspi | `Native -> assert false | `Cps -> false | `Double_translation -> true diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 123a2279b2..647b19545a 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -28,7 +28,7 @@ let cps_transform () = match Config.effects () with | `Cps | `Double_translation -> true | `Disabled -> false - | `Jspi -> assert false + | `Jspi | `Native -> assert false open Code module J = Javascript @@ -1092,7 +1092,7 @@ let apply_fun_raw = (* Effects enabled, CPS version, not single-version *) J.EDot (f, J.ANormal, cps_field) | `Cps | `Double_translation | `Disabled -> f - | `Jspi -> assert false + | `Jspi | `Native -> assert false in (* We skip the arity check when we know that we have the right number of parameters, since this test is expensive. *) @@ -1119,7 +1119,7 @@ let apply_fun_raw = (match Config.effects () with | `Double_translation when cps -> "caml_call_gen_cps" | `Double_translation | `Cps | `Disabled -> "caml_call_gen" - | `Jspi -> assert false)) + | `Jspi | `Native -> assert false)) [ f; J.array params ] J.N ) in @@ -1135,7 +1135,7 @@ let apply_fun_raw = [ apply ~cps:false f (fst (List.take (n - 1) params)) ] J.N ) | `Double_translation | `Cps | `Disabled -> apply ~cps f params - | `Jspi -> assert false + | `Jspi | `Native -> assert false in if trampolined then ( diff --git a/compiler/lib/generate_closure.ml b/compiler/lib/generate_closure.ml index 659a5a6479..34bc2b775f 100644 --- a/compiler/lib/generate_closure.ml +++ b/compiler/lib/generate_closure.ml @@ -337,7 +337,7 @@ let f p : Code.program = let f p = assert ( match Config.effects () with - | `Disabled | `Jspi -> true + | `Disabled | `Jspi | `Native -> true | `Cps | `Double_translation -> false); let open Config.Param in match tailcall_optim () with diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index 6da3837a9f..f7546a58e8 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -454,7 +454,7 @@ and should_inline ~context info args = || (not (Lazy.force !(context.has_closures))) && Option.equal Var.equal info.enclosing_function context.enclosing_function | `Wasm, _ | `JavaScript, `Double_translation -> true - | `JavaScript, `Jspi -> assert false) + | `JavaScript, (`Jspi | `Native) -> assert false) && (functor_like ~context info || (context.live_vars.(Var.idx info.f) = 1 && diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml index 47b7d44f51..3b33f9c80a 100644 --- a/compiler/lib/js_output.ml +++ b/compiler/lib/js_output.ml @@ -2229,7 +2229,7 @@ let program ?(accept_unnamed_var = false) ?(source_map = false) f p = PP.set_needed_space_function f need_space; (match Config.effects () with | `Cps | `Double_translation -> PP.set_adjust_indentation_function f (fun n -> n mod 40) - | `Disabled | `Jspi | (exception Failure _) -> ()); + | `Disabled | `Jspi | `Native | (exception Failure _) -> ()); PP.start_group f 0; O.program f p; PP.end_group f; diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index 1fbc0f90ed..d17823cb60 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -205,13 +205,13 @@ module Fragment = struct ; ( "effects" , fun () -> match Config.effects () with - | `Disabled | `Jspi -> false + | `Disabled | `Jspi | `Native -> false | `Cps | `Double_translation -> true ) ; ( "doubletranslate" , fun () -> match Config.effects () with | `Double_translation -> true - | `Jspi | `Cps | `Disabled -> false ) + | `Jspi | `Cps | `Native | `Disabled -> false ) ; ( "wasm" , fun () -> match Config.target () with diff --git a/compiler/lib/magic_number.ml b/compiler/lib/magic_number.ml index 403280afc0..1bd4478e59 100644 --- a/compiler/lib/magic_number.ml +++ b/compiler/lib/magic_number.ml @@ -66,8 +66,8 @@ let equal a b = compare a b = 0 let () = let current = Ocaml_version.current in - if Ocaml_version.compare current [ 4; 13 ] < 0 - then failwith "OCaml version unsupported. Upgrade to OCaml 4.13 or newer." + if Ocaml_version.compare current [ 4; 14 ] < 0 + then failwith "OCaml version unsupported. Upgrade to OCaml 4.14 or newer." else if Ocaml_version.compare current [ 5; 6 ] >= 0 then failwith "OCaml version unsupported. Upgrade js_of_ocaml." diff --git a/compiler/lib/partial_cps_analysis.ml b/compiler/lib/partial_cps_analysis.ml index df7eeb8fcd..bc92f52965 100644 --- a/compiler/lib/partial_cps_analysis.ml +++ b/compiler/lib/partial_cps_analysis.ml @@ -24,7 +24,7 @@ let times = Debug.find "times" let double_translate () = match Config.effects () with - | `Disabled | `Jspi -> assert false + | `Disabled | `Jspi | `Native -> assert false | `Cps -> false | `Double_translation -> true diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 2d19410f84..ecbba2d1e5 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -553,7 +553,7 @@ let f_once_after p = match Config.target (), Config.effects () with | `JavaScript, `Disabled -> true | `JavaScript, (`Cps | `Double_translation) | `Wasm, _ -> false - | `JavaScript, `Jspi -> assert false + | `JavaScript, (`Jspi | `Native) -> assert false in let f = function | Let (x, Closure (l, (pc, []), _)) as i -> ( diff --git a/compiler/lib/unit_info.ml b/compiler/lib/unit_info.ml index f5f52459aa..84e351e3a9 100644 --- a/compiler/lib/unit_info.ml +++ b/compiler/lib/unit_info.ml @@ -56,7 +56,7 @@ let of_cmo (cmo : Ocaml_compiler.Cmo_format.t) = let requires = Global_name.Compunit_set.diff requires provides in let effects_without_cps = (match Config.effects () with - | `Disabled | `Jspi -> true + | `Disabled | `Jspi | `Native -> true | `Cps | `Double_translation -> false) && List.exists (Cmo_format.primitives cmo) ~f:(function | "%resume" | "%reperform" | "%perform" -> true diff --git a/compiler/tests-check-prim/gen_dune.ml b/compiler/tests-check-prim/gen_dune.ml index 471d2bae1a..78bde85519 100644 --- a/compiler/tests-check-prim/gen_dune.ml +++ b/compiler/tests-check-prim/gen_dune.ml @@ -1,8 +1,7 @@ (** *) type version = - [ `V4_13 - | `V4_14 + [ `V4_14 | `V5_0 | `V5_1 | `V5_2 @@ -18,7 +17,6 @@ type variant = ] let string_of_version : version -> string = function - | `V4_13 -> "4.13" | `V4_14 -> "4.14" | `V5_0 -> "5.0" | `V5_1 -> "5.1" @@ -29,7 +27,6 @@ let string_of_version : version -> string = function | `V5_6 -> "5.6" let next_version : version -> version option = function - | `V4_13 -> Some `V4_14 | `V4_14 -> Some `V5_0 | `V5_0 -> Some `V5_1 | `V5_1 -> Some `V5_2 diff --git a/compiler/tests-compiler/double-translation/dune b/compiler/tests-compiler/double-translation/dune index 063207b8a9..7a16010230 100644 --- a/compiler/tests-compiler/double-translation/dune +++ b/compiler/tests-compiler/double-translation/dune @@ -6,7 +6,7 @@ (action (with-stdout-to dune.inc.gen - (run ../gen-rules/gen.exe jsoo_compiler_test)))) + (run ../gen-rules/gen.exe compiler/tests-compiler/double-translation)))) (rule (alias runtest) diff --git a/compiler/tests-compiler/dune b/compiler/tests-compiler/dune index bf40299a44..6702f7246f 100644 --- a/compiler/tests-compiler/dune +++ b/compiler/tests-compiler/dune @@ -6,7 +6,7 @@ (action (with-stdout-to dune.inc.gen - (run gen-rules/gen.exe jsoo_compiler_test)))) + (run gen-rules/gen.exe compiler/tests-compiler)))) (rule (alias runtest) diff --git a/compiler/tests-compiler/gen-rules/gen.ml b/compiler/tests-compiler/gen-rules/gen.ml index d5fd09d9d2..c261aa45ef 100644 --- a/compiler/tests-compiler/gen-rules/gen.ml +++ b/compiler/tests-compiler/gen-rules/gen.ml @@ -14,20 +14,14 @@ let is_implem x = let () = set_binary_mode_out stdout true +(* Project-relative path to this directory, passed by dune *) let prefix : string = - let rec loop acc rem = - let basename = Filename.basename rem in - let dirname = Filename.dirname rem in - if - String.equal dirname rem - || String.ends_with ~suffix:"_build" dirname - || Sys.file_exists (Filename.concat rem "dune-project") - then acc - else - let acc = basename :: acc in - loop acc dirname - in - loop [ "" ] (Sys.getcwd ()) |> String.concat ~sep:"/" + if Array.length Sys.argv < 2 + then failwith "gen.exe: expected source directory as first argument"; + let p = Sys.argv.(1) in + if String.length p > 0 && not (Char.equal p.[String.length p - 1] '/') + then p ^ "/" + else p type lang = | Not of lang diff --git a/compiler/tests-dynlink-wasm/dune b/compiler/tests-dynlink-wasm/dune index dc5fea7c01..149afd33a6 100644 --- a/compiler/tests-dynlink-wasm/dune +++ b/compiler/tests-dynlink-wasm/dune @@ -42,7 +42,11 @@ (rule (target plugin.wasmo) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} with-native-effects) + (<> %{profile} wasi))) (action (run %{bin:wasm_of_ocaml} @@ -54,8 +58,14 @@ (rule (target main.out) - (deps plugin.wasmo) - (enabled_if %{env:WASM_OF_OCAML=false}) + (deps + plugin.wasmo + (glob_files main.bc.wasm.assets/*)) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} with-native-effects) + (<> %{profile} wasi))) (action (with-outputs-to %{target} @@ -63,7 +73,11 @@ (rule (alias runtest-wasm) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} with-native-effects) + (<> %{profile} wasi))) (action (diff main.out.expected main.out))) @@ -90,8 +104,14 @@ (rule (target main_compile_and_load.out) - (deps plugin_compiled.wasmo) - (enabled_if %{env:WASM_OF_OCAML=false}) + (deps + plugin_compiled.wasmo + (glob_files main_compile_and_load.bc.wasm.assets/*)) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} with-native-effects) + (<> %{profile} wasi))) (action (with-outputs-to %{target} @@ -99,7 +119,11 @@ (rule (alias runtest-wasm) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} with-native-effects) + (<> %{profile} wasi))) (action (diff main_compile_and_load.out.expected main_compile_and_load.out))) @@ -115,8 +139,15 @@ (rule (target dynlink_loadfile.out) - (deps plugin.cmo plugin2.cma) - (enabled_if %{env:WASM_OF_OCAML=false}) + (deps + plugin.cmo + plugin2.cma + (glob_files dynlink_loadfile.bc.wasm.assets/*)) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} with-native-effects) + (<> %{profile} wasi))) (action (with-outputs-to %{target} @@ -124,7 +155,11 @@ (rule (alias runtest-wasm) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} with-native-effects) + (<> %{profile} wasi))) (action (diff dynlink_loadfile.out.expected dynlink_loadfile.out))) @@ -168,7 +203,10 @@ (targets dynlink_loadfile_wp.js (dir dynlink_loadfile_wp.assets)) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) (action (run %{bin:wasm_of_ocaml} @@ -181,8 +219,16 @@ (rule (target dynlink_loadfile_wp.out) - (deps plugin.cmo plugin2.cma plugin_uses_dep.cmo plugin_js.cmo) - (enabled_if %{env:WASM_OF_OCAML=false}) + (deps + plugin.cmo + plugin2.cma + plugin_uses_dep.cmo + plugin_js.cmo + (glob_files dynlink_loadfile_wp.assets/*)) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) (action (with-outputs-to %{target} @@ -190,6 +236,9 @@ (rule (alias runtest-wasm) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) (action (diff dynlink_loadfile_wp.out.expected dynlink_loadfile_wp.out))) diff --git a/compiler/tests-io/dune b/compiler/tests-io/dune index c7c4ea26e9..3798704005 100644 --- a/compiler/tests-io/dune +++ b/compiler/tests-io/dune @@ -21,6 +21,8 @@ (tests (names md5) (modes js wasm) + (deps + (sandbox preserve_file_kind)) (action (progn (run node %{test} %{dep:some-random-file}) @@ -89,6 +91,8 @@ (names non_ascii_filenames_wasm) (deps "accentué") (modes wasm) + (enabled_if + (<> %{profile} wasi)) (wasm_of_ocaml (compilation_mode whole_program) (flags @@ -109,6 +113,8 @@ (names gh1856) (deps file.txt) (modes js wasm) + (enabled_if + (<> %{profile} wasi)) (js_of_ocaml (compilation_mode whole_program) (flags diff --git a/compiler/tests-jsoo/dune b/compiler/tests-jsoo/dune index 64509cb621..3ad6c7d5cd 100644 --- a/compiler/tests-jsoo/dune +++ b/compiler/tests-jsoo/dune @@ -11,6 +11,8 @@ (enabled_if (>= %{ocaml_version} 4.14)) (inline_tests + (deps + (sandbox preserve_file_kind)) (modes js wasm best)) (preprocess (pps ppx_expect))) @@ -24,6 +26,8 @@ (>= %{ocaml_version} 5.1.1) (not %{oxcaml_supported}))) (inline_tests + (deps + (sandbox preserve_file_kind)) (modes js wasm best)) (preprocess (pps ppx_expect))) @@ -35,6 +39,22 @@ (enabled_if (>= %{ocaml_version} 5.1.1)) (inline_tests + (deps + (sandbox preserve_file_kind)) + (modes js wasm best)) + (preprocess + (pps ppx_expect))) + +(library + (name jsoo_testsuite_perms) + (modules test_unix_perms) + (libraries unix) + ;; WASI has no notion of file permissions (it uses capabilities instead) + (enabled_if + (<> %{profile} wasi)) + (inline_tests + (deps + (sandbox preserve_file_kind)) (modes js wasm best)) (preprocess (pps ppx_expect))) @@ -75,6 +95,7 @@ test_parsing test_runtime_value test_custom_name + test_unix_perms calc_parser calc_lexer)) (libraries unix compiler-libs.common js_of_ocaml-compiler) @@ -82,6 +103,8 @@ (language c) (names bigarray_stubs jsoo_runtime_stubs)) (inline_tests + (deps + (sandbox preserve_file_kind)) (modes js wasm best)) (preprocess (pps ppx_expect))) @@ -97,6 +120,8 @@ (name test_runtime_value) (modules test_runtime_value) (libraries js_of_ocaml) + (enabled_if + (<> %{profile} wasi)) (js_of_ocaml (javascript_files custom.js)) (wasm_of_ocaml @@ -106,6 +131,8 @@ (library (name test_custom_name) (modules test_custom_name) + (enabled_if + (<> %{profile} wasi)) (inline_tests (modes js wasm)) (libraries js_of_ocaml) @@ -115,6 +142,8 @@ (library (name test_list_of_js_array) (modules test_list_of_js_array) + (enabled_if + (<> %{profile} wasi)) (inline_tests (modes js wasm)) (libraries js_of_ocaml) diff --git a/compiler/tests-jsoo/lib-effects/dune b/compiler/tests-jsoo/lib-effects/dune index 246c25364c..d24cee0ce3 100644 --- a/compiler/tests-jsoo/lib-effects/dune +++ b/compiler/tests-jsoo/lib-effects/dune @@ -1,6 +1,10 @@ (env (with-effects-double-translation) (with-effects) + (wasi + (wasm_of_ocaml + (flags + (:standard --effects cps)))) (_ (js_of_ocaml (flags @@ -11,6 +15,8 @@ (enabled_if (>= %{ocaml_version} 5)) (inline_tests + (deps + (sandbox preserve_file_kind)) (modes js wasm best)) (modules (:standard diff --git a/compiler/tests-jsoo/test_unix.ml b/compiler/tests-jsoo/test_unix.ml index ae80a2f8ed..798ee28aca 100644 --- a/compiler/tests-jsoo/test_unix.ml +++ b/compiler/tests-jsoo/test_unix.ml @@ -14,85 +14,6 @@ let%expect_test "Unix.times" = then Printf.printf "OK\n"; [%expect {| OK |}] -let on_windows = Sys.os_type = "Win32" - -let%expect_test "Unix.chmod / Unix.fchmod / Unix.access" = - let tmp = Filename.temp_file "a" "txt" in - let test ?(ok_on_windows = false) flags = - try - Unix.access tmp flags; - if on_windows && ok_on_windows - then Printf.printf "denied (success on Windows)\n" - else Printf.printf "success\n" - with - | Unix.Unix_error ((EPERM | EACCES), _, _) -> - if (not on_windows) && ok_on_windows - then Printf.printf "denied (success on Windows)\n" - else Printf.printf "denied\n" - | Unix.Unix_error (ENOENT, _, _) -> Printf.printf "absent\n" - in - let touch perms = - Unix.chmod tmp 0o600; - Unix.unlink tmp; - let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] perms in - Unix.close fd - in - let test_perms set = - set 0o200; - test ~ok_on_windows:true [ R_OK ]; - test [ W_OK ]; - test ~ok_on_windows:true [ R_OK; W_OK ]; - [%expect - {| - denied (success on Windows) - success - denied (success on Windows) - |}]; - set 0o400; - test [ R_OK ]; - test [ W_OK ]; - test [ R_OK; W_OK ]; - [%expect {| - success - denied - denied |}]; - set 0o600; - test [ R_OK ]; - test [ W_OK ]; - test [ R_OK; W_OK ]; - [%expect {| - success - success - success |}]; - set 0o000; - test ~ok_on_windows:true [ R_OK ]; - test [ W_OK ]; - test [ R_OK; W_OK ]; - [%expect {| - denied (success on Windows) - denied - denied - |}] - in - test [ F_OK ]; - [%expect {| - success |}]; - Unix.chmod tmp 0o600; - Unix.unlink tmp; - test [ F_OK ]; - [%expect {| - absent |}]; - let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] 0o666 in - test [ F_OK ]; - [%expect {| - success |}]; - if not on_windows then test_perms (Unix.fchmod fd); - Unix.close fd; - test_perms (Unix.chmod tmp); - test_perms touch; - Unix.chmod tmp 0o600; - Unix.unlink tmp - let%expect_test "Unix.link" = let tmp = Filename.temp_file "a" "txt" in let ch = open_out tmp in @@ -192,7 +113,7 @@ let%expect_test "Unix.symlink to_dir" = let tmp = Filename.temp_file "a" "txt" in Unix.unlink tmp; (try - Unix.symlink ~to_dir:true "/some/target" tmp; + Unix.symlink ~to_dir:true "some/target" tmp; ignore (Unix.readlink tmp); Printf.printf "ok\n"; Unix.unlink tmp diff --git a/compiler/tests-jsoo/test_unix_perms.ml b/compiler/tests-jsoo/test_unix_perms.ml new file mode 100644 index 0000000000..8f07952db9 --- /dev/null +++ b/compiler/tests-jsoo/test_unix_perms.ml @@ -0,0 +1,78 @@ +let on_windows = Sys.os_type = "Win32" + +let%expect_test "Unix.chmod / Unix.fchmod / Unix.access" = + let tmp = Filename.temp_file "a" "txt" in + let test ?(ok_on_windows = false) flags = + try + Unix.access tmp flags; + if on_windows && ok_on_windows + then Printf.printf "denied (success on Windows)\n" + else Printf.printf "success\n" + with + | Unix.Unix_error ((EPERM | EACCES), _, _) -> + if (not on_windows) && ok_on_windows + then Printf.printf "denied (success on Windows)\n" + else Printf.printf "denied\n" + | Unix.Unix_error (ENOENT, _, _) -> Printf.printf "absent\n" + in + let touch perms = + Unix.chmod tmp 0o600; + Unix.unlink tmp; + let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] perms in + Unix.close fd + in + let test_perms set = + set 0o200; + test ~ok_on_windows:true [ R_OK ]; + test [ W_OK ]; + test ~ok_on_windows:true [ R_OK; W_OK ]; + [%expect + {| + denied (success on Windows) + success + denied (success on Windows) + |}]; + set 0o400; + test [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + success + denied + denied |}]; + set 0o600; + test [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + success + success + success |}]; + set 0o000; + test ~ok_on_windows:true [ R_OK ]; + test [ W_OK ]; + test [ R_OK; W_OK ]; + [%expect {| + denied (success on Windows) + denied + denied + |}] + in + test [ F_OK ]; + [%expect {| + success |}]; + Unix.chmod tmp 0o600; + Unix.unlink tmp; + test [ F_OK ]; + [%expect {| + absent |}]; + let fd = Unix.openfile tmp [ O_WRONLY; O_CREAT; O_TRUNC ] 0o666 in + test [ F_OK ]; + [%expect {| + success |}]; + if not on_windows then test_perms (Unix.fchmod fd); + Unix.close fd; + test_perms (Unix.chmod tmp); + test_perms touch; + Unix.chmod tmp 0o600; + Unix.unlink tmp diff --git a/compiler/tests-linkall/dune b/compiler/tests-linkall/dune index dbfe6e4c78..1290fd438c 100644 --- a/compiler/tests-linkall/dune +++ b/compiler/tests-linkall/dune @@ -13,6 +13,10 @@ (test (name test) (modes byte js wasm) + (enabled_if + (and + (<> %{profile} with-native-effects) + (<> %{profile} wasi))) (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-ocaml/basic-io-2/dune b/compiler/tests-ocaml/basic-io-2/dune index 121f745198..e666404c1f 100644 --- a/compiler/tests-ocaml/basic-io-2/dune +++ b/compiler/tests-ocaml/basic-io-2/dune @@ -1,5 +1,8 @@ (tests (names io) (modes js wasm) + ;; Sys.command not available + (enabled_if + (<> %{profile} wasi)) (action (run node %{test} %{dep:test-file-short-lines}))) diff --git a/compiler/tests-ocaml/basic-io/dune b/compiler/tests-ocaml/basic-io/dune index 0dda8c0246..7b7de19d04 100644 --- a/compiler/tests-ocaml/basic-io/dune +++ b/compiler/tests-ocaml/basic-io/dune @@ -1,5 +1,8 @@ (tests (names wc) (modes js wasm) + (deps + wc.ml + (sandbox preserve_file_kind)) (action (run node %{test} wc.ml))) diff --git a/compiler/tests-ocaml/effect-syntax/dune b/compiler/tests-ocaml/effect-syntax/dune index 6439ed0495..36d33cfb28 100644 --- a/compiler/tests-ocaml/effect-syntax/dune +++ b/compiler/tests-ocaml/effect-syntax/dune @@ -1,6 +1,10 @@ (env (with-effects-double-translation) (with-effects) + (wasi + (wasm_of_ocaml + (flags + (:standard --effects cps)))) (_ (js_of_ocaml (flags diff --git a/compiler/tests-ocaml/effects/dune b/compiler/tests-ocaml/effects/dune index ee1488ad49..8bab7bd398 100644 --- a/compiler/tests-ocaml/effects/dune +++ b/compiler/tests-ocaml/effects/dune @@ -1,6 +1,10 @@ (env (with-effects-double-translation) (with-effects) + (wasi + (wasm_of_ocaml + (flags + (:standard --effects cps)))) (_ (js_of_ocaml (flags diff --git a/compiler/tests-ocaml/lib-arg/dune b/compiler/tests-ocaml/lib-arg/dune index 1fee099413..2f39568281 100644 --- a/compiler/tests-ocaml/lib-arg/dune +++ b/compiler/tests-ocaml/lib-arg/dune @@ -17,12 +17,20 @@ (rule (target test_rest_all_wasm.ml.corrected) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) + (deps + (glob_files ../expect_wasm.bc.wasm.assets/*)) (action (run node %{dep:../expect_wasm.bc.wasm.js} %{dep:test_rest_all_wasm.ml}))) (rule (alias runtest-wasm) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) (action (diff test_rest_all.ml test_rest_all_wasm.ml.corrected))) diff --git a/compiler/tests-ocaml/lib-array/dune b/compiler/tests-ocaml/lib-array/dune index c281ad438c..e19a357f6e 100644 --- a/compiler/tests-ocaml/lib-array/dune +++ b/compiler/tests-ocaml/lib-array/dune @@ -15,7 +15,12 @@ (rule (target test_array_wasm.ml.corrected) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) + (deps + (glob_files ../expect_wasm.bc.wasm.assets/*)) (action (run node %{dep:../expect_wasm.bc.wasm.js} %{dep:test_array_wasm.ml}))) @@ -24,6 +29,7 @@ (enabled_if (and (>= %{ocaml_version} 5.2) + (<> %{profile} wasi) %{env:WASM_OF_OCAML=false})) (action (diff test_array.ml test_array_wasm.ml.corrected))) diff --git a/compiler/tests-ocaml/lib-channels/close_in.ml b/compiler/tests-ocaml/lib-channels/close_in.ml index 9b3717362a..8697d78c6a 100644 --- a/compiler/tests-ocaml/lib-channels/close_in.ml +++ b/compiler/tests-ocaml/lib-channels/close_in.ml @@ -6,8 +6,14 @@ between 1 and IO_BUFFER_SIZE *) let nb_bytes = 3 +let temp_file = + let name, ch = Filename.open_temp_file "data" ".txt" in + output_string ch (String.make 1024 'a'); + close_out ch; + name + let () = - let ic = open_in_bin (Filename.basename Sys.argv.(0)) in + let ic = open_in_bin temp_file in seek_in ic nb_bytes; close_in ic; assert ( @@ -21,7 +27,7 @@ let () = (* A variant of #11878, which #11965 failed to fix. *) let () = - let ic = open_in_bin (Filename.basename Sys.argv.(0)) in + let ic = open_in_bin temp_file in close_in ic; begin try seek_in ic (-1); diff --git a/compiler/tests-ocaml/lib-digest/dune b/compiler/tests-ocaml/lib-digest/dune index 3ba1799930..19fe2dce08 100644 --- a/compiler/tests-ocaml/lib-digest/dune +++ b/compiler/tests-ocaml/lib-digest/dune @@ -8,6 +8,8 @@ (names digests) (libraries) (build_if - (>= %{ocaml_version} 5.2)) + (and + (>= %{ocaml_version} 5.2) + (<> %{profile} wasi))) (modules digests) (modes js wasm)) diff --git a/compiler/tests-ocaml/lib-either/dune b/compiler/tests-ocaml/lib-either/dune index febf0dccb0..bfa3355f55 100644 --- a/compiler/tests-ocaml/lib-either/dune +++ b/compiler/tests-ocaml/lib-either/dune @@ -13,12 +13,20 @@ (rule (target test_wasm.ml.corrected) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) + (deps + (glob_files ../expect_wasm.bc.wasm.assets/*)) (action (run node %{dep:../expect_wasm.bc.wasm.js} %{dep:test_wasm.ml}))) (rule (alias runtest-wasm) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) (action (diff test.ml test_wasm.ml.corrected))) diff --git a/compiler/tests-ocaml/lib-internalformat/dune b/compiler/tests-ocaml/lib-internalformat/dune index febf0dccb0..bfa3355f55 100644 --- a/compiler/tests-ocaml/lib-internalformat/dune +++ b/compiler/tests-ocaml/lib-internalformat/dune @@ -13,12 +13,20 @@ (rule (target test_wasm.ml.corrected) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) + (deps + (glob_files ../expect_wasm.bc.wasm.assets/*)) (action (run node %{dep:../expect_wasm.bc.wasm.js} %{dep:test_wasm.ml}))) (rule (alias runtest-wasm) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) (action (diff test.ml test_wasm.ml.corrected))) diff --git a/compiler/tests-ocaml/lib-lazy/dune b/compiler/tests-ocaml/lib-lazy/dune index febf0dccb0..bfa3355f55 100644 --- a/compiler/tests-ocaml/lib-lazy/dune +++ b/compiler/tests-ocaml/lib-lazy/dune @@ -13,12 +13,20 @@ (rule (target test_wasm.ml.corrected) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) + (deps + (glob_files ../expect_wasm.bc.wasm.assets/*)) (action (run node %{dep:../expect_wasm.bc.wasm.js} %{dep:test_wasm.ml}))) (rule (alias runtest-wasm) - (enabled_if %{env:WASM_OF_OCAML=false}) + (enabled_if + (and + %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi))) (action (diff test.ml test_wasm.ml.corrected))) diff --git a/compiler/tests-ocaml/lib-marshal/intext.ml b/compiler/tests-ocaml/lib-marshal/intext.ml index 3e0477dffd..5340806495 100644 --- a/compiler/tests-ocaml/lib-marshal/intext.ml +++ b/compiler/tests-ocaml/lib-marshal/intext.ml @@ -4,7 +4,8 @@ (* Test for output_value / input_value *) -let max_data_depth = 500000 +let max_data_depth = 10000 +(* Reduced since we use a quadratic algorithm for sharing in the WASI runtime *) type t = A | B of int | C of float | D of string | E of char | F of t | G of t * t | H of int * t | I of t * float | J diff --git a/compiler/tests-ocaml/lib-marshal/intext_par.ml b/compiler/tests-ocaml/lib-marshal/intext_par.ml index bb4da7f89d..1136a5c115 100644 --- a/compiler/tests-ocaml/lib-marshal/intext_par.ml +++ b/compiler/tests-ocaml/lib-marshal/intext_par.ml @@ -19,7 +19,8 @@ let test_size = let num_domains = 1 lsl test_size -let max_data_depth = 500000 +let max_data_depth = 10000 +(* Reduced since we use a quadratic algorithm for sharing in the WASI runtime *) type t = A | B of int | C of float | D of string | E of char | F of t | G of t * t | H of int * t | I of t * float | J diff --git a/compiler/tests-ocaml/lib-unix/isatty/dune b/compiler/tests-ocaml/lib-unix/isatty/dune index 6740efe55b..852dd49d6a 100644 --- a/compiler/tests-ocaml/lib-unix/isatty/dune +++ b/compiler/tests-ocaml/lib-unix/isatty/dune @@ -6,7 +6,10 @@ (tests (names isatty_tty) (enabled_if - (not %{env:CI=false})) + (and + (<> %{profile} wasi) + (not %{env:CI=false}))) + ; WASI has no notion of tty ; isatty_tty does not work on the CI since we are not running in a tty there (libraries ocaml_testing unix) (modes js wasm)) diff --git a/compiler/tests-predef/dune b/compiler/tests-predef/dune index 80d7337edf..2ea5508b71 100644 --- a/compiler/tests-predef/dune +++ b/compiler/tests-predef/dune @@ -43,6 +43,8 @@ (rule (target main-wasm.out) (enabled_if %{env:WASM_OF_OCAML=false}) + (deps + (glob_files main.bc.wasm.assets/*)) (action (with-stdout-to %{target} diff --git a/compiler/tests-toplevel/dune b/compiler/tests-toplevel/dune index c94fcc24ef..71b402a8e2 100644 --- a/compiler/tests-toplevel/dune +++ b/compiler/tests-toplevel/dune @@ -7,6 +7,15 @@ (flags :standard --toplevel)) (modes byte js)) +(rule + (target cmi_include_dirs.txt) + (deps + (package js_of_ocaml-compiler)) + (action + (with-stdout-to + %{target} + (run ocamlfind query -format "-I\n%d" -r js_of_ocaml-compiler.dynlink)))) + (rule (targets test_toplevel.js) (action @@ -15,6 +24,7 @@ --toplevel -w no-missing-effects-backend + %{read-strings:cmi_include_dirs.txt} %{dep:test_toplevel.bc} -o %{targets}))) @@ -60,6 +70,16 @@ (action (copy %{dep:test_toplevel.ml} %{target}))) +(rule + (target cmi_include_dirs_wasm.txt) + (deps + (package js_of_ocaml-compiler) + (package wasm_of_ocaml-compiler)) + (action + (with-stdout-to + %{target} + (run ocamlfind query -format "-I\n%d" -r wasm_of_ocaml-compiler.dynlink)))) + (rule (targets test_toplevel_wasm.js @@ -71,6 +91,7 @@ --toplevel -w no-missing-effects-backend + %{read-strings:cmi_include_dirs_wasm.txt} %{dep:test_toplevel_wasm.bc} -o test_toplevel_wasm.js))) @@ -80,7 +101,10 @@ (enabled_if (and %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi) (>= %{ocaml_version} 5.4))) + (deps + (glob_files test_toplevel_wasm.bc.wasm.assets/*)) (action (with-stdout-to %{target} @@ -102,6 +126,7 @@ (enabled_if (and %{env:WASM_OF_OCAML=false} + (<> %{profile} wasi) (>= %{ocaml_version} 5.4))) (action (progn diff --git a/compiler/tests-wasm_of_ocaml/dune b/compiler/tests-wasm_of_ocaml/dune index bc2e20c363..ae1634bbb5 100644 --- a/compiler/tests-wasm_of_ocaml/dune +++ b/compiler/tests-wasm_of_ocaml/dune @@ -14,7 +14,9 @@ (names gh2093) (modes wasm) (enabled_if - (>= %{ocaml_version} 5)) + (and + (>= %{ocaml_version} 5) + (<> %{profile} wasi))) (wasm_of_ocaml (compilation_mode whole_program) (flags :standard))) diff --git a/dune b/dune index fa9ca7d14d..55c51c8701 100644 --- a/dune +++ b/dune @@ -36,6 +36,32 @@ (binaries (tools/node_wrapper.exe as node) (tools/node_wrapper.exe as node.exe))) + (with-native-effects + (js_of_ocaml + ;; Native effects is not supported in js + (enabled_if false)) + (wasm_of_ocaml + (compilation_mode separate) + (flags + (:standard --effects native))) + (binaries + (tools/node_wrapper.exe as node) + (tools/node_wrapper.exe as node.exe))) + (wasi + (wasm_of_ocaml + (build_runtime_flags + (:standard --enable wasi)) + (flags + (:standard + --pretty + --enable + wasi + (:include wasi_extra_flags))) + ; Wasmtime is slow on large binaries, so use whole program compilation + (compilation_mode whole_program)) + (binaries + (tools/node_wrapper.exe as node) + (tools/node_wrapper.exe as node.exe))) (bench_no_debug (flags (:standard \ -g)) @@ -78,6 +104,13 @@ %{target} (echo "(--debug invariant)")))) +(rule + (targets wasi_extra_flags) + (action + (with-stdout-to + %{targets} + (echo "(%{env:WASI_FLAGS=})")))) + (data_only_dirs _wikidoc doc-dev janestreet) (vendored_dirs) diff --git a/dune-project b/dune-project index e35053e5c4..f8d4352296 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.20) +(lang dune 3.23) (using menhir 3.0) (using directory-targets 0.1) (using oxcaml 0.1) @@ -19,7 +19,7 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (and (>= 4.13) (< 5.6))) + (ocaml (and (>= 4.14) (< 5.6))) (num :with-test) (ppx_expect (and (>= v0.16.1) :with-test)) (ppxlib (>= 0.33)) @@ -28,7 +28,7 @@ (cmdliner (>= 2.0)) (sedlex (>= 3.3)) (qcheck :with-test) - menhir + (menhir (>= 20180523)) menhirLib menhirSdk (yojson (>= 2.1))) @@ -45,13 +45,14 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.13)) + (ocaml (>= 4.14)) (js_of_ocaml (= :version)) (js_of_ocaml-ppx (= :version)) (lwt (and (>= 2.4.4) (<> 5.9.2))) (num :with-test) (ppx_expect (and (>= v0.14.2) :with-test)) - (re (and (>= 1.9.0) :with-test))) + (re (and (>= 1.9.0) :with-test)) + (menhir (>= 20180523))) (depopts graphics lwt_log @@ -63,12 +64,13 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.13)) + (ocaml (>= 4.14)) (js_of_ocaml (= :version)) (ppxlib (>= 0.33)) (num :with-test) (ppx_expect (and (>= v0.14.2) :with-test)) (re (and (>= 1.9.0) :with-test)) + (menhir (>= 20180523)) )) (package @@ -77,12 +79,13 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.13)) + (ocaml (>= 4.14)) (js_of_ocaml (= :version)) (ppxlib (>= 0.33)) (num :with-test) (ppx_expect (and (>= v0.14.2) :with-test)) (re (and (>= 1.9.0) :with-test)) + (menhir (>= 20180523)) )) (package @@ -91,7 +94,7 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.13)) + (ocaml (>= 4.14)) (js_of_ocaml-compiler (= :version)) (ocamlfind (>= 1.5.1)) ;;(cohttp-lwt-unix (and (>= 6.0.0) :with-test)) @@ -100,6 +103,7 @@ (ppx_expect (and (>= v0.14.2) :with-test)) (ppxlib (>= 0.33)) (re (and (>= 1.9.0) :with-test)) + (menhir (>= 20180523)) )) (package @@ -108,7 +112,7 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.13)) + (ocaml (>= 4.14)) (js_of_ocaml (= :version)) (js_of_ocaml-ppx (= :version)) (react (>= 1.2.2)) @@ -117,6 +121,7 @@ (num :with-test) (ppx_expect (and (>= v0.14.2) :with-test)) (re (and (>= 1.9.0) :with-test)) + (menhir (>= 20180523)) )) (package @@ -125,12 +130,13 @@ (description "Js_of_ocaml is a compiler from OCaml bytecode to JavaScript. It makes it possible to run pure OCaml programs in JavaScript environment like browsers and Node.js") (depends - (ocaml (>= 4.13)) + (ocaml (>= 4.14)) (js_of_ocaml-compiler (= :version)) (num :with-test) (ppx_expect (and (>= v0.14.2) :with-test)) (ppxlib (>= 0.33)) (re (and (>= 1.9.0) :with-test)) + (menhir (>= 20180523)) )) (package @@ -148,7 +154,7 @@ (cmdliner (>= 2.0)) (opam-format :with-test) (sedlex (>= 2.3)) - menhir + (menhir (>= 20180523)) menhirLib menhirSdk (yojson (>= 2.1)) diff --git a/dune-workspace.dev b/dune-workspace.dev index fd0e58234d..f7352b536c 100644 --- a/dune-workspace.dev +++ b/dune-workspace.dev @@ -7,10 +7,6 @@ ;; ;; This will build js_of_ocaml against all these version of OCaml -(context - (opam - (switch 4.13.1))) - (context (opam (switch 4.14.0))) diff --git a/js_of_ocaml-compiler.opam b/js_of_ocaml-compiler.opam index 1c7e4f20eb..4d7254f15c 100644 --- a/js_of_ocaml-compiler.opam +++ b/js_of_ocaml-compiler.opam @@ -12,8 +12,8 @@ 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.20"} - "ocaml" {>= "4.13" & < "5.6"} + "dune" {>= "3.23"} + "ocaml" {>= "4.14" & < "5.6"} "num" {with-test} "ppx_expect" {>= "v0.16.1" & with-test} "ppxlib" {>= "0.33"} diff --git a/js_of_ocaml-lwt.opam b/js_of_ocaml-lwt.opam index f3360433a3..bf648baf5a 100644 --- a/js_of_ocaml-lwt.opam +++ b/js_of_ocaml-lwt.opam @@ -12,16 +12,16 @@ 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.20"} - "ocaml" {>= "4.13"} + "dune" {>= "3.23"} + "ocaml" {>= "4.14"} "js_of_ocaml" {= version} "js_of_ocaml-ppx" {= version} "lwt" {>= "2.4.4" & != "5.9.2"} "num" {with-test} "ppx_expect" {>= "v0.14.2" & with-test} "re" {>= "1.9.0" & with-test} - "odoc" {with-doc} "menhir" {>= "20180523"} + "odoc" {with-doc} ] depopts: ["graphics" "lwt_log"] dev-repo: "git+https://github.com/ocsigen/js_of_ocaml.git" diff --git a/js_of_ocaml-ppx.opam b/js_of_ocaml-ppx.opam index 5b29455456..fb86d883a4 100644 --- a/js_of_ocaml-ppx.opam +++ b/js_of_ocaml-ppx.opam @@ -12,15 +12,15 @@ 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.20"} - "ocaml" {>= "4.13"} + "dune" {>= "3.23"} + "ocaml" {>= "4.14"} "js_of_ocaml" {= version} "ppxlib" {>= "0.33"} "num" {with-test} "ppx_expect" {>= "v0.14.2" & with-test} "re" {>= "1.9.0" & with-test} - "odoc" {with-doc} "menhir" {>= "20180523"} + "odoc" {with-doc} ] dev-repo: "git+https://github.com/ocsigen/js_of_ocaml.git" x-maintenance-intent: ["(latest)"] diff --git a/js_of_ocaml-ppx_deriving_json.opam b/js_of_ocaml-ppx_deriving_json.opam index 5b29455456..fb86d883a4 100644 --- a/js_of_ocaml-ppx_deriving_json.opam +++ b/js_of_ocaml-ppx_deriving_json.opam @@ -12,15 +12,15 @@ 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.20"} - "ocaml" {>= "4.13"} + "dune" {>= "3.23"} + "ocaml" {>= "4.14"} "js_of_ocaml" {= version} "ppxlib" {>= "0.33"} "num" {with-test} "ppx_expect" {>= "v0.14.2" & with-test} "re" {>= "1.9.0" & with-test} - "odoc" {with-doc} "menhir" {>= "20180523"} + "odoc" {with-doc} ] dev-repo: "git+https://github.com/ocsigen/js_of_ocaml.git" x-maintenance-intent: ["(latest)"] diff --git a/js_of_ocaml-toplevel.opam b/js_of_ocaml-toplevel.opam index 3a7662e1f1..b01647d84a 100644 --- a/js_of_ocaml-toplevel.opam +++ b/js_of_ocaml-toplevel.opam @@ -12,8 +12,8 @@ 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.20"} - "ocaml" {>= "4.13"} + "dune" {>= "3.23"} + "ocaml" {>= "4.14"} "js_of_ocaml-compiler" {= version} "ocamlfind" {>= "1.5.1"} "graphics" {with-test} @@ -21,8 +21,8 @@ depends: [ "ppx_expect" {>= "v0.14.2" & with-test} "ppxlib" {>= "0.33"} "re" {>= "1.9.0" & with-test} - "odoc" {with-doc} "menhir" {>= "20180523"} + "odoc" {with-doc} ] dev-repo: "git+https://github.com/ocsigen/js_of_ocaml.git" x-maintenance-intent: ["(latest)"] diff --git a/js_of_ocaml-tyxml.opam b/js_of_ocaml-tyxml.opam index 0abc0cd3b7..6364219381 100644 --- a/js_of_ocaml-tyxml.opam +++ b/js_of_ocaml-tyxml.opam @@ -12,8 +12,8 @@ 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.20"} - "ocaml" {>= "4.13"} + "dune" {>= "3.23"} + "ocaml" {>= "4.14"} "js_of_ocaml" {= version} "js_of_ocaml-ppx" {= version} "react" {>= "1.2.2"} @@ -22,8 +22,8 @@ depends: [ "num" {with-test} "ppx_expect" {>= "v0.14.2" & with-test} "re" {>= "1.9.0" & with-test} - "odoc" {with-doc} "menhir" {>= "20180523"} + "odoc" {with-doc} ] dev-repo: "git+https://github.com/ocsigen/js_of_ocaml.git" x-maintenance-intent: ["(latest)"] diff --git a/js_of_ocaml.opam b/js_of_ocaml.opam index 4b52d11364..c764cb0349 100644 --- a/js_of_ocaml.opam +++ b/js_of_ocaml.opam @@ -12,15 +12,15 @@ 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.20"} - "ocaml" {>= "4.13"} + "dune" {>= "3.23"} + "ocaml" {>= "4.14"} "js_of_ocaml-compiler" {= version} "num" {with-test} "ppx_expect" {>= "v0.14.2" & with-test} "ppxlib" {>= "0.33"} "re" {>= "1.9.0" & with-test} - "odoc" {with-doc} "menhir" {>= "20180523"} + "odoc" {with-doc} ] dev-repo: "git+https://github.com/ocsigen/js_of_ocaml.git" x-maintenance-intent: ["(latest)"] diff --git a/lib/deriving_json/tests/dune b/lib/deriving_json/tests/dune index c1e0147b3d..b7772e347e 100644 --- a/lib/deriving_json/tests/dune +++ b/lib/deriving_json/tests/dune @@ -2,6 +2,8 @@ (name deriving_expect_tests) (libraries unix js_of_ocaml js_of_ocaml.deriving) (inline_tests + (enabled_if + (<> %{profile} wasi)) (modes js wasm)) (preprocess (pps ppx_expect ppx_deriving_json))) diff --git a/lib/tests/dune b/lib/tests/dune index f4902cdc3a..30c19e35c1 100644 --- a/lib/tests/dune +++ b/lib/tests/dune @@ -6,7 +6,7 @@ (action (with-stdout-to dune.inc.gen - (run gen-rules/gen.exe jsoo_lib_expect_tests)))) + (run gen-rules/gen.exe lib/tests)))) (rule (alias runtest) diff --git a/lib/tests/dune.inc b/lib/tests/dune.inc index 9f3324c463..04d5d99d7a 100644 --- a/lib/tests/dune.inc +++ b/lib/tests/dune.inc @@ -2,6 +2,7 @@ (library ;; lib/tests/test_css_angle.ml (name test_css_angle_75) + (enabled_if (<> %{profile} wasi)) (modules test_css_angle) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -11,6 +12,7 @@ (library ;; lib/tests/test_css_color.ml (name test_css_color_75) + (enabled_if (<> %{profile} wasi)) (modules test_css_color) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -20,6 +22,7 @@ (library ;; lib/tests/test_css_length.ml (name test_css_length_75) + (enabled_if (<> %{profile} wasi)) (modules test_css_length) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -29,6 +32,7 @@ (library ;; lib/tests/test_eval.ml (name test_eval_75) + (enabled_if (<> %{profile} wasi)) (modules test_eval) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -48,6 +52,7 @@ (library ;; lib/tests/test_fun_call_2.ml (name test_fun_call_2_75) + (enabled_if (<> %{profile} wasi)) (modules test_fun_call_2) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -57,6 +62,7 @@ (library ;; lib/tests/test_json.ml (name test_json_75) + (enabled_if (<> %{profile} wasi)) (modules test_json) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -66,6 +72,7 @@ (library ;; lib/tests/test_misc.ml (name test_misc_75) + (enabled_if (<> %{profile} wasi)) (modules test_misc) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -75,6 +82,7 @@ (library ;; lib/tests/test_nodejs_filesystem_errors.ml (name test_nodejs_filesystem_errors_75) + (enabled_if (<> %{profile} wasi)) (modules test_nodejs_filesystem_errors) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -84,6 +92,7 @@ (library ;; lib/tests/test_poly_compare.ml (name test_poly_compare_75) + (enabled_if (<> %{profile} wasi)) (modules test_poly_compare) (libraries js_of_ocaml unix) (inline_tests (modes js)) @@ -93,6 +102,7 @@ (library ;; lib/tests/test_poly_equal.ml (name test_poly_equal_75) + (enabled_if (<> %{profile} wasi)) (modules test_poly_equal) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -102,6 +112,7 @@ (library ;; lib/tests/test_regexp.ml (name test_regexp_75) + (enabled_if (<> %{profile} wasi)) (modules test_regexp) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -111,6 +122,7 @@ (library ;; lib/tests/test_string.ml (name test_string_75) + (enabled_if (<> %{profile} wasi)) (modules test_string) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -130,6 +142,7 @@ (library ;; lib/tests/test_typed_array.ml (name test_typed_array_75) + (enabled_if (<> %{profile} wasi)) (modules test_typed_array) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -139,6 +152,7 @@ (library ;; lib/tests/test_unsafe_set_get.ml (name test_unsafe_set_get_75) + (enabled_if (<> %{profile} wasi)) (modules test_unsafe_set_get) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) @@ -148,6 +162,7 @@ (library ;; lib/tests/test_url.ml (name test_url_75) + (enabled_if (<> %{profile} wasi)) (modules test_url) (libraries js_of_ocaml unix) (inline_tests (modes js wasm)) diff --git a/lib/tests/gen-rules/gen.ml b/lib/tests/gen-rules/gen.ml index 2899edb21e..6bfba9aaaa 100644 --- a/lib/tests/gen-rules/gen.ml +++ b/lib/tests/gen-rules/gen.ml @@ -32,20 +32,14 @@ let is_implem x = let () = set_binary_mode_out stdout true +(* Project-relative path to this directory, passed by dune *) let prefix : string = - let rec loop acc rem = - let basename = Filename.basename rem in - let dirname = Filename.dirname rem in - if - String.equal dirname rem - || String.ends_with ~suffix:"_build" dirname - || Sys.file_exists (Filename.concat rem "dune-project") - then acc - else - let acc = basename :: acc in - loop acc dirname - in - loop [ "" ] (Sys.getcwd ()) |> String.concat ~sep:"/" + if Array.length Sys.argv < 2 + then failwith "gen.exe: expected source directory as first argument"; + let p = Sys.argv.(1) in + if String.length p > 0 && not (Char.equal p.[String.length p - 1] '/') + then p ^ "/" + else p type enabled_if = | GE5 @@ -85,7 +79,7 @@ let () = basename (Hashtbl.hash prefix mod 100) (match enabled_if basename with - | Any -> "" + | Any -> "\n (enabled_if (<> %{profile} wasi))" | GE5 -> "\n (enabled_if (>= %{ocaml_version} 5))" | No_effects -> "\n (enabled_if (<> %{profile} with-effects))") basename diff --git a/manual/effects.wiki b/manual/effects.wiki index 2bd6742489..ae36c19e69 100644 --- a/manual/effects.wiki +++ b/manual/effects.wiki @@ -21,6 +21,19 @@ Since CPS code is usually slower, this can avoid performance degradations. You c also ensure that some code runs in direct style using <>. +==@@id="wasm"@@ Wasm_of_ocaml + +Wasm_of_ocaml provides three effect handler implementations: + +* **{{{--effects=jspi}}}** (default) uses the JavaScript-Promise Integration extension. + It does not require any code transformation but requires a runtime that supports JSPI. +* **{{{--effects=cps}}}** uses the same CPS transformation as js_of_ocaml. +* **{{{--effects=native}}}** uses the + [[https://github.com/WebAssembly/stack-switching|WebAssembly Stack Switching proposal]] + (typed continuations). It provides the best performance but requires a runtime with + support for the WasmFX extension (currently available in V8/Node.js behind the + {{{--experimental-wasm-wasmfx}}} flag). + ==@@id="dune"@@ Dune integration Dune is aware of the {{{--effects}}} option. You can add it to the diff --git a/manual/install.wiki b/manual/install.wiki index 6e488b3f26..9d77a5dfbd 100644 --- a/manual/install.wiki +++ b/manual/install.wiki @@ -2,7 +2,7 @@ ==@@id="requirements"@@ Requirements -**OCaml**: 4.13 to 5.4 +**OCaml**: 4.14 to 5.4 **Build tools**: * dune >= 3.19 @@ -61,4 +61,4 @@ See <> for usage. == See also * <> — Get started with a simple example -* <> — Learn what js_of_ocaml can do \ No newline at end of file +* <> — Learn what js_of_ocaml can do diff --git a/manual/options.wiki b/manual/options.wiki index 78d8309662..3a0fd87c3d 100644 --- a/manual/options.wiki +++ b/manual/options.wiki @@ -45,6 +45,7 @@ For **js_of_ocaml** (default: {{{disabled}}}): For **wasm_of_ocaml** (default: {{{jspi}}}): * **{{{jspi}}}** - JavaScript-Promise Integration (default). Available in Chrome 137, Node.js 25, and higher. Use {{{cps}}} for other browsers. Performing effects is slower than with {{{cps}}}. * **{{{cps}}}** - CPS transformation for effect support +* **{{{native}}}** - WebAssembly stack switching (wasm_of_ocaml only, requires WasmFX runtime support) * **{{{disabled}}}** - No effect handler support See <> for details. diff --git a/manual/wasm_overview.wiki b/manual/wasm_overview.wiki index 3424d75571..b1bdab6c85 100644 --- a/manual/wasm_overview.wiki +++ b/manual/wasm_overview.wiki @@ -68,16 +68,43 @@ Compared to js_of_ocaml: === Effect handlers -OCaml 5.x code using effect handlers can be compiled in two ways: +OCaml 5.x code using effect handlers can be compiled in three ways: * **{{{--effects=cps}}}** - Uses the CPS transformation from js_of_ocaml * **{{{--effects=jspi}}}** (default) - Uses the [[https://github.com/WebAssembly/js-promise-integration|JavaScript-Promise Integration extension]] +* **{{{--effects=native}}}** - Uses the [[https://github.com/WebAssembly/stack-switching|WebAssembly Stack Switching proposal]] The CPS transformation is not the default since the generated code is slower, larger, and less readable. However, the JSPI extension is currently only available in Chrome 137 and Node.js 25 (or higher), and performing effects is slower when using it. Use {{{--effects=cps}}} for other browsers. +The native implementation is based on the WebAssembly typed continuations +proposal (stack switching). It provides the best performance but requires a +runtime with support for the WasmFX extension (currently available in +V8/Node.js behind the {{{--experimental-wasm-wasmfx}}} flag). + +==@@id="wasi"@@ WASI support + +You can produce a WASI binary by running {{{wasm_of_ocaml}}} with the +{{{--enable wasi}}} flag. At the moment, {{{wasm_of_ocaml}}} supports +WASI 0.1. Features from the Sys and Unix modules are available +whenever they're supported by the WASI API. + +The binaries produced by {{{wasm_of_ocaml}}} require the GC and +exception-handling proposals, which are supported by Node.js, Wasmtime +(with the {{{-W=all-proposals=y}}} flag), and the Wizard engine (with +the {{{--ext:gc --ext:exception-handling --ext:legacy-eh}}} flags). +Wasmtime does not support the legacy Wasm exception-handling +instructions. To generate a binary that runs with Wasmtime, add the +{{{--enable exnref}}} flag. + +For now, the output remains the same as without the {{{--enable +wasi}}} flag: a JavaScript file {{{foo.js}}} and a directory +{{{foo.assets}}} containing the Wasm code {{{code.wasm}}}. The +JavaScript file can be used to run the WASI binary with {{{node}}}, +while the Wasm code can be run directly by other Wasm engines. + ==@@id="js-bindings"@@ Binding with JavaScript libraries Js_of_ocaml lets you bind code with JavaScript libraries by linking {{{.js}}} files. diff --git a/runtime/wasm/backtrace.wat b/runtime/wasm/backtrace.wat index 6b351fb78d..25282323a4 100644 --- a/runtime/wasm/backtrace.wat +++ b/runtime/wasm/backtrace.wat @@ -18,10 +18,20 @@ (module (import "fail" "caml_invalid_argument" (func $caml_invalid_argument (param (ref eq)))) +(@if wasi +(@then + (global $backtrace_status (mut (ref eq)) (ref.i31 (i32.const 0))) + (func $backtrace_status (result (ref eq)) + (global.get $backtrace_status)) + (func $record_backtrace (param $b (ref eq)) + (global.set $backtrace_status (local.get $b))) +) +(@else (import "bindings" "backtrace_status" (func $backtrace_status (result (ref eq)))) (import "bindings" "record_backtrace" (func $record_backtrace (param (ref eq)))) +)) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) diff --git a/runtime/wasm/bigarray.wat b/runtime/wasm/bigarray.wat index 945d24a7a6..745d00c2ef 100644 --- a/runtime/wasm/bigarray.wat +++ b/runtime/wasm/bigarray.wat @@ -65,6 +65,518 @@ (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))) + +(@if wasi +(@then + (type $i64_array (array (mut i64))) + (type $i32_array (array (mut i32))) + (type $i16_array (array (mut i16))) + (type $i8_array (array (mut i8))) + (type $f64_array (array (mut f64))) + (type $f32_array (array (mut f32))) + + (type $data + (struct + (field $array (ref array)) + (field $offset i32) + (field $len i32))) + + (func $ta_create (export "ta_create") + (param $kind i32) (param $sz i32) (result (ref extern)) + (local $a (ref array)) + (local.set $a + (block $cont (result (ref array)) + (block $f32 + (block $f64 + (block $i8 + (block $i16 + (block $i32 + (block $i64 + (br_table + $f32 $f64 $i8 $i8 $i16 $i16 $i32 + $i64 $i32 $i32 $f32 $f64 $i8 $i16 + (local.get $kind))) + ;; i64 + (local.set $sz (i32.shr_u (local.get $sz) (i32.const 1))) + (br $cont (array.new $i64_array (i64.const 0) (local.get $sz)))) + ;; i32 + (br $cont (array.new $i32_array (i32.const 0) (local.get $sz)))) + ;; i16 + (br $cont (array.new $i16_array (i32.const 0) (local.get $sz)))) + ;; i8 + (br $cont (array.new $i8_array (i32.const 0) (local.get $sz)))) + ;; f64 + (br $cont (array.new $f64_array (f64.const 0) (local.get $sz)))) + ;; f32 + (array.new $f32_array (f32.const 0) (local.get $sz)))) + (extern.convert_any + (struct.new $data (local.get $a) (i32.const 0) (local.get $sz)))) + + (func $ta_fill_int (param $b (ref extern)) (param $v i32) + (local $d (ref $data)) + (local $a (ref array)) + (local $a32 (ref $i32_array)) (local $a16 (ref $i16_array)) + (local $a8 (ref $bytes)) + (local $ofs i32) (local $i i32) (local $len i32) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $a (struct.get $data $array (local.get $d))) + (local.set $ofs (struct.get $data $offset (local.get $d))) + (local.set $len (struct.get $data $len (local.get $d))) + (if (ref.test (ref $i32_array) (local.get $a)) + (then + (local.set $a32 (ref.cast (ref $i32_array) (local.get $a))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $i32_array (local.get $a32) + (i32.add (local.get $ofs) (local.get $i)) + (local.get $v)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (else (if (ref.test (ref $i16_array) (local.get $a)) + (then + (local.set $a16 (ref.cast (ref $i16_array) (local.get $a))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $i16_array (local.get $a16) + (i32.add (local.get $ofs) (local.get $i)) + (local.get $v)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (else + (local.set $a8 (ref.cast (ref $bytes) (local.get $a))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $a8) + (i32.add (local.get $ofs) (local.get $i)) + (local.get $v)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))))))) + + (func $ta_fill_float (param $b (ref extern)) (param $f f64) + (local $d (ref $data)) + (local $a (ref array)) + (local $a64 (ref $float_array)) (local $a32 (ref $f32_array)) + (local $f32 f32) + (local $ofs i32) (local $i i32) (local $len i32) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $a (struct.get $data $array (local.get $d))) + (local.set $ofs (struct.get $data $offset (local.get $d))) + (local.set $len (struct.get $data $len (local.get $d))) + (if (ref.test (ref $float_array) (local.get $a)) + (then + (local.set $a64 (ref.cast (ref $float_array) (local.get $a))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $float_array (local.get $a64) + (i32.add (local.get $ofs) (local.get $i)) + (local.get $f)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (else + (local.set $a32 (ref.cast (ref $f32_array) (local.get $a))) + (local.set $f32 (f32.demote_f64 (local.get $f))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $f32_array (local.get $a32) + (i32.add (local.get $ofs) (local.get $i)) + (local.get $f32)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))))) + + (func $ta_set (export "ta_set") + (param $d (ref extern)) (param $s (ref extern)) (param $do i32) + (local $sd (ref $data)) (local $sa (ref array)) (local $so i32) + (local $dd (ref $data)) (local $da (ref array)) + (local $i i32) (local $len i32) + (local $sf64 (ref $float_array)) (local $df64 (ref $float_array)) + (local $sf32 (ref $f32_array)) (local $df32 (ref $f32_array)) + (local $si64 (ref $i64_array)) (local $di64 (ref $i64_array)) + (local $si32 (ref $i32_array)) (local $di32 (ref $i32_array)) + (local $si16 (ref $i16_array)) (local $di16 (ref $i16_array)) + (local $si8 (ref $bytes)) (local $di8 (ref $bytes)) + (local.set $sd (ref.cast (ref $data) (any.convert_extern (local.get $s)))) + (local.set $sa (struct.get $data $array (local.get $sd))) + (local.set $so (struct.get $data $offset (local.get $sd))) + (local.set $len (struct.get $data $len (local.get $sd))) + (local.set $dd (ref.cast (ref $data) (any.convert_extern (local.get $d)))) + (local.set $da (struct.get $data $array (local.get $dd))) + (local.set $do + (i32.add (struct.get $data $offset (local.get $dd)) (local.get $do))) + (if (ref.test (ref $float_array) (local.get $sa)) + (then + (local.set $sf64 (ref.cast (ref $float_array) (local.get $sa))) + (local.set $df64 (ref.cast (ref $float_array) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $float_array (local.get $df64) + (i32.add (local.get $do) (local.get $i)) + (array.get $float_array (local.get $sf64) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (if (ref.test (ref $f32_array) (local.get $sa)) + (then + (local.set $sf32 (ref.cast (ref $f32_array) (local.get $sa))) + (local.set $df32 (ref.cast (ref $f32_array) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $f32_array (local.get $df32) + (i32.add (local.get $do) (local.get $i)) + (array.get $f32_array (local.get $sf32) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (if (ref.test (ref $i64_array) (local.get $sa)) + (then + (local.set $si64 (ref.cast (ref $i64_array) (local.get $sa))) + (local.set $di64 (ref.cast (ref $i64_array) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $i64_array (local.get $di64) + (i32.add (local.get $do) (local.get $i)) + (array.get $i64_array (local.get $si64) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (if (ref.test (ref $i32_array) (local.get $sa)) + (then + (local.set $si32 (ref.cast (ref $i32_array) (local.get $sa))) + (local.set $di32 (ref.cast (ref $i32_array) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $i32_array (local.get $di32) + (i32.add (local.get $do) (local.get $i)) + (array.get $i32_array (local.get $si32) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (if (ref.test (ref $i16_array) (local.get $sa)) + (then + (local.set $si16 (ref.cast (ref $i16_array) (local.get $sa))) + (local.set $di16 (ref.cast (ref $i16_array) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $i16_array (local.get $di16) + (i32.add (local.get $do) (local.get $i)) + (array.get $i16_array (local.get $si16) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))))) + (if (ref.test (ref $bytes) (local.get $sa)) + (then + (local.set $si8 (ref.cast (ref $bytes) (local.get $sa))) + (local.set $di8 (ref.cast (ref $bytes) (local.get $da))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $di8) + (i32.add (local.get $do) (local.get $i)) + (array.get $bytes (local.get $si8) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))))) + + (func $ta_blit (param $s (ref extern)) (param $d (ref extern)) + (return_call $ta_set (local.get $d) (local.get $s) (i32.const 0))) + + (func $ta_subarray (export "ta_subarray") + (param $b (ref extern)) (param $s i32) (param $e i32) (result (ref extern)) + (local $d (ref $data)) + (local $a (ref array)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $a (struct.get $data $array (local.get $d))) + (if (ref.test (ref $i64_array) (local.get $a)) + (then + (local.set $s (i32.shr_u (local.get $s) (i32.const 1))) + (local.set $e (i32.shr_u (local.get $e) (i32.const 1))))) + (extern.convert_any + (struct.new $data + (local.get $a) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $s)) + (i32.sub (local.get $e) (local.get $s))))) + + (func $ta_blit_from_bytes (export "ta_blit_from_bytes") + (param $s (ref $bytes)) (param $so i32) + (param $b (ref extern)) (param $do i32) + (param $len i32) + (local $data (ref $data)) + (local $d (ref $bytes)) + (local $i i32) + (local.set $data + (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $d + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data)))) + (local.set $do + (i32.add (local.get $do) (struct.get $data $offset (local.get $data)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $d) + (i32.add (local.get $do) (local.get $i)) + (array.get $bytes (local.get $s) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func $ta_blit_to_bytes (export "ta_blit_to_bytes") + (param $b (ref extern)) (param $so i32) + (param $d (ref $bytes)) (param $do i32) + (param $len i32) + (local $data (ref $data)) + (local $s (ref $bytes)) + (local $i i32) + (local.set $data + (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $s + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data)))) + (local.set $so + (i32.add (local.get $so) (struct.get $data $offset (local.get $data)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $d) + (i32.add (local.get $do) (local.get $i)) + (array.get $bytes (local.get $s) + (i32.add (local.get $so) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func $dv_make (param $a (ref extern)) (result (ref extern)) (local.get $a)) + + (func $dv_get_i8 (export "dv_get_i8") + (param $a (ref extern)) (param $i i32) (result i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.get_s $i8_array + (ref.cast (ref $i8_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)))) + + (func $dv_get_ui8 (export "dv_get_ui8") + (param $a (ref extern)) (param $i i32) (result i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.get_u $i8_array + (ref.cast (ref $i8_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)))) + + (func $dv_get_i16 (export "dv_get_i16") + (param $a (ref extern)) (param $i i32) (param i32) (result i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.get_s $i16_array + (ref.cast (ref $i16_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 1))))) + + (func $dv_get_ui16 (export "dv_get_ui16") + (param $a (ref extern)) (param $i i32) (param i32) (result i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.get_u $i16_array + (ref.cast (ref $i16_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 1))))) + + (func $dv_get_i32 (export "dv_get_i32") + (param $a (ref extern)) (param $i i32) (param i32) (result i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.get $i32_array + (ref.cast (ref $i32_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 2))))) + + (func $dv_get_i64 (export "dv_get_i64") + (param $a (ref extern)) (param $i i32) (param i32) (result i64) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.get $i64_array + (ref.cast (ref $i64_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 3))))) + + (func $dv_get_f32 (export "dv_get_f32") + (param $a (ref extern)) (param $i i32) (param i32) (result f32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.get $f32_array + (ref.cast (ref $f32_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 2))))) + + (func $dv_get_f64 (export "dv_get_f64") + (param $a (ref extern)) (param $i i32) (param i32) (result f64) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.get $f64_array + (ref.cast (ref $f64_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 3))))) + + (func $dv_set_i8 (export "dv_set_i8") + (param $a (ref extern)) (param $i i32) (param $v i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.set $i8_array + (ref.cast (ref $i8_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i)) + (local.get $v))) + + (func $dv_set_i16 (export "dv_set_i16") + (param $a (ref extern)) (param $i i32) (param $v i32) (param i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.set $i16_array + (ref.cast (ref $i16_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 1))) + (local.get $v))) + + (func $dv_set_i32 (export "dv_set_i32") + (param $a (ref extern)) (param $i i32) (param $v i32) (param i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.set $i32_array + (ref.cast (ref $i32_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 2))) + (local.get $v))) + + (func $dv_set_i64 (export "dv_set_i64") + (param $a (ref extern)) (param $i i32) (param $v i64) (param i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.set $i64_array + (ref.cast (ref $i64_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 3))) + (local.get $v))) + + (func $dv_set_f32 (export "dv_set_f32") + (param $a (ref extern)) (param $i i32) (param $v f32) (param i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.set $f32_array + (ref.cast (ref $f32_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 2))) + (local.get $v))) + + (func $dv_set_f64 (export "dv_set_f64") + (param $a (ref extern)) (param $i i32) (param $v f64) (param i32) + (local $d (ref $data)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $a)))) + (array.set $f64_array + (ref.cast (ref $f64_array) (struct.get $data $array (local.get $d))) + (i32.add (struct.get $data $offset (local.get $d)) + (i32.shr_u (local.get $i) (i32.const 3))) + (local.get $v))) + + (func $dv_get_ui16_unaligned + (param $b (ref extern)) (param $i i32) (param i32) (result i32) + (local $d (ref $data)) (local $s (ref $bytes)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $s + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d)))) + (local.set $i + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i))) + (i32.or + (array.get_u $bytes (local.get $s) (local.get $i)) + (i32.shl + (array.get_u $bytes (local.get $s) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8)))) + + (func $dv_get_i32_unaligned (export "dv_get_i32_unaligned") + (param $b (ref extern)) (param $i i32) (param i32) (result i32) + (local $d (ref $data)) (local $s (ref $bytes)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $s + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d)))) + (local.set $i + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i))) + (i32.or + (i32.or + (array.get_u $bytes (local.get $s) (local.get $i)) + (i32.shl + (array.get_u $bytes (local.get $s) + (i32.add (local.get $i) (i32.const 1))) + (i32.const 8))) + (i32.or + (i32.shl + (array.get_u $bytes (local.get $s) + (i32.add (local.get $i) (i32.const 2))) + (i32.const 16)) + (i32.shl + (array.get_u $bytes (local.get $s) + (i32.add (local.get $i) (i32.const 3))) + (i32.const 24))))) + + (func $dv_get_i64_unaligned (export "dv_get_i64_unaligned") + (param $b (ref extern)) (param $i i32) (param $le i32) (result i64) + (i64.or + (i64.extend_i32_u + (call $dv_get_i32_unaligned + (local.get $b) (local.get $i) (local.get $le))) + (i64.shl + (i64.extend_i32_u + (call $dv_get_i32_unaligned + (local.get $b) (i32.add (local.get $i) (i32.const 4)) + (local.get $le))) + (i64.const 32)))) + + (func $dv_set_i16_unaligned + (param $b (ref extern)) (param $i i32) (param $v i32) (param i32) + (local $d (ref $data)) (local $s (ref $bytes)) (local $j i32) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $s + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d)))) + (local.set $i + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i))) + (array.set $bytes (local.get $s) (local.get $i) (local.get $v)) + (array.set $bytes (local.get $s) (i32.add (local.get $i) (i32.const 1)) + (i32.shr_u (local.get $v) (i32.const 8)))) + + (func $dv_set_i32_unaligned + (param $b (ref extern)) (param $i i32) (param $v i32) (param i32) + (local $d (ref $data)) (local $s (ref $bytes)) + (local.set $d (ref.cast (ref $data) (any.convert_extern (local.get $b)))) + (local.set $s + (ref.cast (ref $bytes) (struct.get $data $array (local.get $d)))) + (local.set $i + (i32.add (struct.get $data $offset (local.get $d)) (local.get $i))) + (array.set $bytes (local.get $s) (local.get $i) (local.get $v)) + (array.set $bytes (local.get $s) (i32.add (local.get $i) (i32.const 1)) + (i32.shr_u (local.get $v) (i32.const 8))) + (array.set $bytes (local.get $s) (i32.add (local.get $i) (i32.const 2)) + (i32.shr_u (local.get $v) (i32.const 16))) + (array.set $bytes (local.get $s) (i32.add (local.get $i) (i32.const 3)) + (i32.shr_u (local.get $v) (i32.const 24)))) + + (func $dv_set_i64_unaligned + (param $b (ref extern)) (param $i i32) (param $v i64) (param $le i32) + (call $dv_set_i32_unaligned + (local.get $b) (local.get $i) + (i32.wrap_i64 (local.get $v)) + (local.get $le)) + (call $dv_set_i32_unaligned + (local.get $b) (i32.add (local.get $i) (i32.const 4)) + (i32.wrap_i64 (i64.shr_u (local.get $v) (i64.const 32))) + (local.get $le))) + + (global $littleEndian i32 (i32.const 1)) +) +(@else (import "bindings" "ta_create" (func $ta_create (param i32) (param i32) (result (ref extern)))) (import "bindings" "ta_normalize" @@ -125,6 +637,7 @@ (import "bindings" "dv_set_i16" (func $dv_set_i16_unaligned (param externref i32 i32 i32))) (import "bindings" "littleEndian" (global $littleEndian i32)) +)) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -777,6 +1290,8 @@ (@string $ta_unsupported_kind "Typed_array.to_genarray: unsupported kind") (@string $ta_too_large "Typed_array.to_genarray: too large") +(@if (not wasi) +(@then (func (export "caml_ba_from_typed_array") (param (ref eq)) (result (ref eq)) (local $data (ref extern)) (local $kind i32) @@ -823,6 +1338,7 @@ (if (i32.eq (local.get $kind) (i32.const 14)) ;; Uint8ClampedArray (then (local.set $kind (i32.const 3)))) (ref.i31 (local.get $kind))) +)) (func $caml_ba_get_at_offset (param $ba (ref $bigarray)) (param $i i32) (result (ref eq)) @@ -2528,6 +3044,8 @@ (array.get_u $bytes (local.get $s) (i32.add (local.get $i) (local.get $k))))))) +(@if (not wasi) +(@then (export "caml_bytes_of_uint8_array" (func $caml_string_of_uint8_array)) (func $caml_string_of_uint8_array (export "caml_string_of_uint8_array") (param (ref eq)) (result (ref eq)) @@ -2561,6 +3079,7 @@ (call $dv_make (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_u $bigarray $ba_kind (ref.cast (ref $bigarray) (local.get 0)))) diff --git a/runtime/wasm/bigstring.wat b/runtime/wasm/bigstring.wat index 950ceff77f..818651e2ef 100644 --- a/runtime/wasm/bigstring.wat +++ b/runtime/wasm/bigstring.wat @@ -41,6 +41,21 @@ (import "bigarray" "caml_blit_bytes_to_dataview" (func $caml_blit_bytes_to_dataview (param (ref $bytes) i32 (ref extern) i32 i32))) +(@if wasi +(@then + (import "bigarray" "ta_subarray" + (func $ta_subarray + (param (ref extern)) (param i32) (param i32) (result (ref extern)))) + (import "bigarray" "ta_set" + (func $ta_set (param (ref extern)) (param (ref extern)) (param i32))) + (import "bigarray" "dv_get_i32_unaligned" + (func $dv_get_i32_unaligned (param (ref extern) i32 i32) (result i32))) + (import "bigarray" "dv_get_ui8" + (func $dv_get_ui8 (param (ref extern) i32) (result i32))) + (import "bigarray" "dv_set_i8" + (func $dv_set_i8 (param (ref extern) i32 i32))) +) +(@else (import "bindings" "ta_create" (func $ta_create (param i32) (param anyref) (result anyref))) (import "bindings" "dv_get_i32" @@ -56,6 +71,7 @@ (func $ta_set (param (ref extern)) (param (ref extern)) (param i32))) (import "bindings" "ta_bytes" (func $ta_bytes (param anyref) (result anyref))) +)) (import "hash" "caml_hash_mix_int" (func $caml_hash_mix_int (param i32) (param i32) (result i32))) @@ -102,6 +118,8 @@ (local.set $h (call $caml_hash_mix_int (local.get $h) (local.get $w)))) (i32.xor (local.get $h) (local.get $len))) +(@if (not wasi) +(@then (@string $buffer "buffer") (func (export "bigstring_to_array_buffer") @@ -120,6 +138,7 @@ (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)) diff --git a/runtime/wasm/blake2.wat b/runtime/wasm/blake2.wat index 25ad007838..214f941b67 100644 --- a/runtime/wasm/blake2.wat +++ b/runtime/wasm/blake2.wat @@ -1,5 +1,5 @@ (module -(@if (>= ocaml_version (5 2 0)) +(@if (and (>= ocaml_version (5 2 0)) (not wasi)) (@then (import "jslib" "wrap" (func $wrap (param anyref) (result (ref eq)))) (import "jslib" "unwrap" (func $unwrap (param (ref eq)) (result anyref))) diff --git a/runtime/wasm/compare.wat b/runtime/wasm/compare.wat index ff4784b9d3..597b1632cd 100644 --- a/runtime/wasm/compare.wat +++ b/runtime/wasm/compare.wat @@ -487,6 +487,8 @@ (call $clear_compare_stack) (call $caml_invalid_argument (global.get $abstract_value)) (ref.i31 (i32.const 0)))) +(@if (not wasi) +(@then (drop (block $v1_not_js (result (ref eq)) (local.set $js1 (struct.get $js 0 @@ -514,6 +516,7 @@ (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)) diff --git a/runtime/wasm/deps-wasi.json b/runtime/wasm/deps-wasi.json new file mode 100644 index 0000000000..0a49660901 --- /dev/null +++ b/runtime/wasm/deps-wasi.json @@ -0,0 +1,15 @@ +[ + { + "name": "root", + "reaches": ["start", "memory"], + "root": true + }, + { + "name": "start", + "export": "_start" + }, + { + "name": "memory", + "export": "memory" + } +] diff --git a/runtime/wasm/dune b/runtime/wasm/dune index 8f8b26c023..a69d9e0a3e 100644 --- a/runtime/wasm/dune +++ b/runtime/wasm/dune @@ -28,6 +28,7 @@ --binaryen=-g --binaryen-opt=-O3 --set=effects=jspi + --disable=wasi --allowed-imports=bindings,Math,js,wasm:js-string,wasm:text-encoder,wasm:text-decoder %{target} %{read-lines:args}))) @@ -44,10 +45,46 @@ --binaryen=-g --binaryen-opt=-O3 --set=effects=cps + --disable=wasi --allowed-imports=bindings,Math,js,wasm:js-string,wasm:text-encoder,wasm:text-decoder %{target} %{read-lines:args}))) +(rule + (target runtime-wasi.wasm) + (deps + args + (glob_files *.wat) + libc.wasm) + (action + (run + ../../compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.exe + --binaryen=-g + --binaryen-opt=-O3 + --set=effects=disabled + --enable=wasi + --allowed-imports=wasi_snapshot_preview1,OCaml + %{target} + libc:libc.wasm + %{read-lines:args}))) + +(rule + (target runtime-cps-wasi.wasm) + (deps + args + (glob_files *.wat) + libc.wasm) + (action + (run + ../../compiler/bin-wasm_of_ocaml/wasmoo_link_wasm.exe + --binaryen=-g + --binaryen-opt=-O3 + --set=effects=cps + --enable=wasi + %{target} + libc:libc.wasm + %{read-lines:args}))) + (rule (target args) (deps @@ -57,3 +94,34 @@ (with-stdout-to %{target} (run ocaml %{deps})))) + +(rule + (target libc.new.wasm) + (deps libc.c) + (enabled_if + (not %{env:CI=false})) + (mode promote) + (action + (with-stdout-to + %{target} + (pipe-stdout + (run + docker + run + -v + .:/src + -w + /src + ghcr.io/webassembly/wasi-sdk + /opt/wasi-sdk/bin/clang + -O2 + libc.c + -flto + -o + -) + (run wasm-opt -Oz --strip-debug --strip-dwarf - -o -))))) + +(rule + (alias recompile-libc) + (action + (cmp libc.wasm libc.new.wasm))) diff --git a/runtime/wasm/dynlink.wat b/runtime/wasm/dynlink.wat index 6e49560817..5e1edea6c0 100644 --- a/runtime/wasm/dynlink.wat +++ b/runtime/wasm/dynlink.wat @@ -37,6 +37,8 @@ (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) +(@if (not wasi) +(@then (func (export "caml_wasm_load_module") (param $str (ref eq)) (result (ref eq)) (call $wrap @@ -57,6 +59,7 @@ (call $unwrap (call $caml_jsstring_of_string (local.get $unit_name))) (call $unwrap (call $caml_jsstring_of_string (local.get $source)))) (ref.i31 (i32.const 0))) +)) ;; Field index for prim_count in link_info (must match stdlib.wat) (global $LINK_INFO_PRIM_COUNT i32 (i32.const 3)) diff --git a/runtime/wasm/effect-native.wat b/runtime/wasm/effect-native.wat new file mode 100644 index 0000000000..3208f80e55 --- /dev/null +++ b/runtime/wasm/effect-native.wat @@ -0,0 +1,234 @@ +;; 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 +(@if (= effects "native") +(@then + (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 "obj" "object_tag" (global $object_tag i32)) + (import "stdlib" "caml_named_value" + (func $caml_named_value (param (ref eq)) (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 "stdlib" "caml_main_wrapper" + (global $caml_main_wrapper (mut (ref null $wrapper_func)))) + (import "effect" "effect_allowed" (global $effect_allowed (mut i32))) + + (type $block (array (mut (ref eq)))) + (type $bytes (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))))) + + ;; Effect types + + (tag $effect (param (ref eq)) (result (ref eq) (ref eq))) + + (type $cont_function (func (param (ref eq) (ref eq)) (result (ref eq)))) + + (type $cont (cont $cont_function)) + + (type $generic_fiber + (sub + (struct + (field $value (mut (ref eq))) + (field $exn (mut (ref eq))) + (field $effect (mut (ref eq)))))) + + (type $fiber + (sub final $generic_fiber + (struct + (field $value (mut (ref eq))) + (field $exn (mut (ref eq))) + (field $effect (mut (ref eq))) + (field $cont (mut (ref $cont)))))) + + ;; Unhandled effects + + (@string $effect_unhandled "Effect.Unhandled") + + (func $raise_unhandled + (param $eff (ref eq)) (param (ref eq)) (result (ref eq)) + (block $null + (call $caml_raise_with_arg + (br_on_null $null + (call $caml_named_value (global.get $effect_unhandled))) + (local.get $eff))) + (call $caml_raise_constant + (array.new_fixed $block 3 (ref.i31 (global.get $object_tag)) + (global.get $effect_unhandled) + (call $caml_fresh_oo_id (ref.i31 (i32.const 0))))) + (ref.i31 (i32.const 0))) + + (global $raise_unhandled (ref $closure) + (struct.new $closure (ref.func $raise_unhandled))) + + (type $func (func (result (ref eq)))) + (type $wrapper_func (func (param (ref $func)))) + (type $func_closure (struct (field (ref $func)))) + + (func $wrapper_cont + (param $f (ref eq)) (param (ref eq)) (result (ref eq)) + (return_call_ref $func + (local.get $f) + (struct.get $func_closure 0 + (ref.cast (ref $func_closure) (local.get $f))))) + + (func $unhandled_effect_wrapper (param $start (ref $func)) + (local $cont (ref $cont)) + (local $f (ref eq)) (local $v (ref eq)) + (local $resume_res (tuple (ref eq) (ref $cont))) + (local.set $cont (cont.new $cont (ref.func $wrapper_cont))) + (local.set $f (struct.new $func_closure (local.get $start))) + (local.set $v (ref.i31 (i32.const 0))) + (loop $loop + (local.set $resume_res + (block $handle_effect (result (ref eq) (ref $cont)) + (resume $cont (on $effect $handle_effect) + (local.get $f) (local.get $v) (local.get $cont)) + (return))) + (local.set $cont (tuple.extract 2 1 (local.get $resume_res))) + (local.set $v (tuple.extract 2 0 (local.get $resume_res))) + (local.set $f (global.get $raise_unhandled)) + (br $loop))) + + (func $init + (global.set $caml_main_wrapper (ref.func $unhandled_effect_wrapper))) + + (start $init) + + ;; Resume + + (@string $already_resumed "Effect.Continuation_already_resumed") + + (func $resume (export "%resume") + (param $vfiber (ref eq)) (param $f (ref eq)) (param $v (ref eq)) + (param $tail (ref eq)) (result (ref eq)) + (local $fiber (ref $fiber)) + (local $res (ref eq)) + (local $exn (ref eq)) + (local $resume_res (tuple (ref eq) (ref $cont))) + (if (ref.eq (local.get $vfiber) (ref.i31 (i32.const 0))) + (then + (call $caml_raise_constant + (ref.as_non_null + (call $caml_named_value (global.get $already_resumed)))))) + (local.set $fiber (ref.cast (ref $fiber) (local.get $vfiber))) + (local.set $exn + (block $handle_exception (result (ref eq)) + (local.set $resume_res + (block $handle_effect (result (ref eq) (ref $cont)) + (local.set $res + (try (result (ref eq)) + (do + (resume $cont + (on $effect $handle_effect) + (local.get $f) (local.get $v) + (struct.get $fiber $cont (local.get $fiber)))) +(@if (not wasi) +(@then + (catch $javascript_exception + (br $handle_exception + (call $caml_wrap_exception (pop externref)))) +)) + (catch $ocaml_exception + (br $handle_exception (pop (ref eq)))))) + ;; handle return + (return_call_ref $function_1 (local.get $res) + (local.tee $f + (struct.get $fiber $value (local.get $fiber))) + (struct.get $closure 0 + (ref.cast (ref $closure) (local.get $f)))))) + ;; handle effect + (struct.set $fiber $cont (local.get $fiber) + (tuple.extract 2 1 (local.get $resume_res))) + (return_call_ref $function_3 + (tuple.extract 2 0 (local.get $resume_res)) + (array.new_fixed $block 3 (ref.i31 (global.get $cont_tag)) + (local.get $fiber) + (local.get $fiber)) + (if (result (ref eq)) + (ref.eq (local.get $tail) (ref.i31 (i32.const 0))) + (then (local.get $fiber)) + (else (local.get $tail))) + (local.tee $f + (struct.get $fiber $effect (local.get $fiber))) + (struct.get $closure_3 1 + (ref.cast (ref $closure_3) (local.get $f)))))) + ;; handle exception + (return_call_ref $function_1 (local.get $exn) + (local.tee $f + (struct.get $fiber $exn (local.get $fiber))) + (struct.get $closure 0 (ref.cast (ref $closure) (local.get $f))))) + + ;; Perform + + (func (export "%reperform") + (param $eff (ref eq)) (param $cont (ref eq)) (param $tail (ref eq)) + (result (ref eq)) + (local $res (tuple (ref eq) (ref eq))) + (local.set $res (suspend $effect (local.get $eff))) + (return_call $resume + (ref.as_non_null + (array.get $block + (ref.cast (ref $block) (local.get $cont)) + (i32.const 1))) + (tuple.extract 2 0 (local.get $res)) + (tuple.extract 2 1 (local.get $res)) + (local.get $tail))) + + (func (export "%perform") (param $eff (ref eq)) (result (ref eq)) + (local $res (tuple (ref eq) (ref eq))) + (if (i32.eqz (global.get $effect_allowed)) + (then + (return_call $raise_unhandled + (local.get $eff) (ref.i31 (i32.const 0))))) + (local.set $res (suspend $effect (local.get $eff))) + (return_call_ref $function_1 (tuple.extract 2 1 (local.get $res)) + (tuple.extract 2 0 (local.get $res)) + (struct.get $closure 0 + (ref.cast (ref $closure) (tuple.extract 2 0 (local.get $res)))))) + + ;; Allocate a stack + + (func $initial_cont + (param $f (ref eq)) (param $x (ref eq)) (result (ref eq)) + (return_call_ref $function_1 (local.get $x) + (local.get $f) + (struct.get $closure 0 (ref.cast (ref $closure) (local.get $f))))) + + (func (export "caml_alloc_stack") + (param $hv (ref eq)) (param $hx (ref eq)) (param $hf (ref eq)) + (result (ref eq)) + (struct.new $fiber + (local.get $hv) (local.get $hx) (local.get $hf) + (cont.new $cont (ref.func $initial_cont)))) +)) +) diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index 00ef85d8e8..c370975b2d 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -33,6 +33,12 @@ (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) (import "fail" "javascript_exception" (tag $javascript_exception (param externref))) +(@if wasi +(@then + (func $caml_wrap_exception (param externref) (result (ref eq)) + (unreachable)) +) +(@else (import "jslib" "caml_wrap_exception" (func $caml_wrap_exception (param externref) (result (ref eq)))) (import "bindings" "start_fiber" (func $start_fiber (param (ref eq)))) @@ -41,6 +47,7 @@ (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 $bytes (array (mut i8))) @@ -81,7 +88,7 @@ (global $raise_unhandled (ref $closure) (struct.new $closure (ref.func $raise_unhandled))) - (global $effect_allowed (mut i32) (i32.const 1)) + (global $effect_allowed (export "effect_allowed") (mut i32) (i32.const 1)) (func $caml_continuation_use_noexc (export "caml_continuation_use_noexc") (param (ref eq)) (result (ref eq)) diff --git a/runtime/wasm/fail.wat b/runtime/wasm/fail.wat index ebdda6bd33..a85805329f 100644 --- a/runtime/wasm/fail.wat +++ b/runtime/wasm/fail.wat @@ -18,7 +18,13 @@ (module (import "stdlib" "caml_global_data" (global $caml_global_data (mut (ref $block)))) +(@if wasi +(@then + (tag $javascript_exception (param externref)) +) +(@else (import "bindings" "jstag" (tag $javascript_exception (param externref))) +)) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) diff --git a/runtime/wasm/float.wat b/runtime/wasm/float.wat index de248db496..0d4fdc25d4 100644 --- a/runtime/wasm/float.wat +++ b/runtime/wasm/float.wat @@ -16,12 +16,35 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if wasi +(@then + (import "io" "IO_BUFFER_SIZE" (global $IO_BUFFER_SIZE i32)) + (import "libc" "memory" (memory 2)) + (import "libc" "free" (func $free (param i32))) + (import "libc" "format_float" + (func $format_float (param i32 i32 i32 f64) (result i32))) + (import "libc" "strtod" (func $strtod (param i32) (param i32) (result f64))) + (import "libc" "exp" (func $exp (param f64) (result f64))) + (import "wasi_memory" "checked_malloc" + (func $checked_malloc (param i32) (result i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "write_string_to_memory" + (func $write_string_to_memory (param i32 i32 (ref eq)) (result i32))) + (import "wasi_memory" "release_memory" + (func $release_memory (param i32 i32))) + (import "wasi_memory" "blit_string_to_memory" + (func $blit_string_to_memory (param i32 (ref $bytes)))) + (import "wasi_memory" "blit_memory_to_string" + (func $blit_memory_to_string (param i32 i32) (result (ref $bytes)))) +) +(@else (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)))) @@ -251,6 +274,49 @@ (global $inf (ref $chars) (array.new_fixed $chars 3 (@char "i") (@char "n") (@char "f"))) +(@if wasi +(@then + (func (export "caml_format_float") + (param $vfmt (ref eq)) (param $arg (ref eq)) (result (ref eq)) + (local $fmt (ref $bytes)) (local $res (ref $bytes)) + (local $d f64) + (local $buffer i32) (local $out_buffer i32) + (local $fmt_len i32) (local $avail i32) (local $len i32) + (local.set $fmt (ref.cast (ref $bytes) (local.get $vfmt))) + (local.set $d + (struct.get $float 0 (ref.cast (ref $float) (local.get $arg)))) + (local.set $buffer (call $get_buffer)) + (local.set $fmt_len (array.len (local.get $fmt))) + (call $blit_string_to_memory (local.get $buffer) (local.get $fmt)) + (i32.store8 + (i32.add (local.get $buffer) (local.get $fmt_len)) (i32.const 0)) + (local.set $out_buffer + (i32.add (local.get $buffer) + (i32.add (local.get $fmt_len) (i32.const 1)))) + (local.set $avail + (i32.sub (global.get $IO_BUFFER_SIZE) (local.get $fmt_len))) + (local.set $len + (call $format_float + (local.get $out_buffer) (local.get $avail) + (local.get $buffer) (local.get $d))) + (if (i32.ge_u (local.get $len) (local.get $avail)) + (then + (local.set $out_buffer + (call $checked_malloc (i32.add (local.get $len) (i32.const 1)))) + (drop + (call $format_float + (local.get $out_buffer) + (i32.add (local.get $len) (i32.const 1)) + (local.get $buffer) (local.get $d))))) + (local.set $res + (call $blit_memory_to_string (local.get $out_buffer) (local.get $len))) + (if (i32.ge_u (local.get $len) (local.get $avail)) + (then + (call $free (local.get $out_buffer)))) + (local.get $res) + ) +) +(@else (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)) @@ -333,6 +399,7 @@ (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)) +)) (func $caml_float_of_hex (param $err_msg (ref eq)) (param $s (ref $bytes)) (param $i i32) @@ -490,6 +557,7 @@ (local $s' (ref $bytes)) (local $negative i32) (local $c i32) (local $f f64) + (local $buffer i32) (local $buf i32) (local.set $s (ref.cast (ref $bytes) (local.get 1))) (local.set $len (array.len (local.get $s))) (loop $count @@ -657,9 +725,26 @@ (f64.const inf) (local.get $negative)))) )))))))))))))))))) +(@if wasi +(@then + (local.set $buffer (call $get_buffer)) + (local.set $buf + (call $write_string_to_memory + (i32.add (local.get $buffer) (i32.const 4)) + (global.get $IO_BUFFER_SIZE) + (local.get $s))) + (local.set $f (call $strtod (local.get $buf) (local.get $buffer))) + (call $release_memory (i32.add (local.get $buffer) (i32.const 4)) + (local.get $buf)) + (br_if $error + (i32.ne (i32.load (local.get $buffer)) + (i32.add (local.get $buf) (local.get $len)))) +) +(@else (local.set $f (call $parse_float (call $jsstring_of_bytes (local.get $s)))) (br_if $error (f64.ne (local.get $f) (local.get $f))) +)) (return (struct.new $float (local.get $f)))) (call $caml_failwith (local.get $err_msg)) (return (ref.i31 (i32.const 0)))) diff --git a/runtime/wasm/fs.wat b/runtime/wasm/fs.wat index 11a92da7c0..fff3ec814a 100644 --- a/runtime/wasm/fs.wat +++ b/runtime/wasm/fs.wat @@ -16,6 +16,41 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if wasi +(@then + (import "libc" "memory" (memory 2)) + (import "libc" "free" (func $free (param i32))) + (import "wasi_memory" "checked_malloc" + (func $checked_malloc (param i32) (result i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "write_string_to_memory" + (func $write_string_to_memory (param i32 i32 (ref eq)) (result i32))) + (import "wasi_memory" "blit_memory_to_string" + (func $blit_memory_to_string (param i32 i32) (result (ref $bytes)))) + (import "wasi_snapshot_preview1" "fd_prestat_get" + (func $fd_prestat_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_prestat_dir_name" + (func $fd_prestat_dir_name (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_rename" + (func $path_rename (param i32 i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_unlink_file" + (func $path_unlink_file (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_create_directory" + (func $path_create_directory (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_remove_directory" + (func $path_remove_directory (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_filestat_get" + (func $path_filestat_get (param i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_open" + (func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_readdir" + (func $fd_readddir (param i32 i32 i32 i64 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_close" + (func $fd_close (param i32) (result i32))) + (import "sys" "caml_handle_sys_error" + (func $caml_handle_sys_error (param (ref eq) i32))) +) +(@else (import "bindings" "on_windows" (global $on_windows i32)) (import "bindings" "getcwd" (func $getcwd (result anyref))) (import "bindings" "chdir" (func $chdir (param anyref))) @@ -44,6 +79,11 @@ (tag $javascript_exception (param externref))) (import "sys" "caml_handle_sys_error" (func $caml_handle_sys_error (param externref))) + (import "bigarray" "caml_uint8_array_of_string" + (func $caml_uint8_array_of_string (param (ref eq)) (result (ref eq)))) + (import "bigarray" "caml_string_of_uint8_array" + (func $caml_string_of_uint8_array (param (ref eq)) (result (ref eq)))) +)) (import "string" "caml_string_concat" (func $caml_string_concat (param (ref eq) (ref eq)) (result (ref eq)))) (import "fail" "caml_raise_sys_error" @@ -52,13 +92,291 @@ (func $register_file (param anyref) (param anyref))) (import "bindings" "read_file" (func $read_file (param anyref) (result anyref))) - (import "bigarray" "caml_uint8_array_of_string" - (func $caml_uint8_array_of_string (param (ref eq)) (result (ref eq)))) - (import "bigarray" "caml_string_of_uint8_array" - (func $caml_string_of_uint8_array (param (ref eq)) (result (ref eq)))) (type $bytes (array (mut i8))) + (type $block (array (mut (ref eq)))) + +(@if wasi +(@then + (type $preopen + (struct + (field $prefix (ref $bytes)) + (field $fd i32) + (field $next (ref null $preopen)))) + + (global $preopens (mut (ref null $preopen)) (ref.null $preopen)) + + (global $preopens_initialized (mut i32) (i32.const 0)) + + (func $normalize_prefix (param $prefix (ref $bytes)) (result (ref $bytes)) + (local $i i32) (local $len i32) (local $c i32) (local $res (ref $bytes)) + (local.set $len (array.len (local.get $prefix))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (local.set $c + (array.get $bytes (local.get $prefix) (local.get $i))) + (if (i32.eq (local.get $c) (i32.const 47)) ;; '/' + (then + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))) + (if (i32.eq (local.get $c) (i32.const 46)) ;; '.' + (then + (if (i32.eq (local.get $i) + (i32.sub (local.get $len) (i32.const 1))) + (then + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)) + (else + (local.set $c + (array.get $bytes (local.get $prefix) + (i32.add (local.get $i) (i32.const 1)))) + (if (i32.eq (local.get $c) (i32.const 47)) ;; '/' + (then + (local.set $i + (i32.add (local.get $i) (i32.const 2))) + (br $loop)))))))))) + (if (i32.eq (local.get $i) (local.get $len)) + (then (return (@string "")))) + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (if (i32.gt_u (local.get $i) (i32.const 0)) + (then + (local.set $res + (array.new $bytes (i32.const 0) + (i32.sub (local.get $len) (local.get $i)))) + (array.copy $bytes $bytes + (local.get $res) (i32.const 0) + (local.get $prefix) (local.get $i) + (i32.sub (local.get $len) (local.get $i))) + (return (local.get $res)))) + (return (local.get $prefix))) + + (func $get_preopens (result (ref null $preopen)) + (local $fd i32) (local $buffer i32) (local $res i32) (local $len i32) + (if $done (i32.eqz (global.get $preopens_initialized)) + (then + (local.set $buffer (call $get_buffer)) + (local.set $fd (i32.const 3)) + (loop $loop + (local.set $res + (call $fd_prestat_get (local.get $fd) (local.get $buffer))) + (br_if $done (i32.eq (local.get $res) (i32.const 8))) ;; EBADF + (block $skip + (br_if $skip + (i32.eqz + (i32.and (i32.eqz (local.get $res)) + (i32.eqz (i32.load8_u (local.get $buffer)))))) + (local.set $len (i32.load offset=4 (local.get $buffer))) + (local.set $res + (call $fd_prestat_dir_name + (local.get $fd) (local.get $buffer) (local.get $len))) + (br_if $skip (local.get $res)) + (global.set $preopens + (struct.new $preopen + (call $normalize_prefix + (call $blit_memory_to_string + (local.get $buffer) (local.get $len))) + (local.get $fd) + (global.get $preopens)))) + (local.set $fd (i32.add (local.get $fd) (i32.const 1))) + (br $loop)) + (global.set $preopens_initialized (i32.const 1)))) + (global.get $preopens)) + + (global $current_dir (mut (ref $bytes)) (@string "")) + + (@string $root_dir "/") + + (func $make_absolute + (param $path (ref $bytes)) (result (ref $bytes)) + (local $need_slash i32) (local $i i32) (local $abs_path (ref $bytes)) + (if (i32.eqz (array.len (local.get $path))) + (then ;; empty path + (return (global.get $current_dir)))) + (if (i32.eq (i32.const 47) ;; '/' + (array.get_u $bytes (local.get $path) (i32.const 0))) + (then ;; absolute path + (return (local.get $path)))) + (if (i32.and + (i32.eq (i32.const 46) ;; '.' + (array.get_u $bytes (local.get $path) (i32.const 0))) + (i32.eq (array.len (local.get $path)) (i32.const 1))) + (then + ;; "." + (return (global.get $current_dir)))) + (if (i32.ge_u (array.len (local.get $path)) (i32.const 2)) + (then + (if (i32.and + (i32.eq (i32.const 46) ;; '.' + (array.get_u $bytes (local.get $path) (i32.const 0))) + (i32.eq (i32.const 47) ;; '/' + (array.get_u $bytes (local.get $path) (i32.const 1)))) + (then ;; starts with "./" + (local.set $i (i32.const 2)))))) + (if (i32.eq (local.get $i) (array.len (local.get $path))) + (then ;; "./" + (return (global.get $current_dir)))) + (local.set $need_slash + (if (result i32) (array.len (global.get $current_dir)) + (then + (i32.ne (i32.const 47) ;; '/' + (array.get_u $bytes (global.get $current_dir) + (i32.sub (array.len (global.get $current_dir)) + (i32.const 1))))) + (else + (i32.const 1)))) + (local.set $abs_path + (array.new $bytes (i32.const 0) + (i32.add (array.len (global.get $current_dir)) + (i32.add (i32.sub (local.get $need_slash) (local.get $i)) + (array.len (local.get $path)))))) + (array.copy $bytes $bytes + (local.get $abs_path) (i32.const 0) + (global.get $current_dir) (i32.const 0) + (array.len (global.get $current_dir))) + (array.set $bytes (local.get $abs_path) + (array.len (global.get $current_dir)) + (i32.const 47)) ;; '/' + (array.copy $bytes $bytes + (local.get $abs_path) + (i32.add (array.len (global.get $current_dir)) + (local.get $need_slash)) + (local.get $path) (local.get $i) + (i32.sub (array.len (local.get $path)) (local.get $i))) + (local.get $abs_path)) + (func $wasi_chdir (export "wasi_chdir") (param $name (ref eq)) + (local $abs_path (ref $bytes)) (local $path (ref $bytes)) (local $i i32) + (local.set $abs_path + (call $make_absolute (ref.cast (ref $bytes) (local.get $name)))) + (local.set $i (i32.sub (array.len (local.get $abs_path)) (i32.const 1))) + ;; remove trailing slashes + (loop $loop + (if (i32.ge_s (local.get $i) (i32.const 0)) + (then + (if (i32.eq (i32.const 47) ;; '/' + (array.get $bytes (local.get $abs_path) (local.get $i))) + (then + (local.set $i (i32.sub (local.get $i) (i32.const 1))) + (br $loop)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (if (i32.lt_u (local.get $i) (array.len (local.get $abs_path))) + (then + (local.set $path (array.new $bytes (i32.const 0) (local.get $i))) + (array.copy $bytes $bytes + (local.get $path) (i32.const 0) + (local.get $abs_path) (i32.const 0) + (local.get $i)) + (local.set $abs_path (local.get $path)))) + (global.set $current_dir (local.get $abs_path))) + + (func $prefix_match + (param $prefix (ref $bytes)) (param $path (ref $bytes)) (result i32) + (local $i i32) (local $len i32) + (local.set $len (array.len (local.get $prefix))) + (if (i32.lt_u (array.len (local.get $path)) (local.get $len)) + (then (return (i32.const 0)))) + (if (i32.gt_u (array.len (local.get $path)) (local.get $len)) + (then + (if (i32.ne (array.get_u $bytes (local.get $path) (local.get $len)) + (i32.const 47)) + (then (return (i32.const 0)))))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (if (i32.ne (array.get_u $bytes (local.get $path) (local.get $i)) + (array.get_u $bytes (local.get $prefix) (local.get $i))) + (then (return (i32.const 0)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (return (i32.const 1))) + + (func $resolve_abs_path + (param $path (ref $bytes)) (result i32 (ref $bytes)) + (local $fd i32) (local $len i32) (local $i i32) + (local $preopens (ref null $preopen)) (local $current (ref $preopen)) + (local $prefix (ref $bytes)) (local $rel_path (ref $bytes)) + (local.set $preopens (call $get_preopens)) + (local.set $i (i32.const -1)) + (block $done + (loop $loop + (local.set $current (br_on_null $done (local.get $preopens))) + (local.set $prefix + (struct.get $preopen $prefix (local.get $current))) + (if (i32.and + (i32.gt_s (array.len (local.get $prefix)) (local.get $i)) + (call $prefix_match (local.get $prefix) (local.get $path))) + (then + (local.set $fd (struct.get $preopen $fd (local.get $current))) + (local.set $i (array.len (local.get $prefix))))) + (local.set $preopens + (struct.get $preopen $next (local.get $current))) + (br $loop))) + (if (i32.eq (local.get $i) (i32.const -1)) + (then ;; not found + (return (tuple.make 2 (i32.const -1) (@string ""))))) + ;; skip leading slashes + (local.set $len (local.get $i)) + (loop $loop + (if (i32.lt_u (local.get $i) (array.len (local.get $path))) + (then + (if (i32.eq (array.get_u $bytes (local.get $path) (local.get $i)) + (i32.const 47)) ;; 47 + (then + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))) + (local.set $rel_path + (array.new $bytes (i32.const 0) + (i32.sub (array.len (local.get $path)) (local.get $i)))) + (array.copy $bytes $bytes + (local.get $rel_path) (i32.const 0) + (local.get $path) (local.get $i) + (i32.sub (array.len (local.get $path)) (local.get $i))) + (return + (tuple.make 2 (local.get $fd) (local.get $rel_path)))))) + (return (tuple.make 2 (local.get $fd) (@string ".")))) + + (func (export "wasi_resolve_path") + (param $vpath (ref eq)) + (result (;fd;) i32 (;address;) i32 (;length;) i32) + (local $res (tuple i32 (ref $bytes))) + (local $p i32) + (local.set $res + (call $resolve_abs_path + (call $make_absolute + (ref.cast (ref $bytes) (local.get $vpath))))) + (if (i32.ge_u (tuple.extract 2 0 (local.get $res)) (i32.const 0)) + (then + (local.set $p + (call $write_string_to_memory + (i32.const 0) (i32.const 0) + (tuple.extract 2 1 (local.get $res)))))) + (return + (tuple.make 3 + (tuple.extract 2 0 (local.get $res)) + (local.get $p) + (array.len (tuple.extract 2 1 (local.get $res)))))) + + (func $caml_sys_resolve_path (export "caml_sys_resolve_path") + (param $path (ref eq)) (result i32 i32 i32) + (local $res (tuple i32 i32 i32)) + (local.set $res (call $wasi_resolve_path (local.get $path))) + (if (i32.lt_s (tuple.extract 3 0 (local.get $res)) (i32.const 0)) + (then ;; ENOENT + (call $caml_handle_sys_error (local.get $path) (i32.const 44)))) + (local.get $res)) +)) + +(@if wasi +(@then + (func (export "caml_sys_getcwd") + (export "unix_getcwd") (export "caml_unix_getcwd") + (param (ref eq)) (result (ref eq)) + (if (array.len (global.get $current_dir)) + (then (return (global.get $current_dir)))) + (global.get $root_dir)) +) +(@else (func (export "caml_sys_getcwd") (param (ref eq)) (result (ref eq)) (try (result (ref eq)) @@ -67,7 +385,35 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)) (ref.i31 (i32.const 0))))) +)) +(@if wasi +(@then + (func (export "caml_sys_chdir") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $res i32) (local $kind i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (local.set $kind (i32.load8_u offset=16 (local.get $buffer))) + (if (i32.ne (local.get $kind) (i32.const 3)) + (then + (call $caml_handle_sys_error + (local.get $name) (i32.const 54)))) ;; ENOTDIR + (call $wasi_chdir (local.get $name)) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_chdir") (param $name (ref eq)) (result (ref eq)) (try @@ -77,7 +423,26 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "caml_sys_mkdir") + (param $name (ref eq)) (param $perm (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $res + (call $path_create_directory + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_mkdir") (param $name (ref eq)) (param $perm (ref eq)) (result (ref eq)) (try @@ -88,7 +453,130 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "caml_sys_read_directory") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $res i32) (local $fd i32) + (local $buf i32) (local $new_buf i32) + (local $size i32) (local $pos i32) (local $available i32) + (local $left i32) (local $namelen i32) + (local $entry i32) (local $entry_size i32) + (local $cookie i64) (local $tbl (ref $block)) (local $new_tbl (ref $block)) + (local $i i32) (local $s (ref $bytes)) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_open + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) ;; symlink_follow + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (i32.const 2) ;; O_DIRECTORY + (i64.const 0x4000) ;; allow fd_readdir + (i64.const 0) + (i32.const 0) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (local.set $fd (i32.load (local.get $buffer))) + (local.set $buf (call $checked_malloc (i32.const 512))) + (local.set $size (i32.const 512)) + (local.set $tbl (array.new $block (ref.i31 (i32.const 0)) (i32.const 50))) + (local.set $i (i32.const 1)) + (loop $loop + (block $refill + (local.set $left (i32.sub (local.get $available) (local.get $pos))) + (br_if $refill (i32.lt_u (local.get $left) (i32.const 24))) + (local.set $entry (i32.add (local.get $buf) (local.get $pos))) + (local.set $namelen (i32.load offset=16 (local.get $entry))) + (local.set $entry_size (i32.add (local.get $namelen) (i32.const 24))) + (br_if $refill (i32.lt_u (local.get $left) (local.get $entry_size))) + (local.set $pos (i32.add (local.get $pos) (local.get $entry_size))) + (local.set $cookie (i64.load (local.get $entry))) + (if (i32.eq (local.get $i) (array.len (local.get $tbl))) + (then + (local.set $new_tbl + (array.new $block (ref.i31 (i32.const 0)) + (i32.shl (local.get $i) (i32.const 1)))) + (array.copy $block $block + (local.get $new_tbl) (i32.const 0) + (local.get $tbl) (i32.const 0) (local.get $i)) + (local.set $tbl (local.get $new_tbl)))) + (local.set $s + (call $blit_memory_to_string + (i32.add (local.get $entry) (i32.const 24)) + (local.get $namelen))) + ;; skip "." and ".." + (if (i32.eq (local.get $namelen) (i32.const 2)) + (then + (br_if $loop + (i32.and + (i32.eq (i32.const 46) + (array.get_u $bytes (local.get $s) (i32.const 0))) + (i32.eq (i32.const 46) + (array.get_u $bytes (local.get $s) (i32.const 1)))))) + (else + (if (i32.eq (local.get $namelen) (i32.const 1)) + (then + (br_if $loop + (i32.eq + (array.get_u $bytes (local.get $s) (i32.const 0)) + (i32.const 46))))))) + (array.set $block (local.get $tbl) (local.get $i) (local.get $s)) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)) + ;; refill + (if (i32.lt_u (local.get $size) (local.get $entry_size)) + (then + ;; the entry does not fit + (local.set $new_buf + (call $checked_malloc (local.get $entry_size))) + (call $free (local.get $buf)) + (local.set $buf (local.get $new_buf)) + (local.set $size (local.get $entry_size)))) + (block $done + (br_if $done + (i32.and + (i32.ne (i32.const 0) (local.get $available)) + (i32.lt_u (local.get $available) (local.get $size)))) + (local.set $res + (call $fd_readddir + (local.get $fd) + (local.get $buf) + (local.get $size) + (local.get $cookie) + (local.get $buffer))) + (if (local.get $res) + (then + (call $free (local.get $buf)) + (drop (call $fd_close (local.get $fd))) + (call $caml_handle_sys_error + (local.get $name) (local.get $res)))) + (local.set $available (i32.load (local.get $buffer))) + (br_if $done (i32.eqz (local.get $available))) + (local.set $pos (i32.const 0)) + (br $loop))) + ;; done + (call $free (local.get $buf)) + (local.set $res (call $fd_close (local.get $fd))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (if (i32.eq (local.get $i) (array.len (local.get $tbl))) + (then (return (local.get $tbl)))) + (local.set $new_tbl + (array.new $block (ref.i31 (i32.const 0)) (local.get $i))) + (array.copy $block $block + (local.get $new_tbl) (i32.const 0) + (local.get $tbl) (i32.const 0) (local.get $i)) + (local.get $new_tbl)) +) +(@else (func (export "caml_sys_read_directory") (param $name (ref eq)) (result (ref eq)) (try @@ -101,7 +589,26 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)) (return (ref.i31 (i32.const 0)))))) +)) +(@if wasi +(@then + (func (export "caml_sys_rmdir") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $res + (call $path_remove_directory + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_rmdir") (param $name (ref eq)) (result (ref eq)) (try @@ -111,7 +618,26 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "caml_sys_remove") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $res + (call $path_unlink_file + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_remove") (param $name (ref eq)) (result (ref eq)) (try @@ -121,7 +647,32 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "caml_sys_rename") + (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) + (local $op (tuple i32 i32 i32)) + (local $np (tuple i32 i32 i32)) + (local $res i32) + (local.set $op (call $caml_sys_resolve_path (local.get $o))) + (local.set $np (call $caml_sys_resolve_path (local.get $n))) + (local.set $res + (call $path_rename + (tuple.extract 3 0 (local.get $op)) + (tuple.extract 3 1 (local.get $op)) + (tuple.extract 3 2 (local.get $op)) + (tuple.extract 3 0 (local.get $np)) + (tuple.extract 3 1 (local.get $np)) + (tuple.extract 3 2 (local.get $np)))) + (call $free (tuple.extract 3 1 (local.get $op))) + (call $free (tuple.extract 3 1 (local.get $np))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $o) (local.get $res)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_rename") (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) (try @@ -132,11 +683,34 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "caml_sys_file_exists") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) (local $buffer i32) + (local.set $p (call $wasi_resolve_path (local.get $name))) + (if (i32.lt_s (tuple.extract 3 0 (local.get $p)) (i32.const 0)) + (then (return (ref.i31 (i32.const 0))))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (ref.i31 (i32.eqz (local.get $res)))) +) +(@else (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))))) +)) (@string $no_such_file ": No such file or directory") @@ -145,6 +719,14 @@ (call $caml_string_concat (local.get $name) (global.get $no_such_file)))) +(@if wasi +(@then + (func (export "caml_read_file_content") + (param $name (ref eq)) (result (ref eq)) + (call $caml_raise_no_such_file (local.get $name)) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_read_file_content") (param $name (ref eq)) (result (ref eq)) (local $res anyref) @@ -157,17 +739,51 @@ (return (ref.i31 (i32.const 0))))) (return_call $caml_string_of_uint8_array (call $wrap (local.get $res)))) +)) +(@if wasi +(@then + (func (export "caml_create_file") + (param $name (ref eq)) (param $content (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_create_file") (param $name (ref eq)) (param $content (ref eq)) (result (ref eq)) (call $register_file (call $unwrap (call $caml_jsstring_of_string (local.get $name))) (call $unwrap (call $caml_uint8_array_of_string (local.get $content)))) (ref.i31 (i32.const 0))) +)) (func (export "caml_fs_init") (result (ref eq)) (ref.i31 (i32.const 0))) +(@if wasi +(@then + (func $caml_sys_file_mode (param $name (ref eq)) (result i32) + (local $p (tuple i32 i32 i32)) + (local $res i32) (local $buffer i32) + (local.set $p (call $caml_sys_resolve_path (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then (call $caml_handle_sys_error (local.get $name) (local.get $res)))) + (i32.load8_u offset=16 (local.get $buffer))) + + (func (export "caml_sys_is_directory") + (param $name (ref eq)) (result (ref eq)) + (ref.i31 + (i32.eq (call $caml_sys_file_mode (local.get $name)) (i32.const 3)))) +) +(@else (func (export "caml_sys_is_directory") (param $name (ref eq)) (result (ref eq)) (try @@ -179,7 +795,16 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)) (return (ref.i31 (i32.const 0)))))) +)) +(@if wasi +(@then + (func (export "caml_sys_is_regular_file") + (param $name (ref eq)) (result (ref eq)) + (ref.i31 + (i32.eq (call $caml_sys_file_mode (local.get $name)) (i32.const 4)))) +) +(@else (func (export "caml_sys_is_regular_file") (param $name (ref eq)) (result (ref eq)) (try @@ -191,12 +816,20 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)) (return (ref.i31 (i32.const 0)))))) +)) +(@if wasi +(@then + (func (export "caml_sys_temp_dir_name") (param (ref eq)) (result (ref eq)) + (@string "/tmp")) +) +(@else (func (export "caml_sys_temp_dir_name") (param (ref eq)) (result (ref eq)) (if (global.get $on_windows) (then (return_call $caml_string_of_jsstring (call $wrap (call $tmpdir))))) (@string "")) +)) (func (export "caml_mount_autoload") (param (ref eq) (ref eq)) (result (ref eq)) diff --git a/runtime/wasm/graphics.wat b/runtime/wasm/graphics.wat index 5046b2a7c9..7a8003ce20 100644 --- a/runtime/wasm/graphics.wat +++ b/runtime/wasm/graphics.wat @@ -16,6 +16,10 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module + +(@if (not wasi) +(@then + ;; Imports from other wasm modules (import "fail" "caml_failwith" (func $caml_failwith (param (ref eq)))) (import "fail" "caml_raise_with_arg" @@ -546,4 +550,5 @@ (param (ref eq)) (result (ref eq)) (call $caml_failwith (global.get $close_subwindow)) (ref.i31 (i32.const 0))) +)) ) diff --git a/runtime/wasm/hash.wat b/runtime/wasm/hash.wat index 671eb50595..0912b448fa 100644 --- a/runtime/wasm/hash.wat +++ b/runtime/wasm/hash.wat @@ -304,6 +304,8 @@ (local.get $v)))))))) (local.set $num (i32.sub (local.get $num) (i32.const 1))) (br $loop))) +(@if (not wasi) +(@then (drop (block $not_jsstring (result anyref) (local.set $str (struct.get $js 0 @@ -315,6 +317,7 @@ (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 diff --git a/runtime/wasm/io.wat b/runtime/wasm/io.wat index 7e32923055..fb495dfdf5 100644 --- a/runtime/wasm/io.wat +++ b/runtime/wasm/io.wat @@ -25,6 +25,31 @@ (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)))) +(@if wasi +(@then + (import "wasi_snapshot_preview1" "fd_close" + (func $fd_close (param i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_write" + (func $fd_write (param i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_read" + (func $fd_read (param i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_seek" + (func $fd_seek (param i32 i64 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_open" + (func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) (result i32))) + (import "libc" "memory" (memory 2)) + (import "libc" "free" (func $free (param i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "blit_memory_to_substring" + (func $blit_memory_to_substring (param i32 (ref $bytes) i32 i32))) + (import "wasi_memory" "blit_substring_to_memory" + (func $blit_substring_to_memory (param i32 (ref $bytes) i32 i32))) + (import "sys" "caml_handle_sys_error" + (func $caml_handle_sys_error (param (ref eq) i32))) + (import "fs" "caml_sys_resolve_path" + (func $caml_sys_resolve_path (param (ref eq)) (result i32 i32 i32))) +) +(@else (import "bindings" "open" (func $open (param anyref) (param i32) (param i32) (result i32))) (import "bindings" "close" (func $close (param i32))) @@ -69,10 +94,17 @@ (func $dv_get_ui8 (param externref i32) (result i32))) (import "bindings" "dv_set_i8" (func $dv_set_i8 (param externref i32 i32))) - (import "fail" "javascript_exception" - (tag $javascript_exception (param externref))) (import "sys" "caml_handle_sys_error" (func $caml_handle_sys_error (param externref))) + (import "fail" "javascript_exception" + (tag $javascript_exception (param externref))) + (import "bigarray" "caml_blit_dataview_to_bytes" + (func $caml_blit_dataview_to_bytes + (param (ref extern) i32 (ref $bytes) i32 i32))) + (import "bigarray" "caml_blit_bytes_to_dataview" + (func $caml_blit_bytes_to_dataview + (param (ref $bytes) i32 (ref extern) i32 i32))) +)) (import "custom" "custom_compare_id" (func $custom_compare_id (param (ref eq)) (param (ref eq)) (param i32) (result i32))) @@ -83,15 +115,134 @@ (func $caml_copy_int64 (param i64) (result (ref eq)))) (import "int64" "Int64_val" (func $Int64_val (param (ref eq)) (result i64))) - (import "bigarray" "caml_blit_dataview_to_bytes" - (func $caml_blit_dataview_to_bytes - (param (ref extern) i32 (ref $bytes) i32 i32))) - (import "bigarray" "caml_blit_bytes_to_dataview" - (func $caml_blit_bytes_to_dataview - (param (ref $bytes) i32 (ref extern) i32 i32))) (import "bigarray" "caml_ba_get_data" (func $caml_ba_get_data (param (ref eq)) (result (ref extern)))) +(@if wasi +(@then + (func $ta_new (param $sz i32) (result (ref extern)) + (extern.convert_any (array.new $bytes (i32.const 0) (local.get $sz)))) + + (func $ta_copy + (param $buf (ref extern)) + (param $dst i32) (param $src i32) (param $end i32) + (local $b (ref $bytes)) + (local.set $b + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf)))) + (array.copy $bytes $bytes + (local.get $b) (local.get $dst) + (local.get $b) (local.get $src) + (i32.sub (local.get $end) (local.get $src)))) + + (func $caml_blit_bytes_to_dataview + (param $s (ref $bytes)) (param $i i32) (param $buf (ref extern)) + (param $j i32) (param $l i32) + (array.copy $bytes $bytes + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf))) + (local.get $j) + (local.get $s) (local.get $i) + (local.get $l))) + + (func $caml_blit_dataview_to_bytes + (param $buf (ref extern)) (param $i i32) (param $s (ref $bytes)) + (param $j i32) (param $l i32) + (array.copy $bytes $bytes + (local.get $s) (local.get $j) + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf))) + (local.get $i) + (local.get $l))) + + (func $dv_make) + + (func $dv_get_ui8 + (param $a (ref extern)) (param $i i32) (result i32) + (array.get_u $bytes + (ref.cast (ref $bytes) (any.convert_extern (local.get $a))) + (local.get $i))) + + (func $dv_set_i8 + (param $a (ref extern)) (param $i i32) (param $v i32) + (array.set $bytes + (ref.cast (ref $bytes) (any.convert_extern (local.get $a))) + (local.get $i) + (local.get $v))) + + (type $data + (struct + (field $array (ref array)) + (field $offset i32) + (field $len i32))) + + (func $ta_blit_from_buffer + (param $buf (ref extern)) (param $i i32) + (param $ta (ref extern)) (param $j i32) + (param $len i32) + (local $data (ref $data)) + (local.set $data + (ref.cast (ref $data) (any.convert_extern (local.get $ta)))) + (call $caml_blit_dataview_to_bytes + (local.get $buf) + (local.get $i) + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data))) + (i32.add (struct.get $data $offset (local.get $data)) (local.get $j)) + (local.get $len))) + + (func $ta_blit_to_buffer + (param $ta (ref extern)) (param $i i32) + (param $buf (ref extern)) (param $j i32) + (param $len i32) + (local $data (ref $data)) + (local.set $data + (ref.cast (ref $data) (any.convert_extern (local.get $ta)))) + (call $caml_blit_bytes_to_dataview + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data))) + (i32.add (struct.get $data $offset (local.get $data)) (local.get $i)) + (local.get $buf) + (local.get $j) + (local.get $len))) + + (global $caml_stdout + (mut (ref eq)) (ref.i31 (i32.const 0))) + + (func $register_channel (param $ch (ref eq)) + (if (i32.eq + (struct.get $channel $fd (ref.cast (ref $channel) (local.get $ch))) + (i32.const 1)) + (then + (global.set $caml_stdout (local.get $ch))))) + + (func $unregister_channel (param (ref eq))) + (func $map_new (result (ref extern)) + (extern.convert_any (ref.i31 (i32.const 0)))) + (func $map_get (param (ref extern)) (param i32) (result (ref $fd_offset)) + (struct.new $fd_offset (i64.const 0) (i32.const 0))) + (func $map_set (param (ref extern)) (param i32) (param (ref $fd_offset))) + (func $map_delete (param (ref extern)) (param i32)) + + (func $file_size (param $fd i32) (result i64) + (local $cur i64) (local $end i64) (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (block $error + (local.set $res + (call $fd_seek + (local.get $fd) (i64.const 0) (i32.const 1) (local.get $buffer))) + (br_if $error (local.get $res)) + (local.set $cur (i64.load (local.get $buffer))) + (local.set $res + (call $fd_seek + (local.get $fd) (i64.const 0) (i32.const 2) (local.get $buffer))) + (br_if $error (local.get $res)) + (local.set $end (i64.load (local.get $buffer))) + (local.set $res + (call $fd_seek + (local.get $fd) (local.get $cur) (i32.const 0) + (local.get $buffer))) + (br_if $error (local.get $res)) + (return (local.get $end))) + (call $caml_handle_sys_error (ref.i31 (i32.const 0)) (local.get $res)) + (i64.const 0)) +) +(@else (import "bindings" "map_new" (func $map_new (result (ref extern)))) (import "bindings" "map_get" (func $map_get @@ -120,6 +271,7 @@ (call $ta_subarray (local.get $ta) (local.get $i) (i32.add (local.get $i) (local.get $len))) (local.get $j))) +)) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -220,7 +372,24 @@ (global $IO_BUFFER_SIZE (export "IO_BUFFER_SIZE") i32 (i32.const 65536)) - (type $open_flags (array i8)) + (type $open_flags (array i16)) + +(@if wasi +(@then + ;; 1 O_RDONLY + ;; 2 O_WRONLY + ;; 0x10 O_CREAT + ;; 0x40 O_EXCL + ;; 0x80 O_TRUNC + ;; 0x100 O_APPEND + ;; 0x400 O_NONBLOCK + (global $sys_open_flags (ref $open_flags) + (array.new_fixed $open_flags 9 + (i32.const 1) (i32.const 2) (i32.const 0x102) (i32.const 0x10) + (i32.const 0x80) (i32.const 0x40) (i32.const 0) (i32.const 0) + (i32.const 0x400))) +) +(@else ;; 1 O_RDONLY ;; 2 O_WRONLY ;; 4 O_RDWR @@ -233,6 +402,7 @@ (array.new_fixed $open_flags 9 (i32.const 1) (i32.const 2) (i32.const 10) (i32.const 16) (i32.const 32) (i32.const 64) (i32.const 0) (i32.const 0) (i32.const 128))) +)) (func $convert_flag_list (export "convert_flag_list") (param $tbl (ref $open_flags)) (param $vflags (ref eq)) (result i32) @@ -254,6 +424,41 @@ (br $loop)))) (local.get $flags)) +(@if wasi +(@then + (func (export "caml_sys_open") + (param $vpath (ref eq)) (param $vflags (ref eq)) (param $perm (ref eq)) + (result (ref eq)) + (local $fd i32) (local $flags i32) (local $offset i64) + (local $path (tuple i32 i32 i32)) + (local $res i32) (local $buffer i32) + (local.set $path (call $caml_sys_resolve_path (local.get $vpath))) + (local.set $buffer (call $get_buffer)) + (local.set $flags + (call $convert_flag_list + (global.get $sys_open_flags) (local.get $vflags))) + (local.set $res + (call $path_open + (tuple.extract 3 0 (local.get $path)) + (i32.const 1) ;; symlink_follow + (tuple.extract 3 1 (local.get $path)) + (tuple.extract 3 2 (local.get $path)) + (i32.and (i32.shr_u (local.get $flags) (i32.const 4)) + (i32.const 0xF)) + (select (i64.const 0x860007c) (i64.const 0x820003e) + (i32.and (local.get $flags) (i32.const 2))) + (i64.const 0) + (i32.shr_u (local.get $flags) (i32.const 8)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $path))) + (if (local.get $res) + (then + (call $caml_handle_sys_error (local.get $vpath) (local.get $res)))) + (local.set $fd (i32.load (local.get $buffer))) + (call $initialize_fd_offset (local.get $fd) (local.get $offset)) + (ref.i31 (local.get $fd))) +) +(@else (func (export "caml_sys_open") (param $path (ref eq)) (param $vflags (ref eq)) (param $perm (ref eq)) (result (ref eq)) @@ -270,14 +475,30 @@ (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)))))) + (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))) +)) +(@if wasi +(@then (func (export "caml_sys_close") (param (ref eq)) (result (ref eq)) - (local $fd i32) + (local $fd i32) (local $res i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get 0)))) + (call $release_fd_offset (local.get $fd)) + (local.set $res (call $fd_close (local.get $fd))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (ref.i31 (i32.const 0))) +) +(@else + (func (export "caml_sys_close") (param (ref eq)) (result (ref eq)) + (local $fd i32) (local $res i32) (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get 0)))) (call $release_fd_offset (local.get $fd)) (try @@ -286,6 +507,7 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (ref.i31 (i32.const 0))) +)) (func (export "caml_sys_io_buffer_size") (param (ref eq)) (result (ref eq)) (ref.i31 (global.get $IO_BUFFER_SIZE))) @@ -308,9 +530,34 @@ (local.get $f)) (ref.i31 (i32.const 0))) +(@if wasi +(@then + (func $push_channel (param $l (ref eq)) (param $ch (ref eq)) (result (ref eq)) + (local $c (ref $channel)) + (block $continue + (br_if $continue (i32.eqz (ref.test (ref $channel) (local.get $ch)))) + (local.set $c (ref.cast (ref $channel) (local.get $ch))) + (br_if $continue + (i32.eq (struct.get $channel $fd (local.get $c)) (i32.const -1))) + (local.set $l + (array.new_fixed $block 3 + (ref.i31 (i32.const 0)) (local.get $ch) (local.get $l)))) + (local.get $l)) +)) + +(@if wasi +(@then + (func (export "caml_ml_out_channels_list") + (param (ref eq)) (result (ref eq)) + (call $push_channel + (call $push_channel (ref.i31 (i32.const 0)) (global.get $caml_stdout)) + (global.get $caml_stderr))) +) +(@else (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)) @@ -376,7 +623,7 @@ (func (export "caml_ml_close_channel") (param (ref eq)) (result (ref eq)) (local $ch (ref $channel)) - (local $fd i32) + (local $fd i32) (local $res i32) (local.set $ch (ref.cast (ref $channel) (local.get 0))) ;; output channels: any output will trigger a flush since the ;; buffer is non-empty (curr > 0) and full (curr = size) @@ -391,14 +638,56 @@ (struct.set $channel $fd (local.get $ch) (i32.const -1)) (call $unregister_channel (local.get $ch)) (call $release_fd_offset (local.get $fd)) +(@if wasi +(@then + (local.set $res (call $fd_close (local.get $fd))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) +) +(@else (try (do (call $close (local.get $fd))) (catch $javascript_exception ;; ignore exception - (drop (pop externref)))))) + (drop (pop externref)))) +)) + )) (ref.i31 (i32.const 0))) +(@if wasi +(@then + (func $read + (param $fd i32) (param $buf (ref extern)) (param $pos i32) (param $n i32) + (result i32) + (local $buffer i32) + (local $iovs i32) (local $iovs_len i32) (local $nread i32) + (local $s (ref $bytes)) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $nread (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (i32.store offset=4 (local.get $iovs) (local.get $n)) + (local.set $iovs_len (i32.const 1)) + (local.set $res + (call $fd_read + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nread))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (local.set $n (i32.load (local.get $nread))) + (local.set $s + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf)))) + (call $blit_memory_to_substring + (local.get $buffer) (local.get $s) (local.get $pos) (local.get $n)) + (local.get $n)) +)) + (func $caml_do_read (param $ch (ref $channel)) (param $pos i32) (param $len i32) (result i32) (local $fd i32) @@ -406,6 +695,16 @@ (local $offset i64) (local $n i32) (local.set $fd (struct.get $channel $fd (local.get $ch))) +(@if wasi +(@then + (local.set $n + (call $read + (local.get $fd) + (struct.get $channel $buffer (local.get $ch)) + (local.get $pos) + (local.get $len))) +) +(@else (local.set $fd_offset (call $get_fd_offset (local.get $fd))) (local.set $offset (struct.get $fd_offset $offset (local.get $fd_offset))) (try @@ -432,8 +731,22 @@ (struct.set $fd_offset $offset (local.get $fd_offset) (i64.add (local.get $offset) (i64.extend_i32_u (local.get $n)))) +)) (local.get $n)) +(@if wasi +(@then + (func $caml_do_read_or_refill + (param $ch (ref $channel)) (param $pos i32) (param $len i32) (result i32) + (local $f (ref null eq)) + (local $str (ref $bytes)) + (local $str_len i32) + (local $n i32) + (local.set $f (struct.get $channel $refill (local.get $ch))) + (return_call $caml_do_read + (local.get $ch) (local.get $pos) (local.get $len))) +) +(@else (func $caml_do_read_or_refill (param $ch (ref $channel)) (param $pos i32) (param $len i32) (result i32) (local $f (ref null eq)) @@ -463,6 +776,7 @@ (struct.get $channel $buffer_view (local.get $ch)) (local.get $pos) (local.get $n)) (local.get $n)) +)) (func $caml_refill (param $ch (ref $channel)) (result i32) (local $n i32) @@ -683,6 +997,26 @@ (i64.add (call $caml_ml_get_channel_offset (local.get $ch)) (i64.extend_i32_s (struct.get $channel $curr (local.get $ch)))))) +(@if wasi +(@then + (func $caml_seek_in + (param $ch (ref $channel)) (param $dest i64) (result (ref eq)) + (local $fd i32) (local $buffer i32) (local $res i32) + (local.set $fd (struct.get $channel $fd (local.get $ch))) + (local.set $buffer (call $get_buffer)) + ;; ZZZ store current offset in channel do avoid some syscalls? + (local.set $res + (call $fd_seek + (local.get $fd) (local.get $dest) (i32.const 0) (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (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))) +) +(@else (func $caml_seek_in (param $ch (ref $channel)) (param $dest i64) (result (ref eq)) (local $fd i32) (local $offset i64) @@ -715,6 +1049,7 @@ (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)) @@ -731,8 +1066,26 @@ (param $vch (ref eq)) (param $voffset (ref eq)) (result (ref eq)) (local $ch (ref $channel)) (local $fd_offset (ref $fd_offset)) (local $offset i64) + (local $buffer i32) (local $res i32) (local.set $ch (ref.cast (ref $channel) (local.get $vch))) (call $caml_flush (local.get $ch)) +(@if wasi +(@then + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_seek + (struct.get $channel $fd (local.get $ch)) + (i64.extend_i32_s + (i31.get_s (ref.cast (ref i31) (local.get $voffset)))) + (i32.const 0) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) +) +(@else + ;; ZZZ Check for error (local.set $fd_offset (call $get_fd_offset (struct.get $channel $fd (local.get $ch)))) (local.set $offset @@ -742,14 +1095,32 @@ (then (call $caml_raise_sys_error (@string "Invalid argument")))) (struct.set $fd_offset $offset (local.get $fd_offset) (local.get $offset)) (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 $offset i64) + (local $buffer i32) (local $res i32) (local.set $ch (ref.cast (ref $channel) (local.get $vch))) (call $caml_flush (local.get $ch)) +(@if wasi +(@then + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_seek + (struct.get $channel $fd (local.get $ch)) + (call $Int64_val (local.get $voffset)) + (i32.const 0) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) +) +(@else + ;; ZZZ Check for error (local.set $fd_offset (call $get_fd_offset (struct.get $channel $fd (local.get $ch)))) (local.set $offset (call $Int64_val (local.get $voffset))) @@ -757,6 +1128,7 @@ (then (call $caml_raise_sys_error (@string "Invalid argument")))) (struct.set $fd_offset $offset (local.get $fd_offset) (local.get $offset)) (struct.set $fd_offset $seeked (local.get $fd_offset) (i32.const 1)) +)) (ref.i31 (i32.const 0))) (func (export "caml_ml_input_scan_line") @@ -834,6 +1206,66 @@ (then (call $caml_flush (local.get $ch)))) (ref.i31 (i32.const 0))) +(@if wasi +(@then + (func $write + (param $fd i32) (param $buf (ref extern)) (param $pos i32) (param $n i32) + (result i32) + (local $buffer i32) + (local $iovs i32) (local $iovs_len i32) (local $nwritten i32) + (local $s (ref $bytes)) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $nwritten (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (i32.store offset=4 (local.get $iovs) (local.get $n)) + (local.set $iovs_len (i32.const 1)) + (local.set $s + (ref.cast (ref $bytes) (any.convert_extern (local.get $buf)))) + (call $blit_substring_to_memory + (local.get $buffer) (local.get $s) (local.get $pos) (local.get $n)) + (local.set $res + (call $fd_write + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nwritten))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (i32.load (local.get $nwritten))) +)) + +(@if wasi +(@then + (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 $tmp (ref $bytes)) + (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 $written + (call $write + (local.get $fd) + (local.get $buf) + (i32.const 0) + (local.get $towrite))) + (if (i32.gt_u (local.get $towrite) (local.get $written)) + (then + (call $ta_copy (local.get $buf) + (i32.const 0) (local.get $written) + (local.get $towrite)))) + (local.set $towrite + (i32.sub (local.get $towrite) (local.get $written))) + (struct.set $channel $curr (local.get $ch) + (local.get $towrite)))) + (i32.eqz (local.get $towrite))) +) +(@else (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)) @@ -901,6 +1333,7 @@ (struct.set $channel $curr (local.get $ch) (i32.const 0)) (local.set $towrite (i32.const 0)))))) (i32.eqz (local.get $towrite))) +)) (func $caml_putblock (param $ch (ref $channel)) (param $s (ref $bytes)) (param $pos i32) @@ -1063,12 +1496,31 @@ (struct.set $channel $fd (ref.cast (ref $channel) (local.get 0)) (local.get 1))) +(@if wasi +(@then + (func $caml_ml_get_channel_offset (export "caml_ml_get_channel_offset") + (param $ch (ref eq)) (result i64) + (local $fd i32) (local $buffer i32) (local $res i32) + (local.set $fd + (struct.get $channel $fd (ref.cast (ref $channel) (local.get $ch)))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_seek + (local.get $fd) (i64.const 0) (i32.const 1) (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (i64.load (local.get $buffer))) +) +(@else (func $caml_ml_get_channel_offset (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)))))) +)) (func (export "caml_ml_output_bigarray") (param $ch (ref eq)) (param $a (ref eq)) (param $vpos (ref eq)) diff --git a/runtime/wasm/jslib.wat b/runtime/wasm/jslib.wat index 96659c52ec..75716c5f7f 100644 --- a/runtime/wasm/jslib.wat +++ b/runtime/wasm/jslib.wat @@ -16,6 +16,10 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module + (type $bytes (array (mut i8))) + +(@if (not wasi) +(@then (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))) @@ -104,7 +108,6 @@ (type $block (array (mut (ref eq)))) (type $float (struct (field f64))) (type $float_array (array (mut f64))) - (type $bytes (array (mut i8))) (type $js (struct (field anyref))) (func $wrap (export "wrap") (param anyref) (result (ref eq)) @@ -681,6 +684,7 @@ (return (array.get $block (local.get $exn) (i32.const 2))))))) (call $wrap (ref.null any))) +)) (func (export "caml_exn_with_js_backtrace") (param $exn (ref eq)) (param (ref eq)) (result (ref eq)) diff --git a/runtime/wasm/jslib_js_of_ocaml.wat b/runtime/wasm/jslib_js_of_ocaml.wat index 5f3c4c14e0..ec69833df0 100644 --- a/runtime/wasm/jslib_js_of_ocaml.wat +++ b/runtime/wasm/jslib_js_of_ocaml.wat @@ -16,6 +16,8 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if (not wasi) +(@then (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" @@ -56,4 +58,5 @@ (call $caml_js_global (ref.i31 (i32.const 0))) (global.get $XMLHttpRequest)) (array.new_fixed $block 1 (ref.i31 (i32.const 0))))) +)) ) diff --git a/runtime/wasm/jsstring.wat b/runtime/wasm/jsstring.wat index 2b3ca0e3bc..821614063e 100644 --- a/runtime/wasm/jsstring.wat +++ b/runtime/wasm/jsstring.wat @@ -16,6 +16,8 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if (not wasi) +(@then (import "wasm:js-string" "compare" (func $compare_strings (param externref externref) (result i32))) (import "wasm:js-string" "test" @@ -290,4 +292,5 @@ (local.set $s (array.new $bytes (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/libc.c b/runtime/wasm/libc.c new file mode 100644 index 0000000000..3b0c44bd04 --- /dev/null +++ b/runtime/wasm/libc.c @@ -0,0 +1,175 @@ +/* +Primitives implemented by the WASI libc. Use 'dune build @recompile-libc' +to update libc.wasm. + +clang -O2 --target=wasm32-wasi --sysroot=/path/to/wasi-libc/sysroot -nodefaultlibs -lc libc.c -o libc.wasm +*/ + +#include +#include +#include +#include +#include + +__attribute__((export_name("cos"))) +double libc_cos (double x) { + return cos(x); +} + +__attribute__((export_name("sin"))) +double libc_sin (double x) { + return sin(x); +} + +__attribute__((export_name("tan"))) +double libc_tan (double x) { + return tan(x); +} + +__attribute__((export_name("acos"))) +double libc_acos (double x) { + return acos(x); +} + +__attribute__((export_name("asin"))) +double libc_asin (double x) { + return asin(x); +} + +__attribute__((export_name("atan"))) +double libc_atan (double x) { + return atan(x); +} + +__attribute__((export_name("cosh"))) +double libc_cosh (double x) { + return cosh(x); +} + +__attribute__((export_name("sinh"))) +double libc_sinh (double x) { + return sinh(x); +} + +__attribute__((export_name("tanh"))) +double libc_tanh (double x) { + return tanh(x); +} + +__attribute__((export_name("acosh"))) +double libc_acosh (double x) { + return acosh(x); +} + +__attribute__((export_name("asinh"))) +double libc_asinh (double x) { + return asinh(x); +} + +__attribute__((export_name("atanh"))) +double libc_atanh (double x) { + return atanh(x); +} + +__attribute__((export_name("cbrt"))) +double libc_cbrt (double x) { + return cbrt(x); +} + +__attribute__((export_name("exp"))) +double libc_exp (double x) { + return exp(x); +} + +__attribute__((export_name("expm1"))) +double libc_expm1 (double x) { + return expm1(x); +} + +__attribute__((export_name("log"))) +double libc_log (double x) { + return log(x); +} + +__attribute__((export_name("log1p"))) +double libc_log1p (double x) { + return log1p(x); +} + +__attribute__((export_name("log2"))) +double libc_log2 (double x) { + return log2(x); +} + +__attribute__((export_name("log10"))) +double libc_log10 (double x) { + return log10(x); +} + +__attribute__((export_name("atan2"))) +double libc_atan2 (double x, double y) { + return atan2(x, y); +} + +__attribute__((export_name("hypot"))) +double libc_hypot (double x, double y) { + return hypot(x, y); +} + +__attribute__((export_name("pow"))) +double libc_pow (double x, double y) { + return pow(x, y); +} + +__attribute__((export_name("fmod"))) +double libc_fmod (double x, double y) { + return fmod(x, y); +} + +__attribute__((export_name("strtod"))) +double libc_strtod (const char * buf, char ** end) { + return strtod(buf, end); +} + +__attribute__((export_name("format_float"))) +int format_float (char * buf, size_t len, const char * fmt, double f) { + return snprintf(buf, len, fmt, f); +} + +__attribute__((export_name("malloc"))) +void * libc_malloc (size_t len) { + return malloc(len); +} + +__attribute__((export_name("free"))) +void libc_free (void * ptr) { + return free(ptr); +} + +__attribute__((export_name("strlen"))) +size_t libc_strlen (const char * s) { + return strlen(s); +} + + +__attribute__((export_name("gmtime"))) +struct tm * libc_gmtime (const time_t * timep) { + return gmtime(timep); +} + +__attribute__((export_name("localtime"))) +struct tm * libc_localtime (const time_t * timep) { + return localtime(timep); +} + +__attribute__((export_name("mktime"))) +time_t libc_mktime(struct tm *tm) { + return mktime(tm); +} + +__attribute__((import_module("OCaml"), import_name("_initialize"))) +void start(void); + +int main () { + start(); +} diff --git a/runtime/wasm/libc.wasm b/runtime/wasm/libc.wasm new file mode 100644 index 0000000000..5e3f34061d Binary files /dev/null and b/runtime/wasm/libc.wasm differ diff --git a/runtime/wasm/marshal.wat b/runtime/wasm/marshal.wat index bed4f5e77b..77ada144b9 100644 --- a/runtime/wasm/marshal.wat +++ b/runtime/wasm/marshal.wat @@ -45,11 +45,76 @@ (import "custom" "caml_find_custom_operations" (func $caml_find_custom_operations (param (ref $bytes)) (result (ref null $custom_operations)))) + (type $block (array (mut (ref eq)))) +(@if wasi +(@then + (type $map + (struct + (field $size (mut i32)) + (field $keys (mut (ref $block))) + (field $values (mut (ref $block))))) + (func $map_new (result (ref any)) + (struct.new $map + (i32.const 0) + (array.new $block (ref.i31 (i32.const 0)) (i32.const 2)) + (array.new $block (ref.i31 (i32.const 0)) (i32.const 2)))) + (func $map_get (param $map (ref any)) (param $k (ref eq)) (result i31ref) + (local $m (ref $map)) (local $keys (ref $block)) + (local $i i32) (local $size i32) + (local.set $m (ref.cast (ref $map) (local.get $map))) + (local.set $size (struct.get $map $size (local.get $m))) + (local.set $keys (struct.get $map $keys (local.get $m))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $size)) + (then + (if (ref.eq (array.get $block (local.get $keys) (local.get $i)) + (local.get $k)) + (then + (return + (ref.cast (ref i31) + (array.get $block + (struct.get $map $values (local.get $m)) + (local.get $i)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (ref.null i31)) + (func $map_set (param $map (ref any)) (param $k (ref eq)) (param $v (ref i31)) + (local $m (ref $map)) (local $i i32) (local $size i32) + (local $keys (ref $block)) (local $a (ref $block)) + (local.set $m (ref.cast (ref $map) (local.get $map))) + (local.set $i (struct.get $map $size (local.get $m))) + (local.set $keys (struct.get $map $keys (local.get $m))) + (if (i32.eq (local.get $i) (array.len (local.get $keys))) + (then + (local.set $size (i32.shl (local.get $i) (i32.const 1))) + (local.set $a + (array.new $block (ref.i31 (i32.const 0)) (local.get $size))) + (array.copy $block $block + (local.get $a) (i32.const 0) + (local.get $keys) (i32.const 0) + (local.get $i)) + (struct.set $map $keys (local.get $m) (local.get $a)) + (local.set $keys (local.get $a)) + (local.set $a + (array.new $block (ref.i31 (i32.const 0)) (local.get $size))) + (array.copy $block $block + (local.get $a) (i32.const 0) + (struct.get $map $values (local.get $m)) (i32.const 0) + (local.get $i)) + (struct.set $map $values (local.get $m) (local.get $a)))) + (array.set $block (local.get $keys) (local.get $i) (local.get $k)) + (array.set $block (struct.get $map $values (local.get $m)) + (local.get $i) (local.get $v)) + (struct.set $map $size (local.get $m) + (i32.add (local.get $i) (i32.const 1)))) +) +(@else (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)))) +)) (@string $input_val_from_string "input_value_from_string") @@ -131,7 +196,6 @@ (global.get $input_value)) (return_call $intern_rec (local.get $s) (local.get $h))) - (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) (type $float (struct (field f64))) (type $float_array (array (mut f64))) diff --git a/runtime/wasm/prng.wat b/runtime/wasm/prng.wat index 4be35de7ed..40adb85ce3 100644 --- a/runtime/wasm/prng.wat +++ b/runtime/wasm/prng.wat @@ -16,13 +16,30 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module + +(@if wasi +(@then + (import "bigarray" "dv_get_i64" + (func $dv_get_i64 (param (ref extern) i32 i32) (result i64))) + (import "bigarray" "dv_set_i64" + (func $dv_set_i64 (param (ref extern) i32 i64 i32))) +) +(@else (import "bindings" "dv_get_i64" (func $dv_get_i64 (param externref i32 i32) (result i64))) (import "bindings" "dv_set_i64" (func $dv_set_i64 (param externref i32 i64 i32))) + (import "bindings" "littleEndian" (global $littleEndian i32)) +)) + (import "bigarray" "caml_ba_get_data" + (func $caml_ba_get_data (param (ref eq)) (result (ref extern)))) (import "bigarray" "caml_ba_get_view" (func $caml_ba_get_view (param (ref eq)) (result (ref extern)))) - (import "bindings" "littleEndian" (global $littleEndian i32)) + +(@if wasi +(@then + (global $littleEndian i32 (i32.const 1)) +)) (func (export "caml_lxm_next") (param $v (ref eq)) (result i64) (local $view (ref extern)) diff --git a/runtime/wasm/runtime-wasi.js b/runtime/wasm/runtime-wasi.js new file mode 100644 index 0000000000..e5bf61e0ca --- /dev/null +++ b/runtime/wasm/runtime-wasi.js @@ -0,0 +1,84 @@ +// 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. + +() => async (args) => { + // biome-ignore lint/suspicious/noRedundantUseStrict: .. + "use strict"; + + const emitWarning = globalThis.process.emitWarning; + globalThis.process.emitWarning = function (...args) { + if (args[1] !== "ExperimentalWarning") emitWarning(...args); + }; + + const { link, src } = args; + + const { argv, env } = require("node:process"); + const { WASI } = require("node:wasi"); + const wasi = new WASI({ + version: "preview1", + args: argv.slice(1), + env, + preopens: { ".": ".", "/tmp": "/tmp" }, + returnOnExit: false, + }); + const imports = wasi.getImportObject(); + 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); + } + async function instantiateModule(code) { + return WebAssembly.instantiate(await code, imports); + } + async function instantiateFromDir() { + imports.env = {}; + imports.OCaml = {}; + const deps = []; + async function loadModule(module, isRuntime) { + const sync = module[1].constructor !== Array; + async function instantiate() { + const code = loadRelative(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(); + + wasi.start(wasmModule.instance); +}; diff --git a/runtime/wasm/stdlib.wat b/runtime/wasm/stdlib.wat index b0e7708d91..3e8fee2f03 100644 --- a/runtime/wasm/stdlib.wat +++ b/runtime/wasm/stdlib.wat @@ -39,10 +39,25 @@ (func $caml_format_exception (param (ref eq)) (result (ref eq)))) (import "sys" "ocaml_exit" (tag $ocaml_exit)) (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) +(@if wasi +(@then + (import "wasi_snapshot_preview1" "proc_exit" (func $exit (param i32))) + (import "wasi_snapshot_preview1" "fd_write" + (func $fd_write (param i32 i32 i32 i32) (result i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "write_string_to_memory" + (func $write_string_to_memory (param i32 i32 (ref eq)) (result i32))) + (import "wasi_memory" "release_memory" + (func $release_memory (param i32 i32))) + (import "io" "IO_BUFFER_SIZE" (global $IO_BUFFER_SIZE i32)) + (import "libc" "memory" (memory 2)) +) +(@else (import "fail" "javascript_exception" (tag $javascript_exception (param externref))) (import "bindings" "write" (func $write (param i32) (param anyref))) (import "bindings" "exit" (func $exit (param i32))) +)) (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) @@ -447,6 +462,8 @@ (global $uncaught_exception (mut externref) (ref.null extern)) +(@if (not wasi) +(@then (func $reraise_exception (result (ref eq)) (throw $javascript_exception (global.get $uncaught_exception)) (ref.i31 (i32.const 0))) @@ -454,12 +471,30 @@ (func (export "caml_handle_uncaught_exception") (param $exn externref) (global.set $uncaught_exception (local.get $exn)) (call $caml_main (ref.func $reraise_exception))) +)) + + (type $wrapper_func (func (param (ref $func)))) + (global $caml_main_wrapper (export "caml_main_wrapper") + (mut (ref null $wrapper_func)) + (ref.null $wrapper_func)) (func $caml_main (export "caml_main") (param $start (ref func)) (local $exn (ref eq)) (local $msg (ref eq)) +(@if wasi +(@then + (local $buffer i32) (local $i i32) (local $len i32) + (local $buf i32) (local $remaining i32) + (local $iovs i32) (local $iovs_len i32) (local $nwritten i32) + (local $res i32) +)) (try (do + (block $fallback + (call_ref $wrapper_func + (ref.cast (ref $func) (local.get $start)) + (br_on_null $fallback (global.get $caml_main_wrapper))) + (return)) (drop (call_ref $func (ref.cast (ref $func) (local.get $start))))) (catch $ocaml_exit) (catch $ocaml_exception @@ -490,9 +525,44 @@ (call $caml_string_concat (call $caml_format_exception (local.get $exn)) (@string "\n")))) +(@if wasi +(@then + (local.set $len + (array.len (ref.cast (ref $bytes) (local.get $msg)))) + (local.set $buffer (call $get_buffer)) + (local.set $nwritten (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $iovs_len (i32.const 1)) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (local.set $buf + (call $write_string_to_memory + (local.get $buffer) (global.get $IO_BUFFER_SIZE) + (local.get $msg))) + (local.set $remaining (local.get $buf)) + (loop $write + (i32.store (local.get $iovs) (local.get $remaining)) + (i32.store offset=4 (local.get $iovs) (local.get $len)) + (local.set $res + (call $fd_write + (i32.const 2) (local.get $iovs) (local.get $iovs_len) + (local.get $nwritten))) + (if (i32.eqz (local.get $res)) + (then + (local.set $len + (i32.sub (local.get $len) + (i32.load (local.get $nwritten)))) + (local.set $remaining + (i32.add (local.get $remaining) + (i32.load (local.get $nwritten)))) + (br_if $write (local.get $len))))) + (call $release_memory (local.get $buffer) (local.get $buf)) +) +(@else (call $write (i32.const 2) (call $unwrap - (call $caml_jsstring_of_string (local.get $msg))))) + (call $caml_jsstring_of_string (local.get $msg)))) +)) + ) (call $exit (i32.const 2))))) (func (export "caml_with_async_exns") (param $f (ref eq)) (result (ref eq)) diff --git a/runtime/wasm/sys.wat b/runtime/wasm/sys.wat index b978e4cdb8..52bd8329d0 100644 --- a/runtime/wasm/sys.wat +++ b/runtime/wasm/sys.wat @@ -19,6 +19,37 @@ (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)) +(@if wasi +(@then + (import "wasi_snapshot_preview1" "random_get" + (func $random_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "clock_time_get" + (func $clock_time_get (param i32 i64 i32) (result i32))) + (import "wasi_snapshot_preview1" "args_get" + (func $args_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "args_sizes_get" + (func $args_sizes_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "environ_get" + (func $environ_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "environ_sizes_get" + (func $environ_sizes_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "proc_exit" (func $exit (param i32))) + (import "libc" "memory" (memory 2)) + (import "libc" "free" (func $free (param i32))) + (import "libc" "strlen" (func $strlen (param i32) (result i32))) + (import "wasi_memory" "checked_malloc" + (func $checked_malloc (param i32) (result i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "blit_memory_to_string" + (func $blit_memory_to_string (param i32 i32) (result (ref $bytes)))) + (import "wasi_errors" "error_messages" (global $error_messages (ref $block))) + (import "string" "caml_string_concat" + (func $caml_string_concat + (param (ref eq)) (param (ref eq)) (result (ref eq)))) + (import "fail" "caml_invalid_argument" + (func $caml_invalid_argument (param (ref eq)))) +) +(@else (import "bindings" "ta_length" (func $ta_length (param (ref extern)) (result i32))) (import "bindings" "ta_get_i32" @@ -48,6 +79,7 @@ (import "jsstring" "jsstring_test" (func $jsstring_test (param anyref) (result i32))) (import "bindings" "exit" (func $exit (param i32))) +)) (import "io" "caml_channel_descriptor" (func $caml_channel_descriptor (param (ref eq)) (result (ref eq)))) @@ -63,29 +95,181 @@ ;; Fallback: try to exit through an exception (throw $ocaml_exit)) - (func (export "caml_sys_getenv") (export "caml_sys_unsafe_getenv") - (param (ref eq)) (result (ref eq)) +(@if wasi +(@then + (global $environment (mut i32) (i32.const 0)) + (global $environment_count (mut i32) (i32.const 0)) + (global $environment_data (mut i32) (i32.const 0)) + + (func $initialize_env + (local $buffer i32) (local $res i32) (local $env i32) (local $data i32) + (if (i32.eqz (global.get $environment)) + (then + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $environ_sizes_get + (local.get $buffer) + (i32.add (local.get $buffer) (i32.const 4)))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (local.set $env + (call $checked_malloc + (i32.shl (i32.load (local.get $buffer)) (i32.const 2)))) + (local.set $data + (call $checked_malloc (i32.load offset=4 (local.get $buffer)))) + (local.set $res + (call $environ_get (local.get $env) (local.get $data))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (global.set $environment (local.get $env)) + (global.set $environment_data (local.get $data)) + (global.set $environment_count (i32.load (local.get $buffer)))))) + + (func $caml_getenv + (param $name (ref eq)) (result eqref) + (local $var (ref $bytes)) (local $i i32) (local $j i32) + (local $len i32) (local $s i32) (local $c i32) + (call $initialize_env) + (local.set $var (ref.cast (ref $bytes) (local.get $name))) + (local.set $len (array.len (local.get $var))) + (block $not_found + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (br_if $not_found + (i32.eq (i32.const 61) ;; '=' + (array.get_u $bytes (local.get $var) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.set $i (i32.const 0)) + (loop $loop + (if (i32.lt_u (local.get $i) (global.get $environment_count)) + (then + (local.set $s + (i32.load + (i32.add (global.get $environment) + (i32.shl (local.get $i) (i32.const 2))))) + (local.set $j (i32.const 0)) + (block $next + (loop $scan + (if (i32.lt_u (local.get $j) (local.get $len)) + (then + (local.set $c + (i32.load8_u + (i32.add (local.get $s) (local.get $j)))) + (br_if $next (i32.eqz (local.get $c))) + (br_if $next + (i32.ne (local.get $c) + (array.get $bytes + (local.get $var) (local.get $j)))) + (local.set $j + (i32.add (local.get $j) (i32.const 1))) + (br $scan)))) + (br_if $next + (i32.ne (i32.const 61) ;; '=' + (i32.load8_u + (i32.add (local.get $s) (local.get $j))))) + (local.set $s + (i32.add (local.get $s) + (i32.add (local.get $j) (i32.const 1)))) + (return_call $blit_memory_to_string + (local.get $s) (call $strlen (local.get $s)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + (ref.null eq)) +) +(@else + (func $caml_getenv + (param (ref eq)) (result eqref) (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 (return (ref.null eq)))) + (return_call $caml_string_of_jsstring (call $wrap (local.get $res)))) +)) + + (func (export "caml_sys_getenv") (export "caml_sys_unsafe_getenv") + (param $name (ref eq)) (result (ref eq)) + (local $res eqref) + (local.set $res (call $caml_getenv (local.get $name))) + (if (ref.is_null (local.get $res)) (then (call $caml_raise_not_found))) - (return_call $caml_string_of_jsstring (call $wrap (local.get $res)))) + (ref.as_non_null (local.get $res))) (func (export "caml_sys_getenv_opt") - (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))) + (param $name (ref eq)) (result (ref eq)) + (local $res eqref) + (local.set $res (call $caml_getenv (local.get $name))) + (if (ref.is_null (local.get $res)) (then (return (ref.i31 (i32.const 0))))) (array.new_fixed $block 2 (ref.i31 (i32.const 0)) - (call $caml_string_of_jsstring (call $wrap (local.get $res))))) + (ref.as_non_null (local.get $res)))) +(@if wasi +(@then + (global $argv (mut (ref null $block)) (ref.null $block)) + + (func $caml_sys_argv (export "caml_sys_argv") + (param (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local $argc i32) (local $argv i32) (local $argv_buf i32) + (local $args (ref $block)) (local $arg i32) (local $i i32) + (block $init + (return (br_on_null $init (global.get $argv)))) + (block $error + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $args_sizes_get + (local.get $buffer) + (i32.add (local.get $buffer) (i32.const 4)))) + (br_if $error (local.get $res)) + (local.set $argc (i32.load (local.get $buffer))) + (local.set $argv + (call $checked_malloc (i32.shl (local.get $argc) (i32.const 2)))) + (local.set $argv_buf + (call $checked_malloc (i32.load offset=4 (local.get $buffer)))) + (local.set $res + (call $args_get (local.get $argv) (local.get $argv_buf))) + (br_if $error (local.get $res)) + (local.set $args + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $argc) (i32.const 1)))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $argc)) + (then + (local.set $arg + (i32.load + (i32.add (local.get $argv) + (i32.shl (local.get $i) (i32.const 2))))) + (array.set $block (local.get $args) + (i32.add (local.get $i) (i32.const 1)) + (call $blit_memory_to_string + (local.get $arg) (call $strlen (local.get $arg)))) + (local.set $i + (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (global.set $argv (local.get $args)) + (call $free (local.get $argv)) + (call $free (local.get $argv_buf)) + (return (local.get $args))) + (call $caml_handle_sys_error (ref.i31 (i32.const 0)) (local.get $res)) + (array.new_fixed $block 0)) + + (func (export "caml_sys_executable_name") + (param (ref eq)) (result (ref eq)) + (array.get $block + (ref.cast (ref $block) (call $caml_sys_argv (ref.i31 (i32.const 0)))) + (i32.const 1))) +) +(@else (func (export "caml_sys_argv") (param (ref eq)) (result (ref eq)) ;; ZZZ (call $caml_js_to_string_array (call $argv))) @@ -95,18 +279,51 @@ (array.get $block (ref.cast (ref $block) (call $caml_js_to_string_array (call $argv))) (i32.const 1))) +)) (func (export "caml_sys_proc_self_exe") (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0))) +(@if wasi +(@then + (func (export "caml_sys_time") (export "caml_sys_time_include_children") + (param (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $clock_time_get (i32.const 2) (i64.const 1) (local.get $buffer))) + ;; wasmtime does not support the CPU-time clock, so use the + ;; monotonic clock instead as a fallback + (if (i32.eq (local.get $res) (i32.const 8)) + (then + (local.set $res + (call $clock_time_get + (i32.const 1) (i64.const 1) (local.get $buffer))))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (struct.new $float + (f64.mul (f64.convert_i64_u (i64.load (local.get $buffer))) + (f64.const 1e-9)))) +) +(@else (func (export "caml_sys_time") (export "caml_sys_time_include_children") (param (ref eq)) (result (ref eq)) (struct.new $float (f64.mul (call $time) (f64.const 0.001)))) +)) +(@if wasi +(@then + (func (export "caml_sys_system_command") + (param (ref eq)) (result (ref eq)) + (call $caml_invalid_argument (@string "Sys.command not implemented")) + (return (ref.i31 (i32.const 0)))) +) +(@else (func (export "caml_sys_system_command") (param (ref eq)) (result (ref eq)) - ;; ZZZ (try (do (return @@ -115,7 +332,40 @@ (catch $javascript_exception (call $caml_handle_sys_error (pop externref)))) (return (ref.i31 (i32.const 0)))) +)) +(@if wasi +(@then + (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 $buffer i32) (local $res i32) + (local.set $n (i32.const 12)) + (local.set $buffer (call $get_buffer)) + (local.set $res (call $random_get (local.get $buffer) (i32.const 96))) + (if (local.get $res) + (then + (call $caml_handle_sys_error + (ref.i31 (i32.const 0)) (local.get $res)))) + (local.set $a + (array.new $block (ref.i31 (i32.const 0)) + (i32.add (local.get $n) (i32.const 1)))) + (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 + (i32.load + (i32.add (local.get $buffer) + (i32.shl (local.get $i) (i32.const 2)))))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $a)) +) +(@else (func (export "caml_sys_random_seed") (param (ref eq)) (result (ref eq)) (local $r (ref extern)) @@ -135,6 +385,7 @@ (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)) @@ -152,6 +403,12 @@ (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 0xfffffff))) +(@if wasi +(@then + (global $on_windows i32 (i32.const 0)) + (global $on_arm64 i32 (i32.const 0)) +)) + (func (export "caml_sys_const_ostype_unix") (param (ref eq)) (result (ref eq)) (ref.i31 (i32.eqz (global.get $on_windows)))) @@ -197,9 +454,17 @@ (ref.i31 (i32.const 32)) (ref.i31 (i32.const 0)))) +(@if wasi +(@then + (func (export "caml_sys_isatty") + (param $ch (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) +(@else (func (export "caml_sys_isatty") (param $ch (ref eq)) (result (ref eq)) (return_call $isatty (call $caml_channel_descriptor (local.get $ch)))) +)) (func (export "caml_sys_const_runtime5") (param (ref eq)) (result (ref eq)) @@ -241,6 +506,28 @@ (@string $toString "toString") +(@if wasi +(@then + (func $caml_handle_sys_error (export "caml_handle_sys_error") + (param $arg (ref eq)) (param $errno i32) + (local $msg (ref eq)) + (local.set $msg + (if (result (ref eq)) (i32.gt_u (local.get $errno) + (array.len (global.get $error_messages))) + (then + (@string "unknown system error")) + (else + (array.get $block (global.get $error_messages) + (local.get $errno))))) + (if (ref.test (ref $bytes) (local.get $arg)) + (then + (local.set $msg + (call $caml_string_concat (local.get $arg) + (call $caml_string_concat (@string ": ") (local.get $msg)))))) + (call $caml_raise_sys_error (local.get $msg)) + ) +) +(@else (func $caml_handle_sys_error (export "caml_handle_sys_error") (param $exn externref) (call $caml_raise_sys_error @@ -249,4 +536,5 @@ (call $wrap (any.convert_extern (local.get $exn))) (global.get $toString) (array.new_fixed $block 1 (ref.i31 (i32.const 0))))))) +)) ) diff --git a/runtime/wasm/toplevel.wat b/runtime/wasm/toplevel.wat index c1bf66c6b1..2e97cb4344 100644 --- a/runtime/wasm/toplevel.wat +++ b/runtime/wasm/toplevel.wat @@ -16,6 +16,8 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if (not wasi) +(@then (import "stdlib" "caml_global_data" (global $caml_global_data (mut (ref $block)))) (import "stdlib" "link_info" @@ -284,5 +286,5 @@ (call $caml_failwith (@string "caml_invoke_traced_function: not available in Wasm")) (unreachable)) - +)) ) diff --git a/runtime/wasm/unix.wat b/runtime/wasm/unix.wat index 61b313ba22..71ed24a778 100644 --- a/runtime/wasm/unix.wat +++ b/runtime/wasm/unix.wat @@ -16,6 +16,73 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module +(@if wasi +(@then + (import "wasi_snapshot_preview1" "clock_time_get" + (func $clock_time_get (param i32 i64 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_filestat_get" + (func $path_filestat_get (param i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_rename" + (func $path_rename (param i32 i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_link" + (func $path_link (param i32 i32 i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_symlink" + (func $path_symlink (param i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_readlink" + (func $path_readlink (param i32 i32 i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_create_directory" + (func $path_create_directory (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_unlink_file" + (func $path_unlink_file (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_remove_directory" + (func $path_remove_directory (param i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_open" + (func $path_open (param i32 i32 i32 i32 i32 i64 i64 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "path_filestat_set_times" + (func $path_filestat_set_times + (param i32 i32 i32 i32 i64 i64 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_filestat_get" + (func $fd_filestat_get (param i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_filestat_set_size" + (func $fd_filestat_set_size (param i32 i64) (result i32))) + (import "wasi_snapshot_preview1" "fd_write" + (func $fd_write (param i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_read" + (func $fd_read (param i32 i32 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_seek" + (func $fd_seek (param i32 i64 i32 i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_sync" + (func $fd_sync (param i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_close" + (func $fd_close (param i32) (result i32))) + (import "wasi_snapshot_preview1" "fd_readdir" + (func $fd_readddir (param i32 i32 i32 i64 i32) (result i32))) + (import "libc" "memory" (memory 2)) + (import "libc" "free" (func $free (param i32))) + (import "libc" "gmtime" (func $gmtime (param i32) (result i32))) + (import "libc" "localtime" (func $localtime (param i32) (result i32))) + (import "libc" "mktime" (func $mktime (param i32) (result i64))) + (import "wasi_memory" "checked_malloc" + (func $checked_malloc (param i32) (result i32))) + (import "wasi_memory" "get_buffer" (func $get_buffer (result i32))) + (import "wasi_memory" "write_string_to_memory" + (func $write_string_to_memory (param i32 i32 (ref eq)) (result i32))) + (import "wasi_memory" "blit_memory_to_string" + (func $blit_memory_to_string (param i32 i32) (result (ref $bytes)))) + (import "wasi_memory" "blit_memory_to_substring" + (func $blit_memory_to_substring (param i32 (ref $bytes) i32 i32))) + (import "wasi_memory" "blit_substring_to_memory" + (func $blit_substring_to_memory (param i32 (ref $bytes) i32 i32))) + (import "fs" "wasi_resolve_path" + (func $wasi_resolve_path (param (ref eq)) (result i32 i32 i32))) + (import "fs" "wasi_chdir" (func $wasi_chdir (param (ref eq)))) + (import "wasi_errors" "error_messages" (global $error_messages (ref $block))) + (import "ints" "caml_format_int" + (func $caml_format_int (param (ref eq) (ref eq)) (result (ref eq)))) + (import "string" "caml_string_concat" + (func $caml_string_concat (param (ref eq) (ref eq)) (result (ref eq)))) +) +(@else (import "bindings" "gettimeofday" (func $gettimeofday (result f64))) (import "bindings" "times" (func $times (result (ref eq)))) (import "bindings" "gmtime" (func $gmtime (param f64) (result (ref eq)))) @@ -80,6 +147,7 @@ (func $caml_jsstring_of_string (param (ref eq)) (result (ref eq)))) (import "jsstring" "jsstring_test" (func $jsstring_test (param anyref) (result i32))) +)) (import "stdlib" "caml_named_value" (func $caml_named_value (param (ref eq)) (result (ref null eq)))) (import "fail" "ocaml_exception" (tag $ocaml_exception (param (ref eq)))) @@ -149,6 +217,102 @@ (@string $no_arg "") +(@if wasi +(@then + (func $unix_resolve_path (export "unix_resolve_path") + (param $cmd (ref eq)) (param $path (ref eq)) (result i32 i32 i32) + (local $res (tuple i32 i32 i32)) + (local.set $res (call $wasi_resolve_path (local.get $path))) + (if (i32.lt_s (tuple.extract 3 0 (local.get $res)) (i32.const 0)) + (then + (call $caml_unix_error + (i32.const 44) ;; ENOENT + (local.get $cmd) (local.get $path)))) + (local.get $res)) + + (type $constr_table (array i8)) + (global $error_codes (ref $constr_table) + (array.new_fixed $constr_table 77 + (i32.const -1) + (i32.const 0) (i32.const 1) (i32.const 50) (i32.const 51) + (i32.const 49) (i32.const 2) (i32.const 39) (i32.const 3) + (i32.const -1) (i32.const 4) (i32.const -1) (i32.const 5) + (i32.const 55) (i32.const 63) (i32.const 56) (i32.const 6) + (i32.const 41) (i32.const 7) (i32.const -1) (i32.const 8) + (i32.const 9) (i32.const 10) (i32.const 65) (i32.const -1) + (i32.const -1) (i32.const 38) (i32.const 11) (i32.const 12) + (i32.const 13) (i32.const 58) (i32.const 14) (i32.const 66) + (i32.const 15) (i32.const 16) (i32.const 42) (i32.const -1) + (i32.const 17) (i32.const 52) (i32.const 54) (i32.const 53) + (i32.const 18) (i32.const 57) (i32.const 19) (i32.const 20) + (i32.const 21) (i32.const 22) (i32.const -1) (i32.const 23) + (i32.const -1) (i32.const 44) (i32.const 24) (i32.const 25) + (i32.const 59) (i32.const 26) (i32.const 27) (i32.const -1) + (i32.const 40) (i32.const 47) (i32.const 28) (i32.const 29) + (i32.const 67) (i32.const -1) (i32.const 30) (i32.const 31) + (i32.const -1) (i32.const 45) (i32.const 43) (i32.const 32) + (i32.const 33) (i32.const 34) (i32.const 35) (i32.const -1) + (i32.const 62) (i32.const -1) (i32.const 36) (i32.const -1))) + + (func $caml_unix_error_of_code (param $errcode i32) (result (ref eq)) + (local $err i32) + (if (i32.le_u (local.get $errcode) (i32.const 76)) + (then + (local.set $err + (array.get_s $constr_table (global.get $error_codes) + (local.get $errcode))) + (if (i32.ne (local.get $err) (i32.const -1)) + (then + (return (ref.i31 (local.get $err))))))) + (array.new_fixed $block 2 + (ref.i31 (i32.const 0)) (ref.i31 (local.get $errcode)))) + + (func $caml_unix_error + (param $errcode i32) (param $cmd_name (ref eq)) (param $cmd_arg (ref eq)) + (throw $ocaml_exception + (array.new_fixed $block 5 + (ref.i31 (i32.const 0)) + (call $get_unix_error_exn) + (call $caml_unix_error_of_code (local.get $errcode)) + (local.get $cmd_name) + (local.get $cmd_arg)))) + + (func (export "unix_error_message") (export "caml_unix_error_message") + (param $err (ref eq)) (result (ref eq)) + (local $errcode i32) (local $i i32) (local $n i32) + (if (ref.test (ref i31) (local.get $err)) + (then + (local.set $n (i31.get_u (ref.cast (ref i31) (local.get $err)))) + (loop $loop + (if (i32.lt_u (local.get $errcode) + (array.len (global.get $error_codes))) + (then + (if (i32.ne (local.get $n) + (array.get $constr_table (global.get $error_codes) + (local.get $errcode))) + (then + (local.set $errcode + (i32.add (local.get $errcode) (i32.const 1))) + (br $loop)))) + (else + (local.set $errcode (i32.const -1)))))) + (else + (local.set $errcode + (i31.get_u + (ref.cast (ref i31) + (array.get $block + (ref.cast (ref $block) (local.get $err)) + (i32.const 1))))))) + (if (i32.gt_u (local.get $errcode) + (array.len (global.get $error_messages))) + (then + (return_call $caml_string_concat + (@string "Unknown error ") + (call $caml_format_int (@string "%d") + (ref.i31 (local.get $errcode)))))) + (array.get $block (global.get $error_messages) (local.get $errcode))) +) +(@else (global $unix_error (ref eq) (struct.new $js (global.get $unix_error_js))) (func $ensure_string (param $s (ref eq)) (result (ref eq)) @@ -228,11 +392,59 @@ (i32.const 1)))))))) (return_call $caml_string_of_jsstring (call $wrap (call $caml_strerror (local.get $errno))))) +)) +(@if wasi +(@then + (func (export "unix_gettimeofday") (export "caml_unix_gettimeofday") + (param (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $clock_time_get + (i32.const 0) (i64.const 1000) (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "gettimeofday") (global.get $no_arg)))) + (struct.new $float + (f64.mul (f64.convert_i64_u (i64.load (local.get $buffer))) + (f64.const 1e-9)))) +) +(@else (func (export "unix_gettimeofday") (export "caml_unix_gettimeofday") (param (ref eq)) (result (ref eq)) (struct.new $float (call $gettimeofday))) +)) +(@if wasi +(@then + (func (export "unix_times") (export "caml_unix_times") + (param (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $clock_time_get + (i32.const 2) (i64.const 1) (local.get $buffer))) + ;; wasmtime does not support the CPU-time clock, so use the + ;; monotonic clock instead as a fallback + (if (i32.eq (local.get $res) (i32.const 8)) + (then + (local.set $res + (call $clock_time_get + (i32.const 1) (i64.const 1) (local.get $buffer))))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) + (@string "time") + (global.get $no_arg)))) + (array.new_fixed $float_array 4 + (f64.mul (f64.convert_i64_u (i64.load (local.get $buffer))) + (f64.const 1e-9)) + (f64.const 0) (f64.const 0) (f64.const 0))) +) +(@else (func (export "caml_alloc_times") (param $u f64) (param $s f64) (result (ref eq)) (array.new_fixed $float_array 4 @@ -241,7 +453,24 @@ (func (export "unix_times") (export "caml_unix_times") (param (ref eq)) (result (ref eq)) (return_call $times)) +)) +(@if wasi +(@then + (func $alloc_tm (param $tm i32) (result (ref eq)) + (array.new_fixed $block 10 (ref.i31 (i32.const 0)) + (ref.i31 (i32.load (local.get $tm))) + (ref.i31 (i32.load offset=4 (local.get $tm))) + (ref.i31 (i32.load offset=8 (local.get $tm))) + (ref.i31 (i32.load offset=12 (local.get $tm))) + (ref.i31 (i32.load offset=16 (local.get $tm))) + (ref.i31 (i32.load offset=20 (local.get $tm))) + (ref.i31 (i32.load offset=24 (local.get $tm))) + (ref.i31 (i32.load offset=28 (local.get $tm))) + (ref.i31 (select (i32.const 1) (i32.const 0) + (i32.load offset=32 (local.get $tm)))))) +) +(@else (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) @@ -256,21 +485,131 @@ (ref.i31 (local.get $wday)) (ref.i31 (local.get $yday)) (ref.i31 (local.get $isdst)))) +)) +(@if wasi +(@then + (func (export "caml_unix_gmtime") (export "unix_gmtime") + (param $t (ref eq)) (result (ref eq)) + (local $buffer i32) (local $tm i32) + (local.set $buffer (call $get_buffer)) + (i64.store (local.get $buffer) + (i64.trunc_sat_f64_s + (struct.get $float 0 (ref.cast (ref $float) (local.get $t))))) + (local.set $tm (call $gmtime (local.get $buffer))) + (if (i32.eqz (local.get $tm)) + (then + (call $caml_unix_error (i32.const 28) (; EINVAL ;) + (@string "gmtime") (global.get $no_arg)))) + (return_call $alloc_tm (local.get $tm))) +) +(@else (func (export "caml_unix_gmtime") (export "unix_gmtime") (param (ref eq)) (result (ref eq)) (call $gmtime (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) +)) +(@if wasi +(@then + (func (export "caml_unix_localtime") (export "unix_localtime") + (param $t (ref eq)) (result (ref eq)) + (local $buffer i32) (local $tm i32) + (local.set $buffer (call $get_buffer)) + (i64.store (local.get $buffer) + (i64.trunc_sat_f64_s + (struct.get $float 0 (ref.cast (ref $float) (local.get $t))))) + (local.set $tm (call $localtime (local.get $buffer))) + (if (i32.eqz (local.get $tm)) + (then + (call $caml_unix_error (i32.const 28) (; EINVAL ;) + (@string "localtime") (global.get $no_arg)))) + (return_call $alloc_tm (local.get $tm))) +) +(@else (func (export "caml_unix_localtime") (export "unix_localtime") (param (ref eq)) (result (ref eq)) (call $localtime (struct.get $float 0 (ref.cast (ref $float) (local.get 0))))) +)) +(@if wasi +(@then + (func (export "caml_unix_time") (export "unix_time") (param (ref eq)) + (result (ref eq)) + (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $clock_time_get + (i32.const 0) (i64.const 1000) (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "time") (global.get $no_arg)))) + (struct.new $float + (f64.floor + (f64.mul (f64.convert_i64_u (i64.load (local.get $buffer))) + (f64.const 1e-9))))) +) +(@else (func (export "caml_unix_time") (export "unix_time") (param (ref eq)) (result (ref eq)) (struct.new $float (f64.floor (call $gettimeofday)))) +)) +(@if wasi +(@then + (func (export "caml_unix_mktime") (export "unix_mktime") + (param $v (ref eq)) (result (ref eq)) + (local $t (ref $block)) (local $tm i32) (local $time i64) + (local.set $t (ref.cast (ref $block) (local.get $v))) + (local.set $tm (call $get_buffer)) + (i32.store (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 1))))) + (i32.store offset=4 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 2))))) + (i32.store offset=8 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 3))))) + (i32.store offset=12 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 4))))) + (i32.store offset=16 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 5))))) + (i32.store offset=20 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 6))))) + (i32.store offset=24 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 7))))) + (i32.store offset=28 (local.get $tm) + (i31.get_s + (ref.cast (ref i31) + (array.get $block (local.get $t) (i32.const 8))))) + (i32.store offset=32 (local.get $tm) + (i32.const -1)) + (local.set $time (call $mktime (local.get $tm))) + (if (i64.eq (local.get $time) (i64.const -1)) + (then + (call $caml_unix_error + (i32.const 68) (; ERANGE ;) + (@string "mktime") (global.get $no_arg)))) + (array.new_fixed $block 3 + (ref.i31 (i32.const 0)) + (struct.new $float (f64.convert_i64_s (local.get $time))) + (call $alloc_tm (local.get $tm)))) +) +(@else (func (export "caml_unix_mktime") (export "unix_mktime") (param (ref eq)) (result (ref eq)) (local $tm (ref $block)) (local $t f64) @@ -302,7 +641,53 @@ (array.new_fixed $block 3 (ref.i31 (i32.const 0)) (struct.new $float (local.get $t)) (call $localtime (local.get $t)))) +)) + +(@if wasi +(@then + (@string $utimes "utimes") + (func (export "unix_utimes") (export "caml_unix_utimes") + (param $path (ref eq)) (param $atime (ref eq)) (param $mtime (ref eq)) + (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $atim i64) (local $mtim i64) + (local $set_to_now i32) (local $res i32) + (local $at f64) (local $mt f64) + (local.set $p + (call $unix_resolve_path (global.get $utimes) (local.get $path))) + (local.set $at + (struct.get $float 0 (ref.cast (ref $float) (local.get $atime)))) + (local.set $mt + (struct.get $float 0 (ref.cast (ref $float) (local.get $mtime)))) + (local.set $set_to_now + (i32.and (f64.eq (local.get $at) (f64.const 0)) + (f64.eq (local.get $mt) (f64.const 0)))) + (if (i32.eqz (local.get $set_to_now)) + (then + (local.set $atim + (i64.trunc_sat_f64_s + (f64.mul (local.get $at) (f64.const 1e9)))) + (local.set $mtim + (i64.trunc_sat_f64_s + (f64.mul (local.get $mt) (f64.const 1e9)))))) + (local.set $res + (call $path_filestat_set_times + (tuple.extract 3 0 (local.get $p)) + (i32.const 0) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $atim) + (local.get $mtim) + (i32.shl (i32.const 5) (local.get $set_to_now)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $utimes) (local.get $path)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_utimes") (export "caml_unix_utimes") (param $path (ref eq)) (param $atime (ref eq)) (param $mtime (ref eq)) (result (ref eq)) @@ -324,6 +709,48 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (global $file_kinds (ref $constr_table) + (array.new_fixed $constr_table 8 + (i32.const 3) + (i32.const 3) + (i32.const 2) + (i32.const 1) + (i32.const 0) + (i32.const 6) + (i32.const 6) + (i32.const 4))) + + (func $alloc_stat (param $large i32) (param $p i32) (result (ref eq)) + (array.new_fixed $block 13 (ref.i31 (i32.const 0)) + (ref.i31 (i32.wrap_i64 (i64.load (local.get $p)))) + (ref.i31 (i32.wrap_i64 (i64.load offset=8 (local.get $p)))) + (ref.i31 + (array.get $constr_table + (global.get $file_kinds) (i32.load8_u offset=16 (local.get $p)))) + (ref.i31 (i32.const 384 (;0600;))) + (ref.i31 (i32.wrap_i64 (i64.load offset=24 (local.get $p)))) + (ref.i31 (i32.const 1)) + (ref.i31 (i32.const 1)) + (ref.i31 (i32.wrap_i64 (i64.load (local.get $p)))) + (if (result (ref eq)) (local.get $large) + (then + (call $caml_copy_int64 (i64.load offset=32 (local.get $p)))) + (else + (ref.i31 (i32.wrap_i64 (i64.load offset=32 (local.get $p)))))) + (struct.new $float + (f64.mul (f64.const 1e-9) + (f64.convert_i64_s (i64.load offset=40 (local.get $p))))) + (struct.new $float + (f64.mul (f64.const 1e-9) + (f64.convert_i64_s (i64.load offset=48 (local.get $p))))) + (struct.new $float + (f64.mul (f64.const 1e-9) + (f64.convert_i64_s (i64.load offset=56 (local.get $p))))))) +)) (func (export "caml_alloc_stat") (param $large i32) @@ -349,6 +776,76 @@ (struct.new $float (local.get $mtime)) (struct.new $float (local.get $ctime)))) +(@if wasi +(@then + (func $stat + (param $path (ref eq)) (param $large i32) (param $follow i32) + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $res i32) + (local.set $p + (call $unix_resolve_path (local.get $name) (local.get $path))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (local.get $follow) ;; symlink_follow + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (local.get $name) (local.get $path)))) + (return_call $alloc_stat (local.get $large) (local.get $buffer))) + + (@string $stat "stat") + + (func (export "unix_stat") (export "caml_unix_stat") + (param $path (ref eq)) (result (ref eq)) + (return_call $stat + (local.get $path) (i32.const 0) (i32.const 1) (global.get $stat))) + + (func (export "unix_stat_64") (export "caml_unix_stat_64") + (param $path (ref eq)) (result (ref eq)) + (return_call $stat + (local.get $path) (i32.const 1) (i32.const 1) (global.get $stat))) + + (@string $lstat "lstat") + + (func (export "unix_lstat") (export "caml_unix_lstat") + (param $path (ref eq)) (result (ref eq)) + (return_call $stat + (local.get $path) (i32.const 0) (i32.const 0) (global.get $lstat))) + + (func (export "unix_lstat_64") (export "caml_unix_lstat_64") + (param $path (ref eq)) (result (ref eq)) + (return_call $stat + (local.get $path) (i32.const 1) (i32.const 0) (global.get $lstat))) + + (func $fstat (param $fd (ref eq)) (param $large i32) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_filestat_get + (i31.get_u (ref.cast (ref i31) (local.get $fd))) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "fstat") (global.get $no_arg)))) + (return_call $alloc_stat (local.get $large) (local.get $buffer))) + + (func (export "unix_fstat") (export "caml_unix_fstat") + (param $fd (ref eq)) (result (ref eq)) + (return_call $fstat (local.get $fd) (i32.const 0))) + + (func (export "unix_fstat_64") (export "caml_unix_fstat_64") + (param $fd (ref eq)) (result (ref eq)) + (return_call $fstat (local.get $fd) (i32.const 1))) +) +(@else (func (export "unix_stat") (export "caml_unix_stat") (param $path (ref eq)) (result (ref eq)) (try (result (ref eq)) @@ -410,7 +907,16 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)) (ref.i31 (i32.const 0))))) +)) +(@if wasi +(@then + (func (export "unix_chmod") (export "caml_unix_chmod") + (param (ref eq) (ref eq)) (result (ref eq)) + ;; no notion of permissions in WASI + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_chmod") (export "caml_unix_chmod") (param $path (ref eq)) (param $perms (ref eq)) (result (ref eq)) (try @@ -421,7 +927,16 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "unix_fchmod") (export "caml_unix_fchmod") + (param (ref eq) (ref eq)) (result (ref eq)) + ;; no notion of permissions in WASI + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_fchmod") (export "caml_unix_fchmod") (param $fd (ref eq)) (param $perms (ref eq)) (result (ref eq)) (try @@ -430,7 +945,38 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $rename "rename") + (func (export "unix_rename") (export "caml_unix_rename") + (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) + (local $op (tuple i32 i32 i32)) + (local $np (tuple i32 i32 i32)) + (local $res i32) + (local.set $op + (call $unix_resolve_path (global.get $rename) (local.get $o))) + (local.set $np + (call $unix_resolve_path (global.get $rename) (local.get $n))) + (local.set $res + (call $path_rename + (tuple.extract 3 0 (local.get $op)) + (tuple.extract 3 1 (local.get $op)) + (tuple.extract 3 2 (local.get $op)) + (tuple.extract 3 0 (local.get $np)) + (tuple.extract 3 1 (local.get $np)) + (tuple.extract 3 2 (local.get $np)))) + (call $free (tuple.extract 3 1 (local.get $op))) + (call $free (tuple.extract 3 1 (local.get $np))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $rename) (local.get $o)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_rename") (export "caml_unix_rename") (param $o (ref eq)) (param $n (ref eq)) (result (ref eq)) (try @@ -441,7 +987,40 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $chdir "chdir") + (func (export "unix_chdir") (export "caml_unix_chdir") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $res i32) (local $kind i32) + (local.set $p + (call $unix_resolve_path (global.get $chdir) (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $chdir) (local.get $name)))) + (local.set $kind (i32.load8_u offset=16 (local.get $buffer))) + (if (i32.ne (local.get $kind) (i32.const 3)) + (then + (call $caml_unix_error (i32.const 54) ;; ENOTDIR + (global.get $chdir) (local.get $name)))) + (call $wasi_chdir (local.get $name)) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_getcwd") (export "caml_unix_getcwd") (param (ref eq)) (result (ref eq)) (try (result (ref eq)) @@ -460,7 +1039,31 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $mkdir "mkdir") + (func (export "unix_mkdir") (export "caml_unix_mkdir") + (param $path (ref eq)) (param $perm (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p + (call $unix_resolve_path (global.get $mkdir) (local.get $path))) + (local.set $res + (call $path_create_directory + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $mkdir) (local.get $path)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_mkdir") (export "caml_unix_mkdir") (param $name (ref eq)) (param $perm (ref eq)) (result (ref eq)) (try @@ -471,7 +1074,147 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (type $directory + (struct + (field $fd i32) + (field $buffer (mut i32)) + (field $size (mut i32)) + (field $pos (mut i32)) + (field $available (mut i32)) + (field $cookie (mut i64)))) + + (@string $opendir "opendir") + (func $unix_opendir (export "unix_opendir") (export "caml_unix_opendir") + (param $name (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $res i32) + (local.set $p + (call $unix_resolve_path (global.get $opendir) (local.get $name))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_open + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) ;; symlink_follow + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (i32.const 2) ;; O_DIRECTORY + (i64.const 0x4000) ;; allow fd_readdir + (i64.const 0) + (i32.const 0) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $opendir) (local.get $name)))) + (struct.new $directory + (i32.load (local.get $buffer)) + (call $checked_malloc (i32.const 512)) + (i32.const 512) + (i32.const 0) + (i32.const 0) + (i64.const 0))) + + (func $readdir_helper + (param $vdir (ref eq)) (result (ref eq)) + (local $dir (ref $directory)) (local $buf i32) (local $res i32) + (local $buffer i32) (local $available i32) (local $left i32) + (local $namelen i32) (local $entry i32) (local $entry_size i32) + (local.set $dir (ref.cast (ref $directory) (local.get $vdir))) + (loop $loop + (block $refill + (local.set $left + (i32.sub (struct.get $directory $available (local.get $dir)) + (struct.get $directory $pos (local.get $dir)))) + (br_if $refill (i32.lt_u (local.get $left) (i32.const 24))) + (local.set $entry + (i32.add (struct.get $directory $buffer (local.get $dir)) + (struct.get $directory $pos (local.get $dir)))) + (local.set $namelen (i32.load offset=16 (local.get $entry))) + (local.set $entry_size (i32.add (local.get $namelen) (i32.const 24))) + (br_if $refill (i32.lt_u (local.get $left) (local.get $entry_size))) + (struct.set $directory $pos (local.get $dir) + (i32.add (struct.get $directory $pos (local.get $dir)) + (local.get $entry_size))) + (struct.set $directory $cookie (local.get $dir) + (i64.load (local.get $entry))) + (return_call $blit_memory_to_string + (i32.add (local.get $entry) (i32.const 24)) + (local.get $namelen))) + ;; refill + (if (i32.lt_u (struct.get $directory $size (local.get $dir)) + (local.get $entry_size)) + (then + ;; the entry does not fit + (local.set $buf (call $checked_malloc (local.get $entry_size))) + (call $free (struct.get $directory $buffer (local.get $dir))) + (struct.set $directory $buffer (local.get $dir) (local.get $buf)) + (struct.set $directory $size (local.get $dir) + (local.get $entry_size)))) + (block $done + (br_if $done + (i32.and + (i32.ne (i32.const 0) + (struct.get $directory $available (local.get $dir)) + (i32.lt_u (struct.get $directory $available (local.get $dir)) + (struct.get $directory $size (local.get $dir)))))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_readddir + (struct.get $directory $fd (local.get $dir)) + (struct.get $directory $buffer (local.get $dir)) + (struct.get $directory $size (local.get $dir)) + (struct.get $directory $cookie (local.get $dir)) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "readdir") (global.get $no_arg)))) + (local.set $available (i32.load (local.get $buffer))) + (br_if $done (i32.eqz (local.get $available))) + (struct.set $directory $pos (local.get $dir) (i32.const 0)) + (struct.set $directory $available (local.get $dir) + (local.get $available)) + (br $loop))) + ;; done + (call $caml_raise_end_of_file) + (ref.i31 (i32.const 0))) + + (func $unix_closedir (export "unix_closedir") (export "caml_unix_closedir") + (param $vdir (ref eq)) (result (ref eq)) + (local $dir (ref $directory)) (local $buf i32) (local $res i32) + (local.set $dir (ref.cast (ref $directory) (local.get $vdir))) + (local.set $buf (struct.get $directory $buffer (local.get $dir))) + (block $error + (if (i32.eqz (local.get $buf)) + (then + (local.set $res (i32.const 8)) ;; EBADF + (br $error))) + (call $free (local.get $buf)) + (struct.set $directory $buffer (local.get $dir) (i32.const 0)) + (local.set $res + (call $fd_close (struct.get $directory $fd (local.get $dir)))) + (br_if $error (local.get $res)) + (return (ref.i31 (i32.const 0)))) + (call $caml_unix_error + (local.get $res) (@string "closedir") (global.get $no_arg)) + (ref.i31 (i32.const 0))) + + (func (export "unix_rewinddir") (export "caml_unix_rewinddir") + (param $vdir (ref eq)) (result (ref eq)) + (local $dir (ref $directory)) + (local.set $dir (ref.cast (ref $directory) (local.get $vdir))) + (struct.set $directory $cookie (local.get $dir) (i64.const 0)) + (struct.set $directory $pos (local.get $dir) (i32.const 0)) + (struct.set $directory $available (local.get $dir) (i32.const 0)) + (ref.i31 (i32.const 0))) +) +(@else (func $unix_opendir (export "unix_opendir") (export "caml_unix_opendir") (param $name (ref eq)) (result (ref eq)) (try (result (ref eq)) @@ -524,6 +1267,7 @@ (param (ref eq)) (result (ref eq)) (call $caml_invalid_argument (@string "rewinddir not implemented")) (ref.i31 (i32.const 0))) +)) (func (export "unix_readdir") (export "caml_unix_readdir") (param $dir (ref eq)) (result (ref eq)) @@ -556,6 +1300,29 @@ (call $win_find_next (local.get $dir)) (local.get $dir))) +(@if wasi +(@then + (@string $unlink "unlink") + + (func (export "unix_unlink") (export "caml_unix_unlink") + (param $path (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p + (call $unix_resolve_path (global.get $unlink) (local.get $path))) + (local.set $res + (call $path_unlink_file + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $unlink) (local.get $path)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_unlink") (export "caml_unix_unlink") (param $p (ref eq)) (result (ref eq)) (try @@ -565,7 +1332,31 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $rmdir "rmdir") + (func (export "unix_rmdir") (export "caml_unix_rmdir") + (param $path (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) + (local.set $p + (call $unix_resolve_path (global.get $rmdir) (local.get $path))) + (local.set $res + (call $path_remove_directory + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $rmdir) (local.get $path)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_rmdir") (export "caml_unix_rmdir") (param $p (ref eq)) (result (ref eq)) (try @@ -575,7 +1366,47 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $link "link") + (func (export "unix_link") (export "caml_unix_link") + (param $follow (ref eq)) (param $o (ref eq)) (param $n (ref eq)) + (result (ref eq)) + (local $op (tuple i32 i32 i32)) + (local $np (tuple i32 i32 i32)) + (local $flags i32) + (local $res i32) + (local.set $op (call $unix_resolve_path (global.get $link) (local.get $o))) + (local.set $np (call $unix_resolve_path (global.get $link) (local.get $n))) + (if (ref.test (ref $block) (local.get $follow)) + (then + (local.set $flags + (i31.get_u + (ref.cast (ref i31) + (array.get $block + (ref.cast (ref $block) (local.get $follow)) + (i32.const 1))))))) + (local.set $res + (call $path_link + (tuple.extract 3 0 (local.get $op)) + (local.get $flags) + (tuple.extract 3 1 (local.get $op)) + (tuple.extract 3 2 (local.get $op)) + (tuple.extract 3 0 (local.get $np)) + (tuple.extract 3 1 (local.get $np)) + (tuple.extract 3 2 (local.get $np)))) + (call $free (tuple.extract 3 1 (local.get $op))) + (call $free (tuple.extract 3 1 (local.get $np))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $link) (local.get $o)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_link") (export "caml_unix_link") (param $follow (ref eq)) (param $d (ref eq)) (param $s (ref eq)) (result (ref eq)) @@ -596,11 +1427,48 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) (func (export "unix_has_symlink") (export "caml_unix_has_symlink") (param (ref eq)) (result (ref eq)) (ref.i31 (i32.const 1))) +(@if wasi +(@then + (@string $symlink "symlink") + + (func (export "unix_symlink") (export "caml_unix_symlink") + (param $to_dir (ref eq)) (param $o (ref eq)) (param $n (ref eq)) + (result (ref eq)) + (local $path (ref $bytes)) + (local $len i32) + (local $op i32) + (local $np (tuple i32 i32 i32)) + (local $flags i32) + (local $res i32) + (local.set $path (ref.cast (ref $bytes) (local.get $o))) + (local.set $len (array.len (local.get $path))) + (local.set $op + (call $write_string_to_memory + (i32.const 0) (i32.const 0) (local.get $path))) + (local.set $np + (call $unix_resolve_path (global.get $symlink) (local.get $n))) + (local.set $res + (call $path_symlink + (local.get $op) + (local.get $len) + (tuple.extract 3 0 (local.get $np)) + (tuple.extract 3 1 (local.get $np)) + (tuple.extract 3 2 (local.get $np)))) + (call $free (local.get $op)) + (call $free (tuple.extract 3 1 (local.get $np))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $symlink) (local.get $o)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_symlink") (export "caml_unix_symlink") (param $to_dir (ref eq)) (param $t (ref eq)) (param $p (ref eq)) (result (ref eq)) @@ -623,7 +1491,37 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (@string $readlink "readlink") + + (func (export "unix_readlink") (export "caml_unix_readlink") + (param $path (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $buffer i32) (local $buf i32) (local $res i32) + (local.set $p + (call $unix_resolve_path (global.get $readlink) (local.get $path))) + (local.set $buffer (call $get_buffer)) + (local.set $buf (i32.add (local.get $buffer) (i32.const 4))) + (local.set $res + (call $path_readlink + (tuple.extract 3 0 (local.get $p)) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buf) + (global.get $IO_BUFFER_SIZE) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $readlink) (local.get $path)))) + (return_call $blit_memory_to_string + (local.get $buf) (i32.load (local.get $buffer)))) +) +(@else (func (export "unix_readlink") (export "caml_unix_readlink") (param $path (ref eq)) (result (ref eq)) (try @@ -636,7 +1534,60 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $truncate "truncate") + + (func $truncate (param $path (ref eq)) (param $len i64) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $fd i32) (local $res i32) (local $buffer i32) + (block $error + (local.set $p + (call $unix_resolve_path (global.get $truncate) (local.get $path))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_open + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) ;; symlink_follow + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (i32.const 0) + (i64.const 0x400040) ;; allow fd_filestat_set_size and fd_write + (i64.const 0) + (i32.const 0) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (br_if $error (local.get $res)) + (local.set $fd (i32.load (local.get $buffer))) + (local.set $res + (call $fd_filestat_set_size (local.get $fd) (local.get $len))) + (if (local.get $res) + (then + (drop (call $fd_close (local.get $fd))) + (br $error))) + (local.set $res (call $fd_close (local.get $fd))) + (br_if $error (local.get $res)) + (return (ref.i31 (i32.const 0)))) + (call $caml_unix_error + (local.get $res) (global.get $truncate) (local.get $path)) + (return (ref.i31 (i32.const 0)))) + (func (export "unix_truncate") (export "caml_unix_truncate") + (param $path (ref eq)) (param $len (ref eq)) + (result (ref eq)) + (return_call $truncate (local.get $path) + (i64.extend_i32_s + (i31.get_s (ref.cast (ref i31) (local.get $len)))))) + + (func (export "unix_truncate_64") (export "caml_unix_truncate_64") + (param $path (ref eq)) (param $len (ref eq)) + (result (ref eq)) + (return_call $truncate (local.get $path) + (call $Int64_val (local.get $len)))) +) +(@else (func (export "unix_truncate") (export "caml_unix_truncate") (param $path (ref eq)) (param $len (ref eq)) (result (ref eq)) @@ -662,7 +1613,33 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (func $ftruncate (param $vfd (ref eq)) (param $len i64) (result (ref eq)) + (local $fd i32) (local $res i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $res + (call $fd_filestat_set_size (local.get $fd) (local.get $len))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "ftruncate") (global.get $no_arg)))) + (ref.i31 (i32.const 0))) + (func (export "unix_ftruncate") (export "caml_unix_ftruncate") + (param $fd (ref eq)) (param $len (ref eq)) (result (ref eq)) + (return_call $ftruncate (local.get $fd) + (i64.extend_i32_s + (i31.get_s (ref.cast (ref i31) (local.get $len)))))) + + (func (export "unix_ftruncate_64") (export "caml_unix_ftruncate_64") + (param $fd (ref eq)) (param $len (ref eq)) (result (ref eq)) + (return_call $ftruncate (local.get $fd) + (call $Int64_val (local.get $len)))) +) +(@else (func (export "unix_ftruncate") (export "caml_unix_ftruncate") (param $fd (ref eq)) (param $vlen (ref eq)) (result (ref eq)) @@ -677,7 +1654,7 @@ (i64.extend_i32_s (i31.get_s (ref.cast (ref i31) (local.get $vlen))))) ;; node truncates to 0 without failure when $len < 0 - (if (i64.lt_s (local.get $len (i64.const 0))) + (if (i64.lt_s (local.get $len) (i64.const 0)) (then (local.set $len (i64.const 0)))) (local.set $fd_offset (call $get_fd_offset (i31.get_u (ref.cast (ref i31) (local.get $fd))))) @@ -701,7 +1678,7 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) ;; node truncates to 0 without failure when $len < 0 - (if (i64.lt_s (local.get $len (i64.const 0))) + (if (i64.lt_s (local.get $len) (i64.const 0)) (then (local.set $len (i64.const 0)))) (local.set $fd_offset (call $get_fd_offset (i31.get_u (ref.cast (ref i31) (local.get $fd))))) @@ -711,7 +1688,35 @@ (struct.set $fd_offset $offset (local.get $fd_offset) (local.get $len)))) (ref.i31 (i32.const 0))) +)) + +(@if wasi +(@then + (@string $access "access") + ;; We can only check that the file exists + (func (export "unix_access") (export "caml_unix_access") + (param $path (ref eq)) (param $flags (ref eq)) (result (ref eq)) + (local $p (tuple i32 i32 i32)) + (local $res i32) (local $buffer i32) + (local.set $p + (call $unix_resolve_path (global.get $access) (local.get $path))) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $path_filestat_get + (tuple.extract 3 0 (local.get $p)) + (i32.const 1) + (tuple.extract 3 1 (local.get $p)) + (tuple.extract 3 2 (local.get $p)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $p))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $access) (local.get $path)))) + (return (ref.i31 (i32.const 0)))) +) +(@else (global $access_flags (ref $flags) (array.new_fixed $flags 4 (i32.const 1) (i32.const 2) (i32.const 4) (i32.const 8))) @@ -730,8 +1735,69 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) + + (type $flags (array i16)) + +(@if wasi +(@then + ;; 0x1 O_RDONLY + ;; 0x2 O_WRONLY + ;; 0x3 O_RDWR + ;; 0x400 O_NONBLOCK + ;; 0x100 O_APPEND + ;; 0x10 O_CREAT + ;; 0x80 O_TRUNC + ;; 0x40 O_EXCL + ;; 0 O_NOCTTY + ;; 0x200 O_DSYNC + ;; 0x1000 O_SYNC + ;; 0x800 O_RSYNC + (global $unix_open_flags (ref $flags) + (array.new_fixed $flags 15 + (i32.const 1) (i32.const 2) (i32.const 3) (i32.const 0x400) + (i32.const 0x100) (i32.const 0x10) (i32.const 0x80) (i32.const 0x40) + (i32.const 0) (i32.const 0x200) (i32.const 0x1000) (i32.const 0x800) + (i32.const 0) (i32.const 0) (i32.const 0))) + + (@string $open "open") - (type $flags (array i8)) + (func (export "unix_open") (export "caml_unix_open") + (param $vpath (ref eq)) (param $vflags (ref eq)) (param $perm (ref eq)) + (result (ref eq)) + (local $flags i32) (local $offset i64) + (local $path (tuple i32 i32 i32)) + (local $res i32) (local $buffer i32) + (local.set $path + (call $unix_resolve_path (global.get $open) (local.get $vpath))) + (local.set $buffer (call $get_buffer)) + (local.set $flags + (call $convert_flag_list + (global.get $unix_open_flags) (local.get $vflags))) + (local.set $res + (call $path_open + (tuple.extract 3 0 (local.get $path)) + (i32.const 1) ;; symlink_follow + (tuple.extract 3 1 (local.get $path)) + (tuple.extract 3 2 (local.get $path)) + (i32.and (i32.shr_u (local.get $flags) (i32.const 4)) + (i32.const 0xF)) + (select + (i64.const 0x860007e) + (select (i64.const 0x860007c) (i64.const 0x820003e) + (i32.and (local.get $flags) (i32.const 2))) + (i32.eq (i32.and (local.get $flags) (i32.const 3)) (i32.const 3))) + (i64.const 0) + (i32.shr_u (local.get $flags) (i32.const 8)) + (local.get $buffer))) + (call $free (tuple.extract 3 1 (local.get $path))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (global.get $open) (local.get $vpath)))) + (ref.i31 (i32.load (local.get $buffer)))) +) +(@else ;; 1 O_RDONLY ;; 2 O_WRONLY ;; 4 O_RDWR @@ -771,6 +1837,7 @@ (call $caml_unix_error (pop externref) (ref.null eq)))) (call $initialize_fd_offset (local.get $fd) (local.get $offset)) (ref.i31 (local.get $fd))) +)) (global $io_buffer (mut externref) (ref.null extern)) (global $io_buffer_view (mut externref) (ref.null extern)) @@ -790,6 +1857,217 @@ (br_on_null $null (call $get_fd_offset_unchecked (local.get $fd))))) (struct.new $fd_offset (i64.const 0) (i32.const 0))) +(@if wasi +(@then + (func (export "unix_write") (export "caml_unix_write") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local $iovs i32) (local $iovs_len i32) (local $nwritten i32) + (local $fd i32) (local $s (ref $bytes)) + (local $pos i32) (local $len i32) (local $numbytes i32) + (local $written i32) (local $n i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $s (ref.cast (ref $bytes) (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 $buffer (call $get_buffer)) + (local.set $nwritten (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (local.set $iovs_len (i32.const 1)) + (loop $loop + (if (i32.gt_u (local.get $len) (i32.const 0)) + (then + (local.set $numbytes + (select (global.get $IO_BUFFER_SIZE) (local.get $len) + (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)))) + (call $blit_substring_to_memory + (local.get $buffer) (local.get $s) (local.get $pos) + (local.get $numbytes)) + (i32.store offset=4 (local.get $iovs) (local.get $numbytes)) + (local.set $res + (call $fd_write + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nwritten))) + (if (local.get $res) + (then + (call $caml_unix_error (local.get $res) (@string "write") + (global.get $no_arg)))) + (local.set $n (i32.load (local.get $nwritten))) + (local.set $written (i32.add (local.get $written) (local.get $n))) + (local.set $pos (i32.add (local.get $pos) (local.get $n))) + (local.set $len (i32.sub (local.get $len) (local.get $n))) + (br $loop)))) + (ref.i31 (local.get $n))) + + (func (export "unix_single_write") (export "caml_unix_single_write") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local $iovs i32) (local $iovs_len i32) (local $nwritten i32) + (local $fd i32) (local $s (ref $bytes)) + (local $pos i32) (local $len i32) (local $numbytes i32) + (local $written i32) (local $n i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $s (ref.cast (ref $bytes) (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)))) + (if (i32.eqz (local.get $len)) + (then (return (ref.i31 (i32.const 0))))) + (local.set $buffer (call $get_buffer)) + (local.set $nwritten (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (local.set $iovs_len (i32.const 1)) + (local.set $numbytes + (select (global.get $IO_BUFFER_SIZE) (local.get $len) + (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)))) + (call $blit_substring_to_memory + (local.get $buffer) (local.get $s) (local.get $pos) + (local.get $numbytes)) + (i32.store offset=4 (local.get $iovs) (local.get $numbytes)) + (local.set $res + (call $fd_write + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nwritten))) + (if (local.get $res) + (then + (call $caml_unix_error (local.get $res) (@string "write") + (global.get $no_arg)))) + (ref.i31 (i32.load (local.get $nwritten)))) + + (func (export "unix_read") (export "caml_unix_read") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $buffer i32) (local $res i32) + (local $iovs i32) (local $iovs_len i32) (local $nread i32) + (local $fd i32) (local $pos i32) (local $len i32) (local $n i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (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)))) + (if (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)) + (then + (local.set $len (global.get $IO_BUFFER_SIZE)))) + (local.set $buffer (call $get_buffer)) + (local.set $nread (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (i32.store offset=4 (local.get $iovs) (local.get $len)) + (local.set $iovs_len (i32.const 1)) + (local.set $res + (call $fd_read + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nread))) + (if (local.get $res) + (then + (call $caml_unix_error (local.get $res) (@string "read") + (global.get $no_arg)))) + (local.set $n (i32.load (local.get $nread))) + (call $blit_memory_to_substring (local.get $buffer) + (ref.cast (ref $bytes) (local.get $vbuf)) + (local.get $pos) (local.get $n)) + (ref.i31 (local.get $n))) + + (type $data + (struct + (field $array (ref array)) + (field $offset i32) + (field $len i32))) + + (func (export "unix_write_bigarray") (export "caml_unix_write_bigarray") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (param $vsingle (ref eq)) (result (ref eq)) + (local $fd i32) (local $data (ref $data)) (local $buf (ref $bytes)) + (local $pos i32) (local $len i32) (local $n i32) (local $written i32) + (local $buffer i32) (local $nwritten i32) (local $iovs i32) + (local $iovs_len i32) (local $numbytes i32) (local $res i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $data + (ref.cast (ref $data) + (any.convert_extern (call $caml_ba_get_data (local.get $vbuf))))) + (local.set $buf + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data)))) + (local.set $pos + (i32.add (i31.get_u (ref.cast (ref i31) (local.get $vpos))) + (struct.get $data $offset (local.get $data)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (local.set $buffer (call $get_buffer)) + (local.set $nwritten (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (local.set $iovs_len (i32.const 1)) + (loop $loop + (if (i32.gt_u (local.get $len) (i32.const 0)) + (then + (local.set $numbytes + (select (global.get $IO_BUFFER_SIZE) (local.get $len) + (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)))) + (call $blit_substring_to_memory + (local.get $buffer) (local.get $buf) (local.get $pos) + (local.get $numbytes)) + (i32.store offset=4 (local.get $iovs) (local.get $numbytes)) + (local.set $res + (call $fd_write + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nwritten))) + (if (local.get $res) + (then + (call $caml_unix_error (local.get $res) (@string "write") + (global.get $no_arg)))) + (local.set $n (i32.load (local.get $nwritten))) + (local.set $written (i32.add (local.get $written) (local.get $n))) + (local.set $pos (i32.add (local.get $pos) (local.get $n))) + (local.set $len (i32.sub (local.get $len) (local.get $n))) + (br_if $loop + (ref.eq (local.get $vsingle) (ref.i31 (i32.const 0))))))) + (ref.i31 (local.get $written))) + + (func (export "unix_read_bigarray") (export "caml_unix_read_bigarray") + (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) + (param $vlen (ref eq)) (result (ref eq)) + (local $fd i32) (local $data (ref $data)) (local $buf (ref $bytes)) + (local $pos i32) (local $len i32) (local $n i32) + (local $buffer i32) (local $nread i32) (local $iovs i32) + (local $iovs_len i32) (local $res i32) + (local.set $fd (i31.get_u (ref.cast (ref i31) (local.get $vfd)))) + (local.set $data + (ref.cast (ref $data) + (any.convert_extern (call $caml_ba_get_data (local.get $vbuf))))) + (local.set $buf + (ref.cast (ref $bytes) (struct.get $data $array (local.get $data)))) + (local.set $pos + (i32.add (i31.get_u (ref.cast (ref i31) (local.get $vpos))) + (struct.get $data $offset (local.get $data)))) + (local.set $len (i31.get_u (ref.cast (ref i31) (local.get $vlen)))) + (if (i32.gt_u (local.get $len) (global.get $IO_BUFFER_SIZE)) + (then + (local.set $len (global.get $IO_BUFFER_SIZE)))) + (local.set $buffer (call $get_buffer)) + (local.set $nread (local.get $buffer)) + (local.set $iovs (i32.add (local.get $buffer) (i32.const 4))) + (local.set $buffer (i32.add (local.get $buffer) (i32.const 12))) + (i32.store (local.get $iovs) (local.get $buffer)) + (i32.store offset=4 (local.get $iovs) (local.get $len)) + (local.set $iovs_len (i32.const 1)) + (local.set $res + (call $fd_read + (local.get $fd) (local.get $iovs) (local.get $iovs_len) + (local.get $nread))) + (if (local.get $res) + (then + (call $caml_unix_error (local.get $res) (@string "read") + (global.get $no_arg)))) + (local.set $n (i32.load (local.get $nread))) + (call $blit_memory_to_substring (local.get $buffer) + (local.get $buf) (local.get $pos) (local.get $n)) + (ref.i31 (local.get $n))) +) +(@else (func (export "unix_write") (export "caml_unix_write") (param $vfd (ref eq)) (param $vbuf (ref eq)) (param $vpos (ref eq)) (param $vlen (ref eq)) (result (ref eq)) @@ -1007,7 +2285,28 @@ (struct.set $fd_offset $offset (local.get $fd_offset) (local.get $offset)) (ref.i31 (local.get $n))) +)) +(@if wasi +(@then + (func $lseek + (param $fd (ref eq)) (param $offset i64) (param $cmd (ref eq)) + (result i64) + (local $res i32) (local $buffer i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_seek + (i31.get_u (ref.cast (ref i31) (local.get $fd))) + (local.get $offset) + (i31.get_u (ref.cast (ref i31) (local.get $cmd))) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "lseek") (global.get $no_arg)))) + (i64.load (local.get $buffer))) +) +(@else (func $lseek_exn (param $errno i32) (result (ref eq)) (array.new_fixed $block 5 (ref.i31 (i32.const 0)) @@ -1043,6 +2342,7 @@ (struct.set $fd_offset $offset (local.get $fd_offset) (local.get $offset)) (struct.set $fd_offset $seeked (local.get $fd_offset) (i32.const 1)) (local.get $offset)) +)) (func (export "unix_lseek") (export "caml_unix_lseek") (param $fd (ref eq)) (param $ofs (ref eq)) (param $cmd (ref eq)) @@ -1064,6 +2364,20 @@ (call $Int64_val (local.get $ofs)) (local.get $cmd)))) +(@if wasi +(@then + (func (export "unix_fsync") (export "caml_unix_fsync") + (param $fd (ref eq)) (result (ref eq)) + (local $res i32) + (local.set $res + (call $fd_sync (i31.get_u (ref.cast (ref i31) (local.get $fd))))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "fsync") (global.get $no_arg)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_fsync") (export "caml_unix_fsync") (param $fd (ref eq)) (result (ref eq)) (try @@ -1072,6 +2386,7 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) (@string $out_channel_of_descr "out_channel_of_descr") (@string $in_channel_of_descr "in_channel_of_descr") @@ -1082,6 +2397,32 @@ (global.get $in_channel_of_descr) (local.get $out))) +(@if wasi +(@then + (func $caml_unix_check_stream_semantics (param $fd (ref eq)) (param $out i32) + (local $s (ref $block)) (local $kind i32) + (local $buffer i32) (local $res i32) (local $file_type i32) + (local.set $buffer (call $get_buffer)) + (local.set $res + (call $fd_filestat_get + (i31.get_u (ref.cast (ref i31) (local.get $fd))) + (local.get $buffer))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) + (call $channel_of_descr_name (local.get $out)) + (global.get $no_arg)))) + (local.set $kind (i32.load8_u offset=16 (local.get $buffer))) + (block $ok + (block $bad + (br_table $ok $bad $ok $bad $ok $bad $ok $bad (local.get $kind))) + (call $caml_unix_error + (i32.const 28) (; EINVAL ;) + (call $channel_of_descr_name (local.get $out)) + (global.get $no_arg)))) +) +(@else (func $caml_unix_check_stream_semantics (param $fd (ref eq)) (param $out i32) (local $s (ref $block)) (local $kind i32) (local.set $s @@ -1107,6 +2448,7 @@ (ref.i31 (i32.const 12)) ;; EINVAL (call $channel_of_descr_name (local.get $out)) (global.get $no_arg))))) +)) (func (export "unix_inchannel_of_filedescr") (export "win_inchannel_of_filedescr") @@ -1122,6 +2464,20 @@ (call $caml_unix_check_stream_semantics (local.get $fd) (i32.const 1)) (return_call $caml_ml_open_descriptor_out (local.get $fd))) +(@if wasi +(@then + (func (export "unix_close") (export "caml_unix_close") + (param $fd (ref eq)) (result (ref eq)) + (local $res i32) + (local.set $res + (call $fd_close (i31.get_u (ref.cast (ref i31) (local.get $fd))))) + (if (local.get $res) + (then + (call $caml_unix_error + (local.get $res) (@string "close") (global.get $no_arg)))) + (ref.i31 (i32.const 0))) +) +(@else (func (export "unix_close") (export "caml_unix_close") (param $fd (ref eq)) (result (ref eq)) (call $release_fd_offset (i31.get_u (ref.cast (ref i31) (local.get $fd)))) @@ -1131,9 +2487,18 @@ (catch $javascript_exception (call $caml_unix_error (pop externref) (ref.null eq)))) (ref.i31 (i32.const 0))) +)) +(@if wasi +(@then + (func (export "unix_isatty") (export "caml_unix_isatty") + (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) +) +(@else (export "unix_isatty" (func $isatty)) (export "caml_unix_isatty" (func $isatty)) +)) (func (export "unix_getuid") (export "caml_unix_getuid") (export "unix_geteuid") (export "caml_unix_geteuid") diff --git a/runtime/wasm/wasi_errors.wat b/runtime/wasm/wasi_errors.wat new file mode 100644 index 0000000000..577fb410fa --- /dev/null +++ b/runtime/wasm/wasi_errors.wat @@ -0,0 +1,86 @@ +(module +(@if wasi +(@then + (type $block (array (mut (ref eq)))) + (type $bytes (array (mut i8))) + (global (export "error_messages") (ref $block) + (array.new_fixed $block 77 + (@string "Success") + (@string "Argument list too long") + (@string "Permission denied") + (@string "Address in use") + (@string "Address not available") + (@string "Address family not supported") + (@string "Resource unavailable, or operation would block") + (@string "Connection already in progress") + (@string "Bad file descriptor") + (@string "Bad message") + (@string "Device or resource busy") + (@string "Operation canceled") + (@string "No child processes") + (@string "Connection aborted") + (@string "Connection refused") + (@string "Connection reset") + (@string "Resource deadlock would occur") + (@string "Destination address required") + (@string "Mathematics argument out of domain of function") + (@string "Reserved") + (@string "File exists") + (@string "Bad address") + (@string "File too large") + (@string "Host is unreachable") + (@string "Identifier removed") + (@string "Illegal byte sequence") + (@string "Operation in progress") + (@string "Interrupted function") + (@string "Invalid argument") + (@string "I/O error") + (@string "Socket is connected") + (@string "Is a directory") + (@string "Too many levels of symbolic links") + (@string "File descriptor value too large") + (@string "Too many links") + (@string "Message too large") + (@string "Reserved") + (@string "Filename too long") + (@string "Network is down") + (@string "Connection aborted by network") + (@string "Network unreachable") + (@string "Too many files open in system") + (@string "No buffer space available") + (@string "No such device") + (@string "No such file or directory") + (@string "Executable file format error") + (@string "No locks available") + (@string "Reserved") + (@string "Not enough space") + (@string "No message of the desired type") + (@string "Protocol not available") + (@string "No space left on device") + (@string "Function not supported") + (@string "The socket is not connected") + (@string "Not a directory or a symbolic link to a directory") + (@string "Directory not empty") + (@string "State not recoverable") + (@string "Not a socket") + (@string "Not supported, or operation not supported on socket") + (@string "Inappropriate I/O control operation") + (@string "No such device or address") + (@string "Value too large to be stored in data type") + (@string "Previous owner died") + (@string "Operation not permitted") + (@string "Broken pipe") + (@string "Protocol error") + (@string "Protocol not supported") + (@string "Protocol wrong type for socket") + (@string "Result too large") + (@string "Read-only file system") + (@string "Invalid seek") + (@string "No such process") + (@string "Reserved") + (@string "Connection timed out") + (@string "Text file busy") + (@string "Cross-device link") + (@string "Capabilities insufficient"))) +)) +) diff --git a/runtime/wasm/wasi_memory.wat b/runtime/wasm/wasi_memory.wat new file mode 100644 index 0000000000..0e737a46db --- /dev/null +++ b/runtime/wasm/wasi_memory.wat @@ -0,0 +1,98 @@ +(module +(@if wasi +(@then + (import "libc" "memory" (memory 2)) + (import "libc" "malloc" (func $malloc (param i32) (result i32))) + (import "libc" "free" (func $free (param i32))) + (import "io" "IO_BUFFER_SIZE" (global $IO_BUFFER_SIZE i32)) + (import "fail" "caml_raise_out_of_memory" (func $caml_raise_out_of_memory)) + + (type $bytes (array (mut i8))) + + (func (export "checked_malloc") (param $size i32) (result i32) + (local $p i32) + (local.set $p (call $malloc (local.get $size))) + (if (i32.eqz (local.get $p)) + (then (call $caml_raise_out_of_memory))) + (local.get $p)) + + (func (export "blit_substring_to_memory") + (param $buf i32) (param $s (ref $bytes)) (param $ofs i32) (param $len i32) + (local $i i32) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (i32.store8 (i32.add (local.get $buf) (local.get $i)) + (array.get $bytes (local.get $s) + (i32.add (local.get $ofs) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func $blit_string_to_memory (export "blit_string_to_memory") + (param $buf i32) (param $s (ref $bytes)) + (local $i i32) (local $len i32) + (local.set $len (array.len (local.get $s))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (i32.store8 (i32.add (local.get $buf) (local.get $i)) + (array.get $bytes (local.get $s) (local.get $i))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func (export "blit_memory_to_substring") + (param $buf i32) (param $s (ref $bytes)) (param $ofs i32) (param $len i32) + (local $i i32) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $s) + (i32.add (local.get $ofs) (local.get $i)) + (i32.load8_u (i32.add (local.get $buf) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop))))) + + (func $blit_memory_to_string (export "blit_memory_to_string") + (param $buf i32) (param $len i32) (result (ref $bytes)) + (local $s (ref $bytes)) + (local $i i32) + (local.set $s (array.new $bytes (i32.const 0) (local.get $len))) + (loop $loop + (if (i32.lt_u (local.get $i) (local.get $len)) + (then + (array.set $bytes (local.get $s) (local.get $i) + (i32.load8_u (i32.add (local.get $buf) (local.get $i)))) + (local.set $i (i32.add (local.get $i) (i32.const 1))) + (br $loop)))) + (local.get $s)) + + (func (export "write_string_to_memory") + (param $buf i32) (param $avail i32) (param $v (ref eq)) + (result i32) + (local $s (ref $bytes)) (local $i i32) (local $len i32) + (local.set $s (ref.cast (ref $bytes) (local.get $v))) + (local.set $len (array.len (local.get $s))) + (if (i32.lt_u (local.get $avail) (i32.add (local.get $len) (i32.const 1))) + (then + (local.set $buf + (call $checked_malloc (i32.add (local.get $len) (i32.const 1)))))) + (call $blit_string_to_memory (local.get $buf) (local.get $s)) + (i32.store8 (i32.add (local.get $buf) (local.get $len)) (i32.const 0)) + (local.get $buf)) + + (func (export "release_memory") (param $initial_buffer i32) (param $buf i32) + (if (i32.ne (local.get $initial_buffer) (local.get $buf)) + (then + (call $free (local.get $buf))))) + + (global $buffer (mut i32) (i32.const 0)) + + (func $get_buffer (export "get_buffer") (result i32) + (if (i32.eqz (global.get $buffer)) + (then + (global.set $buffer + (call $checked_malloc + (i32.add (global.get $IO_BUFFER_SIZE) (i32.const 12)))))) + (global.get $buffer)) +)) +) diff --git a/runtime/wasm/weak.wat b/runtime/wasm/weak.wat index d725cea8d4..68d5328c04 100644 --- a/runtime/wasm/weak.wat +++ b/runtime/wasm/weak.wat @@ -21,6 +21,19 @@ (func $caml_obj_dup (param (ref eq)) (result (ref eq)))) (import "fail" "caml_invalid_argument" (func $caml_invalid_argument (param $arg (ref eq)))) + +(@if wasi +(@then + (func $wrap (param (ref eq)) (result (ref eq)) + (local.get 0)) + (func $unwrap (param (ref eq)) (result (ref eq)) + (local.get 0)) + (func $weak_new (param $v (ref eq)) (result (ref eq)) + (local.get $v)) + (func $weak_deref (param $r (ref eq)) (result (ref eq)) + (local.get $r)) +) +(@else (import "bindings" "weak_new" (func $weak_new (param (ref eq)) (result anyref))) (import "bindings" "weak_deref" @@ -32,6 +45,8 @@ (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 $bytes (array (mut i8))) (type $js (struct (field anyref))) @@ -62,6 +77,8 @@ (block $released (br_if $no_data (ref.eq (local.get $d) (global.get $caml_ephe_none))) +(@if (not wasi) +(@then (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)))) @@ -82,6 +99,7 @@ (call $map_get (local.get $m) (local.get $v)))) (br $loop)))) (local.set $d (ref.cast (ref eq) (local.get $m))) +)) (return (array.new_fixed $block 2 (ref.i31 (i32.const 0)) (local.get $d)))) @@ -111,6 +129,8 @@ (local $m (ref any)) (local $m' (ref any)) (local $i i32) (local.set $x (ref.cast (ref $block) (local.get $vx))) +(@if (not wasi) +(@then (local.set $i (array.len (local.get $x))) (local.set $m (local.get $data)) (loop $loop @@ -135,6 +155,7 @@ (global.get $caml_ephe_none)) (br $loop)))) (local.set $data (call $wrap (local.get $m))) +)) (array.set $block (local.get $x) (global.get $caml_ephe_data_offset) (local.get $data)) (ref.i31 (i32.const 0))) diff --git a/runtime/wasm/zstd.wat b/runtime/wasm/zstd.wat index a6dff7db4f..879ea60a0f 100644 --- a/runtime/wasm/zstd.wat +++ b/runtime/wasm/zstd.wat @@ -16,7 +16,7 @@ ;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. (module -(@if (>= ocaml_version (5 1 0)) +(@if (and (>= ocaml_version (5 1 0)) (not wasi)) (@then (import "bindings" "ta_new" (func $ta_new (param i32) (result (ref extern)))) (import "bindings" "dv_make" @@ -58,5 +58,9 @@ (func (export "caml_zstd_initialize") (param (ref eq)) (result (ref eq)) (global.set $caml_intern_decompress_input (ref.func $decompress)) (ref.i31 (i32.const 1))) +) +(@else + (func (export "caml_zstd_initialize") (param (ref eq)) (result (ref eq)) + (ref.i31 (i32.const 0))) )) ) diff --git a/tools/ci_setup-mainstream.ml b/tools/ci_setup-mainstream.ml index 7c0e0c6044..f083e854b8 100644 --- a/tools/ci_setup-mainstream.ml +++ b/tools/ci_setup-mainstream.ml @@ -49,6 +49,7 @@ let node_wrapper = (name node_wrapper) (libraries unix))|} ) ; "node_wrapper/node_wrapper_per_profile.ml", {|let args = []|} + ; "node_wrapper/node_wrapper_per_engine.ml", {|let engine = "node"|} ; "node_wrapper/dune-project", "(lang dune 3.17)" ; "node_wrapper/node_wrapper.opam", "" ] diff --git a/tools/ci_setup-oxcaml.ml b/tools/ci_setup-oxcaml.ml index d936e7337e..4d18c8ab3d 100644 --- a/tools/ci_setup-oxcaml.ml +++ b/tools/ci_setup-oxcaml.ml @@ -56,6 +56,7 @@ let node_wrapper = (name node_wrapper) (libraries unix))|} ) ; "node_wrapper/node_wrapper_per_profile.ml", {|let args = []|} + ; "node_wrapper/node_wrapper_per_engine.ml", {|let engine = "node"|} ; "node_wrapper/dune-project", "(lang dune 3.17)" ; "node_wrapper/node_wrapper.opam", "" ] diff --git a/tools/dune b/tools/dune index 360e7d8aa7..744b8c8de9 100644 --- a/tools/dune +++ b/tools/dune @@ -1,8 +1,17 @@ (executable (name node_wrapper) - (modules node_wrapper) + (link_deps + (env_var WASM_ENGINE)) + (modules node_wrapper node_wrapper_per_engine) (libraries unix)) +(rule + (target node_wrapper_per_engine.ml) + (action + (with-stdout-to + %{target} + (run echo "let engine = \"%{env:WASM_ENGINE=node}\"")))) + (executable (name ci_setup) (modules ci_setup) diff --git a/tools/node_wrapper.ml b/tools/node_wrapper.ml index 0a3826fd7c..a2ecc5bc06 100644 --- a/tools/node_wrapper.ml +++ b/tools/node_wrapper.ml @@ -1,4 +1,23 @@ -let extra_args_for_wasoo = [ "--stack-size=10000" ] +let wizard_args = + [ "--ext:stack-switching" + ; "--ext:legacy-eh" + ; "--stack-size=2M" + ; "--dir=." + ; "--dir=/tmp" + ] + +let wasmtime_args = + [ (* "-C"; "collector=null"; *) "-W=all-proposals=y"; "--dir=."; "--dir=/tmp" ] + +let wasmedge_args = + [ "--enable-gc" + ; "--enable-exception-handling" + ; "--enable-tail-call" + ; "--dir=." + ; "--dir=/tmp" + ] + +let extra_args_for_wasoo = [ "--experimental-wasm-wasmfx"; "--stack-size=10000" ] let extra_args_for_jsoo = [] @@ -19,16 +38,31 @@ let env = else e) env -let args = +let environment_args () = + List.filter + (fun e -> not (String.contains e ',')) + (Array.to_list (Array.map (fun e -> "--env=" ^ e) env)) + +let wasm_file file = + Filename.concat (Filename.chop_extension file ^ ".assets") "code.wasm" + +let common_args file argv = environment_args () @ (wasm_file file :: List.tl argv) + +let exe, args = match Array.to_list Sys.argv with | exe :: argv -> - let argv = + let exe', argv = match argv with - | file :: _ when Filename.check_suffix file ".wasm.js" -> - extra_args_for_wasoo @ argv - | _ -> extra_args_for_jsoo @ argv + | file :: _ when Filename.check_suffix file ".wasm.js" -> ( + match Node_wrapper_per_engine.engine with + | "wizard" -> "wizeng.x86-linux", wizard_args @ common_args file argv + | "wizard-fast" -> "wizeng.x86-64-linux", wizard_args @ common_args file argv + | "wasmtime" -> "wasmtime", wasmtime_args @ common_args file argv + | "wasmedge" -> "wasmedge", wasmedge_args @ common_args file argv + | _ -> "node", extra_args_for_wasoo @ argv) + | _ -> "node", extra_args_for_jsoo @ argv in - Array.of_list (exe :: argv) + exe', Array.of_list (exe :: argv) | [] -> assert false let () = @@ -41,4 +75,4 @@ let () = | _, WEXITED n -> exit n | _, WSIGNALED _ -> exit 9 | _, WSTOPPED _ -> exit 9 - else Unix.execvpe "node" args env + else Unix.execvpe exe args env diff --git a/toplevel/examples/lwt_toplevel/dune b/toplevel/examples/lwt_toplevel/dune index 117556031f..2e9999cb18 100644 --- a/toplevel/examples/lwt_toplevel/dune +++ b/toplevel/examples/lwt_toplevel/dune @@ -115,6 +115,7 @@ (rule (targets test_dynlink.js) + (deps test_dynlink.cmi) (action (run %{bin:js_of_ocaml} @@ -199,6 +200,33 @@ (or 0 1) (run grep -v ^$)))))) +(rule + (target cmi_include_dirs.txt) + (deps + (package js_of_ocaml) + (package js_of_ocaml-compiler) + (package js_of_ocaml-lwt) + (package js_of_ocaml-tyxml) + (package js_of_ocaml-toplevel) + (package js_of_ocaml-ppx)) + (action + (with-stdout-to + %{target} + (run + ocamlfind + query + -format + "-I\n%d" + -r + js_of_ocaml-compiler.runtime + js_of_ocaml-lwt + js_of_ocaml-lwt.graphics + js_of_ocaml-tyxml + js_of_ocaml-toplevel + js_of_ocaml-toplevel.common + js_of_ocaml-ppx.as-lib + js_of_ocaml.deriving)))) + (rule (targets toplevel.js) (action @@ -223,6 +251,7 @@ --toplevel --disable shortvar + %{read-strings:cmi_include_dirs.txt} %{read-strings:javascript_runtime_files.txt} %{dep:toplevel.bc} -o @@ -271,6 +300,7 @@ compile --toplevel --effects=cps + %{read-strings:cmi_include_dirs.txt} --file %{dep:examples.ml} --export diff --git a/toplevel/test/dune b/toplevel/test/dune index 71875c7974..f9c6e348ae 100644 --- a/toplevel/test/dune +++ b/toplevel/test/dune @@ -29,6 +29,24 @@ (action (run jsoo_mkcmis -o %{target} stdlib))) +(rule + (target cmi_include_dirs.txt) + (deps + (package js_of_ocaml) + (package js_of_ocaml-toplevel)) + (action + (with-stdout-to + %{target} + (run + ocamlfind + query + -format + "-I\n%d" + -r + js_of_ocaml-toplevel + js_of_ocaml-toplevel.common + re)))) + (rule (targets test_toplevel1.js) (action @@ -41,6 +59,7 @@ shortvar -w no-missing-effects-backend + %{read-strings:cmi_include_dirs.txt} %{dep:test_toplevel1.bc} -o %{targets}))) diff --git a/wasm_of_ocaml-compiler.opam b/wasm_of_ocaml-compiler.opam index 2577bd563f..56582758a2 100644 --- a/wasm_of_ocaml-compiler.opam +++ b/wasm_of_ocaml-compiler.opam @@ -12,7 +12,7 @@ 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.20"} + "dune" {>= "3.23"} "ocaml" {>= "4.14"} "js_of_ocaml" {= version} "num" {with-test}