More precise function type

compiler/lib-wasm/code_generation.ml

@@ -161,19 +161,40 @@ let heap_type_sub (ty : W.heap_type) (ty' : W.heap_type) st =
   match ty, ty' with
   | Func, Func
   | Extern, Extern
-  | (Any | Eq | I31 | Type _), Any
-  | (Eq | I31 | Type _), Eq
-  | I31, I31 -> true, st
+  | (Any | Eq | Struct | Array | I31 | None_ | Type _), Any
+  | (Eq | Struct | Array | I31 | None_ | Type _), Eq
+  | (None_ | Struct), Struct -> true, st
+  | (None_ | Array), Array -> true, st
+  | (None_ | I31), I31 -> true, st
+  | None_, None_ -> true, st
+  | Type t, Struct ->
+      ( (let type_field = Hashtbl.find st.context.types t in
+         match type_field.typ with
+         | Struct _ -> true
+         | Array _ | Func _ -> false)
+      , st )
+  | Type t, Array ->
+      ( (let type_field = Hashtbl.find st.context.types t in
+         match type_field.typ with
+         | Array _ -> true
+         | Struct _ | Func _ -> false)
+      , st )
   | Type t, Type t' -> type_index_sub t t' st
+  | None_, Type t ->
+      ( (let type_field = Hashtbl.find st.context.types t in
+         match type_field.typ with
+         | Struct _ | Array _ -> true
+         | Func _ -> false)
+      , st )
   (* Func and Extern are only in suptyping relation with themselves *)
   | Func, _
   | _, Func
   | Extern, _
   | _, Extern
   (* Any has no supertype *)
   | Any, _
-  (* I31, struct and arrays have no subtype (of a different kind) *)
-  | _, (I31 | Type _) -> false, st
+  (* I31, struct, array and none have no other subtype *)
+  | _, (I31 | Type _ | Struct | Array | None_) -> false, st
 
 let register_global name ?exported_name ?(constant = false) typ init st =
   st.context.other_fields <-
@@ -489,6 +510,31 @@ let tee ?typ x e =
 
 let should_make_global x st = Var.Set.mem x st.context.globalized_variables, 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 empty_struct =
+  let* typ =
+    register_type "empty_struct" (fun () ->
+        return { supertype = None; final = true; typ = W.Struct [] })
+  in
+  placeholder_value typ (fun typ -> W.StructNew (typ, []))
+
 let value_type st = st.context.value_type, st
 
 let rec store ?(always = false) ?typ x e =

compiler/lib-wasm/code_generation.mli

@@ -203,3 +203,5 @@ 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 empty_struct : expression

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 ->
@@ -40,7 +35,12 @@ module Make (Target : Target_sig.S) = struct
 
   let call ?typ ~cps ~arity closure args =
     let funct = Var.fresh () in
-    let* closure = tee ?typ funct closure in
+    let closure = tee ?typ funct closure in
+    let* closure =
+      match typ with
+      | None -> Memory.cast_closure ~cps ~arity closure
+      | Some _ -> closure
+    in
     let args = args @ [ closure ] in
     let* ty, funct =
       Memory.load_function_pointer
@@ -73,7 +73,7 @@ module Make (Target : Target_sig.S) = struct
     let body =
       let* () = no_event in
       let* () = bind_parameters args in
-      let* _ = add_var f in
+      let* _ = add_var ~typ:Type.closure f in
       let* args' = expression_list load args in
       let* _f = load f in
       let rec loop m args closure closure_typ =
@@ -102,7 +102,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
 
@@ -124,13 +124,13 @@ module Make (Target : Target_sig.S) = struct
     let body =
       let* () = no_event in
       let* _ = add_var x in
-      let* _ = add_var f in
+      let* _ = add_var ~typ:Type.closure f in
       push (Closure.curry_allocate ~cps:false ~arity m ~f:name' ~closure:f ~arg:x)
     in
     let param_names = [ x; f ] in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
-      { name; exported_name = None; typ = func_type 1; param_names; locals; body }
+      { name; exported_name = None; typ = Type.func_type 1; param_names; locals; body }
     :: functions
 
   let curry ~arity ~name = curry ~arity arity ~name
@@ -145,7 +145,7 @@ module Make (Target : Target_sig.S) = struct
     let body =
       let* () = no_event in
       let* () = bind_parameters args in
-      let* _ = add_var f in
+      let* _ = add_var ~typ:Type.closure f in
       let* args' = expression_list load args in
       let* _f = load f in
       let rec loop m args closure closure_typ =
@@ -174,7 +174,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
 
@@ -198,15 +198,15 @@ module Make (Target : Target_sig.S) = struct
       let* () = no_event in
       let* _ = add_var x in
       let* _ = add_var cont in
-      let* _ = add_var f in
+      let* _ = add_var ~typ:Type.closure f in
       let* e = Closure.curry_allocate ~cps:true ~arity m ~f:name' ~closure:f ~arg:x in
       let* c = call ~cps:false ~arity:1 (load cont) [ e ] in
       instr (W.Return (Some c))
     in
     let param_names = [ x; cont; f ] in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
-      { name; exported_name = None; typ = func_type 2; param_names; locals; body }
+      { 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 +243,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 +277,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 +289,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
@@ -295,7 +307,7 @@ module Make (Target : Target_sig.S) = struct
     let body =
       let* () = no_event in
       let* () = bind_parameters l in
-      let* _ = add_var f in
+      let* _ = add_var ~typ:Type.closure f in
       let* typ, closure = Memory.load_real_closure ~cps ~arity (load f) in
       let* l = expression_list load l in
       let* e =
@@ -311,7 +323,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