Fix JS type test wrappers

Author: rossberg

interpreter/runtime/value.ml

@@ -95,23 +95,17 @@ let is_null_ref = function
 (* Typing *)
 
 let type_of_op = function
-  | I32 _ -> Types.I32T
-  | I64 _ -> Types.I64T
-  | F32 _ -> Types.F32T
-  | F64 _ -> Types.F64T
-
-let type_of_vecop = function
-  | V128 _ -> Types.V128T
-
-let type_of_num = function
   | I32 _ -> I32T
   | I64 _ -> I64T
   | F32 _ -> F32T
   | F64 _ -> F64T
 
-let type_of_vec = function
+let type_of_vecop = function
   | V128 _ -> V128T
 
+let type_of_num = type_of_op
+let type_of_vec = type_of_vecop
+
 let type_of_ref' = ref (function _ -> assert false)
 let type_of_ref = function
   | NullRef t -> (Null, Match.bot_of_heap_type [] t)

interpreter/script/js.ml

@@ -294,8 +294,29 @@ let nan_bitmask_of = function
   | CanonicalNan -> abs_mask_of  (* differ from canonical NaN in sign bit *)
   | ArithmeticNan -> canonical_nan_of  (* 1 everywhere canonical NaN is *)
 
+let type_of_num_pat = function
+  | NumPat num -> Value.type_of_num num.it
+  | NanPat op -> Value.type_of_op op.it
+
+let type_of_vec_pat = function
+  | VecPat vec -> Value.type_of_vec vec
+
+let type_of_ref_pat = function
+  | RefPat ref -> type_of_ref ref.it
+  | RefTypePat ht -> (NoNull, ht)
+  | NullPat -> (Null, BotHT)
+
+let type_of_result res =
+  match res.it with
+  | NumResult pat -> NumT (type_of_num_pat pat)
+  | VecResult pat -> VecT (type_of_vec_pat pat)
+  | RefResult pat -> RefT (type_of_ref_pat pat)
+
 let assert_return ress ts at =
   let test (res, t) =
+    if not (Match.match_val_type [] t (type_of_result res)) then
+      [ Br (0l @@ at) @@ at ]
+    else
     match res.it with
     | NumResult (NumPat {it = num; at = at'}) ->
       let t', reinterpret = reinterpret_of (Value.type_of_op num) in
@@ -362,7 +383,7 @@ let assert_return ress ts at =
         VecTest (V128 (V128.I8x16 V128Op.AllTrue)) @@ at;
         Test (I32 I32Op.Eqz) @@ at;
         BrIf (0l @@ at) @@ at ]
-    | RefResult (RefPat {it = NullRef t; _}) ->
+    | RefResult (RefPat {it = NullRef _; _}) ->
       [ RefIsNull @@ at;
         Test (Value.I32 I32Op.Eqz) @@ at;
         BrIf (0l @@ at) @@ at ]
@@ -374,17 +395,16 @@ let assert_return ress ts at =
         BrIf (0l @@ at) @@ at ]
     | RefResult (RefPat _) ->
       assert false
+    | RefResult (RefTypePat (ExnHT | ExternHT)) ->
+      [ BrOnNull (0l @@ at) @@ at ]
     | RefResult (RefTypePat t) ->
       [ RefTest (NoNull, t) @@ at;
         Test (I32 I32Op.Eqz) @@ at;
         BrIf (0l @@ at) @@ at ]
     | RefResult NullPat ->
-      (match t with
-      | RefT _ ->
-        [ BrOnNull (0l @@ at) @@ at ]
-      | _ ->
-        [ Br (0l @@ at) @@ at ]
-      )
+      [ RefIsNull @@ at;
+        Test (I32 I32Op.Eqz) @@ at;
+        BrIf (0l @@ at) @@ at ]
   in [], List.flatten (List.rev_map test (List.combine ress ts))
 
 let i32 = NumT I32T
@@ -431,10 +451,17 @@ let is_js_num_type = function
   | I32T -> true
   | I64T | F32T | F64T -> false
 
+let is_js_vec_type = function
+  | _ -> false
+
+let is_js_ref_type = function
+  | (_, ExnHT) -> false
+  | _ -> true
+
 let is_js_val_type = function
   | NumT t -> is_js_num_type t
-  | VecT _ -> false
-  | RefT _ -> true
+  | VecT t -> is_js_vec_type t
+  | RefT t -> is_js_ref_type t
   | BotT -> assert false
 
 let is_js_global_type = function

interpreter/script/run.ml

@@ -394,6 +394,7 @@ let assert_ref_pat r p =
   | RefTypePat Types.StructHT, Aggr.StructRef _
   | RefTypePat Types.ArrayHT, Aggr.ArrayRef _ -> true
   | RefTypePat Types.FuncHT, Instance.FuncRef _
+  | RefTypePat Types.ExnHT, Value.ExnRef _
   | RefTypePat Types.ExternHT, _ -> true
   | NullPat, Value.NullRef _ -> true
   | _ -> false

interpreter/text/parser.mly

@@ -1449,7 +1449,7 @@ result :
   | LPAR REF_STRUCT RPAR { RefResult (RefTypePat StructHT) @@ $sloc }
   | LPAR REF_ARRAY RPAR { RefResult (RefTypePat ArrayHT) @@ $sloc }
   | LPAR REF_FUNC RPAR { RefResult (RefTypePat FuncHT) @@ $sloc }
-/*| LPAR REF_EXN RPAR { RefResult (RefTypePat ExnRefType) @@ $sloc }*/
+  | LPAR REF_EXN RPAR { RefResult (RefTypePat ExnHT) @@ $sloc }
   | LPAR REF_EXTERN RPAR { RefResult (RefTypePat ExternHT) @@ $sloc }
   | LPAR REF_NULL RPAR { RefResult NullPat @@ $sloc }
   | LPAR VEC_CONST VEC_SHAPE list(numpat) RPAR