From 81fd141420e09018b441f870d8c94909b21fa437 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 31 Mar 2025 15:31:38 +0200 Subject: [PATCH 01/10] Clean-up regarding function and primitive types --- compiler/lib-wasm/curry.ml | 21 ++++++++------------- compiler/lib-wasm/gc_target.ml | 26 +++++++++++++------------- compiler/lib-wasm/generate.ml | 26 ++++++++++++++------------ compiler/lib-wasm/target_sig.ml | 8 +++++++- runtime/wasm/domain.wat | 2 -- runtime/wasm/effect.wat | 1 + runtime/wasm/jslib.wat | 5 ----- runtime/wasm/obj.wat | 2 +- 8 files changed, 44 insertions(+), 47 deletions(-) diff --git a/compiler/lib-wasm/curry.ml b/compiler/lib-wasm/curry.ml index f383d55da5..c39dcb6910 100644 --- a/compiler/lib-wasm/curry.ml +++ b/compiler/lib-wasm/curry.ml @@ -24,11 +24,6 @@ open Code_generation module Make (Target : Target_sig.S) = struct open Target - let func_type n = - { W.params = List.init ~len:(n + 1) ~f:(fun _ -> Value.value) - ; result = [ Value.value ] - } - let bind_parameters l = List.fold_left ~f:(fun l x -> @@ -105,7 +100,7 @@ module Make (Target : Target_sig.S) = struct { name ; exported_name = None ; typ = None - ; signature = func_type 1 + ; signature = Type.func_type 1 ; param_names ; locals ; body @@ -140,7 +135,7 @@ module Make (Target : Target_sig.S) = struct { name ; exported_name = None ; typ = None - ; signature = func_type 1 + ; signature = Type.func_type 1 ; param_names ; locals ; body @@ -191,7 +186,7 @@ module Make (Target : Target_sig.S) = struct { name ; exported_name = None ; typ = None - ; signature = func_type 2 + ; signature = Type.func_type 2 ; param_names ; locals ; body @@ -230,7 +225,7 @@ module Make (Target : Target_sig.S) = struct { name ; exported_name = None ; typ = None - ; signature = func_type 2 + ; signature = Type.func_type 2 ; param_names ; locals ; body @@ -274,7 +269,7 @@ module Make (Target : Target_sig.S) = struct { name ; exported_name = None ; typ = None - ; signature = func_type arity + ; signature = Type.primitive_type (arity + 1) ; param_names ; locals ; body @@ -306,7 +301,7 @@ module Make (Target : Target_sig.S) = struct (List.map ~f:(fun x -> `Var x) (List.tl l)) in let* make_iterator = - register_import ~name:"caml_apply_continuation" (Fun (func_type 0)) + register_import ~name:"caml_apply_continuation" (Fun (Type.primitive_type 1)) in let iterate = Var.fresh_n "iterate" in let* () = store iterate (return (W.Call (make_iterator, [ args ]))) in @@ -321,7 +316,7 @@ module Make (Target : Target_sig.S) = struct { name ; exported_name = None ; typ = None - ; signature = func_type arity + ; signature = Type.primitive_type (arity + 1) ; param_names ; locals ; body @@ -356,7 +351,7 @@ module Make (Target : Target_sig.S) = struct { name ; exported_name = None ; typ = None - ; signature = func_type arity + ; signature = Type.func_type arity ; param_names ; locals ; body diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index bea1eb09da..6b67069d24 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -202,8 +202,10 @@ module Type = struct ] }) - let func_type n = - { W.params = List.init ~len:(n + 1) ~f:(fun _ -> value); result = [ value ] } + let primitive_type n = + { W.params = List.init ~len:n ~f:(fun _ -> value); result = [ value ] } + + let func_type n = primitive_type (n + 1) let function_type ~cps n = let n = if cps then n + 1 else n in @@ -423,8 +425,6 @@ module Type = struct end module Value = struct - let value = Type.value - let block_type = let* t = Type.block_type in return (W.Ref { nullable = false; typ = Type t }) @@ -743,13 +743,13 @@ module Memory = struct let a = Code.Var.fresh_n "a" in let i = Code.Var.fresh_n "i" in block_expr - { params = []; result = [ Value.value ] } + { params = []; result = [ Type.value ] } (let* () = store a e in let* () = store ~typ:I32 i (Value.int_val e') in let* () = drop (block_expr - { params = []; result = [ Value.value ] } + { params = []; result = [ Type.value ] } (let* block = Type.block_type in let* a = load a in let* e = @@ -779,7 +779,7 @@ module Memory = struct (let* () = drop (block_expr - { params = []; result = [ Value.value ] } + { params = []; result = [ Type.value ] } (let* block = Type.block_type in let* a = load a in let* () = @@ -840,7 +840,7 @@ module Memory = struct let* () = drop (block_expr - { params = []; result = [ Value.value ] } + { params = []; result = [ Type.value ] } (let* e = if_match ~typ:(Some (W.Ref { nullable = false; typ = Type fun_ty })) @@ -1404,7 +1404,7 @@ let () = let arity = List.length args in (* [Type.func_type] counts one additional argument for the closure environment (absent here) *) - let* f = register_import ~name (Fun (Type.func_type (arity - 1))) in + let* f = register_import ~name (Fun (Type.primitive_type arity)) in let args = List.map ~f:transl_prim_arg args in let* args = expression_list Fun.id args in return (W.Call (f, args)) @@ -1668,11 +1668,11 @@ let externref = W.Ref { nullable = true; typ = Extern } let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler = let* js_tag = register_import ~name:"javascript_exception" (Tag externref) in - let* ocaml_tag = register_import ~name:"ocaml_exception" (Tag Value.value) in + let* ocaml_tag = register_import ~name:"ocaml_exception" (Tag Type.value) in let* f = register_import ~name:"caml_wrap_exception" - (Fun { params = [ externref ]; result = [ Value.value ] }) + (Fun { params = [ externref ]; result = [ Type.value ] }) in block { params = []; result = result_typ } @@ -1680,7 +1680,7 @@ let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler = store x (block_expr - { params = []; result = [ Value.value ] } + { params = []; result = [ Type.value ] } (let* exn = block_expr { params = []; result = [ externref ] } @@ -1691,7 +1691,7 @@ let handle_exceptions ~result_typ ~fall_through ~context body x exn_handler = ~result_typ:[ externref ] ~fall_through:`Skip ~context:(`Skip :: `Skip :: `Catch :: context)) - [ ocaml_tag, 1, Value.value; js_tag, 0, externref ] + [ ocaml_tag, 1, Type.value; js_tag, 0, externref ] in instr (W.Push e)) in diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index 104bf0f612..dc5328f371 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -56,13 +56,13 @@ module Generate (Target : Target_sig.S) = struct let repr_type r = match r with - | Value -> Value.value + | Value -> Type.value | Float -> F64 | Int32 -> I32 | Nativeint -> I32 | Int64 -> I64 - let specialized_func_type (params, result) = + let specialized_primitive_type (params, result) = { W.params = List.map ~f:repr_type params; result = [ repr_type result ] } let box_value r e = @@ -112,9 +112,6 @@ module Generate (Target : Target_sig.S) = struct ]; h - let func_type n = - { W.params = List.init ~len:n ~f:(fun _ -> Value.value); result = [ Value.value ] } - let float_bin_op' op f g = Memory.box_float (op (Memory.unbox_float f) (Memory.unbox_float g)) @@ -666,7 +663,7 @@ module Generate (Target : Target_sig.S) = struct let name = Primitive.resolve name in try let typ = Hashtbl.find specialized_primitives name in - let* f = register_import ~name (Fun (specialized_func_type typ)) in + let* f = register_import ~name (Fun (specialized_primitive_type typ)) in let rec loop acc arg_typ l = match arg_typ, l with | [], [] -> box_value (snd typ) (return (W.Call (f, List.rev acc))) @@ -677,7 +674,9 @@ module Generate (Target : Target_sig.S) = struct in loop [] (fst typ) l with Not_found -> - let* f = register_import ~name (Fun (func_type (List.length l))) in + let* f = + register_import ~name (Fun (Type.primitive_type (List.length l))) + in let rec loop acc l = match l with | [] -> return (W.Call (f, List.rev acc)) @@ -951,7 +950,7 @@ module Generate (Target : Target_sig.S) = struct instr (Br_table (e, List.map ~f:dest l, dest a.(len - 1))) | Raise (x, _) -> ( let* e = load x in - let* tag = register_import ~name:exception_name (Tag Value.value) in + let* tag = register_import ~name:exception_name (Tag Type.value) in match fall_through with | `Catch -> instr (Push e) | `Block _ | `Return | `Skip -> ( @@ -1036,7 +1035,7 @@ module Generate (Target : Target_sig.S) = struct wrap_with_handlers p pc - ~result_typ:[ Value.value ] + ~result_typ:[ Type.value ] ~fall_through:`Return ~context:[] (fun ~result_typ ~fall_through ~context -> @@ -1058,7 +1057,10 @@ module Generate (Target : Target_sig.S) = struct | None -> Option.map ~f:(fun name -> name ^ ".init") unit_name | Some _ -> None) ; typ = None - ; signature = func_type param_count + ; signature = + (match name_opt with + | None -> Type.primitive_type param_count + | Some _ -> Type.func_type (param_count - 1)) ; param_names ; locals ; body @@ -1067,7 +1069,7 @@ module Generate (Target : Target_sig.S) = struct let init_function ~context ~to_link = let name = Code.Var.fresh_n "initialize" in - let signature = { W.params = []; result = [ Value.value ] } in + let signature = { W.params = []; result = [ Type.value ] } in let locals, body = function_body ~context @@ -1242,7 +1244,7 @@ let fix_switch_branches p = p.blocks; !p' -let start () = make_context ~value_type:Gc_target.Value.value +let start () = make_context ~value_type:Gc_target.Type.value let f ~context ~unit_name p ~live_vars ~in_cps ~deadcode_sentinal ~debug = let t = Timer.make () in diff --git a/compiler/lib-wasm/target_sig.ml b/compiler/lib-wasm/target_sig.ml index 8b5e5ca761..09c8bf8728 100644 --- a/compiler/lib-wasm/target_sig.ml +++ b/compiler/lib-wasm/target_sig.ml @@ -96,9 +96,15 @@ module type S = sig val unbox_nativeint : expression -> expression end - module Value : sig + module Type : sig val value : Wasm_ast.value_type + val func_type : int -> Wasm_ast.func_type + + val primitive_type : int -> Wasm_ast.func_type + end + + module Value : sig val unit : expression val val_int : expression -> expression diff --git a/runtime/wasm/domain.wat b/runtime/wasm/domain.wat index a4d46414ec..d4a832ed40 100644 --- a/runtime/wasm/domain.wat +++ b/runtime/wasm/domain.wat @@ -23,8 +23,6 @@ (func $caml_ml_mutex_unlock (param (ref eq)) (result (ref eq)))) (type $block (array (mut (ref eq)))) - (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) - (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) (func (export "caml_atomic_cas") (param $ref (ref eq)) (param $o (ref eq)) (param $n (ref eq)) diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index e71be4f60c..4d9592fa5c 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -44,6 +44,7 @@ (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) + (type $primitive (func (param (ref eq) (ref eq)) (result (ref eq)))) (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 diff --git a/runtime/wasm/jslib.wat b/runtime/wasm/jslib.wat index 84b8690151..23542f08e5 100644 --- a/runtime/wasm/jslib.wat +++ b/runtime/wasm/jslib.wat @@ -106,11 +106,6 @@ (type $float_array (array (mut f64))) (type $bytes (array (mut i8))) (type $js (struct (field anyref))) - (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) - (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) - (type $function_2 - (func (param (ref eq) (ref eq) (ref eq)) (result (ref eq)))) - (type $cps_closure (sub (struct (field (ref $function_2))))) (func $wrap (export "wrap") (param anyref) (result (ref eq)) (block $is_eq (result (ref eq)) diff --git a/runtime/wasm/obj.wat b/runtime/wasm/obj.wat index 4eba296265..2fb32bf37b 100644 --- a/runtime/wasm/obj.wat +++ b/runtime/wasm/obj.wat @@ -29,11 +29,11 @@ (func $caml_trampoline (param (ref eq) (ref eq)) (result (ref eq)))) )) - (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) (type $float (struct (field f64))) (type $float_array (array (mut f64))) + (type $primitive (func (param (ref eq) (ref eq)) (result (ref eq)))) (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) (type $closure_last_arg From 2add2d6ad4615a276b12802da2ed28453f420c57 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 27 Mar 2025 16:17:20 +0100 Subject: [PATCH 02/10] Improve placement of Wasm block statements Place Wasm block statements around control instructions rather than around whole blocks. This results in less variable being uninitialized, since variables initialized within a block are no longer considered as initialized after the block. --- compiler/lib-wasm/generate.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index dc5328f371..eafd2c0f1a 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -874,6 +874,8 @@ module Generate (Target : Target_sig.S) = struct | _ -> Structure.is_merge_node g pc' in let code ~context = + let block = Addr.Map.find pc ctx.blocks in + let* () = translate_instrs ctx context block.body in translate_node_within ~result_typ ~fall_through @@ -918,7 +920,6 @@ module Generate (Target : Target_sig.S) = struct translate_tree result_typ fall_through pc' context | [] -> ( let block = Addr.Map.find pc ctx.blocks in - let* () = translate_instrs ctx context block.body in let branch = block.branch in match branch with | Branch cont -> translate_branch result_typ fall_through pc cont context From d51f392188025fd12d029572d7a20aa393e85f55 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 28 Mar 2025 15:43:14 +0100 Subject: [PATCH 03/10] Array placeholder --- compiler/lib-wasm/code_generation.ml | 38 +++++++++++++++++++++++++++ compiler/lib-wasm/code_generation.mli | 6 +++++ compiler/lib-wasm/gc_target.ml | 2 +- 3 files changed, 45 insertions(+), 1 deletion(-) diff --git a/compiler/lib-wasm/code_generation.ml b/compiler/lib-wasm/code_generation.ml index 5669b9ccb2..cfb0e6ed9a 100644 --- a/compiler/lib-wasm/code_generation.ml +++ b/compiler/lib-wasm/code_generation.ml @@ -513,6 +513,44 @@ let should_make_global x st = Var.Set.mem x st.context.globalized_variables, st let value_type st = st.context.value_type, st +let get_constant x st = Hashtbl.find_opt st.context.constants x, st + +let placeholder_value typ f = + let* c = get_constant typ in + match c with + | None -> + let x = Var.fresh () in + let* () = register_constant typ (W.GlobalGet x) in + let* () = + register_global + ~constant:true + x + { mut = false; typ = Ref { nullable = false; typ = Type typ } } + (f typ) + in + return (W.GlobalGet x) + | Some c -> return c + +let array_placeholder typ = placeholder_value typ (fun typ -> ArrayNewFixed (typ, [])) + +let default_value val_typ st = + match val_typ with + | W.Ref { typ = I31 | Eq | Any; _ } -> (W.RefI31 (Const (I32 0l)), val_typ, None), st + | W.Ref { typ = Type typ; nullable = false } -> ( + match (Hashtbl.find st.context.types typ).typ with + | Array _ -> + (let* placeholder = array_placeholder typ in + return (placeholder, val_typ, None)) + st + | Struct _ | Func _ -> + ( ( W.RefNull (Type typ) + , W.Ref { typ = Type typ; nullable = true } + , Some { W.typ = Type typ; nullable = false } ) + , st )) + | W.Ref { nullable = true; _ } + | W.Ref { typ = Func | Extern | Struct | Array | None_; _ } + | I32 | I64 | F32 | F64 -> assert false + let rec store ?(always = false) ?typ x e = let* e = e in match e with diff --git a/compiler/lib-wasm/code_generation.mli b/compiler/lib-wasm/code_generation.mli index f03af255a1..cb46af4ab0 100644 --- a/compiler/lib-wasm/code_generation.mli +++ b/compiler/lib-wasm/code_generation.mli @@ -203,3 +203,9 @@ val function_body : -> param_names:Code.Var.t list -> body:unit t -> (Wasm_ast.var * Wasm_ast.value_type) list * Wasm_ast.instruction list + +val array_placeholder : Code.Var.t -> expression + +val default_value : + Wasm_ast.value_type + -> (Wasm_ast.expression * Wasm_ast.value_type * Wasm_ast.ref_type option) t diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index 6b67069d24..639f9e1bc9 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -431,7 +431,7 @@ module Value = struct let dummy_block = let* t = Type.block_type in - return (W.ArrayNewFixed (t, [])) + array_placeholder t let as_block e = let* t = Type.block_type in From f58f1db268dcaf12ff05725ff9ae13f6692642e6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 27 Mar 2025 21:13:27 +0100 Subject: [PATCH 04/10] Make local initialization for arbitrary local values We change the type of the local into a nullable type if we cannot use a placeholder value --- compiler/lib-wasm/generate.ml | 2 +- compiler/lib-wasm/initialize_locals.ml | 132 +++++++++++++++++++++++- compiler/lib-wasm/initialize_locals.mli | 2 +- compiler/lib-wasm/target_sig.ml | 2 +- 4 files changed, 131 insertions(+), 7 deletions(-) diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index eafd2c0f1a..a4e227c874 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -1047,7 +1047,7 @@ module Generate (Target : Target_sig.S) = struct | Some loc -> event loc | None -> return ()) in - let body = post_process_function_body ~param_names ~locals body in + let locals, body = post_process_function_body ~param_names ~locals body in W.Function { name = (match name_opt with diff --git a/compiler/lib-wasm/initialize_locals.ml b/compiler/lib-wasm/initialize_locals.ml index d359f3bda3..7fa1b6a0f5 100644 --- a/compiler/lib-wasm/initialize_locals.ml +++ b/compiler/lib-wasm/initialize_locals.ml @@ -108,6 +108,106 @@ and scan_instructions ctx l = let ctx = fork_context ctx in List.iter ~f:(fun i -> scan_instruction ctx i) l +let rec rewrite_expression uninitialized (e : Wasm_ast.expression) = + match e with + | Const _ | GlobalGet _ | Pop _ | RefFunc _ | RefNull _ -> e + | UnOp (op, e') -> UnOp (op, rewrite_expression uninitialized e') + | I32WrapI64 e' -> I32WrapI64 (rewrite_expression uninitialized e') + | I64ExtendI32 (s, e') -> I64ExtendI32 (s, rewrite_expression uninitialized e') + | F32DemoteF64 e' -> F32DemoteF64 (rewrite_expression uninitialized e') + | F64PromoteF32 e' -> F64PromoteF32 (rewrite_expression uninitialized e') + | RefI31 e' -> RefI31 (rewrite_expression uninitialized e') + | I31Get (s, e') -> I31Get (s, rewrite_expression uninitialized e') + | ArrayLen e' -> ArrayLen (rewrite_expression uninitialized e') + | StructGet (s, ty, i, e') -> StructGet (s, ty, i, rewrite_expression uninitialized e') + | RefCast (ty, e') -> RefCast (ty, rewrite_expression uninitialized e') + | RefTest (ty, e') -> RefTest (ty, rewrite_expression uninitialized e') + | Br_on_cast (i, ty, ty', e') -> + Br_on_cast (i, ty, ty', rewrite_expression uninitialized e') + | Br_on_cast_fail (i, ty, ty', e') -> + Br_on_cast_fail (i, ty, ty', rewrite_expression uninitialized e') + | BinOp (op, e', e'') -> + BinOp (op, rewrite_expression uninitialized e', rewrite_expression uninitialized e'') + | ArrayNew (ty, e', e'') -> + ArrayNew + (ty, rewrite_expression uninitialized e', rewrite_expression uninitialized e'') + | ArrayNewData (ty, i, e', e'') -> + ArrayNewData + (ty, i, rewrite_expression uninitialized e', rewrite_expression uninitialized e'') + | ArrayGet (s, ty, e', e'') -> + ArrayGet + (s, ty, rewrite_expression uninitialized e', rewrite_expression uninitialized e'') + | RefEq (e', e'') -> + RefEq (rewrite_expression uninitialized e', rewrite_expression uninitialized e'') + | LocalGet i -> + if Hashtbl.mem uninitialized i then RefCast (Hashtbl.find uninitialized i, e) else e + | LocalTee (i, e') -> + let e = Wasm_ast.LocalTee (i, rewrite_expression uninitialized e') in + if Hashtbl.mem uninitialized i then RefCast (Hashtbl.find uninitialized i, e) else e + | Call_ref (f, e', l) -> + Call_ref + (f, rewrite_expression uninitialized e', rewrite_expressions uninitialized l) + | Call (f, l) -> Call (f, rewrite_expressions uninitialized l) + | ArrayNewFixed (ty, l) -> ArrayNewFixed (ty, rewrite_expressions uninitialized l) + | StructNew (ty, l) -> StructNew (ty, rewrite_expressions uninitialized l) + | BlockExpr (ty, l) -> BlockExpr (ty, rewrite_instructions uninitialized l) + | Seq (l, e') -> + Seq (rewrite_instructions uninitialized l, rewrite_expression uninitialized e') + | IfExpr (ty, cond, e1, e2) -> + IfExpr + ( ty + , rewrite_expression uninitialized cond + , rewrite_expression uninitialized e1 + , rewrite_expression uninitialized e2 ) + | Try (ty, body, catches) -> Try (ty, rewrite_instructions uninitialized body, catches) + | ExternConvertAny e' -> ExternConvertAny (rewrite_expression uninitialized e') + +and rewrite_expressions uninitialized l = + List.map ~f:(fun e -> rewrite_expression uninitialized e) l + +and rewrite_instruction uninitialized i = + match i with + | Wasm_ast.Drop e -> Wasm_ast.Drop (rewrite_expression uninitialized e) + | GlobalSet (x, e) -> GlobalSet (x, rewrite_expression uninitialized e) + | Br (i, Some e) -> Br (i, Some (rewrite_expression uninitialized e)) + | Br_if (i, e) -> Br_if (i, rewrite_expression uninitialized e) + | Br_table (e, l, i) -> Br_table (rewrite_expression uninitialized e, l, i) + | Throw (t, e) -> Throw (t, rewrite_expression uninitialized e) + | Return (Some e) -> Return (Some (rewrite_expression uninitialized e)) + | Push e -> Push (rewrite_expression uninitialized e) + | StructSet (ty, i, e, e') -> + StructSet + (ty, i, rewrite_expression uninitialized e, rewrite_expression uninitialized e') + | LocalSet (i, e) -> LocalSet (i, rewrite_expression uninitialized e) + | Loop (ty, l) -> Loop (ty, rewrite_instructions uninitialized l) + | Block (ty, l) -> Block (ty, rewrite_instructions uninitialized l) + | If (ty, e, l, l') -> + If + ( ty + , rewrite_expression uninitialized e + , rewrite_instructions uninitialized l + , rewrite_instructions uninitialized l' ) + | CallInstr (f, l) -> CallInstr (f, rewrite_expressions uninitialized l) + | Return_call (f, l) -> Return_call (f, rewrite_expressions uninitialized l) + | Br (_, None) | Return None | Rethrow _ | Nop | Unreachable | Event _ -> i + | ArraySet (ty, e, e', e'') -> + ArraySet + ( ty + , rewrite_expression uninitialized e + , rewrite_expression uninitialized e' + , rewrite_expression uninitialized e'' ) + | Return_call_ref (f, e', l) -> + Return_call_ref + (f, rewrite_expression uninitialized e', rewrite_expressions uninitialized l) + +and rewrite_instructions uninitialized l = + List.map ~f:(fun i -> rewrite_instruction uninitialized i) l + +let has_default (ty : Wasm_ast.heap_type) = + match ty with + | Any | Eq | I31 -> true + | Func | Extern | Array | Struct | None_ | Type _ -> false + let f ~param_names ~locals instrs = let ctx = { initialized = Code.Var.Set.empty; uninitialized = ref Code.Var.Set.empty } @@ -120,7 +220,31 @@ let f ~param_names ~locals instrs = | Ref { nullable = false; _ } -> ()) locals; scan_instructions ctx instrs; - List.map - ~f:(fun i -> Wasm_ast.LocalSet (i, RefI31 (Const (I32 0l)))) - (Code.Var.Set.elements !(ctx.uninitialized)) - @ instrs + let local_types = Hashtbl.create 16 in + let locals = + List.map + ~f:(fun ((var, typ) as local) -> + match typ with + | Ref ({ nullable = false; typ } as ref_typ) -> + if Code.Var.Set.mem var !(ctx.uninitialized) && not (has_default typ) + then ( + Hashtbl.add local_types var ref_typ; + var, Wasm_ast.Ref { nullable = true; typ }) + else local + | I32 | I64 | F32 | F64 | Ref { nullable = true; _ } -> local) + locals + in + let initializations = + List.filter_map + ~f:(fun i -> + if Hashtbl.mem local_types i + then None + else Some (Wasm_ast.LocalSet (i, RefI31 (Const (I32 0l))))) + (Code.Var.Set.elements !(ctx.uninitialized)) + in + let instrs = + if Hashtbl.length local_types = 0 + then instrs + else rewrite_instructions local_types instrs + in + locals, initializations @ instrs diff --git a/compiler/lib-wasm/initialize_locals.mli b/compiler/lib-wasm/initialize_locals.mli index d43869795d..c356aa396b 100644 --- a/compiler/lib-wasm/initialize_locals.mli +++ b/compiler/lib-wasm/initialize_locals.mli @@ -20,4 +20,4 @@ val f : param_names:Wasm_ast.var list -> locals:(Wasm_ast.var * Wasm_ast.value_type) list -> Wasm_ast.instruction list - -> Wasm_ast.instruction list + -> (Wasm_ast.var * Wasm_ast.value_type) list * Wasm_ast.instruction list diff --git a/compiler/lib-wasm/target_sig.ml b/compiler/lib-wasm/target_sig.ml index 09c8bf8728..65b9d5604b 100644 --- a/compiler/lib-wasm/target_sig.ml +++ b/compiler/lib-wasm/target_sig.ml @@ -274,7 +274,7 @@ module type S = sig param_names:Wasm_ast.var list -> locals:(Wasm_ast.var * Wasm_ast.value_type) list -> Wasm_ast.instruction list - -> Wasm_ast.instruction list + -> (Wasm_ast.var * Wasm_ast.value_type) list * Wasm_ast.instruction list val entry_point : toplevel_fun:Wasm_ast.var From 64258f2f13ec0794df23b60c113dab423af58592 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 27 Mar 2025 16:17:37 +0100 Subject: [PATCH 05/10] WIP --- compiler/lib-wasm/closure_conversion.ml | 4 +- compiler/lib-wasm/closure_conversion.mli | 1 + compiler/lib-wasm/code_generation.ml | 66 +++++++++++++++++++++++- compiler/lib-wasm/code_generation.mli | 5 +- compiler/lib-wasm/gc_target.ml | 66 +++++++++++++----------- 5 files changed, 108 insertions(+), 34 deletions(-) diff --git a/compiler/lib-wasm/closure_conversion.ml b/compiler/lib-wasm/closure_conversion.ml index 162989496c..66e829439a 100644 --- a/compiler/lib-wasm/closure_conversion.ml +++ b/compiler/lib-wasm/closure_conversion.ml @@ -22,6 +22,7 @@ open Code type closure = { functions : (Var.t * int) list ; free_variables : Var.t list + ; mutable id : int option } module SCC = Strongly_connected_components.Make (Var) @@ -144,7 +145,8 @@ let rec traverse var_depth closures program pc depth = in List.iter ~f:(fun (f, _) -> - closures := Var.Map.add f { functions; free_variables } !closures) + closures := + Var.Map.add f { functions; free_variables; id = None } !closures) functions; fun_lst) components diff --git a/compiler/lib-wasm/closure_conversion.mli b/compiler/lib-wasm/closure_conversion.mli index 41a5e0642c..f042f1806f 100644 --- a/compiler/lib-wasm/closure_conversion.mli +++ b/compiler/lib-wasm/closure_conversion.mli @@ -19,6 +19,7 @@ type closure = { functions : (Code.Var.t * int) list ; free_variables : Code.Var.t list + ; mutable id : int option } val f : Code.program -> Code.program * closure Code.Var.Map.t diff --git a/compiler/lib-wasm/code_generation.ml b/compiler/lib-wasm/code_generation.ml index cfb0e6ed9a..9aa96103f0 100644 --- a/compiler/lib-wasm/code_generation.ml +++ b/compiler/lib-wasm/code_generation.ml @@ -46,6 +46,7 @@ type context = ; types : (Var.t, Wasm_ast.type_field) Hashtbl.t ; mutable closure_envs : Var.t Var.Map.t (** GC: mapping of recursive functions to their shared environment *) + ; closure_types : (W.value_type option list, int) Hashtbl.t ; mutable apply_funs : Var.t IntMap.t ; mutable cps_apply_funs : Var.t IntMap.t ; mutable curry_funs : Var.t IntMap.t @@ -71,6 +72,7 @@ let make_context ~value_type = ; type_names = Hashtbl.create 128 ; types = Hashtbl.create 128 ; closure_envs = Var.Map.empty + ; closure_types = Hashtbl.create 128 ; apply_funs = IntMap.empty ; cps_apply_funs = IntMap.empty ; curry_funs = IntMap.empty @@ -498,6 +500,58 @@ let load x = | Local (_, x, _) -> return (W.LocalGet x) | Expr e -> e +let value_type st = st.context.value_type, st + +let rec variable_type x st = + match Var.Map.find_opt x st.vars with + | Some (Local (_, _, typ)) -> typ, st + | Some (Expr e) -> + (let* e = e in + expression_type e) + st + | None -> None, st + +and expression_type (e : W.expression) st = + match e with + | Const _ + | UnOp _ + | BinOp _ + | I32WrapI64 _ + | I64ExtendI32 _ + | F32DemoteF64 _ + | F64PromoteF32 _ + | GlobalGet _ + | BlockExpr _ + | Call _ + | RefFunc _ + | Call_ref _ + | I31Get _ + | ArrayGet _ + | ArrayLen _ + | RefTest _ + | RefEq _ + | RefNull _ + | Try _ -> None, st + | LocalGet x | LocalTee (x, _) -> variable_type x st + | Seq (_, e') -> expression_type e' st + | Pop typ -> Some typ, st + | RefI31 _ -> Some (Ref { nullable = false; typ = I31 }), st + | ArrayNew (ty, _, _) + | ArrayNewFixed (ty, _) + | ArrayNewData (ty, _, _, _) + | StructNew (ty, _) -> Some (Ref { nullable = false; typ = Type ty }), st + | StructGet (_, ty, i, _) -> ( + match (Hashtbl.find st.context.types ty).typ with + | Struct l -> ( + match (List.nth l i).typ with + | Value typ -> + (if Poly.equal typ st.context.value_type then None else Some typ), st + | Packed _ -> assert false) + | Array _ | Func _ -> assert false) + | RefCast (typ, _) | Br_on_cast (_, _, typ, _) | Br_on_cast_fail (_, typ, _, _) -> + Some (Ref typ), st + | IfExpr (_, _, _, _) | ExternConvertAny _ -> None, st + let tee ?typ x e = let* e = e in let* b = is_small_constant e in @@ -506,13 +560,16 @@ let tee ?typ x e = let* () = register_constant x e in return e else + let* typ = + match typ with + | Some _ -> return typ + | None -> expression_type e + in let* i = add_var ?typ x in return (W.LocalTee (i, e)) let should_make_global x st = Var.Set.mem x st.context.globalized_variables, st -let value_type st = st.context.value_type, st - let get_constant x st = Hashtbl.find_opt st.context.constants x, st let placeholder_value typ f = @@ -584,6 +641,11 @@ let rec store ?(always = false) ?typ x e = let* () = register_constant x (W.GlobalGet x) in instr (GlobalSet (x, e)) else + let* typ = + match typ with + | Some _ -> return typ + | None -> if always then return None else expression_type e + in let* i = add_var ?typ x in instr (LocalSet (i, e)) diff --git a/compiler/lib-wasm/code_generation.mli b/compiler/lib-wasm/code_generation.mli index cb46af4ab0..35bb0961b5 100644 --- a/compiler/lib-wasm/code_generation.mli +++ b/compiler/lib-wasm/code_generation.mli @@ -30,6 +30,7 @@ type context = ; types : (Code.Var.t, Wasm_ast.type_field) Hashtbl.t ; mutable closure_envs : Code.Var.t Code.Var.Map.t (** GC: mapping of recursive functions to their shared environment *) + ; closure_types : (Wasm_ast.value_type option list, int) Hashtbl.t ; mutable apply_funs : Code.Var.t Stdlib.IntMap.t ; mutable cps_apply_funs : Code.Var.t Stdlib.IntMap.t ; mutable curry_funs : Code.Var.t Stdlib.IntMap.t @@ -60,7 +61,7 @@ val instr : Wasm_ast.instruction -> unit t val seq : unit t -> expression -> expression -val expression_list : ('a -> expression) -> 'a list -> Wasm_ast.expression list t +val expression_list : ('a -> 'b t) -> 'a list -> 'b list t module Arith : sig val const : int32 -> expression @@ -204,6 +205,8 @@ val function_body : -> body:unit t -> (Wasm_ast.var * Wasm_ast.value_type) list * Wasm_ast.instruction list +val variable_type : Code.Var.t -> Wasm_ast.value_type option t + val array_placeholder : Code.Var.t -> expression val default_value : diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index 639f9e1bc9..c63044a899 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -281,11 +281,19 @@ module Type = struct ]) }) - let env_type ~cps ~arity n = + let make_env_type env_type = + List.map + ~f:(fun typ -> + { W.mut = false + ; typ = W.Value (Option.value ~default:(W.Ref { nullable = false; typ = Eq }) typ) + }) + env_type + + let env_type ~cps ~arity ~env_type_id ~env_type = register_type (if cps - then Printf.sprintf "cps_env_%d_%d" arity n - else Printf.sprintf "env_%d_%d" arity n) + then Printf.sprintf "cps_env_%d_%d" arity env_type_id + else Printf.sprintf "env_%d_%d" arity env_type_id) (fun () -> let* cl_typ = closure_type ~usage:`Alloc ~cps arity in let* common = closure_common_fields ~cps in @@ -309,18 +317,11 @@ module Type = struct ; typ = Value (Ref { nullable = false; typ = Type fun_ty' }) } ]) - @ List.init - ~f:(fun _ -> - { W.mut = false - ; typ = W.Value (Ref { nullable = false; typ = Eq }) - }) - ~len:n) + @ make_env_type env_type) }) - let rec_env_type ~function_count ~free_variable_count = - register_type - (Printf.sprintf "rec_env_%d_%d" function_count free_variable_count) - (fun () -> + let rec_env_type ~function_count ~env_type_id ~env_type = + register_type (Printf.sprintf "rec_env_%d_%d" function_count env_type_id) (fun () -> return { supertype = None ; final = true @@ -331,24 +332,20 @@ module Type = struct { W.mut = i < function_count ; typ = W.Value (Ref { nullable = false; typ = Eq }) }) - ~len:(function_count + free_variable_count)) + ~len:function_count + @ make_env_type env_type) }) - let rec_closure_type ~cps ~arity ~function_count ~free_variable_count = + let rec_closure_type ~cps ~arity ~function_count ~env_type_id ~env_type = register_type (if cps - then - Printf.sprintf - "cps_closure_rec_%d_%d_%d" - arity - function_count - free_variable_count - else Printf.sprintf "closure_rec_%d_%d_%d" arity function_count free_variable_count) + then Printf.sprintf "cps_closure_rec_%d_%d_%d" arity function_count env_type_id + else Printf.sprintf "closure_rec_%d_%d_%d" arity function_count env_type_id) (fun () -> let* cl_typ = closure_type ~usage:`Alloc ~cps arity in let* common = closure_common_fields ~cps in let* fun_ty' = function_type ~cps arity in - let* env_ty = rec_env_type ~function_count ~free_variable_count in + let* env_ty = rec_env_type ~function_count ~env_type_id ~env_type in return { supertype = Some cl_typ ; final = true @@ -1106,11 +1103,19 @@ module Closure = struct in return (W.GlobalGet name) else - let free_variable_count = List.length free_variables in + let* env_type = expression_list variable_type free_variables in + let env_type_id = + try Hashtbl.find context.closure_types env_type + with Not_found -> + let id = Hashtbl.length context.closure_types in + Hashtbl.add context.closure_types env_type id; + id + in + info.id <- Some env_type_id; match info.Closure_conversion.functions with | [] -> assert false | [ _ ] -> - let* typ = Type.env_type ~cps ~arity free_variable_count in + let* typ = Type.env_type ~cps ~arity ~env_type_id ~env_type in let* l = expression_list load free_variables in return (W.StructNew @@ -1129,7 +1134,7 @@ module Closure = struct @ l )) | (g, _) :: _ as functions -> let function_count = List.length functions in - let* env_typ = Type.rec_env_type ~function_count ~free_variable_count in + let* env_typ = Type.rec_env_type ~function_count ~env_type_id ~env_type in let env = if Code.Var.equal f g then @@ -1151,7 +1156,7 @@ module Closure = struct load env in let* typ = - Type.rec_closure_type ~cps ~arity ~function_count ~free_variable_count + Type.rec_closure_type ~cps ~arity ~function_count ~env_type_id ~env_type in let res = let* env = env in @@ -1196,12 +1201,13 @@ module Closure = struct let* _ = add_var (Code.Var.fresh ()) in return () else + let env_type_id = Option.value ~default:(-1) info.id in let arity = List.assoc f info.functions in let arity = if cps then arity - 1 else arity in let offset = Memory.env_start arity in match info.Closure_conversion.functions with | [ _ ] -> - let* typ = Type.env_type ~cps ~arity free_variable_count in + let* typ = Type.env_type ~cps ~arity ~env_type_id ~env_type:[] in let* _ = add_var f in let env = Code.Var.fresh_n "env" in let* () = @@ -1221,11 +1227,11 @@ module Closure = struct | functions -> let function_count = List.length functions in let* typ = - Type.rec_closure_type ~cps ~arity ~function_count ~free_variable_count + Type.rec_closure_type ~cps ~arity ~function_count ~env_type_id ~env_type:[] in let* _ = add_var f in let env = Code.Var.fresh_n "env" in - let* env_typ = Type.rec_env_type ~function_count ~free_variable_count in + let* env_typ = Type.rec_env_type ~function_count ~env_type_id ~env_type:[] in let* () = store ~typ:(W.Ref { nullable = false; typ = Type env_typ }) From fdbf150cabdf7744928777b22ef4db5166de45eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 27 Mar 2025 22:12:41 +0100 Subject: [PATCH 06/10] WIP --- compiler/lib-wasm/code_generation.ml | 34 +++++++++++++++++++--------- compiler/lib-wasm/gc_target.ml | 6 +++-- 2 files changed, 27 insertions(+), 13 deletions(-) diff --git a/compiler/lib-wasm/code_generation.ml b/compiler/lib-wasm/code_generation.ml index 9aa96103f0..c5f2cf7f7b 100644 --- a/compiler/lib-wasm/code_generation.ml +++ b/compiler/lib-wasm/code_generation.ml @@ -34,6 +34,7 @@ https://github.com/llvm/llvm-project/issues/58438 type constant_global = { init : W.expression option ; constant : bool + ; typ : W.value_type } type context = @@ -206,6 +207,7 @@ let register_global name ?exported_name ?(constant = false) typ init st = name { init = (if not typ.mut then Some init else None) ; constant = (not typ.mut) || constant + ; typ = typ.typ } st.context.constant_globals; (), st @@ -520,7 +522,6 @@ and expression_type (e : W.expression) st = | I64ExtendI32 _ | F32DemoteF64 _ | F64PromoteF32 _ - | GlobalGet _ | BlockExpr _ | Call _ | RefFunc _ @@ -533,6 +534,9 @@ and expression_type (e : W.expression) st = | RefNull _ | Try _ -> None, st | LocalGet x | LocalTee (x, _) -> variable_type x st + | GlobalGet x -> + let typ = (Var.Map.find x st.context.constant_globals).typ in + (if Poly.equal typ st.context.value_type then None else Some typ), st | Seq (_, e') -> expression_type e' st | Pop typ -> Some typ, st | RefI31 _ -> Some (Ref { nullable = false; typ = I31 }), st @@ -622,21 +626,29 @@ let rec store ?(always = false) ?typ x e = let* b = should_make_global x in if b then - let* typ = - match typ with - | Some typ -> return typ - | None -> value_type - in let* () = let* b = global_is_registered x in if b then return () else - register_global - ~constant:true - x - { mut = true; typ } - (W.RefI31 (Const (I32 0l))) + let* typ = + match typ with + | Some typ -> return typ + | None -> ( + let* typ = expression_type e in + match typ with + | None -> value_type + | Some typ -> return typ) + in + let* default, typ', cast = default_value typ in + let* () = + register_constant + x + (match cast with + | Some typ -> W.RefCast (typ, W.GlobalGet x) + | None -> W.GlobalGet x) + in + register_global ~constant:true x { mut = true; typ = typ' } default in let* () = register_constant x (W.GlobalGet x) in instr (GlobalSet (x, e)) diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index c63044a899..657048dfaa 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -1046,13 +1046,15 @@ module Constant = struct if b then return c else store_in_global c | Const_named name -> store_in_global ~name c | Mutated -> + let* typ = Type.string_type in let name = Code.Var.fresh_n "const" in + let* placeholder = array_placeholder typ in let* () = register_global ~constant:true name - { mut = true; typ = Type.value } - (W.RefI31 (Const (I32 0l))) + { mut = true; typ = Ref { nullable = false; typ = Type typ } } + placeholder in let* () = register_init_code (instr (W.GlobalSet (name, c))) in return (W.GlobalGet name) From 2494eee1ba85ed638f5f6af2e83246e089679b16 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Thu, 27 Mar 2025 23:13:54 +0100 Subject: [PATCH 07/10] FIX --- compiler/lib-wasm/code_generation.ml | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/compiler/lib-wasm/code_generation.ml b/compiler/lib-wasm/code_generation.ml index c5f2cf7f7b..b9dc089e8a 100644 --- a/compiler/lib-wasm/code_generation.ml +++ b/compiler/lib-wasm/code_generation.ml @@ -535,8 +535,11 @@ and expression_type (e : W.expression) st = | Try _ -> None, st | LocalGet x | LocalTee (x, _) -> variable_type x st | GlobalGet x -> - let typ = (Var.Map.find x st.context.constant_globals).typ in - (if Poly.equal typ st.context.value_type then None else Some typ), st + ( (try + let typ = (Var.Map.find x st.context.constant_globals).typ in + if Poly.equal typ st.context.value_type then None else Some typ + with Not_found -> None) + , st ) | Seq (_, e') -> expression_type e' st | Pop typ -> Some typ, st | RefI31 _ -> Some (Ref { nullable = false; typ = I31 }), st From 12c46dd2f8e0a28d8cf06ebe7354485ec578acbe Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 28 Mar 2025 14:03:52 +0100 Subject: [PATCH 08/10] Nullable globals + more precise constant globals --- compiler/lib-wasm/code_generation.ml | 20 ++++++++++++++------ compiler/lib-wasm/code_generation.mli | 2 ++ compiler/lib-wasm/gc_target.ml | 21 ++++++++++++++------- 3 files changed, 30 insertions(+), 13 deletions(-) diff --git a/compiler/lib-wasm/code_generation.ml b/compiler/lib-wasm/code_generation.ml index b9dc089e8a..fa66b64d19 100644 --- a/compiler/lib-wasm/code_generation.ml +++ b/compiler/lib-wasm/code_generation.ml @@ -537,7 +537,13 @@ and expression_type (e : W.expression) st = | GlobalGet x -> ( (try let typ = (Var.Map.find x st.context.constant_globals).typ in - if Poly.equal typ st.context.value_type then None else Some typ + if Poly.equal typ st.context.value_type + then None + else + Some + (match typ with + | Ref { typ; nullable = true } -> Ref { typ; nullable = false } + | _ -> typ) with Not_found -> None) , st ) | Seq (_, e') -> expression_type e' st @@ -638,10 +644,13 @@ let rec store ?(always = false) ?typ x e = match typ with | Some typ -> return typ | None -> ( - let* typ = expression_type e in - match typ with - | None -> value_type - | Some typ -> return typ) + if always + then value_type + else + let* typ = expression_type e in + match typ with + | None -> value_type + | Some typ -> return typ) in let* default, typ', cast = default_value typ in let* () = @@ -653,7 +662,6 @@ let rec store ?(always = false) ?typ x e = in register_global ~constant:true x { mut = true; typ = typ' } default in - let* () = register_constant x (W.GlobalGet x) in instr (GlobalSet (x, e)) else let* typ = diff --git a/compiler/lib-wasm/code_generation.mli b/compiler/lib-wasm/code_generation.mli index 35bb0961b5..903b515303 100644 --- a/compiler/lib-wasm/code_generation.mli +++ b/compiler/lib-wasm/code_generation.mli @@ -207,6 +207,8 @@ val function_body : val variable_type : Code.Var.t -> Wasm_ast.value_type option t +val expression_type : Wasm_ast.expression -> Wasm_ast.value_type option t + val array_placeholder : Code.Var.t -> expression val default_value : diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index 657048dfaa..a02905d0e4 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -606,6 +606,14 @@ module Value = struct let int_asr = binop Arith.( asr ) end +let store_in_global ?(name = "const") c = + let name = Code.Var.fresh_n name in + let* typ = expression_type c in + let* () = + register_global name { mut = false; typ = Option.value ~default:Type.value typ } c + in + return (W.GlobalGet name) + module Memory = struct let wasm_cast ty e = let* e = e in @@ -865,7 +873,9 @@ module Memory = struct in let* ty = Type.int32_type in let* e = e in - return (W.StructNew (ty, [ GlobalGet int32_ops; e ])) + let e' = W.StructNew (ty, [ GlobalGet int32_ops; e ]) in + let* b = is_small_constant e in + if b then store_in_global e' else return e' let box_int32 e = make_int32 ~kind:`Int32 e @@ -883,7 +893,9 @@ module Memory = struct in let* ty = Type.int64_type in let* e = e in - return (W.StructNew (ty, [ GlobalGet int64_ops; e ])) + let e' = W.StructNew (ty, [ GlobalGet int64_ops; e ]) in + let* b = is_small_constant e in + if b then store_in_global e' else return e' let box_int64 e = make_int64 e @@ -903,11 +915,6 @@ module Constant = struct strings are encoded as a sequence of bytes in the wasm module. *) let string_length_threshold = 64 - let store_in_global ?(name = "const") c = - let name = Code.Var.fresh_n name in - let* () = register_global name { mut = false; typ = Type.value } c in - return (W.GlobalGet name) - let str_js_utf8 s = let b = Buffer.create (String.length s) in String.iter s ~f:(function From 328c2d251b73d5bf28b474b156738ca779b8d659 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 28 Mar 2025 15:58:50 +0100 Subject: [PATCH 09/10] Improve elimination of call to caml_js_strict_equals --- compiler/lib-wasm/gc_target.ml | 58 ++++++++++++++++++++++------------ 1 file changed, 37 insertions(+), 21 deletions(-) diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index a02905d0e4..7a7242f123 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -546,30 +546,46 @@ module Value = struct let ( >>| ) x f = map f x + let may_be_js js x = + let* ty = expression_type x in + match ty with + | None -> return true + | Some (Ref { typ; _ }) -> heap_type_sub (Type js) typ + | Some (I32 | I64 | F32 | F64) -> return false + let eq_gen ~negate x y = - let xv = Code.Var.fresh () in - let yv = Code.Var.fresh () in + let* x = x in + let* y = y in let* js = Type.js_type in - let n = - if_expr - I32 - (* We mimic an "and" on the two conditions, but in a way that is nicer to the + let* bx = may_be_js js x in + let* by = may_be_js js y in + if bx && by + then + let xv = Code.Var.fresh () in + let yv = Code.Var.fresh () in + let n = + if_expr + I32 + (* We mimic an "and" on the two conditions, but in a way that is nicer to the binaryen optimizer. *) - (if_expr - I32 - (ref_test (ref js) (load xv)) - (ref_test (ref js) (load yv)) - (Arith.const 0l)) - (caml_js_strict_equals (load xv) (load yv) - >>| (fun e -> W.RefCast ({ nullable = false; typ = I31 }, e)) - >>| fun e -> W.I31Get (S, e)) - (ref_eq (load xv) (load yv)) - in - seq - (let* () = store xv x in - let* () = store yv y in - return ()) - (val_int (if negate then Arith.eqz n else n)) + (if_expr + I32 + (ref_test (ref js) (load xv)) + (ref_test (ref js) (load yv)) + (Arith.const 0l)) + (caml_js_strict_equals (load xv) (load yv) + >>| (fun e -> W.RefCast ({ nullable = false; typ = I31 }, e)) + >>| fun e -> W.I31Get (S, e)) + (ref_eq (load xv) (load yv)) + in + seq + (let* () = store xv (return x) in + let* () = store yv (return y) in + return ()) + (val_int (if negate then Arith.eqz n else n)) + else + let n = ref_eq (return x) (return y) in + val_int (if negate then Arith.eqz n else n) let eq x y = eq_gen ~negate:false x y From 3c3d2bc10505e646b77d1bcfc2ce38c7eb07c8fc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 8 Apr 2025 15:57:03 +0200 Subject: [PATCH 10/10] More precise return types --- compiler/lib-wasm/code_generation.ml | 95 ++++++++++++++++++++-- compiler/lib-wasm/code_generation.mli | 8 +- compiler/lib-wasm/curry.ml | 24 +++--- compiler/lib-wasm/gc_target.ml | 35 +++++++-- compiler/lib-wasm/generate.ml | 108 +++++++++++++++++++++++--- compiler/lib-wasm/target_sig.ml | 5 +- compiler/lib-wasm/wasm_output.ml | 43 +++++----- runtime/wasm/effect.wat | 31 ++++---- runtime/wasm/obj.wat | 10 +-- 9 files changed, 283 insertions(+), 76 deletions(-) diff --git a/compiler/lib-wasm/code_generation.ml b/compiler/lib-wasm/code_generation.ml index fa66b64d19..03208b91ed 100644 --- a/compiler/lib-wasm/code_generation.ml +++ b/compiler/lib-wasm/code_generation.ml @@ -199,6 +199,68 @@ let heap_type_sub (ty : W.heap_type) (ty' : W.heap_type) st = (* I31, struct, array and none have no other subtype *) | _, (I31 | Type _ | Struct | Array | None_) -> false, st +(*ZZZ*) +let rec type_index_lub ty ty' st = + if Var.equal ty ty' + then Some ty + else + let type_field = Hashtbl.find st.context.types ty in + match type_field.supertype with + | None -> None + | Some ty -> ( + match type_index_lub ty ty' st with + | Some ty -> Some ty + | None -> ( + let type_field = Hashtbl.find st.context.types ty' in + match type_field.supertype with + | None -> None + | Some ty' -> type_index_lub ty ty' st)) + +let heap_type_lub (ty : W.heap_type) (ty' : W.heap_type) = + match ty, ty' with + | (Func | Extern), _ | _, (Func | Extern) -> assert false + | None_, _ -> return ty' + | _, None_ | Struct, Struct | Array, Array -> return ty + | Any, _ | _, Any -> return W.Any + | Eq, _ + | _, Eq + | (Struct | Array | Type _), I31 + | I31, (Struct | Array | Type _) + | Struct, Array + | Array, Struct -> return (Eq : W.heap_type) + | Struct, Type t | Type t, Struct -> ( + fun st -> + let type_field = Hashtbl.find st.context.types t in + match type_field.typ with + | Struct _ -> W.Struct, st + | Array _ | Func _ -> W.Eq, st) + | Array, Type t | Type t, Array -> ( + fun st -> + let type_field = Hashtbl.find st.context.types t in + match type_field.typ with + | Array _ -> W.Struct, st + | Struct _ | Func _ -> W.Eq, st) + | Type t, Type t' -> ( + let* r = fun st -> type_index_lub t t' st, st in + match r with + | Some t'' -> return (Type t'' : W.heap_type) + | None -> ( + fun st -> + let type_field = Hashtbl.find st.context.types t in + let type_field' = Hashtbl.find st.context.types t' in + match type_field.typ, type_field'.typ with + | Struct _, Struct _ -> (Struct : W.heap_type), st + | Array _, Array _ -> W.Array, st + | (Array _ | Struct _ | Func _), (Array _ | Struct _ | Func _) -> W.Eq, st)) + | I31, I31 -> return W.I31 + +let value_type_lub (ty : W.value_type) (ty' : W.value_type) = + match ty, ty' with + | Ref { nullable; typ }, Ref { nullable = nullable'; typ = typ' } -> + let* typ = heap_type_lub typ typ' in + return (W.Ref { nullable = nullable || nullable'; typ }) + | _ -> assert false + let register_global name ?exported_name ?(constant = false) typ init st = st.context.other_fields <- W.Global { name; exported_name; typ; init } :: st.context.other_fields; @@ -701,13 +763,28 @@ let push e = instr (Push e') | _ -> instr (Push e) +let blk' ty l st = + let instrs = st.instrs in + let (), st = l { st with instrs = [] } in + let ty, st = + match st.instrs with + | Push e :: _ -> + (let* ty' = expression_type e in + match ty' with + | None -> return ty + | Some ty' -> return { ty with W.result = [ ty' ] }) + st + | _ -> ty, st + in + (List.rev st.instrs, ty), { st with instrs } + let loop ty l = - let* instrs = blk l in - instr (Loop (ty, instrs)) + let* instrs, ty' = blk' ty l in + instr (Loop (ty', instrs)) let block ty l = - let* instrs = blk l in - instr (Block (ty, instrs)) + let* instrs, ty' = blk' ty l in + instr (Block (ty', instrs)) let block_expr ty l = let* instrs = blk l in @@ -780,7 +857,7 @@ let init_code context = instrs context.init_code let function_body ~context ~param_names ~body = let st = { var_count = 0; vars = Var.Map.empty; instrs = []; context } in - let (), st = body st in + let res, st = body st in let local_count, body = st.var_count, List.rev st.instrs in let local_types = Array.make local_count (Var.fresh (), None) in List.iteri ~f:(fun i x -> local_types.(i) <- x, None) param_names; @@ -798,4 +875,10 @@ let function_body ~context ~param_names ~body = |> (fun a -> Array.sub a ~pos:param_count ~len:(Array.length a - param_count)) |> Array.to_list in - locals, body + locals, res, body + +let eval ~context e = + let st = { var_count = 0; vars = Var.Map.empty; instrs = []; context } in + let r, st = e st in + assert (st.var_count = 0 && List.is_empty st.instrs); + r diff --git a/compiler/lib-wasm/code_generation.mli b/compiler/lib-wasm/code_generation.mli index 903b515303..0184e48ec2 100644 --- a/compiler/lib-wasm/code_generation.mli +++ b/compiler/lib-wasm/code_generation.mli @@ -160,6 +160,8 @@ val register_type : string -> (unit -> type_def t) -> Wasm_ast.var t val heap_type_sub : Wasm_ast.heap_type -> Wasm_ast.heap_type -> bool t +val value_type_lub : Wasm_ast.value_type -> Wasm_ast.value_type -> Wasm_ast.value_type t + val register_import : ?import_module:string -> name:string -> Wasm_ast.import_desc -> Wasm_ast.var t @@ -202,8 +204,8 @@ val need_dummy_fun : cps:bool -> arity:int -> Code.Var.t t val function_body : context:context -> param_names:Code.Var.t list - -> body:unit t - -> (Wasm_ast.var * Wasm_ast.value_type) list * Wasm_ast.instruction list + -> body:'a t + -> (Wasm_ast.var * Wasm_ast.value_type) list * 'a * Wasm_ast.instruction list val variable_type : Code.Var.t -> Wasm_ast.value_type option t @@ -214,3 +216,5 @@ val array_placeholder : Code.Var.t -> expression val default_value : Wasm_ast.value_type -> (Wasm_ast.expression * Wasm_ast.value_type * Wasm_ast.ref_type option) t + +val eval : context:context -> 'a t -> 'a diff --git a/compiler/lib-wasm/curry.ml b/compiler/lib-wasm/curry.ml index c39dcb6910..3aa672e011 100644 --- a/compiler/lib-wasm/curry.ml +++ b/compiler/lib-wasm/curry.ml @@ -95,11 +95,11 @@ module Make (Target : Target_sig.S) = struct loop m [] f None in let param_names = args @ [ f ] in - let locals, body = function_body ~context ~param_names ~body in + let locals, _, body = function_body ~context ~param_names ~body in W.Function { name ; exported_name = None - ; typ = None + ; typ = Some (eval ~context (Type.function_type ~cps:false 1)) ; signature = Type.func_type 1 ; param_names ; locals @@ -130,11 +130,11 @@ module Make (Target : Target_sig.S) = struct push (Closure.curry_allocate ~cps:false ~arity m ~f:name' ~closure:f ~arg:x) in let param_names = [ x; f ] in - let locals, body = function_body ~context ~param_names ~body in + let locals, _, body = function_body ~context ~param_names ~body in W.Function { name ; exported_name = None - ; typ = None + ; typ = Some (eval ~context (Type.function_type ~cps:false 1)) ; signature = Type.func_type 1 ; param_names ; locals @@ -181,11 +181,11 @@ module Make (Target : Target_sig.S) = struct loop m [] f None in let param_names = args @ [ f ] in - let locals, body = function_body ~context ~param_names ~body in + let locals, _, body = function_body ~context ~param_names ~body in W.Function { name ; exported_name = None - ; typ = None + ; typ = Some (eval ~context (Type.function_type ~cps:true 1)) ; signature = Type.func_type 2 ; param_names ; locals @@ -220,11 +220,11 @@ module Make (Target : Target_sig.S) = struct instr (W.Return (Some c)) in let param_names = [ x; cont; f ] in - let locals, body = function_body ~context ~param_names ~body in + let locals, _, body = function_body ~context ~param_names ~body in W.Function { name ; exported_name = None - ; typ = None + ; typ = Some (eval ~context (Type.function_type ~cps:true 1)) ; signature = Type.func_type 2 ; param_names ; locals @@ -264,7 +264,7 @@ module Make (Target : Target_sig.S) = struct build_applies (load f) l) in let param_names = l @ [ f ] in - let locals, body = function_body ~context ~param_names ~body in + let locals, _, body = function_body ~context ~param_names ~body in W.Function { name ; exported_name = None @@ -311,7 +311,7 @@ module Make (Target : Target_sig.S) = struct push (call ~cps:true ~arity:2 (load f) [ x; iterate ])) in let param_names = l @ [ f ] in - let locals, body = function_body ~context ~param_names ~body in + let locals, _, body = function_body ~context ~param_names ~body in W.Function { name ; exported_name = None @@ -346,11 +346,11 @@ module Make (Target : Target_sig.S) = struct instr (W.Return (Some e)) in let param_names = l @ [ f ] in - let locals, body = function_body ~context ~param_names ~body in + let locals, _, body = function_body ~context ~param_names ~body in W.Function { name ; exported_name = None - ; typ = None + ; typ = Some (eval ~context (Type.function_type ~cps (arity - 1))) ; signature = Type.func_type arity ; param_names ; locals diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index 7a7242f123..db350d8e7f 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/compiler/lib-wasm/gc_target.ml @@ -205,12 +205,35 @@ module Type = struct let primitive_type n = { W.params = List.init ~len:n ~f:(fun _ -> value); result = [ value ] } - let func_type n = primitive_type (n + 1) - - let function_type ~cps n = - let n = if cps then n + 1 else n in - register_type (Printf.sprintf "function_%d" n) (fun () -> - return { supertype = None; final = true; typ = W.Func (func_type n) }) + let func_type ?(ret = value) n = + { W.params = List.init ~len:(n + 1) ~f:(fun _ -> value); result = [ ret ] } + + let rec function_type ~cps ?ret n = + let n' = if cps then n + 1 else n in + let ret_str = + match ret with + | None -> "" + | Some (W.Ref { nullable = false; typ }) -> ( + match typ with + | Eq -> "_eq" (*ZZZ remove ret in that case*) + | I31 -> "_i31" + | Struct -> "_struct" + | Array -> "_array" + | None_ -> "_none" + | Type v -> ( + match Code.Var.get_name v with + | None -> assert false + | Some name -> "_" ^ name) + | _ -> assert false) + | _ -> assert false + in + register_type (Printf.sprintf "function_%d%s" n' ret_str) (fun () -> + match ret with + | None -> return { supertype = None; final = false; typ = W.Func (func_type n') } + | Some ret -> + let* super = function_type ~cps n in + return + { supertype = Some super; final = false; typ = W.Func (func_type ~ret n') }) let closure_common_fields ~cps = let* fun_ty = function_type ~cps 1 in diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index a4e227c874..15ba19d494 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -828,7 +828,7 @@ module Generate (Target : Target_sig.S) = struct then handler else let* () = handler in - instr (W.Return (Some (RefI31 (Const (I32 0l))))) + instr W.Unreachable else body ~result_typ ~fall_through ~context let wrap_with_handlers p pc ~result_typ ~fall_through ~context body = @@ -854,6 +854,70 @@ module Generate (Target : Target_sig.S) = struct ~fall_through ~context + let return_type (p : Code.program) name_opt ~toplevel_name pc = + let* ty = + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc ty -> + let block = Code.Addr.Map.find pc p.blocks in + match block.branch with + | Return x -> + let* ty = ty in + let* ty' = variable_type x in + value_type_lub ty (Option.value ~default:Type.value ty') + | Stop -> return Type.value + | Raise _ | Branch _ | Cond _ | Switch _ | Pushtrap _ | Poptrap _ -> ty) + pc + p.blocks + (return (W.Ref { nullable = false; typ = None_ })) + in + ignore (name_opt, toplevel_name); + (* + let nm v = Option.value ~default:"???" (Code.Var.get_name v) in + Format.eprintf + "%a: %s@." + (fun f ty -> + match (ty : W.value_type) with + | I32 | I64 | F32 | F64 -> assert false + | Ref { typ; _ } -> ( + match typ with + | Func | Extern -> assert false + | Any -> Format.fprintf f "any" + | Eq -> Format.fprintf f "eq" + | Struct -> Format.fprintf f "struct" + | Array -> Format.fprintf f "array" + | None_ -> Format.fprintf f "none" + | I31 -> Format.fprintf f "i31" + | Type v -> + Format.fprintf f "$%s" (Option.value ~default:"???" (Code.Var.get_name v)) + )) + ty + (nm + (match name_opt with + | None -> toplevel_name + | Some x -> x)); +*) + return ty + + let rec refine_type ~typ (instrs : W.instruction list) : W.instruction list = + match instrs with + | [ i ] -> [ refine_instr ~typ i ] + | [ i; (Event _ as i') ] -> [ refine_instr ~typ i; i' ] + | i :: rem -> i :: refine_type ~typ rem + | [] -> [] + + and refine_instr ~typ i = + match i with + | Block (ty, instrs') -> Block ({ ty with result = [ typ ] }, refine_type ~typ instrs') + | Loop (ty, instrs') -> Loop ({ ty with result = [ typ ] }, refine_type ~typ instrs') + | If (ty, e, instrs', instrs'') -> + If + ( { ty with result = [ typ ] } + , e + , refine_type ~typ instrs' + , refine_type ~typ instrs'' ) + | i -> i + let translate_function p ctx @@ -1020,7 +1084,7 @@ module Generate (Target : Target_sig.S) = struct (match name_opt with | None -> ctx.global_context.globalized_variables <- Globalize.f p g ctx.closures | Some _ -> ()); - let locals, body = + let locals, return_typ, body = function_body ~context:ctx.global_context ~param_names @@ -1043,9 +1107,12 @@ module Generate (Target : Target_sig.S) = struct translate_branch result_typ fall_through (-1) cont context) in let end_loc = Parse_bytecode.Debug.find_loc ctx.debug ~position:After pc in - match end_loc with - | Some loc -> event loc - | None -> return ()) + let* () = + match end_loc with + | Some loc -> event loc + | None -> return () + in + return_type p name_opt ~toplevel_name pc) in let locals, body = post_process_function_body ~param_names ~locals body in W.Function @@ -1057,21 +1124,38 @@ module Generate (Target : Target_sig.S) = struct (match name_opt with | None -> Option.map ~f:(fun name -> name ^ ".init") unit_name | Some _ -> None) - ; typ = None + ; typ = + (match name_opt with + | None -> None + | Some f -> + let cps = Var.Set.mem f ctx.in_cps in + Some + (Code_generation.eval + ~context:ctx.global_context + (Type.function_type + ~cps + ?ret: + (if Poly.equal return_typ Type.value + then None + else Some return_typ) + (if cps then param_count - 2 else param_count - 1)))) ; signature = (match name_opt with | None -> Type.primitive_type param_count - | Some _ -> Type.func_type (param_count - 1)) + | Some _ -> Type.func_type ~ret:return_typ (param_count - 1)) ; param_names ; locals - ; body + ; body = + (if Poly.equal return_typ Type.value + then body + else refine_type ~typ:return_typ body) } :: acc let init_function ~context ~to_link = let name = Code.Var.fresh_n "initialize" in let signature = { W.params = []; result = [ Type.value ] } in - let locals, body = + let locals, _, body = function_body ~context ~param_names:[] @@ -1086,7 +1170,9 @@ module Generate (Target : Target_sig.S) = struct in let* () = instr (Drop (Call (f, []))) in cont) - ~init:(instr (Push (RefI31 (Const (I32 0l))))) + ~init: + (let* unit = Value.unit in + instr (Push unit)) to_link) in context.other_fields <- @@ -1104,7 +1190,7 @@ module Generate (Target : Target_sig.S) = struct 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 + let locals, _, body = function_body ~context ~param_names ~body in W.Function { name = Var.fresh_n "entry_point" ; exported_name = Some entry_name diff --git a/compiler/lib-wasm/target_sig.ml b/compiler/lib-wasm/target_sig.ml index 65b9d5604b..82c0c4c976 100644 --- a/compiler/lib-wasm/target_sig.ml +++ b/compiler/lib-wasm/target_sig.ml @@ -99,9 +99,12 @@ module type S = sig module Type : sig val value : Wasm_ast.value_type - val func_type : int -> Wasm_ast.func_type + val func_type : ?ret:Wasm_ast.value_type -> int -> Wasm_ast.func_type val primitive_type : int -> Wasm_ast.func_type + + val function_type : + cps:bool -> ?ret:Wasm_ast.value_type -> int -> Wasm_ast.var Code_generation.t end module Value : sig diff --git a/compiler/lib-wasm/wasm_output.ml b/compiler/lib-wasm/wasm_output.ml index 408dc538bd..1badd0b193 100644 --- a/compiler/lib-wasm/wasm_output.ml +++ b/compiler/lib-wasm/wasm_output.ml @@ -264,25 +264,30 @@ end = struct output_uint ch len); List.fold_left ~f:(fun idx { name; typ; supertype; final } -> - Hashtbl.add type_names name idx; - (match supertype, final with - | None, true -> () - | None, false -> - output_byte ch 0x50; - output_byte ch 0 - | Some supertype, _ -> - output_byte ch (if final then 0X4F else 0x50); - output_byte ch 1; - output_uint ch (Hashtbl.find type_names supertype)); - (match typ with - | Array field_type -> - output_byte ch 0x5E; - output_fieldtype type_names ch field_type - | Struct l -> - output_byte ch 0x5F; - output_vec (output_fieldtype type_names) ch l - | Func typ -> output_functype type_names ch typ); - idx + 1) + match typ, supertype, final, len with + | Func typ, None, true, 1 when Hashtbl.mem func_types typ -> + Hashtbl.add type_names name (Hashtbl.find func_types typ); + idx + | _ -> + Hashtbl.add type_names name idx; + (match supertype, final with + | None, true -> () + | None, false -> + output_byte ch 0x50; + output_byte ch 0 + | Some supertype, _ -> + output_byte ch (if final then 0X4F else 0x50); + output_byte ch 1; + output_uint ch (Hashtbl.find type_names supertype)); + (match typ with + | Array field_type -> + output_byte ch 0x5E; + output_fieldtype type_names ch field_type + | Struct l -> + output_byte ch 0x5F; + output_vec (output_fieldtype type_names) ch l + | Func typ -> output_functype type_names ch typ); + idx + 1) ~init:idx l) 0 diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index 4d9592fa5c..1c46efc7eb 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -45,10 +45,10 @@ (type $block (array (mut (ref eq)))) (type $bytes (array (mut i8))) (type $primitive (func (param (ref eq) (ref eq)) (result (ref eq)))) - (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) + (type $function_1 (sub (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)))) + (sub (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))))) @@ -66,7 +66,7 @@ (@string $effect_unhandled "Effect.Unhandled") - (func $raise_unhandled + (func $raise_unhandled (type $function_1) (param $eff (ref eq)) (param (ref eq)) (result (ref eq)) (block $null (call $caml_raise_with_arg @@ -298,7 +298,7 @@ (field $eff (ref eq)) (field $cont (ref eq))))) - (func $call_effect_handler + (func $call_effect_handler (type $function_1) (param $tail (ref eq)) (param $venv (ref eq)) (result (ref eq)) (local $env (ref $call_handler_env)) (local $handler (ref $closure_3)) @@ -439,10 +439,10 @@ (@if (= effects "cps") (@then (type $function_2 - (func (param (ref eq) (ref eq) (ref eq)) (result (ref eq)))) + (sub (func (param (ref eq) (ref eq) (ref eq)) (result (ref eq))))) (type $function_4 - (func (param (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (result (ref eq)))) + (sub (func (param (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (result (ref eq))))) (type $cps_closure (sub (struct (field (ref $function_2))))) (type $cps_closure_0 (sub (struct (field (ref $function_1))))) (type $cps_closure_3 @@ -485,7 +485,7 @@ (struct.get $cps_fiber $exn_stack (global.get $cps_fiber_stack)))) (ref.i31 (i32.const 0))) - (func $raise_exception + (func $raise_exception (type $function_1) (param $exn (ref eq)) (param (ref eq)) (result (ref eq)) (throw $ocaml_exception (local.get $exn))) @@ -507,12 +507,13 @@ (param $exn (ref eq)) (param (ref eq)) (result (ref eq)) (local.get $exn)) - (func $identity (param (ref eq)) (param (ref eq)) (result (ref eq)) + (func $identity (type $function_1) + (param (ref eq)) (param (ref eq)) (result (ref eq)) (local.get 0)) (global $identity (ref $closure) (struct.new $closure (ref.func $identity))) - (func $trampoline_iterator + (func $trampoline_iterator (type $function_1) (param $f (ref eq)) (param $venv (ref eq)) (result (ref eq)) (local $env (ref $iterator)) (local $i i32) (local $args (ref $block)) @@ -532,7 +533,7 @@ (struct.get $cps_closure 0 (ref.cast (ref $cps_closure) (local.get $f))))) - (func $apply_iterator + (func $apply_iterator (type $function_1) (param $f (ref eq)) (param $venv (ref eq)) (result (ref eq)) (local $env (ref $iterator)) (local $i i32) (local $args (ref $block)) @@ -562,7 +563,7 @@ (i32.const 1) (ref.cast (ref $block) (local.get $args)))) - (func $dummy_cps_fun + (func $dummy_cps_fun (type $function_2) (param (ref eq)) (param (ref eq)) (param (ref eq)) (result (ref eq)) (unreachable)) @@ -750,7 +751,8 @@ (struct.get $cps_closure 0 (ref.cast (ref $cps_closure) (local.get $handler))))) - (func $value_handler (param $x (ref eq)) (param (ref eq)) (result (ref eq)) + (func $value_handler (type $function_1) + (param $x (ref eq)) (param (ref eq)) (result (ref eq)) (return_call $cps_call_handler (struct.get $cps_fiber $value (global.get $cps_fiber_stack)) (local.get $x))) @@ -758,7 +760,8 @@ (global $value_handler (ref $closure) (struct.new $closure (ref.func $value_handler))) - (func $exn_handler (param $x (ref eq)) (param (ref eq)) (result (ref eq)) + (func $exn_handler (type $function_1) + (param $x (ref eq)) (param (ref eq)) (result (ref eq)) (return_call $cps_call_handler (struct.get $cps_fiber $exn (global.get $cps_fiber_stack)) (local.get $x))) diff --git a/runtime/wasm/obj.wat b/runtime/wasm/obj.wat index 2fb32bf37b..a6091f6f94 100644 --- a/runtime/wasm/obj.wat +++ b/runtime/wasm/obj.wat @@ -34,12 +34,12 @@ (type $float (struct (field f64))) (type $float_array (array (mut f64))) (type $primitive (func (param (ref eq) (ref eq)) (result (ref eq)))) - (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq)))) + (type $function_1 (sub (func (param (ref eq) (ref eq)) (result (ref eq))))) (type $closure (sub (struct (;(field i32);) (field (ref $function_1))))) (type $closure_last_arg (sub $closure (struct (;(field i32);) (field (ref $function_1))))) (type $function_2 - (func (param (ref eq) (ref eq) (ref eq)) (result (ref eq)))) + (sub (func (param (ref eq) (ref eq) (ref eq)) (result (ref eq))))) (type $cps_closure (sub (struct (field (ref $function_2))))) (type $cps_closure_last_arg (sub $cps_closure (struct (field (ref $function_2))))) @@ -60,7 +60,7 @@ (field (mut (ref null $closure_2)))))) (type $function_3 - (func (param (ref eq) (ref eq) (ref eq) (ref eq)) (result (ref eq)))) + (sub (func (param (ref eq) (ref eq) (ref eq) (ref eq)) (result (ref eq))))) (type $closure_3 (sub $closure @@ -72,8 +72,8 @@ (field (mut (ref null $closure_3)))))) (type $function_4 - (func (param (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) - (result (ref eq)))) + (sub (func (param (ref eq) (ref eq) (ref eq) (ref eq) (ref eq)) + (result (ref eq))))) (type $closure_4 (sub $closure