More extensive Wasm AST

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 <-
@@ -453,7 +474,8 @@ let rec is_smi e =
   | RefNull _
   | Br_on_cast _
   | Br_on_cast_fail _
-  | Try _ -> false
+  | Try _
+  | ExternConvertAny _ -> false
   | BinOp ((F32 _ | F64 _), _, _) | RefTest _ | RefEq _ -> true
   | IfExpr (_, _, ift, iff) -> is_smi ift && is_smi iff
 

compiler/lib-wasm/curry.ml

@@ -102,7 +102,14 @@ 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 = None
+      ; signature = func_type 1
+      ; param_names
+      ; locals
+      ; body
+      }
 
   let curry_name n m = Printf.sprintf "curry_%d_%d" n m
 
@@ -130,7 +137,14 @@ 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 = None
+      ; signature = func_type 1
+      ; param_names
+      ; locals
+      ; body
+      }
     :: functions
 
   let curry ~arity ~name = curry ~arity arity ~name
@@ -174,7 +188,14 @@ 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 = None
+      ; signature = func_type 2
+      ; param_names
+      ; locals
+      ; body
+      }
 
   let cps_curry_name n m = Printf.sprintf "cps_curry_%d_%d" n m
 
@@ -206,7 +227,14 @@ 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 = None
+      ; signature = func_type 2
+      ; param_names
+      ; locals
+      ; body
+      }
     :: functions
 
   let cps_curry ~arity ~name = cps_curry ~arity arity ~name
@@ -243,7 +271,14 @@ 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 = None
+      ; signature = func_type arity
+      ; param_names
+      ; locals
+      ; body
+      }
 
   let cps_apply ~context ~arity ~name =
     assert (arity > 2);
@@ -283,7 +318,14 @@ 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 = None
+      ; signature = func_type arity
+      ; param_names
+      ; locals
+      ; body
+      }
 
   let dummy ~context ~cps ~arity ~name =
     let arity = if cps then arity + 1 else arity in
@@ -311,7 +353,14 @@ 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 = None
+      ; signature = func_type arity
+      ; param_names
+      ; locals
+      ; body
+      }
 
   let f ~context =
     IntMap.iter

compiler/lib-wasm/gc_target.ml

@@ -479,7 +479,7 @@ module Value = struct
     | W.RefI31 _ -> (
         match typ.typ with
         | W.I31 | Eq | Any -> return (W.Const (I32 1l))
-        | Type _ | Func | Extern -> return (W.Const (I32 0l)))
+        | Struct | Array | Type _ | None_ | Func | Extern -> return (W.Const (I32 0l)))
     | GlobalGet nm -> (
         let* init = get_global nm in
         match init with
@@ -513,7 +513,8 @@ module Value = struct
     | ArrayLen e'
     | StructGet (_, _, _, e')
     | RefCast (_, e')
-    | RefTest (_, e') -> effect_free e'
+    | RefTest (_, e')
+    | ExternConvertAny e' -> effect_free e'
     | BinOp (_, e1, e2)
     | ArrayNew (_, e1, e2)
     | ArrayNewData (_, _, e1, e2)

compiler/lib-wasm/generate.ml

@@ -1055,16 +1055,17 @@ 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
+      ; signature = func_type param_count
       ; param_names
-      ; typ = func_type param_count
       ; 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 signature = { W.params = []; result = [ Value.value ] } in
     let locals, body =
       function_body
         ~context
@@ -1073,25 +1074,37 @@ module Generate (Target : Target_sig.S) = struct
           (List.fold_right
              ~f:(fun name cont ->
                let* f =
-                 register_import ~import_module:"OCaml" ~name:(name ^ ".init") (Fun typ)
+                 register_import
+                   ~import_module:"OCaml"
+                   ~name:(name ^ ".init")
+                   (Fun signature)
                in
                let* () = instr (Drop (Call (f, []))) in
                cont)
              ~init:(instr (Push (RefI31 (Const (I32 0l)))))
              to_link)
     in
     context.other_fields <-
-      W.Function { name; exported_name = None; typ; param_names = []; locals; body }
+      W.Function
+        { name
+        ; exported_name = None
+        ; typ = None
+        ; signature
+        ; param_names = []
+        ; locals
+        ; body
+        }
       :: context.other_fields;
     name
 
   let entry_point context toplevel_fun entry_name =
-    let typ, param_names, body = entry_point ~toplevel_fun in
+    let signature, param_names, body = entry_point ~toplevel_fun in
     let locals, body = function_body ~context ~param_names ~body in
     W.Function
       { name = Var.fresh_n "entry_point"
       ; exported_name = Some entry_name
-      ; typ
+      ; typ = None
+      ; signature
       ; param_names
       ; locals
       ; body

compiler/lib-wasm/initialize_locals.ml

@@ -46,7 +46,8 @@ let rec scan_expression ctx e =
   | RefCast (_, e')
   | RefTest (_, e')
   | Br_on_cast (_, _, _, e')
-  | Br_on_cast_fail (_, _, _, e') -> scan_expression ctx e'
+  | Br_on_cast_fail (_, _, _, e')
+  | ExternConvertAny e' -> scan_expression ctx e'
   | BinOp (_, e', e'')
   | ArrayNew (_, e', e'')
   | ArrayNewData (_, _, e', e'')
@@ -94,7 +95,7 @@ and scan_instruction ctx i =
       scan_instructions ctx l;
       scan_instructions ctx l'
   | CallInstr (_, l) | Return_call (_, l) -> scan_expressions ctx l
-  | Br (_, None) | Return None | Rethrow _ | Nop | Event _ -> ()
+  | Br (_, None) | Return None | Rethrow _ | Nop | Unreachable | Event _ -> ()
   | ArraySet (_, e, e', e'') ->
       scan_expression ctx e;
       scan_expression ctx e';

compiler/lib-wasm/tail_call.ml

@@ -59,6 +59,7 @@ let rec instruction ~tail i =
   | StructSet _
   | Return_call _
   | Return_call_ref _
+  | Unreachable
   | Event _ -> i
 
 and instructions ~tail l =

compiler/lib-wasm/wasm_ast.ml

@@ -27,7 +27,10 @@ type heap_type =
   | Extern
   | Any
   | Eq
+  | Struct
+  | Array
   | I31
+  | None_
   | Type of var
 
 type ref_type =
@@ -166,6 +169,7 @@ type expression =
   | Br_on_cast_fail of int * ref_type * ref_type * expression
   | IfExpr of value_type * expression * expression * expression
   | Try of func_type * instruction list * (var * int * value_type) list
+  | ExternConvertAny of expression
 
 and instruction =
   | Drop of expression
@@ -187,6 +191,7 @@ and instruction =
   | StructSet of var * int * expression * expression
   | Return_call of var * expression list
   | Return_call_ref of var * expression * expression list
+  | Unreachable
   | Event of Parse_info.t  (** Location information *)
 
 type import_desc =
@@ -205,7 +210,8 @@ type module_field =
   | Function of
       { name : var
       ; exported_name : string option
-      ; typ : func_type
+      ; typ : var option
+      ; signature : func_type
       ; param_names : var list
       ; locals : (var * value_type) list
       ; body : instruction list

compiler/lib-wasm/wasm_link.ml

@@ -697,6 +697,12 @@ module Read = struct
         let pos = st.type_index_count in
         let pos' = add_rectype types ty in
         let count = Array.length ty in
+        let len = Array.length st.type_mapping in
+        if pos + count > len
+        then (
+          let m = Array.make (len + (len / 5) + count) 0 in
+          Array.blit ~src:st.type_mapping ~src_pos:0 ~dst:m ~dst_pos:0 ~len;
+          st.type_mapping <- m);
         for i = 0 to count - 1 do
           st.type_mapping.(pos + i) <- pos' + i
         done;