diff --git a/.depend b/.depend index 0c371510f8..c588bacbbc 100644 --- a/.depend +++ b/.depend @@ -2342,7 +2342,7 @@ asmcomp/asmlink.cmo : \ utils/misc.cmi \ parsing/location.cmi \ utils/load_path.cmi \ - wasm/link_wast.cmi \ + wasm/link_wat.cmi \ asmcomp/emitaux.cmi \ asmcomp/emit.cmi \ utils/consistbl.cmi \ @@ -2361,7 +2361,7 @@ asmcomp/asmlink.cmx : \ utils/misc.cmx \ parsing/location.cmx \ utils/load_path.cmx \ - wasm/link_wast.cmx \ + wasm/link_wat.cmx \ asmcomp/emitaux.cmx \ asmcomp/emit.cmx \ utils/consistbl.cmx \ @@ -3874,12 +3874,12 @@ wasm/block_repr.cmx : \ wasm/block_repr.cmi wasm/block_repr.cmi : \ wasm/wmodule.cmo -wasm/emit_wast.cmo : \ +wasm/emit_wat.cmo : \ wasm/wtype.cmo \ wasm/wstate.cmo \ wasm/wmodule.cmo \ wasm/wident.cmo \ - wasm/wast.cmo \ + wasm/wat.cmo \ wasm/wasm_closure_offsets.cmi \ middle_end/variable.cmi \ middle_end/flambda/base_types/var_within_closure.cmi \ @@ -3905,13 +3905,13 @@ wasm/emit_wast.cmo : \ middle_end/clambda_primitives.cmi \ wasm/block_repr.cmi \ middle_end/flambda/allocated_const.cmi \ - wasm/emit_wast.cmi -wasm/emit_wast.cmx : \ + wasm/emit_wat.cmi +wasm/emit_wat.cmx : \ wasm/wtype.cmx \ wasm/wstate.cmx \ wasm/wmodule.cmx \ wasm/wident.cmx \ - wasm/wast.cmx \ + wasm/wat.cmx \ wasm/wasm_closure_offsets.cmx \ middle_end/variable.cmx \ middle_end/flambda/base_types/var_within_closure.cmx \ @@ -3937,26 +3937,26 @@ wasm/emit_wast.cmx : \ middle_end/clambda_primitives.cmx \ wasm/block_repr.cmx \ middle_end/flambda/allocated_const.cmx \ - wasm/emit_wast.cmi -wasm/emit_wast.cmi : \ - wasm/wast.cmo \ + wasm/emit_wat.cmi +wasm/emit_wat.cmi : \ + wasm/wat.cmo \ middle_end/flambda/flambda.cmi -wasm/link_wast.cmo : \ +wasm/link_wat.cmo : \ wasm/wstate.cmo \ - wasm/wast.cmo \ + wasm/wat.cmo \ utils/misc.cmi \ - wasm/emit_wast.cmi \ + wasm/emit_wat.cmi \ utils/config.cmi \ - wasm/link_wast.cmi -wasm/link_wast.cmx : \ + wasm/link_wat.cmi +wasm/link_wat.cmx : \ wasm/wstate.cmx \ - wasm/wast.cmx \ + wasm/wat.cmx \ utils/misc.cmx \ - wasm/emit_wast.cmx \ + wasm/emit_wat.cmx \ utils/config.cmx \ - wasm/link_wast.cmi -wasm/link_wast.cmi : \ - wasm/wast.cmo + wasm/link_wat.cmi +wasm/link_wat.cmi : \ + wasm/wat.cmo wasm/wasm_closure_offsets.cmo : \ middle_end/variable.cmi \ middle_end/flambda/base_types/var_within_closure.cmi \ @@ -3983,12 +3983,12 @@ wasm/wasm_closure_offsets.cmi : \ middle_end/flambda/flambda.cmi \ middle_end/compilation_unit.cmi \ middle_end/flambda/base_types/closure_id.cmi -wasm/wast.cmo : \ +wasm/wat.cmo : \ wasm/wtype.cmo \ wasm/wstate.cmo \ wasm/wident.cmo \ wasm/wexpr.cmo -wasm/wast.cmx : \ +wasm/wat.cmx : \ wasm/wtype.cmx \ wasm/wstate.cmx \ wasm/wident.cmx \ @@ -4455,7 +4455,7 @@ middle_end/flambda/effect_analysis.cmx : \ middle_end/flambda/effect_analysis.cmi : \ middle_end/flambda/flambda.cmi middle_end/flambda/export_info.cmo : \ - wasm/wast.cmo \ + wasm/wat.cmo \ wasm/wasm_closure_offsets.cmi \ middle_end/variable.cmi \ middle_end/flambda/base_types/var_within_closure.cmi \ @@ -4469,7 +4469,7 @@ middle_end/flambda/export_info.cmo : \ middle_end/flambda/base_types/closure_id.cmi \ middle_end/flambda/export_info.cmi middle_end/flambda/export_info.cmx : \ - wasm/wast.cmx \ + wasm/wat.cmx \ wasm/wasm_closure_offsets.cmx \ middle_end/variable.cmx \ middle_end/flambda/base_types/var_within_closure.cmx \ @@ -4483,7 +4483,7 @@ middle_end/flambda/export_info.cmx : \ middle_end/flambda/base_types/closure_id.cmx \ middle_end/flambda/export_info.cmi middle_end/flambda/export_info.cmi : \ - wasm/wast.cmo \ + wasm/wat.cmo \ wasm/wasm_closure_offsets.cmi \ middle_end/variable.cmi \ middle_end/flambda/base_types/var_within_closure.cmi \ @@ -4738,7 +4738,7 @@ middle_end/flambda/flambda_middle_end.cmo : \ middle_end/flambda/flambda_iterators.cmi \ middle_end/flambda/flambda_invariants.cmi \ middle_end/flambda/flambda.cmi \ - wasm/emit_wast.cmi \ + wasm/emit_wat.cmi \ lambda/debuginfo.cmi \ middle_end/compilenv.cmi \ middle_end/flambda/base_types/closure_id.cmi \ @@ -4774,7 +4774,7 @@ middle_end/flambda/flambda_middle_end.cmx : \ middle_end/flambda/flambda_iterators.cmx \ middle_end/flambda/flambda_invariants.cmx \ middle_end/flambda/flambda.cmx \ - wasm/emit_wast.cmx \ + wasm/emit_wat.cmx \ lambda/debuginfo.cmx \ middle_end/compilenv.cmx \ middle_end/flambda/base_types/closure_id.cmx \ @@ -4851,7 +4851,7 @@ middle_end/flambda/flambda_to_clambda.cmx : \ middle_end/flambda/allocated_const.cmx \ middle_end/flambda/flambda_to_clambda.cmi middle_end/flambda/flambda_to_clambda.cmi : \ - wasm/wast.cmo \ + wasm/wat.cmo \ middle_end/symbol.cmi \ middle_end/flambda/flambda.cmi \ middle_end/flambda/export_info.cmi \ diff --git a/.gitignore b/.gitignore index 096e7736ec..502104b127 100644 --- a/.gitignore +++ b/.gitignore @@ -57,7 +57,7 @@ _build /ocamlopt.opt /ocamlnat /_opam -/o*.wast +/o*.wat /o*.wasm # specific files and patterns in sub-directories diff --git a/Makefile b/Makefile index 084be02ba1..b0697b6da1 100644 --- a/Makefile +++ b/Makefile @@ -422,7 +422,7 @@ ifeq "$(INSTALL_SOURCE_ARTIFACTS)" "true" "$(INSTALL_COMPLIBDIR)" endif $(INSTALL_DATA) \ - wasm/*.wast \ + wasm/*.wat \ "$(INSTALL_LIBDIR)" $(INSTALL_DATA) \ compilerlibs/*.cma \ diff --git a/README.md b/README.md index 3ab9d0947a..a7c5823306 100644 --- a/README.md +++ b/README.md @@ -42,12 +42,12 @@ $ opam switch create wasocaml --repos default,wasocaml=git+https://github.com/oc ### Usage -Running the compiler will produce two files: `a.out.wasm` (the Wasm binary) and `a.out.wast` (the Wast text format). +Running the compiler will produce two files: `a.out.wasm` (the Wasm binary) and `a.out.wat` (the Wast text format). ```shell-session $ /usr/local/bin/ocamlopt file.ml $ ls -a.out a.out.wasm a.out.wast +a.out a.out.wasm a.out.wat ``` For a complete example using the compiler installed as an opam switch, see [wasocaml-demo]. diff --git a/asmcomp/asmlink.ml b/asmcomp/asmlink.ml index f813287ba0..57570e3376 100644 --- a/asmcomp/asmlink.ml +++ b/asmcomp/asmlink.ml @@ -365,7 +365,7 @@ let link ~ppf_dump objfiles output_name = | Some w -> Some (ui.ui_name, w)) units_tolink in - Link_wast.link fl_export ~output:output_name; + Link_wat.link fl_export ~output:output_name; in Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; diff --git a/compilerlibs/Makefile.compilerlibs b/compilerlibs/Makefile.compilerlibs index 64b7f620f4..5b606e6011 100644 --- a/compilerlibs/Makefile.compilerlibs +++ b/compilerlibs/Makefile.compilerlibs @@ -146,10 +146,10 @@ WASM = \ wasm/wident.cmo \ wasm/wexpr.cmo \ wasm/wmodule.cmo \ - wasm/wast.cmo \ + wasm/wat.cmo \ wasm/block_repr.cmo \ - wasm/emit_wast.cmo \ - wasm/link_wast.cmo + wasm/emit_wat.cmo \ + wasm/link_wat.cmo WASM_CMI = COMP = \ diff --git a/dune b/dune index 8c001ca593..79ba05fefc 100644 --- a/dune +++ b/dune @@ -146,10 +146,10 @@ wident wexpr wmodule - wast + wat block_repr - emit_wast - link_wast + emit_wat + link_wat ) ) diff --git a/middle_end/flambda/export_info.ml b/middle_end/flambda/export_info.ml index bf95336255..efddc86a53 100644 --- a/middle_end/flambda/export_info.ml +++ b/middle_end/flambda/export_info.ml @@ -147,7 +147,7 @@ type t = { invariant_params : Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t; recursive : Variable.Set.t Set_of_closures_id.Map.t; wasm_offsets : Wasm_closure_offsets.t; - wasm_contents : Wast.t option; + wasm_contents : Wat.t option; } type transient = { diff --git a/middle_end/flambda/export_info.mli b/middle_end/flambda/export_info.mli index 3659d6de72..a91ff1c718 100644 --- a/middle_end/flambda/export_info.mli +++ b/middle_end/flambda/export_info.mli @@ -96,7 +96,7 @@ type t = private { indexed by set of closures ID. *) recursive : Variable.Set.t Set_of_closures_id.Map.t; wasm_offsets : Wasm_closure_offsets.t; - wasm_contents : Wast.t option; + wasm_contents : Wat.t option; } type transient = private { @@ -114,7 +114,7 @@ type transient = private { (** Export information for a compilation unit that exports nothing. *) val empty : t -val empty_with_wasm : Wast.t option -> t +val empty_with_wasm : Wat.t option -> t val opaque_transient : compilation_unit:Compilation_unit.t @@ -132,7 +132,7 @@ val create -> invariant_params:Variable.Set.t Variable.Map.t Set_of_closures_id.Map.t -> recursive:Variable.Set.t Set_of_closures_id.Map.t -> wasm_offsets:Wasm_closure_offsets.t - -> wasm_contents:Wast.t option + -> wasm_contents:Wat.t option -> t val create_transient @@ -165,7 +165,7 @@ val t_of_transient -> imported_offset_fv:int Var_within_closure.Map.t -> constant_closures:Closure_id.Set.t -> wasm_offsets:Wasm_closure_offsets.t - -> wasm_contents:Wast.t option + -> wasm_contents:Wat.t option -> t (** Union of export information. Verifies that there are no identifier diff --git a/middle_end/flambda/flambda_middle_end.ml b/middle_end/flambda/flambda_middle_end.ml index f86ba92ab2..c69d52b4d5 100644 --- a/middle_end/flambda/flambda_middle_end.ml +++ b/middle_end/flambda/flambda_middle_end.ml @@ -230,8 +230,8 @@ let lambda_to_clambda ~backend ~prefixname ~ppf_dump let wasm_contents = try Some ( - Profile.record_call "emit_wast" (fun () -> - Emit_wast.emit ~to_file:do_wasm ~output_prefix:prefixname program)) + Profile.record_call "emit_wat" (fun () -> + Emit_wat.emit ~to_file:do_wasm ~output_prefix:prefixname program)) with Failure s -> Format.eprintf "No wasm generated@.%s@." s; None diff --git a/middle_end/flambda/flambda_to_clambda.mli b/middle_end/flambda/flambda_to_clambda.mli index 4ae908b7d1..0b41259e3d 100644 --- a/middle_end/flambda/flambda_to_clambda.mli +++ b/middle_end/flambda/flambda_to_clambda.mli @@ -37,6 +37,6 @@ type result = { *) val convert : ppf_dump:Format.formatter - -> wasm_contents:Wast.t option + -> wasm_contents:Wat.t option -> Flambda.program * Export_info.transient -> result diff --git a/stdlib/Makefile b/stdlib/Makefile index 8c88dd27de..458ad41e89 100644 --- a/stdlib/Makefile +++ b/stdlib/Makefile @@ -232,7 +232,7 @@ stdlib__%.cmo: WASMOPT=~/test/wasm/binaryen/bin/wasm-opt -%.wasm: %.wast +%.wasm: %.wat $(WASMOPT) \ --enable-reference-types --enable-gc --enable-tail-call --enable-exception-handling \ --enable-multivalue \ diff --git a/wasm/block_repr.ml b/wasm/block_repr.ml index a282ccea98..9bf683c9f3 100644 --- a/wasm/block_repr.ml +++ b/wasm/block_repr.ml @@ -64,8 +64,8 @@ module Block_struct : Block = struct if size <= 1 then Gen_block else Block { size = size - 1 } in Struct { sub = Some sub; fields = (* Tag *) - I8 :: (* size *) - I16 :: fields } + I8 :: (* size *) + I16 :: fields } let type_decl name size : Decl.t list = [ Decl.Type (name, type_descr size) ] end diff --git a/wasm/emit_wast.mli b/wasm/emit_wast.mli deleted file mode 100644 index 56e86d86e1..0000000000 --- a/wasm/emit_wast.mli +++ /dev/null @@ -1,3 +0,0 @@ -val emit : to_file:bool -> output_prefix:string -> Flambda.program -> Wast.t - -val output_wast : Format.formatter -> Wast.printable_expr -> unit diff --git a/wasm/emit_wast.ml b/wasm/emit_wat.ml similarity index 86% rename from wasm/emit_wast.ml rename to wasm/emit_wat.ml index b52279957f..9604fac193 100644 --- a/wasm/emit_wast.ml +++ b/wasm/emit_wat.ml @@ -84,24 +84,21 @@ module Conv = struct let function_call_handling handler ~tail call : Expr.t = if tail then call else - match mode with - | Reference -> failwith "TODO reference call" - | Binarien -> - let var = Local.fresh "call_result" in - let body : Expr.t = - If_then_else - { cond = Unop (Tuple_extract 0, Var (V var)) - ; if_expr = - NR (raise handler (Unop (Tuple_extract 1, Var (V var)))) - ; else_expr = Unop (Tuple_extract 1, Var (V var)) - } - in - Let - { var - ; typ = Type.Tuple [ I32; ref_eq ] - ; defining_expr = call - ; body + let var = Local.fresh "call_result" in + let body : Expr.t = + If_then_else + { cond = Unop (Tuple_extract 0, Var (V var)) + ; if_expr = + NR (raise handler (Unop (Tuple_extract 1, Var (V var)))) + ; else_expr = Unop (Tuple_extract 1, Var (V var)) } + in + Let + { var + ; typ = Type.Tuple [ I32; ref_eq ] + ; defining_expr = call + ; body + } end let exceptions_module = @@ -216,7 +213,7 @@ module Conv = struct raise e let project_closure ?(cast : unit option) (top_env : top_env) closure_id - set_of_closures : Expr.t = + set_of_closures : Expr.t = let accessor = closure_info top_env closure_id in if not accessor.recursive_set then set_of_closures else @@ -229,7 +226,7 @@ module Conv = struct Unop (Struct_get { typ; field = accessor.field }, set_of_closures) let project_var ?(cast : unit option) (top_env : top_env) closure_id var - closure : Expr.t = + closure : Expr.t = let accessor = var_within_closure_info top_env var in let closure_info = closure_info top_env closure_id in if not accessor.recursive_set then begin @@ -267,7 +264,7 @@ module Conv = struct (Struct_get { typ = set_typ; field = accessor.field }, set_of_closures) let move_within_set_of_closures ?(cast : unit option) (top_env : top_env) - ~start_from ~move_to closure : Expr.t = + ~start_from ~move_to closure : Expr.t = if Closure_id.equal start_from move_to then closure else begin let start_from_info = @@ -511,12 +508,12 @@ module Conv = struct Seq (List.map drop l, last) let const_block ~symbols_being_bound tag fields : - Const.t * (int * Symbol.t) list = + Const.t * (int * Symbol.t) list = let size = List.length fields in State.add_block_size size; let fields_to_update = ref [] in let field i (f : Flambda.constant_defining_value_block_field) : Const.field - = + = match f with | Symbol s -> if Symbol.Set.mem s symbols_being_bound then begin @@ -539,7 +536,7 @@ module Conv = struct Unop (Struct_get { typ; field = 0 }, Ref_cast { typ; r = x }) let c_import_type_var (descr : Primitive.description) : - Type.Var.c_import_func_type = + Type.Var.c_import_func_type = let repr_type (t : Primitive.native_repr) : Type.Var.C_import_atom.t = if descr.prim_native_name = "" then assert (t = Primitive.Same_as_ocaml_repr); @@ -572,33 +569,33 @@ module Conv = struct State.add_arity arity; match apply.kind with | Indirect -> begin - match apply.args with - | [] -> assert false - | [ arg ] -> - let func_typ = Type.Var.Func { arity = 1 } in - let var : Expr.Local.var = Indirec_call_closure { arity = 1 } in - let closure : Expr.t = Closure.cast (conv_var env apply.func) in - let func : Expr.t = Closure.get_gen_func (Var (V var)) in - let args : Expr.t list = [ conv_var env arg; Var (V var) ] in - Let - { var - ; typ = Rvar Env - ; defining_expr = closure - ; body = - Exceptions.function_call_handling env.current_exception_handler - ~tail - (Call_ref { typ = func_typ; func; args; tail }) - } - | _ :: _ :: _ -> - let args = - Closure.cast (conv_var env apply.func) - :: List.map (conv_var env) apply.args - in - State.add_caml_apply arity; - let typ = Type.Var.Caml_apply_func { arity } in - Exceptions.function_call_handling ~tail env.current_exception_handler - (Call { typ; func = Caml_apply arity; args; tail }) - end + match apply.args with + | [] -> assert false + | [ arg ] -> + let func_typ = Type.Var.Func { arity = 1 } in + let var : Expr.Local.var = Indirec_call_closure { arity = 1 } in + let closure : Expr.t = Closure.cast (conv_var env apply.func) in + let func : Expr.t = Closure.get_gen_func (Var (V var)) in + let args : Expr.t list = [ conv_var env arg; Var (V var) ] in + Let + { var + ; typ = Rvar Env + ; defining_expr = closure + ; body = + Exceptions.function_call_handling env.current_exception_handler + ~tail + (Call_ref { typ = func_typ; func; args; tail }) + } + | _ :: _ :: _ -> + let args = + Closure.cast (conv_var env apply.func) + :: List.map (conv_var env) apply.args + in + State.add_caml_apply arity; + let typ = Type.Var.Caml_apply_func { arity } in + Exceptions.function_call_handling ~tail env.current_exception_handler + (Call { typ; func = Caml_apply arity; args; tail }) + end | Direct closure_id -> let func = Func_id.of_closure_id closure_id in let () = @@ -616,7 +613,7 @@ module Conv = struct (Call { typ; func; args; tail }) let conv_allocated_const_expr (const : Allocated_const.t) : Type.atom * Expr.t - = + = match const with | Float f -> (Rvar Float, const_float f) | Int32 i -> (Rvar Int32, const_int32 i) @@ -638,13 +635,13 @@ module Conv = struct Expr { typ; e } let closure_type_from_info (id : Set_of_closures_id.t) - (set_info : Wasm_closure_offsets.set_of_closures_id_type) = + (set_info : Wasm_closure_offsets.set_of_closures_id_type) = let name : Type.Var.t = Set_of_closures id in let func_types = List.fold_left (fun acc ({ arity; fields } : Wasm_closure_offsets.func) -> - let typ : Type.atom = Rvar (Closure { arity; fields }) in - typ :: acc ) + let typ : Type.atom = Rvar (Closure { arity; fields }) in + typ :: acc ) [] set_info.functions in let data_fields = List.init set_info.fields (fun _ -> ref_eq) in @@ -679,7 +676,7 @@ module Conv = struct runtime_prim ~tail:false name args let rec conv_body (env : top_env) (expr : Flambda.program_body) effects : - Module.t = + Module.t = match expr with | Let_symbol (symbol, Set_of_closures set, body) -> let decl = closed_set_of_closures symbol set in @@ -701,10 +698,10 @@ module Conv = struct let decls, effects = List.fold_left (fun (decls, effects) (symbol, const) -> - let decl, new_effecs = - conv_symbol ~symbols_being_bound symbol const - in - (decl @ decls, new_effecs @ effects) ) + let decl, new_effecs = + conv_symbol ~symbols_being_bound symbol const + in + (decl @ decls, new_effecs @ effects) ) ([], effects) decls in let body = conv_body env body effects in @@ -739,38 +736,38 @@ module Conv = struct ; body = No_value (NV_call - { typ - ; func = not_really_start - ; args = [] - ; tail = false - } ) + { typ + ; func = not_really_start + ; args = [] + ; tail = false + } ) } } ] and conv_initialize_symbol env symbol tag fields : - _ * Expr.no_value_expression list = + _ * Expr.no_value_expression list = let fields = List.mapi (fun i field -> - (i, field, Initialize_symbol_to_let_symbol.constant_field field) ) + (i, field, Initialize_symbol_to_let_symbol.constant_field field) ) fields in let fields_to_update = ref [] in let predefined_fields = List.map (fun (i, expr, field) : Const.field -> - match field with - | None -> - let expr_env = empty_env ~top_env:env in - let expr = conv_expr ~tail:false expr_env expr in - fields_to_update := (i, expr) :: !fields_to_update; - I31 dummy_const - | Some (field : Flambda.constant_defining_value_block_field) -> ( match field with - | Symbol s -> WSymbol.const s - | Const (Int i) -> I31 i - | Const (Char c) -> I31 (Char.code c) ) ) + | None -> + let expr_env = empty_env ~top_env:env in + let expr = conv_expr ~tail:false expr_env expr in + fields_to_update := (i, expr) :: !fields_to_update; + I31 dummy_const + | Some (field : Flambda.constant_defining_value_block_field) -> ( + match field with + | Symbol s -> WSymbol.const s + | Const (Int i) -> I31 i + | Const (Char c) -> I31 (Char.code c) ) ) fields in let name = Global.of_symbol symbol in @@ -788,7 +785,7 @@ module Conv = struct and conv_symbol ~symbols_being_bound symbol (const : Flambda.constant_defining_value) : - Decl.t list * Expr.no_value_expression list = + Decl.t list * Expr.no_value_expression list = match const with | Block (tag, fields) -> let name = Global.of_symbol symbol in @@ -798,9 +795,9 @@ module Conv = struct let new_effects = List.map (fun (field_to_update, field_contents) : Expr.no_value_expression -> - Block.set_field ~cast:true ~field:field_to_update - ~block:(WSymbol.get symbol) - (WSymbol.get field_contents) ) + Block.set_field ~cast:true ~field:field_to_update + ~block:(WSymbol.get symbol) + (WSymbol.get field_contents) ) fields_to_update in ([ Const { name; export = Some symbol; descr } ], new_effects) @@ -814,7 +811,7 @@ module Conv = struct ([ Const { name; export = Some symbol; descr } ], []) and closed_function_declaration (name : Variable.t) - (declaration : Flambda.function_declaration) : Decl.const = + (declaration : Flambda.function_declaration) : Decl.const = let function_name = Func_id.of_var_closure_id name in let arity = List.length declaration.params in let closure = @@ -835,7 +832,7 @@ module Conv = struct { name = closure_name; export = Some closure_symbol; descr = closure } and closed_set_of_closures symbol (set_of_closures : Flambda.set_of_closures) - : Decl.t list = + : Decl.t list = let function_decls = set_of_closures.function_decls in let is_recursive = Variable.Map.cardinal function_decls.funs > 1 in if not is_recursive then begin @@ -853,8 +850,8 @@ module Conv = struct let decls = Variable.Map.fold (fun name (declaration : Flambda.function_declaration) declarations -> - let decl = closed_function_declaration name declaration in - decl :: declarations ) + let decl = closed_function_declaration name declaration in + decl :: declarations ) set_of_closures.function_decls.funs [] in let closure_decls = List.map (fun decl -> Decl.Const decl) decls in @@ -869,18 +866,18 @@ module Conv = struct in closure_decls @ [ Decl.Const - { name = Global.of_symbol symbol - ; export = - Some symbol - (* This export might not be required, there is no reason for - a cross module reference to a set of closure *) - ; descr = set_of_closures - } - ] + { name = Global.of_symbol symbol + ; export = + Some symbol + (* This export might not be required, there is no reason for + a cross module reference to a set of closure *) + ; descr = set_of_closures + } + ] end and conv_set_of_closures env (set_of_closures : Flambda.set_of_closures) : - Expr.t = + Expr.t = let function_decls = set_of_closures.function_decls in let is_recursive = Variable.Map.cardinal function_decls.funs > 1 in if not is_recursive then begin @@ -892,7 +889,7 @@ module Conv = struct let rev_value_fields = Variable.Map.fold (fun _id (var : Flambda.specialised_to) acc -> - conv_var env var.var :: acc ) + conv_var env var.var :: acc ) set_of_closures.free_vars [] in let func_id = Func_id.of_var_closure_id func_var in @@ -909,7 +906,7 @@ module Conv = struct end else begin let add_closure func_var (function_decl : Flambda.function_declaration) - body : Expr.t = + body : Expr.t = let arity = Flambda_utils.function_arity function_decl in let typ : Type.Var.t = Closure { arity; fields = 1 } in State.add_closure_type ~arity ~fields:1; @@ -933,7 +930,7 @@ module Conv = struct Set_of_closures function_decls.set_of_closures_id in let update_fields func_var (function_decl : Flambda.function_declaration) - updates : Expr.no_value_expression list = + updates : Expr.no_value_expression list = let arity = Flambda_utils.function_arity function_decl in let typ : Type.Var.t = Closure { arity; fields = 1 } in let field = if arity = 1 then 2 else 3 in @@ -1083,7 +1080,7 @@ module Conv = struct let body : Expr.t = Unit (NV_if_then_else - { cond; if_expr = Loop { cont; body }; else_expr = NV } ) + { cond; if_expr = Loop { cont; body }; else_expr = NV } ) in Let { var = local @@ -1117,14 +1114,14 @@ module Conv = struct let body = List.fold_left (fun body (str, branch) : Expr.t -> - let cond = - WInt.untag - (runtime_prim ~tail:false "string_eq" - [ Expr.Var (V local); const_string str ] ) - in - If_then_else - { cond; if_expr = conv_expr ~tail env branch; else_expr = body } - ) + let cond = + WInt.untag + (runtime_prim ~tail:false "string_eq" + [ Expr.Var (V local); const_string str ] ) + in + If_then_else + { cond; if_expr = conv_expr ~tail env branch; else_expr = body } + ) body branches in Let @@ -1162,14 +1159,14 @@ module Conv = struct else failwith msg and conv_switch ~tail (env : env) (cond : Expr.t) (switch : Flambda.switch) : - Expr.t = + Expr.t = let default_id = Block_id.fresh "switch_default" in let branches _set cases = let cases, defs = List.fold_left (fun (map, defs) (i, branch) -> - let id = Block_id.fresh (Printf.sprintf "switch_%i" i) in - (Numbers.Int.Map.add i id map, (id, branch) :: defs) ) + let id = Block_id.fresh (Printf.sprintf "switch_%i" i) in + (Numbers.Int.Map.add i id map, (id, branch) :: defs) ) (Numbers.Int.Map.empty, []) cases in @@ -1179,16 +1176,16 @@ module Conv = struct let max, max_branch = Numbers.Int.Map.max_binding cases in ( max , match switch.failaction with - | None -> max_branch - | Some _ -> default_id ) + | None -> max_branch + | Some _ -> default_id ) in let cases = (* TODO max_branch should be sufficient sometimes: the default can replace the last case *) List.init (max_branch + 1) (fun i -> - match Numbers.Int.Map.find_opt i cases with - | None -> default_branch - | Some branch -> branch ) + match Numbers.Int.Map.find_opt i cases with + | None -> default_branch + | Some branch -> branch ) in (cases, defs) in @@ -1286,7 +1283,7 @@ module Conv = struct e and conv_prim ~tail env ~(prim : Clambda_primitives.primitive) ~args : Expr.t - = + = let args = List.map (conv_var env) args in let arg1 args = match args with @@ -1342,23 +1339,23 @@ module Conv = struct | Pdivfloat -> box_float (Expr.Binop (Expr.f64_div, args2 (List.map unbox_float args))) | Pfloatcomp cmp -> begin - let relop, is_not = float_comparision cmp in - let cmp_op : Expr.t = - F_relop (S64, relop, args2 (List.map unbox_float args)) - in - let op = match is_not with Id -> cmp_op | Not -> bool_not cmp_op in - i31 op - end + let relop, is_not = float_comparision cmp in + let cmp_op : Expr.t = + F_relop (S64, relop, args2 (List.map unbox_float args)) + in + let op = match is_not with Id -> cmp_op | Not -> bool_not cmp_op in + i31 op + end | Pintoffloat -> i31 (Unop - ( Trunc { from_type = S64; to_type = S32; sign = S } - , unbox_float (arg1 args) ) ) + ( Trunc { from_type = S64; to_type = S32; sign = S } + , unbox_float (arg1 args) ) ) | Pfloatofint -> box_float (Unop - ( Convert { from_type = S32; to_type = S64; sign = S } - , i32 (arg1 args) ) ) + ( Convert { from_type = S32; to_type = S64; sign = S } + , i32 (arg1 args) ) ) | Pccall descr -> let unbox_arg (t : Primitive.native_repr) arg = match t with @@ -1403,23 +1400,23 @@ module Conv = struct | Pmakearray ((Pintarray | Paddrarray), _) -> Array_new_fixed { typ = Array; fields = args } | Pmakearray (Pgenarray, _) -> begin - match args with - | [] -> Array_new_fixed { typ = Array; fields = [] } - | first :: _ -> - let cont = Block_id.fresh "make_float_array" in - let handler : Expr.t = - Array_new_fixed - { typ = FloatArray; fields = List.map unbox_float args } - in - let if_else : Expr.t = Array_new_fixed { typ = Array; fields = args } in - Let_cont - { cont - ; params = [ (None, Rvar Float) ] - ; handler - ; body = - Br_on_cast { value = first; typ = Float; if_cast = cont; if_else } - } - end + match args with + | [] -> Array_new_fixed { typ = Array; fields = [] } + | first :: _ -> + let cont = Block_id.fresh "make_float_array" in + let handler : Expr.t = + Array_new_fixed + { typ = FloatArray; fields = List.map unbox_float args } + in + let if_else : Expr.t = Array_new_fixed { typ = Array; fields = args } in + Let_cont + { cont + ; params = [ (None, Rvar Float) ] + ; handler + ; body = + Br_on_cast { value = first; typ = Float; if_cast = cont; if_else } + } + end | Pduparray (_, _) -> runtime_prim "duparray" | Pfloatfield field -> let arg = arg1 args in @@ -1432,16 +1429,16 @@ module Conv = struct | Pisint -> WInt.tag (Unop (Is_i31, arg1 args)) | Pintcomp Ceq -> i31 (Expr.Binop (Ref_eq, args2 args)) | Pintcomp cop -> begin - let op : Expr.t = - match cop with - | Ceq -> Binop (Ref_eq, args2 args) - | Cne -> bool_not (Binop (Ref_eq, args2 args)) - | Clt | Cgt | Cle | Cge -> - let cmp = integer_comparision cop in - I_relop (S32, cmp, args2 (List.map i32 args)) - in - i31 op - end + let op : Expr.t = + match cop with + | Ceq -> Binop (Ref_eq, args2 args) + | Cne -> bool_not (Binop (Ref_eq, args2 args)) + | Clt | Cgt | Cle | Cge -> + let cmp = integer_comparision cop in + I_relop (S32, cmp, args2 (List.map i32 args)) + in + i31 op + end | Pcompare_ints -> runtime_prim "compare_ints" | Pcompare_floats -> runtime_prim "compare_floats" | Pcompare_bints Pint64 -> runtime_prim "compare_i64" @@ -1500,21 +1497,21 @@ module Conv = struct let array, field, value = args3 args in Unit (Array_set - { typ - ; array = Ref_cast { typ; r = array } - ; field = i32 field - ; value - } ) + { typ + ; array = Ref_cast { typ; r = array } + ; field = i32 field + ; value + } ) | Parraysetu Pfloatarray -> let typ : Type.Var.t = FloatArray in let array, field, value = args3 args in Unit (Array_set - { typ - ; array = Ref_cast { typ; r = array } - ; field = i32 field - ; value = unbox_float value - } ) + { typ + ; array = Ref_cast { typ; r = array } + ; field = i32 field + ; value = unbox_float value + } ) | Parraysetu Pgenarray -> runtime_prim "array_set_unsafe" | Parraysets (Paddrarray | Pintarray) -> runtime_prim "array_set_int_or_addr_safe" @@ -1526,18 +1523,18 @@ module Conv = struct let arr, idx = args2 args in i31 (Binop - ( Array_get_packed { typ = String; extend = S } - , (Ref_cast { typ = String; r = arr }, i32 idx) ) ) + ( Array_get_packed { typ = String; extend = S } + , (Ref_cast { typ = String; r = arr }, i32 idx) ) ) | Pbytessets -> runtime_prim "bytes_set" | Pbytessetu -> let array, field, value = args3 args in Unit (Array_set - { typ = String - ; array = Ref_cast { typ = String; r = array } - ; field = i32 field - ; value = i32 value - } ) + { typ = String + ; array = Ref_cast { typ = String; r = array } + ; field = i32 field + ; value = i32 value + } ) | Pbigarrayref _ | Pbigarrayset _ | Pbigarraydim _ | Pbigstring_load _ | Pbigstring_set _ | Pstring_load _ | Pbytes_load _ | Pbytes_set _ | Pbswap16 | Pbbswap _ | Pint_as_pointer | _ -> @@ -1556,20 +1553,20 @@ module Conv = struct in List.fold_left (fun decls (set_of_closures : Flambda.set_of_closures) -> - let function_decls = set_of_closures.function_decls in - let constant_function = - Set_of_closures_id.Set.mem function_decls.set_of_closures_id - constant_sets - in - let closure_functions = Variable.Map.keys function_decls.funs in - Variable.Map.fold - (fun var function_declaration decls -> - let decl = - conv_function_declaration ~top_env ~closure_functions var - ~constant_function function_declaration - in - decl :: decls ) - function_decls.funs decls ) + let function_decls = set_of_closures.function_decls in + let constant_function = + Set_of_closures_id.Set.mem function_decls.set_of_closures_id + constant_sets + in + let closure_functions = Variable.Map.keys function_decls.funs in + Variable.Map.fold + (fun var function_declaration decls -> + let decl = + conv_function_declaration ~top_env ~closure_functions var + ~constant_function function_declaration + in + decl :: decls ) + function_decls.funs decls ) [] (Flambda_utils.all_sets_of_closures flambda) @@ -1639,10 +1636,10 @@ module Conv = struct let closure_args = let first_arg_field = 3 in List.init (n - 1) (fun i : Expr.t -> - let field = first_arg_field + i in - Unop - ( Struct_get { typ = partial_closure_arg_typ; field } - , Expr.Var (Expr.Local.V partial_closure_var) ) ) + let field = first_arg_field + i in + Unop + ( Struct_get { typ = partial_closure_arg_typ; field } + , Expr.Var (Expr.Local.V partial_closure_var) ) ) in let args = closure_args @ [ Expr.Var param_arg; Expr.Var (V closure_var) ] @@ -1653,11 +1650,11 @@ module Conv = struct Expr.let_ partial_closure_var (Type.Rvar partial_closure_arg_typ) (Ref_cast { typ = partial_closure_arg_typ; r = Var env_arg }) (Expr.let_ closure_var (Type.Rvar closure_arg_typ) - (Unop - ( Struct_get { typ = partial_closure_arg_typ; field = 2 } - , Expr.Var (Expr.Local.V partial_closure_var) ) ) - (Call_ref - { tail = true; typ = Type.Var.Func { arity = n }; args; func } ) ) + (Unop + ( Struct_get { typ = partial_closure_arg_typ; field = 2 } + , Expr.Var (Expr.Local.V partial_closure_var) ) ) + (Call_ref + { tail = true; typ = Type.Var.Func { arity = n }; args; func } ) ) let caml_curry_alloc ~param_arg ~env_arg n m : Expr.t = (* arity, func, env, arg1..., argn-1, argn *) @@ -1667,9 +1664,9 @@ module Conv = struct let closure_args = let first_arg_field = 3 in List.init m (fun i : Expr.t -> - let field = first_arg_field + i in - Unop - (Struct_get { typ = closure_arg_typ; field }, Expr.Var closure_local) ) + let field = first_arg_field + i in + Unop + (Struct_get { typ = closure_arg_typ; field }, Expr.Var closure_local) ) in let closure_field = if m = 0 then @@ -1720,11 +1717,11 @@ module Conv = struct let mk_call ~tail param = Exceptions.function_call_handling ~tail Exceptions.function_return (Expr.Call_ref - { typ = Func { arity = 1 } - ; args = [ Var (Param param); Var closure_var ] - ; func = Closure.get_gen_func (Var closure_var) - ; tail - } ) + { typ = Func { arity = 1 } + ; args = [ Var (Param param); Var closure_var ] + ; func = Closure.get_gen_func (Var closure_var) + ; tail + } ) in match params with | [] -> assert false @@ -1843,9 +1840,9 @@ module Conv = struct let sizes = List.init (max_size + 1) (fun i -> i) in List.fold_left (fun decls size -> - let name = name size in - let decl = decl name size in - decl @ decls ) + let name = name size in + let decl = decl name size in + decl @ decls ) decls (List.rev sizes) let make_common () = @@ -1853,60 +1850,60 @@ module Conv = struct let decls = Arity.Set.fold (fun arity decls -> - let ms = List.init (max arity 1) (fun i -> i) in - List.fold_left - (fun decls applied_args -> - let decl = - Decl.Func - { name = Func_id.Caml_curry (arity, applied_args) - ; descr = caml_curry arity applied_args - } - in - decl :: decls ) - decls ms ) + let ms = List.init (max arity 1) (fun i -> i) in + List.fold_left + (fun decls applied_args -> + let decl = + Decl.Func + { name = Func_id.Caml_curry (arity, applied_args) + ; descr = caml_curry arity applied_args + } + in + decl :: decls ) + decls ms ) (Arity.Set.remove 1 !State.arities) decls in let decls = Arity.Set.fold (fun arity decls -> - let decl = - Decl.Func - { name = Func_id.Caml_apply arity; descr = caml_apply arity } - in - decl :: decls ) + let decl = + Decl.Func + { name = Func_id.Caml_apply arity; descr = caml_apply arity } + in + decl :: decls ) !State.caml_applies decls in let decls = C_import.Set.fold (fun (descr : Primitive.description) decls -> - let name = Func_id.prim_name descr in - let descr = c_import descr in - Decl.Func { name; descr } :: decls ) + let name = Func_id.prim_name descr in + let descr = c_import descr in + Decl.Func { name; descr } :: decls ) !State.c_imports decls in let decls = Runtime_import.Set.fold (fun (descr : Runtime_import.t) decls -> - let name = Func_id.Runtime descr.name in - let descr = runtime_import descr in - Decl.Func { name; descr } :: decls ) + let name = Func_id.Runtime descr.name in + let descr = runtime_import descr in + Decl.Func { name; descr } :: decls ) !State.runtime_imports decls in let decls = Global_import.Set.fold (fun (sym : Global_import.t) decls -> - let name = Global.Sym sym in - let descr = global_import sym in - Decl.Const { name; export = None; descr } :: decls ) + let name = Global.Sym sym in + let descr = global_import sym in + Decl.Const { name; export = None; descr } :: decls ) !State.global_imports decls in let decls = Func_import.Set.fold (fun (import : Func_import.t) decls -> - let name = Func_id.of_closure_id import.id in - let descr = func_import import in - Decl.Func { name; descr } :: decls ) + let name = Func_id.of_closure_id import.id in + let descr = func_import import in + Decl.Func { name; descr } :: decls ) !State.func_imports decls in let decls = @@ -1924,57 +1921,57 @@ module Conv = struct let decls = Arity.Set.fold (fun arity decls -> - let ms = List.init arity (fun i -> i) in - List.fold_left - (fun decls applied_args -> - let decl = - Decl.Type - ( Type.Var.Partial_closure (arity, applied_args) - , partial_closure_type ~arity ~applied:applied_args ) - in - decl :: decls ) - decls ms ) + let ms = List.init arity (fun i -> i) in + List.fold_left + (fun decls applied_args -> + let decl = + Decl.Type + ( Type.Var.Partial_closure (arity, applied_args) + , partial_closure_type ~arity ~applied:applied_args ) + in + decl :: decls ) + decls ms ) (Arity.Set.remove 1 !State.arities) decls in let decls = Closure_type.Set.fold (fun { arity; fields } decls -> - let name = Type.Var.Closure { arity; fields } in - let descr = closure_type ~arity ~fields in - Decl.Type (name, descr) :: decls ) + let name = Type.Var.Closure { arity; fields } in + let descr = closure_type ~arity ~fields in + Decl.Type (name, descr) :: decls ) !State.closure_types decls in let decls = Arity.Set.fold (fun arity decls -> - let name = Type.Var.Gen_closure { arity } in - let descr = gen_closure_type ~arity in - Decl.Type (name, descr) :: decls ) + let name = Type.Var.Gen_closure { arity } in + let descr = gen_closure_type ~arity in + Decl.Type (name, descr) :: decls ) !State.arities decls in let decls = C_import_func_type.Set.fold (fun (descr : Type.Var.c_import_func_type) decls -> - c_import_type descr :: decls ) + c_import_type descr :: decls ) !State.c_import_func_types decls in let decls = Block.gen_block_decl @ decls in let decls = Arity.Set.fold (fun arity decls -> - let name = Type.Var.Func { arity } in - let descr = func_type arity in - Decl.Type (name, descr) :: decls ) + let name = Type.Var.Func { arity } in + let descr = func_type arity in + Decl.Type (name, descr) :: decls ) (Arity.Set.remove 1 !State.arities) decls in let decls = Arity.Set.fold (fun arity decls -> - let name = Type.Var.Caml_apply_func { arity } in - let descr = caml_apply_type arity in - Decl.Type (name, descr) :: decls ) + let name = Type.Var.Caml_apply_func { arity } in + let descr = caml_apply_type arity in + Decl.Type (name, descr) :: decls ) (Arity.Set.remove 1 !State.caml_applies) decls in @@ -1986,8 +1983,8 @@ module Conv = struct end module ToWasm = struct - module Cst = Wast.Cst - module C = Wast.C + module Cst = Wat.Cst + module C = Wat.C let option_to_list = function None -> [] | Some v -> [ v ] @@ -2163,25 +2160,27 @@ module ToWasm = struct (conv_expr else_expr) ] | Let_cont { cont; params; handler; body } -> begin - let result_types = List.map snd params in - let fallthrough = Block_id.not_id cont in - let body = - C.block cont result_types [ C.br fallthrough [ conv_expr_group body ] ] - in - let handler_expr = conv_expr handler in - match mode with - | Reference -> - let handler = - List.map - (fun (var, _typ) -> - match var with - | Some var -> C.local_set' (Expr.Local.V var) - | None -> C.drop' ) - params - @ handler_expr + let result_types = List.map snd params in + let fallthrough = Block_id.not_id cont in + let body = + C.block cont result_types [ C.br fallthrough [ conv_expr_group body ] ] in - [ C.block fallthrough [ ref_eq ] (body :: handler) ] - | Binarien -> + let handler_expr = conv_expr handler in + (* + match mode with + | Reference -> + let handler = + List.map + (fun (var, _typ) -> + match var with + | Some var -> C.local_set' (Expr.Local.V var) + | None -> C.drop' ) + params + @ handler_expr + in + [ C.block fallthrough [ ref_eq ] (body :: handler) ] + | Binarien -> + *) let set_locals = match params with | [] -> [ body ] @@ -2192,20 +2191,20 @@ module ToWasm = struct let _i, assigns = List.fold_left (fun (i, assigns) (var, _typ) -> - match var with - | Some var -> - let project = - C.tuple_extract i (C.local_get (Expr.Local.V local_tuple)) - in - let expr = C.local_set (Expr.Local.V var) project in - (i + 1, expr :: assigns) - | None -> (i + 1, assigns) ) + match var with + | Some var -> + let project = + C.tuple_extract i (C.local_get (Expr.Local.V local_tuple)) + in + let expr = C.local_set (Expr.Local.V var) project in + (i + 1, expr :: assigns) + | None -> (i + 1, assigns) ) (0, []) params in [ C.local_set (Expr.Local.V local_tuple) body ] @ assigns in [ C.block fallthrough [ ref_eq ] (set_locals @ handler_expr) ] - end + end | Br_on_cast { value; typ; if_cast; if_else } -> [ C.drop (C.br_on_cast if_cast typ (conv_expr_group value)) ] @ conv_expr if_else @@ -2213,16 +2212,10 @@ module ToWasm = struct [ C.br_if if_true (conv_expr_group cond) ] @ conv_expr if_else | Br_table { cond; cases; default } -> [ C.br_table (conv_expr_group cond) (cases @ [ default ]) ] - | Try { body; handler; result_typ; param = local, typ } -> begin - match mode with - | Reference -> - Format.eprintf "Warning exception not supported@."; - conv_expr body - | Binarien -> - let body = conv_expr body in - let handler = C.local_set (V local) (C.pop typ) :: conv_expr handler in - [ C.try_ ~result_typ ~body ~handler ~typ ] - end + | Try { body; handler; result_typ; param = local, typ } -> + let body = conv_expr body in + let handler = C.local_set (V local) (C.pop typ) :: conv_expr handler in + [ C.try_ ~result_typ ~body ~handler ~typ ] | Unit e -> conv_no_value e @ [ unit ] | NR nr -> conv_no_return nr @@ -2275,9 +2268,9 @@ module ToWasm = struct let handler = List.map (fun (var, _typ) -> - match var with - | Some var -> C.local_set' (Expr.Local.V var) - | None -> C.drop' ) + match var with + | Some var -> C.local_set' (Expr.Local.V var) + | None -> C.drop' ) params @ conv_no_return handler in @@ -2289,11 +2282,7 @@ module ToWasm = struct | NR_br { cont; args } -> [ C.br cont [ C.br cont (List.map conv_expr_group args) ] ] | NR_return args -> [ C.return (List.map conv_expr_group args) ] - | Throw e -> begin - match mode with - | Reference -> [ C.unreachable ] - | Binarien -> [ C.throw (conv_expr_group e) ] - end + | Throw e -> [ C.throw (conv_expr_group e) ] | Unreachable -> [ C.unreachable ] let conv_const name export (const : Const.t) = @@ -2345,18 +2334,18 @@ module ToWasm = struct let body, result = match body with | Value body -> begin - match body with - | [ (expr, typ) ] -> (conv_expr expr, [ C.result typ ]) - | _ -> - let exprs = - List.map - (fun (expr, typ) -> C.group_block [ typ ] (conv_expr expr)) - body - in - let _, typs = List.split body in - let exprs = [ C.tuple_make exprs ] in - (exprs, List.map C.result typs) - end + match body with + | [ (expr, typ) ] -> (conv_expr expr, [ C.result typ ]) + | _ -> + let exprs = + List.map + (fun (expr, typ) -> C.group_block [ typ ] (conv_expr expr)) + body + in + let _, typs = List.split body in + let exprs = [ C.tuple_make exprs ] in + (exprs, List.map C.result typs) + end | No_value body -> (conv_no_value body, []) in C.func ~name ~type_decl ~params ~locals ~result ~body @@ -2396,24 +2385,21 @@ module ToWasm = struct let conv_module module_ = C.module_ (conv_decl module_) end -(* let output_wast ppf wast = *) -(* ToWasm.Cst.emit ppf wast *) - -let output_wast ppf wast = Format.pp_print_string ppf wast +let output_wat ppf wat = Format.pp_print_string ppf wat let output_file ~output_prefix ~module_ ~register = - let wastfile = output_prefix ^ ".wast" in - let oc = open_out_bin wastfile in + let watfile = output_prefix ^ ".wat" in + let oc = open_out_bin watfile in let ppf = Format.formatter_of_out_channel oc in Misc.try_finally ~always:(fun () -> Format.fprintf ppf "@."; close_out oc ) - (* ~exceptionally:(fun () -> Misc.remove_file wastfile) *) - (fun () -> - output_wast ppf module_; - Format.fprintf ppf "@\n"; - output_wast ppf register ) + (* ~exceptionally:(fun () -> Misc.remove_file watfile) *) + (fun () -> + output_wat ppf module_; + Format.fprintf ppf "@\n"; + output_wat ppf register ) let run ~output_prefix (flambda : Flambda.program) = State.reset (); @@ -2445,17 +2431,17 @@ let run ~output_prefix (flambda : Flambda.program) = let ln = Compilation_unit.get_linkage_name (Compilation_unit.get_current_exn ()) in - Wast.C.register (Linkage_name.to_string ln) + Wat.C.register (Linkage_name.to_string ln) in (* Format.printf "@.%a@." ToWasm.Cst.emit wasm; *) - let emit = if Wstate.pp_wast then ToWasm.Cst.pp else ToWasm.Cst.emit in + let emit = if Wstate.pp_wat then ToWasm.Cst.pp else ToWasm.Cst.emit in let wasm = Format.asprintf "%a" emit wasm in let register = Format.asprintf "%a" emit register in - Wast.{ module_ = wasm; register } + Wat.{ module_ = wasm; register } let emit ~to_file ~output_prefix (flambda : Flambda.program) = let r = run ~output_prefix flambda in if to_file then Profile.record_call "output_wasm" (fun () -> - output_file ~output_prefix ~module_:r.module_ ~register:r.register ); + output_file ~output_prefix ~module_:r.module_ ~register:r.register ); r diff --git a/wasm/emit_wat.mli b/wasm/emit_wat.mli new file mode 100644 index 0000000000..9fc0d17067 --- /dev/null +++ b/wasm/emit_wat.mli @@ -0,0 +1,3 @@ +val emit : to_file:bool -> output_prefix:string -> Flambda.program -> Wat.t + +val output_wat : Format.formatter -> Wat.printable_expr -> unit diff --git a/wasm/exn_tag.wast b/wasm/exn_tag.wat similarity index 76% rename from wasm/exn_tag.wast rename to wasm/exn_tag.wat index a2922cb31a..ceb5b76b16 100644 --- a/wasm/exn_tag.wast +++ b/wasm/exn_tag.wat @@ -2,4 +2,3 @@ (tag $exc (param (ref eq))) (export "exc" (tag $exc)) ) -(register "exn_tag") diff --git a/wasm/import.wast b/wasm/import.wat similarity index 99% rename from wasm/import.wast rename to wasm/import.wat index df5d34e534..1814687bae 100644 --- a/wasm/import.wast +++ b/wasm/import.wat @@ -318,5 +318,3 @@ (param (ref eq)) (result (ref eq)) (unreachable)) ) - -(register "import") diff --git a/wasm/imports_binaryen.wast b/wasm/imports_binaryen.wat similarity index 86% rename from wasm/imports_binaryen.wast rename to wasm/imports_binaryen.wat index b3afba05d0..5c433b53f4 100644 --- a/wasm/imports_binaryen.wast +++ b/wasm/imports_binaryen.wat @@ -27,7 +27,7 @@ (func (export "caml_int64_float_of_bits") (param $x (ref eq)) (result (ref $Float)) (struct.new $Float (f64.reinterpret_i64 - (struct.get $Int64 0 (ref.cast $Int64 (local.get $x)))))) + (struct.get $Int64 0 (ref.cast (ref $Int64) (local.get $x)))))) (func (export "caml_int64_float_of_bits_unboxed") (param $x i64) (result f64) (f64.reinterpret_i64 (local.get $x))) @@ -51,7 +51,7 @@ (global.set $oo_id (i32.add (i32.const 1) (local.tee $oo_id (global.get $oo_id)))) - (i31.new (local.get $oo_id)) + (ref.i31 (local.get $oo_id)) ) ;; ===== @@ -59,7 +59,7 @@ ;; ===== (func (export "caml_create_bytes") (param $size (ref eq)) (result (ref eq)) - (array.new_default $String (i31.get_s (ref.cast i31 (local.get $size)))) + (array.new_default $String (i31.get_s (ref.cast (ref i31) (local.get $size)))) ) ;; (func $caml_fill_bytes (param $arr (ref $String)) @@ -97,8 +97,8 @@ (local $c1 i32) (local $c2 i32) (if (ref.eq (local.get $s1) (local.get $s2)) (then (return (i32.const 0)))) - (local.set $l1 (array.len $String (local.get $s1))) - (local.set $l2 (array.len $String (local.get $s2))) + (local.set $l1 (array.len (local.get $s1))) + (local.set $l2 (array.len (local.get $s2))) (local.set $len (select (local.get $l1) (local.get $l2) (i32.le_u (local.get $l1) (local.get $l2)))) @@ -120,9 +120,9 @@ (i32.sub (local.get $l1) (local.get $l2))) (func $caml_string_compare (param $a (ref eq)) (param $b (ref eq)) (result (ref i31)) - (i31.new (call $compare_strings - (ref.cast $String (local.get $a)) - (ref.cast $String (local.get $b))))) + (ref.i31 (call $compare_strings + (ref.cast (ref $String) (local.get $a)) + (ref.cast (ref $String) (local.get $b))))) (export "caml_bytes_compare" (func $caml_string_compare)) (export "caml_string_compare" (func $caml_string_compare)) @@ -157,15 +157,15 @@ (func (export "caml_compare") (param $a (ref eq)) (param $b (ref eq)) (result (ref i31)) (local $a_block (ref $Gen_block)) (local $b_block (ref $Gen_block)) - (if (result (ref i31)) (ref.test i31 (local.get $a)) + (if (result (ref i31)) (ref.test (ref i31) (local.get $a)) (then - (if (result (ref i31)) (ref.test i31 (local.get $b)) + (if (result (ref i31)) (ref.test (ref i31) (local.get $b)) (then (return_call $compare_int (local.get $a) (local.get $b))) - (else (i31.new (i32.const -1)))) + (else (ref.i31 (i32.const -1)))) ) (else - (if (result (ref i31)) (ref.test i31 (local.get $b)) - (then (i31.new (i32.const 1))) + (if (result (ref i31)) (ref.test (ref i31) (local.get $b)) + (then (ref.i31 (i32.const 1))) (else (local.set $b_block (block $both_block (result (ref $Gen_block)) @@ -176,10 +176,10 @@ )) ;; a block, b unknown (drop (br_on_cast $both_block (ref eq) (ref $Gen_block) (local.get $b))) - (return (i31.new (i32.const -1))) + (return (ref.i31 (i32.const -1))) )) ;; Both blocks (test b = block) - (local.set $a_block (ref.cast $Gen_block (local.get $a))) + (local.set $a_block (ref.cast (ref $Gen_block) (local.get $a))) ;; This cast shouldn't be required (return_call $caml_compare_blocks (local.get $a_block) (local.get $b_block)) ) @@ -197,11 +197,11 @@ (func $caml_compare_blocks (param $a (ref $Gen_block)) (param $b (ref $Gen_block)) (result (ref i31)) (local $len_a i32) (local $len_b i32) - (local.set $len_a (array.len $Gen_block (local.get $a))) - (local.set $len_b (array.len $Gen_block (local.get $b))) + (local.set $len_a (array.len (local.get $a))) + (local.set $len_b (array.len (local.get $b))) (if (i32.ne (local.get $len_a) (local.get $len_b)) (then - (return (i31.new + (return (ref.i31 (i32.sub (i32.gt_s (local.get $len_a) (local.get $len_b)) (i32.lt_s (local.get $len_a) (local.get $len_b))))))) @@ -212,15 +212,15 @@ (func $caml_equal (export "caml_equal") (param $a (ref eq)) (param $b (ref eq)) (result (ref i31)) (local $a_block (ref $Gen_block)) (local $b_block (ref $Gen_block)) - (if (result (ref i31)) (ref.test i31 (local.get $a)) + (if (result (ref i31)) (ref.test (ref i31) (local.get $a)) (then - (if (result (ref i31)) (ref.test i31 (local.get $b)) - (then (i31.new (ref.eq (local.get $a) (local.get $b)))) - (else (i31.new (i32.const 0)))) + (if (result (ref i31)) (ref.test (ref i31) (local.get $b)) + (then (ref.i31 (ref.eq (local.get $a) (local.get $b)))) + (else (ref.i31 (i32.const 0)))) ) (else - (if (result (ref i31)) (ref.test i31 (local.get $b)) - (then (i31.new (i32.const 0))) + (if (result (ref i31)) (ref.test (ref i31) (local.get $b)) + (then (ref.i31 (i32.const 0))) (else (local.set $b_block (block $both_block (result (ref $Gen_block)) @@ -232,10 +232,10 @@ (drop (local.get $a_block)) ;; a block, b unknown (drop (br_on_cast $both_block (ref eq) (ref $Gen_block) (local.get $b))) - (return (i31.new (i32.const 0))) + (return (ref.i31 (i32.const 0))) )) ;; Both blocks (test b = block) - (local.set $a_block (ref.cast $Gen_block (local.get $a))) + (local.set $a_block (ref.cast (ref $Gen_block) (local.get $a))) ;; This cast shouldn't be required (return_call $equal_blocks (local.get $a_block) (local.get $b_block)) ) @@ -245,11 +245,11 @@ ) (func $equal_data_non_block (export "equal_data_non_block") (param $a (ref eq)) (param $b (ref eq)) (result (ref i31)) - (i31.new (i32.eq + (ref.i31 (i32.eq (i32.const 0) (call $compare_strings - (ref.cast $String (local.get $a)) - (ref.cast $String (local.get $b))))) + (ref.cast (ref $String) (local.get $a)) + (ref.cast (ref $String) (local.get $b))))) ) (func $equal_blocks (param $a (ref $Gen_block)) (param $b (ref $Gen_block)) (result (ref i31)) @@ -258,20 +258,20 @@ (local $v_a (ref eq)) (local $v_b (ref eq)) (local $i i32) - (local.set $len_a (array.len $Gen_block (local.get $a))) - (local.set $len_b (array.len $Gen_block (local.get $b))) + (local.set $len_a (array.len (local.get $a))) + (local.set $len_b (array.len (local.get $b))) (if (i32.ne (local.get $len_a) (local.get $len_b)) - (then (return (i31.new (i32.const 0))))) + (then (return (ref.i31 (i32.const 0))))) ;; Same length (loop $loop (if (i32.eq (local.get $i) (local.get $len_a)) - (then (return (i31.new (i32.const 1))))) + (then (return (ref.i31 (i32.const 1))))) (local.set $v_a (array.get $Gen_block (local.get $a) (local.get $i))) (local.set $v_b (array.get $Gen_block (local.get $b) (local.get $i))) (if (ref.eq - (i31.new (i32.const 0)) + (ref.i31 (i32.const 0)) (call $caml_equal (local.get $v_a) (local.get $v_b))) - (then (return (i31.new (i32.const 0))))) + (then (return (ref.i31 (i32.const 0))))) (local.set $i (i32.add (i32.const 1) (local.get $i))) (br $loop) ) @@ -323,7 +323,7 @@ (local.get $s)) (func (export "caml_format_int") (param $format (ref eq)) (param $d (ref eq)) (result (ref eq)) - (call $format_int_default (i31.get_s (ref.cast i31 (local.get $d))))) + (call $format_int_default (i31.get_s (ref.cast (ref i31) (local.get $d))))) (func (export "caml_format_float") (param (ref eq)) (param (ref eq)) (result (ref eq)) ;; TODO @@ -341,10 +341,10 @@ ;; ======== (func (export "caml_ml_open_descriptor_out") (param (ref eq)) (result (ref eq)) - (ref.cast i31 (local.get 0))) + (ref.cast (ref i31) (local.get 0))) (func (export "caml_ml_open_descriptor_in") (param (ref eq)) (result (ref eq)) - (ref.cast i31 (local.get 0))) + (ref.cast (ref i31) (local.get 0))) (func (export "caml_sys_open") (param (ref eq)) (param (ref eq)) (param (ref eq)) @@ -355,38 +355,38 @@ (func (export "caml_ml_flush") (param (ref eq)) (result (ref eq)) (call $flush) - (i31.new (i32.const 0))) + (ref.i31 (i32.const 0))) (func $cons (param $h (ref eq)) (param $t (ref eq)) (result (ref $Gen_block)) - (array.init_static $Gen_block - (i31.new (i32.const 0)) + (array.new_fixed $Gen_block 3 + (ref.i31 (i32.const 0)) (local.get $h) (local.get $t))) - (global $empty_list (ref eq) (i31.new (i32.const 0))) + (global $empty_list (ref eq) (ref.i31 (i32.const 0))) (func (export "caml_ml_out_channels_list") (param (ref eq)) (result (ref eq)) - (call $cons (i31.new (i32.const 0)) (global.get $empty_list)) + (call $cons (ref.i31 (i32.const 0)) (global.get $empty_list)) ) (func $caml_ml_output (export "caml_ml_output") (param $ch (ref eq)) (param $s (ref eq)) (param $vpos (ref eq)) (param $vlen (ref eq)) (result (ref eq)) (local $pos i32) (local $len i32) - (local.set $pos (i31.get_s (ref.cast i31 (local.get $vpos)))) - (local.set $len (i31.get_s (ref.cast i31 (local.get $vlen)))) + (local.set $pos (i31.get_s (ref.cast (ref i31) (local.get $vpos)))) + (local.set $len (i31.get_s (ref.cast (ref i31) (local.get $vlen)))) (loop $loop (if (i32.gt_s (local.get $len) (i32.const 0)) (then (call $putchar (array.get $String - (ref.cast $String (local.get $s)) + (ref.cast (ref $String) (local.get $s)) (local.get $pos))) (local.set $pos (i32.add (local.get $pos) (i32.const 1))) (local.set $len (i32.sub (local.get $len) (i32.const 1))) (br $loop)))) - (i31.new (i32.const 0))) + (ref.i31 (i32.const 0))) (func (export "caml_ml_output_bytes") (param (ref eq)) (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) @@ -400,8 +400,8 @@ (func (export "caml_ml_output_char") (param $ch (ref eq)) (param $char (ref eq)) (result (ref eq)) - (call $putchar (i31.get_s (ref.cast i31 (local.get $char)))) - (i31.new (i32.const 0)) + (call $putchar (i31.get_s (ref.cast (ref i31) (local.get $char)))) + (ref.i31 (i32.const 0)) ) (func (export "caml_ml_output_string") (param (ref eq)) (param (ref eq)) @@ -501,22 +501,38 @@ (func (export "caml_register_named_value") (param (ref eq)) (param (ref eq)) (result (ref eq)) ;; TODO - (i31.new (i32.const 0))) + (ref.i31 (i32.const 0))) (func $C_caml_sys_getenv (export "caml_sys_getenv") (param (ref eq)) (result (ref eq)) (unreachable)) - (global $os_type (ref $String) (array.init_static $String (i32.const 87)(i32.const 97)(i32.const 115)(i32.const 109))) + (global $os_type (ref $String) (array.new_fixed $String 4 (i32.const 87)(i32.const 97)(i32.const 115)(i32.const 109))) (func $C_caml_sys_get_config (export "caml_sys_get_config") (param (ref eq)) (result (ref eq)) - (array.init_static $Gen_block (i31.new (i32.const 0)) + (array.new_fixed $Gen_block 4 + (ref.i31 (i32.const 0)) (global.get $os_type) - (i31.new (i32.const 32)) - (i31.new (i32.const 0)) + (ref.i31 (i32.const 32)) + (ref.i31 (i32.const 0)) ) ) - (global $executable_name (ref $String) (array.init_static $String (i32.const 119)(i32.const 97)(i32.const 115)(i32.const 111)(i32.const 99)(i32.const 97)(i32.const 109)(i32.const 108)(i32.const 95)(i32.const 98)(i32.const 105)(i32.const 110)(i32.const 97)(i32.const 114)(i32.const 121))) + (global $executable_name (ref $String) (array.new_fixed $String 15 + (i32.const 119) + (i32.const 97) + (i32.const 115) + (i32.const 111) + (i32.const 99) + (i32.const 97) + (i32.const 109) + (i32.const 108) + (i32.const 95) + (i32.const 98) + (i32.const 105) + (i32.const 110) + (i32.const 97) + (i32.const 114) + (i32.const 121))) (func $C_caml_sys_executable_name (export "caml_sys_executable_name") (param (ref eq)) (result (ref eq)) (global.get $executable_name)) @@ -545,12 +561,12 @@ (func $C_caml_lazy_make_forward (export "caml_lazy_make_forward") (param (ref eq)) (result (ref eq)) (unreachable)) (func (export "caml_gc_major") (param (ref eq)) (result (ref eq)) - (i31.new (i32.const 0))) + (ref.i31 (i32.const 0))) (func (export "caml_gc_minor") (param (ref eq)) (result (ref eq)) - (i31.new (i32.const 0))) + (ref.i31 (i32.const 0))) (func (export "caml_sys_const_naked_pointers_checked") (param (ref eq)) (result (ref eq)) - (i31.new (i32.const 0))) + (ref.i31 (i32.const 0))) ;; ================== ;; CamlinternalFormat @@ -582,12 +598,12 @@ ;; ==== (func (export "print_int") (param $a (ref eq)) (result (ref eq)) - (call $print_i32 (i31.get_s (ref.cast i31 (local.get $a)))) - (i31.new (i32.const 0)) + (call $print_i32 (i31.get_s (ref.cast (ref i31) (local.get $a)))) + (ref.i31 (i32.const 0)) ) (func (export "print_float") (param $a (ref eq)) (result (ref eq)) - (call $print_f64 (struct.get $Float 0 (ref.cast $Float (local.get $a)))) - (i31.new (i32.const 0)) + (call $print_f64 (struct.get $Float 0 (ref.cast (ref $Float) (local.get $a)))) + (ref.i31 (i32.const 0)) ) ;; (func (export "print_string") (param $a (ref eq)) (result (ref eq)) @@ -615,12 +631,10 @@ (func (export "print_string") (param $a (ref eq)) (result (ref eq)) (call $print_string_mem (i32.const 0) - (call $copy_string (ref.cast $String (local.get $a)))) - (i31.new (i32.const 0))) + (call $copy_string (ref.cast (ref $String) (local.get $a)))) + (ref.i31 (i32.const 0))) (func (export "print_endline") (param $a (ref eq)) (result (ref eq)) (call $print_endline) - (i31.new (i32.const 0))) + (ref.i31 (i32.const 0))) ) - -(register "imports") diff --git a/wasm/link_wast.mli b/wasm/link_wast.mli deleted file mode 100644 index 0f1afe0a54..0000000000 --- a/wasm/link_wast.mli +++ /dev/null @@ -1,4 +0,0 @@ - -type wasm_compilation_unit = string - -val link : (wasm_compilation_unit * Wast.t) list -> output:string -> unit diff --git a/wasm/link_wast.ml b/wasm/link_wat.ml similarity index 82% rename from wasm/link_wast.ml rename to wasm/link_wat.ml index c4a3282dcf..61e320f81b 100644 --- a/wasm/link_wast.ml +++ b/wasm/link_wat.ml @@ -7,9 +7,9 @@ type tmp_file = ; filename : string } -let out_file (name, (wast : Wast.t)) = +let out_file (name, (wat : Wat.t)) = let filename, oc = - Filename.open_temp_file (tmp_dirname ^ "/" ^ name) ".wast" + Filename.open_temp_file (tmp_dirname ^ "/" ^ name) ".wat" in Format.printf "tmp_file: %s@." filename; let ppf = Format.formatter_of_out_channel oc in @@ -18,9 +18,9 @@ let out_file (name, (wast : Wast.t)) = Format.fprintf ppf "@."; close_out oc ) (fun () -> - Emit_wast.output_wast ppf wast.module_; + Emit_wat.output_wat ppf wat.module_; Format.fprintf ppf "@\n"; - Emit_wast.output_wast ppf wast.register ); + Emit_wat.output_wat ppf wat.register ); { name; filename } let emit_text = "--emit-text" @@ -46,7 +46,7 @@ let merge_files ~runtime_dir ~text files output = let command = let runtime_files = List.concat_map - (fun (file, name) -> [ Filename.concat runtime_dir (file ^ ".wast"); name ]) + (fun (file, name) -> [ Filename.concat runtime_dir (file ^ ".wat"); name ]) runtime in let ocaml_files = @@ -69,14 +69,14 @@ let rec make_directory dir = Sys.mkdir dir 0o777 end -let link (modules : (wasm_compilation_unit * Wast.t) list) ~output = - let output_wast = output ^ ".wast" in +let link (modules : (wasm_compilation_unit * Wat.t) list) ~output = + let output_wat = output ^ ".wat" in let output_wasm = output ^ ".wasm" in - Format.eprintf "OUTPUT: %s@." output_wast; + Format.eprintf "OUTPUT: %s@." output_wat; let dirname = Filename.concat (Filename.get_temp_dir_name ()) tmp_dirname in make_directory dirname; (* Sys.mkdir dirname 0o700; *) let tmp_modules = List.map out_file modules in let runtime_dir = Config.standard_library in - merge_files ~runtime_dir ~text:true tmp_modules output_wast; + merge_files ~runtime_dir ~text:true tmp_modules output_wat; merge_files ~runtime_dir ~text:false tmp_modules output_wasm diff --git a/wasm/link_wat.mli b/wasm/link_wat.mli new file mode 100644 index 0000000000..3b195dff60 --- /dev/null +++ b/wasm/link_wat.mli @@ -0,0 +1,3 @@ +type wasm_compilation_unit = string + +val link : (wasm_compilation_unit * Wat.t) list -> output:string -> unit diff --git a/wasm/runtime.wast b/wasm/runtime.wat similarity index 99% rename from wasm/runtime.wast rename to wasm/runtime.wat index cf2b668486..97e60a2b5c 100644 --- a/wasm/runtime.wast +++ b/wasm/runtime.wat @@ -196,5 +196,3 @@ (unreachable)) ) - -(register "runtime") diff --git a/wasm/runtime_binaryen.wast b/wasm/runtime_binaryen.wat similarity index 76% rename from wasm/runtime_binaryen.wast rename to wasm/runtime_binaryen.wat index 1805000199..d427f68796 100644 --- a/wasm/runtime_binaryen.wast +++ b/wasm/runtime_binaryen.wat @@ -11,7 +11,7 @@ ;; ========== (global $index_out_of_bound_string (ref $String) - (array.init_static $String + (array.new_fixed $String 19 (i32.const 105)(i32.const 110)(i32.const 100)(i32.const 101)(i32.const 120) (i32.const 32)(i32.const 111)(i32.const 117)(i32.const 116)(i32.const 32) (i32.const 111)(i32.const 102)(i32.const 32)(i32.const 98)(i32.const 111) @@ -19,38 +19,38 @@ ;; TODO exceptions (global (export "caml_exn_Match_failure") (ref eq) - (array.init_static $Gen_block - (i31.new (i32.const 248)) - (array.init_static $String (i32.const 78) (i32.const 78) (i32.const 78)) - (i31.new (i32.const 0)))) + (array.new_fixed $Gen_block 3 + (ref.i31 (i32.const 248)) + (array.new_fixed $String 3 (i32.const 78) (i32.const 78) (i32.const 78)) + (ref.i31 (i32.const 0)))) (global (export "caml_exn_Assert_failure") (ref eq) - (array.init_static $Gen_block - (i31.new (i32.const 248)) - (array.init_static $String (i32.const 78) (i32.const 78) (i32.const 78)) - (i31.new (i32.const 1)))) + (array.new_fixed $Gen_block 3 + (ref.i31 (i32.const 248)) + (array.new_fixed $String 3 (i32.const 78) (i32.const 78) (i32.const 78)) + (ref.i31 (i32.const 1)))) (global $invalid_argument (export "caml_exn_Invalid_argument") (ref eq) - (array.init_static $Gen_block - (i31.new (i32.const 248)) - (array.init_static $String (i32.const 78) (i32.const 78) (i32.const 78)) - (i31.new (i32.const 2)))) + (array.new_fixed $Gen_block 3 + (ref.i31 (i32.const 248)) + (array.new_fixed $String 3 (i32.const 78) (i32.const 78) (i32.const 78)) + (ref.i31 (i32.const 2)))) (global (export "caml_exn_Failure") (ref eq) - (array.init_static $Gen_block - (i31.new (i32.const 248)) - (array.init_static $String (i32.const 78) (i32.const 78) (i32.const 78)) - (i31.new (i32.const 3)))) + (array.new_fixed $Gen_block 3 + (ref.i31 (i32.const 248)) + (array.new_fixed $String 3 (i32.const 78) (i32.const 78) (i32.const 78)) + (ref.i31 (i32.const 3)))) (global (export "caml_exn_Not_found") (ref eq) - (array.init_static $Gen_block - (i31.new (i32.const 248)) - (array.init_static $String (i32.const 78) (i32.const 78) (i32.const 78)) - (i31.new (i32.const 4)))) - - (global (export "caml_exn_Out_of_memory") (ref eq) (i31.new (i32.const 5))) - (global (export "caml_exn_Stack_overflow") (ref eq) (i31.new (i32.const 6))) - (global (export "caml_exn_Sys_error") (ref eq) (i31.new (i32.const 7))) - (global (export "caml_exn_End_of_file") (ref eq) (i31.new (i32.const 8))) - (global (export "caml_exn_Division_by_zero") (ref eq) (i31.new (i32.const 9))) - (global (export "caml_exn_Sys_blocked_io") (ref eq) (i31.new (i32.const 10))) - (global (export "caml_exn_Undefined_recursive_module") (ref eq) (i31.new (i32.const 11))) + (array.new_fixed $Gen_block 3 + (ref.i31 (i32.const 248)) + (array.new_fixed $String 3 (i32.const 78) (i32.const 78) (i32.const 78)) + (ref.i31 (i32.const 4)))) + + (global (export "caml_exn_Out_of_memory") (ref eq) (ref.i31 (i32.const 5))) + (global (export "caml_exn_Stack_overflow") (ref eq) (ref.i31 (i32.const 6))) + (global (export "caml_exn_Sys_error") (ref eq) (ref.i31 (i32.const 7))) + (global (export "caml_exn_End_of_file") (ref eq) (ref.i31 (i32.const 8))) + (global (export "caml_exn_Division_by_zero") (ref eq) (ref.i31 (i32.const 9))) + (global (export "caml_exn_Sys_blocked_io") (ref eq) (ref.i31 (i32.const 10))) + (global (export "caml_exn_Undefined_recursive_module") (ref eq) (ref.i31 (i32.const 11))) ;; ========= ;; functions @@ -58,9 +58,9 @@ (func (export "compare_ints") (param $a (ref eq)) (param $b (ref eq)) (result (ref i31)) (local $a' i32) (local $b' i32) - (local.set $a' (i31.get_s (ref.cast i31 (local.get $a)))) - (local.set $b' (i31.get_s (ref.cast i31 (local.get $b)))) - (i31.new + (local.set $a' (i31.get_s (ref.cast (ref i31) (local.get $a)))) + (local.set $b' (i31.get_s (ref.cast (ref i31) (local.get $b)))) + (ref.i31 (i32.sub (i32.gt_s (local.get $a') (local.get $b')) (i32.lt_s (local.get $a') (local.get $b')))) @@ -68,9 +68,9 @@ (func (export "compare_floats") (param $a (ref eq)) (param $b (ref eq)) (result (ref i31)) (local $a' f64) (local $b' f64) - (local.set $a' (struct.get $Float 0 (ref.cast $Float (local.get $a)))) - (local.set $b' (struct.get $Float 0 (ref.cast $Float (local.get $b)))) - (i31.new + (local.set $a' (struct.get $Float 0 (ref.cast (ref $Float) (local.get $a)))) + (local.set $b' (struct.get $Float 0 (ref.cast (ref $Float) (local.get $b)))) + (ref.i31 (i32.add (i32.sub (f64.gt (local.get $a') (local.get $b')) @@ -84,11 +84,9 @@ ;; ====== (func $array_length (export "array_length") (param $arr (ref eq)) (result (ref eq)) - (i31.new (array.len $FloatArray (block $floatarray (result (ref $FloatArray)) - (return (i31.new (array.len $Array (ref.cast $Array - (br_on_cast $floatarray (ref eq) (ref $FloatArray) (local.get $arr)))))) - ))) + (return (ref.i31 (array.len (ref.cast (ref $Array) + (br_on_cast $floatarray (ref eq) (ref $FloatArray) (local.get $arr))))))) ) ;; (func $array_get_float_safe (param $arr (ref $FloatArray)) (param $field (ref eq)) (result (ref $Float)) @@ -141,7 +139,7 @@ ;; (local.get $arr) ;; (i31.get_s (ref.cast i31 (local.get $field))) ;; (struct.get $Float 0 (ref.cast $Float (local.get $value)))) - ;; (i31.new (i32.const 0)) + ;; (ref.i31 (i32.const 0)) ;; ) ;; (func $array_set_int_or_addr_unsafe (param $arr (ref $Array)) (param $field (ref eq)) @@ -150,7 +148,7 @@ ;; (local.get $arr) ;; (i31.get_s (ref.cast i31 (local.get $field))) ;; (local.get $value)) - ;; (i31.new (i32.const 0)) + ;; (ref.i31 (i32.const 0)) ;; ) ;; (func $array_set_unsafe (export "array_set_unsafe") @@ -186,24 +184,24 @@ ;; (ref.cast $String (local.get $arr)) ;; (i31.get_s (ref.cast i31 (local.get $field))) ;; (i31.get_s (ref.cast i31 (local.get $value)))) - ;; (i31.new (i32.const 0)) + ;; (ref.i31 (i32.const 0)) ;; ) (func (export "string_get") (param $arr (ref eq)) (param $field_i31 (ref eq)) (result (ref eq)) (local $field i32) - (local.set $field (i31.get_s (ref.cast i31 (local.get $field_i31)))) + (local.set $field (i31.get_s (ref.cast (ref i31) (local.get $field_i31)))) (if (result (ref i31)) - (i32.lt_s (local.get $field) (array.len (ref.cast $String (local.get $arr)))) + (i32.lt_s (local.get $field) (array.len (ref.cast (ref $String) (local.get $arr)))) (then - (i31.new + (ref.i31 (array.get_s $String - (ref.cast $String (local.get $arr)) + (ref.cast (ref $String) (local.get $arr)) (local.get $field)))) (else (throw $exc - (array.init_static $Gen_block - (i31.new (i32.const 0)) + (array.new_fixed $Gen_block 3 + (ref.i31 (i32.const 0)) (global.get $invalid_argument) (global.get $index_out_of_bound_string))))) ) @@ -232,8 +230,8 @@ ) (func (export "string_eq") (param $a (ref eq)) (param $b (ref eq)) (result (ref eq)) - (i31.new - (call $string_eq (ref.cast $String (local.get $a)) (ref.cast $String (local.get $b)))) + (ref.i31 + (call $string_eq (ref.cast (ref $String) (local.get $a)) (ref.cast (ref $String) (local.get $b)))) ) ;; ========== @@ -250,5 +248,3 @@ (unreachable)) ) - -(register "runtime") diff --git a/wasm/test/saucisse.wast b/wasm/test/saucisse.wat similarity index 100% rename from wasm/test/saucisse.wast rename to wasm/test/saucisse.wat diff --git a/wasm/wasm_closure_offsets.ml b/wasm/wasm_closure_offsets.ml index c55ac60c76..515dd74210 100644 --- a/wasm/wasm_closure_offsets.ml +++ b/wasm/wasm_closure_offsets.ml @@ -75,8 +75,8 @@ let add_closure_offsets result ~constant let fun_offset = 1 + - (* arity field *) - if arity > 1 then 1 else 0 + (* arity field *) + if arity > 1 then 1 else 0 in let fun_accessor = { field = fun_offset @@ -130,9 +130,9 @@ let add_closure_offsets result ~constant let functions = Variable.Map.fold (fun _id (function_decl : Flambda.function_declaration) acc -> - let arity = Flambda_utils.function_arity function_decl in - let fields = if constant then 0 else 1 in - { arity; fields } :: acc ) + let arity = Flambda_utils.function_arity function_decl in + let fields = if constant then 0 else 1 in + { arity; fields } :: acc ) function_decls.funs [] in let fields = Variable.Map.cardinal free_vars in diff --git a/wasm/wast.ml b/wasm/wat.ml similarity index 73% rename from wasm/wast.ml rename to wasm/wat.ml index 178e2e6a50..73183b0ed0 100644 --- a/wasm/wast.ml +++ b/wasm/wat.ml @@ -1,4 +1,3 @@ -open Wstate open Wident module Expr = Wexpr module Type = Wtype @@ -25,73 +24,73 @@ module Cst = struct | String s -> Format.fprintf ppf "\"%s\"" s | Atom s -> Format.pp_print_string ppf s | Node { name; args_h; args_v; force_paren } -> begin - match (args_h, args_v) with - | [], [] -> - if force_paren then Format.fprintf ppf "(%s)" name - else Format.pp_print_string ppf name - | _ -> - Format.fprintf ppf "@[@["; - Format.fprintf ppf "(%s@ %a@]" name (print_lst pp) args_h; - ( match args_v with - | [] -> () - | _ -> Format.fprintf ppf "@ %a" (print_lst pp) args_v ); - Format.fprintf ppf ")@]" - end + match (args_h, args_v) with + | [], [] -> + if force_paren then Format.fprintf ppf "(%s)" name + else Format.pp_print_string ppf name + | _ -> + Format.fprintf ppf "@[@["; + Format.fprintf ppf "(%s@ %a@]" name (print_lst pp) args_h; + ( match args_v with + | [] -> () + | _ -> Format.fprintf ppf "@ %a" (print_lst pp) args_v ); + Format.fprintf ppf ")@]" + end let rec emit ~indent buf = function | Int i -> Buffer.add_string buf (Int64.to_string i) | Float f -> Buffer.add_string buf (Printf.sprintf "%h" f) | String s -> - Buffer.add_char buf '"'; - Buffer.add_string buf s; - Buffer.add_char buf '"' + Buffer.add_char buf '"'; + Buffer.add_string buf s; + Buffer.add_char buf '"' | Atom s -> - Buffer.add_string buf s + Buffer.add_string buf s | Node { name; args_h; args_v; force_paren } -> begin - match (args_h, args_v) with - | [], [] -> + match (args_h, args_v) with + | [], [] -> if force_paren then begin Buffer.add_char buf '('; Buffer.add_string buf name; Buffer.add_char buf ')' end else Buffer.add_string buf name - | _ -> + | _ -> Buffer.add_char buf '('; Buffer.add_string buf name; Buffer.add_char buf ' '; emit_h_list ~indent buf args_h; (match args_v with - | [] -> () - | _ -> - Buffer.add_char buf '\n'; - emit_v_list ~indent buf args_v); + | [] -> () + | _ -> + Buffer.add_char buf '\n'; + emit_v_list ~indent buf args_v); Buffer.add_char buf ')' - end + end and emit_h_list ~indent buf = function | [] -> () | [v] -> - emit ~indent buf v + emit ~indent buf v | h :: t -> - emit ~indent buf h; - Buffer.add_char buf ' '; - emit_h_list ~indent buf t + emit ~indent buf h; + Buffer.add_char buf ' '; + emit_h_list ~indent buf t and emit_v_list ~indent buf = function | [] -> () | [v] -> - for _ = 1 to indent do - Buffer.add_char buf ' ' - done; - emit ~indent:(1+indent) buf v + for _ = 1 to indent do + Buffer.add_char buf ' ' + done; + emit ~indent:(1+indent) buf v | h :: t -> - for _ = 1 to indent do - Buffer.add_char buf ' ' - done; - emit ~indent:(1+indent) buf h; - Buffer.add_char buf '\n'; - emit_v_list ~indent buf t + for _ = 1 to indent do + Buffer.add_char buf ' ' + done; + emit ~indent:(1+indent) buf h; + Buffer.add_char buf '\n'; + emit_v_list ~indent buf t let emit ppf e = let b = Buffer.create 100 in @@ -166,19 +165,11 @@ module C = struct let reft name = node "ref" [ type_name name ] let struct_new_canon typ fields = - let name = - match mode with - | Binarien -> "struct.new" - | Reference -> "struct.new_canon" - in - node name (type_name typ :: fields) + node "struct.new" (type_name typ :: fields) let array_new_canon_fixed typ size args = - match mode with - | Binarien -> node "array.init_static" ([ type_name typ ] @ args) - | Reference -> - node "array.new_canon_fixed" - ([ type_name typ; Int (Int64.of_int size) ] @ args) + node "array.new_fixed" + ([ type_name typ; Int (Int64.of_int size) ] @ args) let int i = (* XXX TODO remove this is wrong, @@ -288,19 +279,10 @@ module C = struct let field f = node "field" [ node "mut" [ type_atom f ] ] let struct_type ~sub fields = - match mode with - | Reference -> begin - let descr = node "struct" (List.map field fields) in - match sub with - | None -> descr - | Some name -> node "sub" [ type_name name; descr ] - end - | Binarien -> begin - match sub with - | None -> node "struct" (List.map field fields) - | Some name -> - node "struct_subtype" (List.map field fields @ [ type_name name ]) - end + let descr = node "struct" (List.map field fields) in + match sub with + | None -> descr + | Some name -> node "sub" [ type_name name; descr ] let array_type f = node "array" [ node "mut" [ type_atom f ] ] @@ -317,13 +299,6 @@ module C = struct node "func" (name @ typ @ List.map param_t params @ res) let if_then_else typ cond if_expr else_expr = - let nopise e = - match mode with - | Reference -> e - | Binarien -> ( match e with [] -> [ node_p "nop" [] ] | _ -> e ) - in - let if_expr = nopise if_expr in - let else_expr = nopise else_expr in node "if" [ results typ; cond; node_p "then" if_expr; node_p "else" else_expr ] @@ -336,29 +311,15 @@ module C = struct nodehv "loop" [ !$(Block_id.name id); results result ] body let br id args = - match (mode, args) with - | Binarien, _ :: _ :: _ -> - node "br" [ !$(Block_id.name id); node "tuple.make" args ] - | _ -> node "br" ([ !$(Block_id.name id) ] @ args) + node "br" ([ !$(Block_id.name id) ] @ args) let br' id = node "br" [ !$(Block_id.name id) ] let return args = - match (mode, args) with - | Binarien, _ :: _ :: _ -> node "return" [ node "tuple.make" args ] - | _ -> node "return" args + node "return" args let br_on_cast id typ arg = - match mode with - | Binarien -> begin - match typ with - | Type.Var.I31 -> - node "drop" [ node "br_on_i31" [ !$(Block_id.name id); arg ] ] - | _ -> - node "br_on_cast_static" [ !$(Block_id.name id); type_name typ; arg ] - end - | Reference -> - node "br_on_cast" [ !$(Block_id.name id); type_name typ; arg ] + node "br_on_cast" [ !$(Block_id.name id); type_name typ; arg ] let br_if id cond = node "br_if" [ !$(Block_id.name id); cond ] @@ -379,18 +340,14 @@ module C = struct [ result result_typ ; node "do" body ; node "catch" (!$"exc" :: (* type_atom typ :: *) - handler) + handler) ] let sub name descr = - match mode with - | Binarien -> descr - | Reference -> node "sub" [ type_name name; descr ] + node "sub" [ type_name name; descr ] let opt_tuple fields = - match mode with - | Binarien -> [ node "tuple.make" fields ] - | Reference -> fields + fields let tuple_make fields = node "tuple.make" fields @@ -407,7 +364,7 @@ module C = struct (node "tag" [ !$"exc"; node "param" [ node "ref" [ atom "eq" ] ] ]) let module_ m = - let m = match mode with Reference -> m | Binarien -> import_tag :: m in + let m = import_tag :: m in nodev "module" m let register name = node "register" [ String (module_name name) ] diff --git a/wasm/wexpr.ml b/wasm/wexpr.ml index ae5bda1943..24753c77f5 100644 --- a/wasm/wexpr.ml +++ b/wasm/wexpr.ml @@ -1,4 +1,3 @@ -open Wstate module Type = Wtype open Wident module Local = Wident.Local @@ -395,11 +394,11 @@ let rec print ppf = function Format.fprintf ppf "@[Let_cont %a(%a) =@ %a@]@ in@ %a" Block_id.print cont (print_list - (fun ppf (local, typ) -> - Format.fprintf ppf "%a : %a" - (Format.pp_print_option Local.print_var) - local Type.print_atom typ ) - ", " ) + (fun ppf (local, typ) -> + Format.fprintf ppf "%a : %a" + (Format.pp_print_option Local.print_var) + local Type.print_atom typ ) + ", " ) params print handler print body | Br_on_cast { value; typ; if_cast; if_else } -> Format.fprintf ppf "@[Br_on_cast(%a %a -> (%a) else %a)@]" print @@ -463,11 +462,11 @@ and print_no_return ppf no_return = Format.fprintf ppf "@[Let_cont %a(%a) =@ %a@]@ in@ %a" Block_id.print cont (print_list - (fun ppf (local, typ) -> - Format.fprintf ppf "%a : %a" - (Format.pp_print_option Local.print_var) - local Type.print_atom typ ) - ", " ) + (fun ppf (local, typ) -> + Format.fprintf ppf "%a : %a" + (Format.pp_print_option Local.print_var) + local Type.print_atom typ ) + ", " ) params print_no_return handler print_no_return body | NR_br { cont; args } -> Format.fprintf ppf "@[Br(%a(%a))@]" Block_id.print cont @@ -495,12 +494,12 @@ let required_locals body = let acc = List.fold_left (fun acc (var, typ) -> - match var with None -> acc | Some var -> add var typ acc ) + match var with None -> acc | Some var -> add var typ acc ) acc params in let acc = - match (mode, params) with - | Binarien, _ :: _ :: _ -> + match ( params) with + | _ :: _ :: _ -> let var = Local.Block_result cont in add var (Type.Tuple (List.map snd params)) acc | _ -> acc diff --git a/wasm/wmodule.ml b/wasm/wmodule.ml index 3639d19223..66a17a10d7 100644 --- a/wasm/wmodule.ml +++ b/wasm/wmodule.ml @@ -36,9 +36,9 @@ module Func = struct | Expr.Value [e, typ] -> Format.fprintf ppf " -> %a@ {@ %a@ }" Type.print_atom typ Expr.print e | Expr.Value l -> - Format.fprintf ppf " -> %a@ {@ @[%a@]@ }" - (print_list (printconv snd Type.print_atom) " ") l - (print_list (printconv fst Expr.print) ";") l + Format.fprintf ppf " -> %a@ {@ @[%a@]@ }" + (print_list (printconv snd Type.print_atom) " ") l + (print_list (printconv fst Expr.print) ";") l | Expr.No_value e -> Format.fprintf ppf "@ {@ %a@ }" Expr.print_no_value e in @@ -139,7 +139,7 @@ module Module = struct let print ppf l = Format.fprintf ppf "@[Module {@ %a@ }@]" (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ") - Decl.print ) + ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ") + Decl.print ) l end diff --git a/wasm/wstate.ml b/wasm/wstate.ml index aa1ec0e9c3..f105e465f9 100644 --- a/wasm/wstate.ml +++ b/wasm/wstate.ml @@ -6,19 +6,12 @@ type block_repr = | Struct_block | Array_block -type mode = - | Reference - | Binarien - -let mode = Binarien -(* let mode = Reference *) - let block_repr = Array_block (* let block_repr = Struct_block *) let exception_repr = Multi_return -let pp_wast = false +let pp_wat = false let unmangle_module_name = true let uncapitalize_module_name = false diff --git a/wasm/wtype.ml b/wasm/wtype.ml index 95b75584a0..03cc57ddb4 100644 --- a/wasm/wtype.ml +++ b/wasm/wtype.ml @@ -39,8 +39,8 @@ module Var = struct | Env | Block of { size : int } | BlockFloat of { size : int } - (* This may not work, it is not always possible to distinghuish float - blocks from float array. This should probaly be replaced by FloatArray *) + (* This may not work, it is not always possible to distinghuish float + blocks from float array. This should probaly be replaced by FloatArray *) | Set_of_closures of Set_of_closures_id.t | Gen_block | I31