Clean-up regarding function and primitive types

Author: vouillon

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 ->
@@ -102,7 +97,7 @@ module Make (Target : Target_sig.S) = struct
     let param_names = args @ [ f ] in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
-      { name; exported_name = None; typ = func_type 1; param_names; locals; body }
+      { name; exported_name = None; typ = Type.func_type 1; param_names; locals; body }
 
   let curry_name n m = Printf.sprintf "curry_%d_%d" n m
 
@@ -130,7 +125,7 @@ module Make (Target : Target_sig.S) = struct
     let param_names = [ x; f ] in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
-      { name; exported_name = None; typ = func_type 1; param_names; locals; body }
+      { name; exported_name = None; typ = Type.func_type 1; param_names; locals; body }
     :: functions
 
   let curry ~arity ~name = curry ~arity arity ~name
@@ -174,7 +169,7 @@ module Make (Target : Target_sig.S) = struct
     let param_names = args @ [ f ] in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
-      { name; exported_name = None; typ = func_type 2; param_names; locals; body }
+      { name; exported_name = None; typ = Type.func_type 2; param_names; locals; body }
 
   let cps_curry_name n m = Printf.sprintf "cps_curry_%d_%d" n m
 
@@ -206,7 +201,7 @@ module Make (Target : Target_sig.S) = struct
     let param_names = [ x; cont; f ] in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
-      { name; exported_name = None; typ = func_type 2; param_names; locals; body }
+      { name; exported_name = None; typ = Type.func_type 2; param_names; locals; body }
     :: functions
 
   let cps_curry ~arity ~name = cps_curry ~arity arity ~name
@@ -243,7 +238,13 @@ module Make (Target : Target_sig.S) = struct
     let param_names = l @ [ f ] in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
-      { name; exported_name = None; typ = func_type arity; param_names; locals; body }
+      { name
+      ; exported_name = None
+      ; typ = Type.primitive_type (arity + 1)
+      ; param_names
+      ; locals
+      ; body
+      }
 
   let cps_apply ~context ~arity ~name =
     assert (arity > 2);
@@ -271,7 +272,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
@@ -283,7 +284,13 @@ module Make (Target : Target_sig.S) = struct
     let param_names = l @ [ f ] in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
-      { name; exported_name = None; typ = func_type arity; param_names; locals; body }
+      { name
+      ; exported_name = None
+      ; typ = Type.primitive_type (arity + 1)
+      ; param_names
+      ; locals
+      ; body
+      }
 
   let dummy ~context ~cps ~arity ~name =
     let arity = if cps then arity + 1 else arity in
@@ -311,7 +318,13 @@ module Make (Target : Target_sig.S) = struct
     let param_names = l @ [ f ] in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
-      { name; exported_name = None; typ = func_type arity; param_names; locals; body }
+      { name
+      ; exported_name = None
+      ; typ = Type.func_type arity
+      ; param_names
+      ; locals
+      ; body
+      }
 
   let f ~context =
     IntMap.iter

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 })
@@ -742,13 +742,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 =
@@ -778,7 +778,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* () =
@@ -839,7 +839,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 }))
@@ -1403,7 +1403,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))
@@ -1667,19 +1667,19 @@ 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 }
     (let* () =
        store
          x
          (block_expr
-            { params = []; result = [ Value.value ] }
+            { params = []; result = [ Type.value ] }
             (let* exn =
                block_expr
                  { params = []; result = [ externref ] }
@@ -1690,7 +1690,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

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,15 +1057,18 @@ module Generate (Target : Target_sig.S) = struct
           | None -> Option.map ~f:(fun name -> name ^ ".init") unit_name
           | Some _ -> None)
       ; param_names
-      ; typ = func_type param_count
+      ; typ =
+          (match name_opt with
+          | None -> Type.primitive_type param_count
+          | Some _ -> Type.func_type (param_count - 1))
       ; locals
       ; body
       }
     :: acc
 
   let init_function ~context ~to_link =
     let name = Code.Var.fresh_n "initialize" in
-    let typ = { W.params = []; result = [ Value.value ] } in
+    let typ = { W.params = []; result = [ Type.value ] } in
     let locals, body =
       function_body
         ~context
@@ -1232,7 +1234,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

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

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))

runtime/wasm/effect.wat

@@ -45,6 +45,7 @@
    (type $block (array (mut (ref eq))))
    (type $bytes (array (mut i8)))
    (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq))))
+   (type $primitive_2 (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))))
@@ -640,7 +641,7 @@
       (throw $ocaml_exception (local.get $exn)))
 
    (global $caml_trampoline_ref (export "caml_trampoline_ref")
-      (mut (ref null $function_1)) (ref.null $function_1))
+      (mut (ref null $primitive_2)) (ref.null $primitive_2))
 
    (func $caml_pop_fiber (result (ref eq))
       (local $f (ref $cps_fiber))

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))

runtime/wasm/obj.wat

@@ -24,13 +24,14 @@
    (import "effect" "caml_is_continuation"
       (func $caml_is_continuation (param (ref eq)) (result i32)))
    (import "effect" "caml_trampoline_ref"
-      (global $caml_trampoline_ref (mut (ref null $function_1))))
+      (global $caml_trampoline_ref (mut (ref null $primitive_2))))
 
    (type $block (array (mut (ref eq))))
    (type $bytes (array (mut i8)))
    (type $float (struct (field f64)))
    (type $float_array (array (mut f64)))
    (type $function_1 (func (param (ref eq) (ref eq)) (result (ref eq))))
+   (type $primitive_2 (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)))))
@@ -460,7 +461,7 @@
             (struct.get $closure 0
                (br_on_cast_fail $cps (ref eq) (ref $closure)
                   (local.get $f))))))
-      (return_call_ref $function_1
+      (return_call_ref $primitive_2
          (local.get $f)
          (array.new_fixed $block 2 (ref.i31 (i32.const 0)) (local.get $x))
          (ref.as_non_null (global.get $caml_trampoline_ref))))
@@ -480,7 +481,7 @@
                (call $caml_callback_1 (local.get $f) (local.get $x))
                (local.get $y)))
          (else
-            (return_call_ref $function_1
+            (return_call_ref $primitive_2
                (local.get $f)
                (array.new_fixed $block 3 (ref.i31 (i32.const 0))
                  (local.get $x) (local.get $y))