Add 2nd type annotations on casts

interpreter/binary/decode.ml

@@ -62,6 +62,8 @@ let at f s =
 
 (* Generic values *)
 
+let bit i n = n land (1 lsl i) <> 0
+
 let byte s =
   get s
 
@@ -588,37 +590,40 @@ let rec instr s =
 
   | 0xfb as b ->
     (match u32 s with
-    | 0x01l -> struct_new_canon (at var s)
-    | 0x02l -> struct_new_canon_default (at var s)
+    | 0x01l -> struct_new (at var s)
+    | 0x02l -> struct_new_default (at var s)
     | 0x03l -> let x = at var s in let y = at var s in struct_get x y
     | 0x04l -> let x = at var s in let y = at var s in struct_get_s x y
     | 0x05l -> let x = at var s in let y = at var s in struct_get_u x y
     | 0x06l -> let x = at var s in let y = at var s in struct_set x y
 
-    | 0x11l -> array_new_canon (at var s)
-    | 0x12l -> array_new_canon_default (at var s)
+    | 0x11l -> array_new (at var s)
+    | 0x12l -> array_new_default (at var s)
     | 0x13l -> array_get (at var s)
     | 0x14l -> array_get_s (at var s)
     | 0x15l -> array_get_u (at var s)
     | 0x16l -> array_set (at var s)
     | 0x17l -> array_len
 
-    | 0x19l -> let x = at var s in let n = u32 s in array_new_canon_fixed x n
-    | 0x1bl -> let x = at var s in let y = at var s in array_new_canon_data x y
-    | 0x1cl -> let x = at var s in let y = at var s in array_new_canon_elem x y
+    | 0x19l -> let x = at var s in let n = u32 s in array_new_fixed x n
+    | 0x1bl -> let x = at var s in let y = at var s in array_new_data x y
+    | 0x1cl -> let x = at var s in let y = at var s in array_new_elem x y
 
     | 0x20l -> i31_new
     | 0x21l -> i31_get_s
     | 0x22l -> i31_get_u
 
-    | 0x40l -> ref_test (heap_type s)
-    | 0x41l -> ref_cast (heap_type s)
-    | 0x42l -> let x = at var s in br_on_cast x (heap_type s)
-    | 0x43l -> let x = at var s in br_on_cast_fail x (heap_type s)
-    | 0x48l -> ref_test_null (heap_type s)
-    | 0x49l -> ref_cast_null (heap_type s)
-    | 0x4al -> let x = at var s in br_on_cast_null x (heap_type s)
-    | 0x4bl -> let x = at var s in br_on_cast_fail_null x (heap_type s)
+    | 0x40l -> ref_test (NoNull, heap_type s)
+    | 0x41l -> ref_cast (NoNull, heap_type s)
+    | 0x48l -> ref_test (Null, heap_type s)
+    | 0x49l -> ref_cast (Null, heap_type s)
+    | 0x4el | 0x4fl as opcode ->
+      let flags = byte s in
+      require (flags land 0xfc = 0) s (pos + 2) "malformed br_on_cast flags";
+      let x = at var s in
+      let rt1 = ((if bit 0 flags then Null else NoNull), heap_type s) in
+      let rt2 = ((if bit 1 flags then Null else NoNull), heap_type s) in
+      (if opcode = 0x4el then br_on_cast else br_on_cast_fail) x rt1 rt2
 
     | 0x70l -> extern_internalize
     | 0x71l -> extern_externalize

interpreter/binary/encode.ml

@@ -40,6 +40,8 @@ struct
 
   (* Generic values *)
 
+  let bit i b = (if b then 1 else 0) lsl i
+
   let byte i = put s (Char.chr (i land 0xff))
   let word16 i = byte (i land 0xff); byte (i lsr 8)
   let word32 i =
@@ -241,10 +243,12 @@ struct
     | BrTable (xs, x) -> op 0x0e; vec var xs; var x
     | BrOnNull x -> op 0xd4; var x
     | BrOnNonNull x -> op 0xd6; var x
-    | BrOnCast (x, (NoNull, t)) -> op 0xfb; op 0x42; var x; heap_type t
-    | BrOnCast (x, (Null, t)) -> op 0xfb; op 0x4a; var x; heap_type t
-    | BrOnCastFail (x, (NoNull, t)) -> op 0xfb; op 0x43; var x; heap_type t
-    | BrOnCastFail (x, (Null, t)) -> op 0xfb; op 0x4b; var x; heap_type t
+    | BrOnCast (x, (nul1, t1), (nul2, t2)) ->
+      let flags = bit 0 (nul1 = Null) + bit 1 (nul2 = Null) in
+      op 0xfb; op 0x4e; byte flags; var x; heap_type t1; heap_type t2
+    | BrOnCastFail (x, (nul1, t1), (nul2, t2)) ->
+      let flags = bit 0 (nul1 = Null) + bit 1 (nul2 = Null) in
+      op 0xfb; op 0x4f; byte flags; var x; heap_type t1; heap_type t2
     | Return -> op 0x0f
     | Call x -> op 0x10; var x
     | CallRef x -> op 0x14; var x

interpreter/exec/eval.ml

@@ -215,16 +215,16 @@ let rec step (c : config) : config =
       | BrOnNonNull x, Ref r :: vs' ->
         Ref r :: vs', [Plain (Br x) @@ e.at]
 
-      | BrOnCast (x, rt), Ref r :: vs' ->
-        let rt' = dyn_ref_type c.frame.inst.types rt in
-        if Match.match_ref_type [] (type_of_ref r) rt' then
+      | BrOnCast (x, _rt1, rt2), Ref r :: vs' ->
+        let rt2' = dyn_ref_type c.frame.inst.types rt2 in
+        if Match.match_ref_type [] (type_of_ref r) rt2' then
           Ref r :: vs', [Plain (Br x) @@ e.at]
         else
           Ref r :: vs', []
 
-      | BrOnCastFail (x, rt), Ref r :: vs' ->
-        let rt' = dyn_ref_type c.frame.inst.types rt in
-        if Match.match_ref_type [] (type_of_ref r) rt' then
+      | BrOnCastFail (x, _rt1, rt2), Ref r :: vs' ->
+        let rt2' = dyn_ref_type c.frame.inst.types rt2 in
+        if Match.match_ref_type [] (type_of_ref r) rt2' then
           Ref r :: vs', []
         else
           Ref r :: vs', [Plain (Br x) @@ e.at]

interpreter/syntax/ast.ml

@@ -154,8 +154,8 @@ and instr' =
   | BrTable of idx list * idx         (* indexed break *)
   | BrOnNull of idx                   (* break on type *)
   | BrOnNonNull of idx                (* break on type inverted *)
-  | BrOnCast of idx * ref_type        (* break on type *)
-  | BrOnCastFail of idx * ref_type    (* break on type inverted *)
+  | BrOnCast of idx * ref_type * ref_type     (* break on type *)
+  | BrOnCastFail of idx * ref_type * ref_type (* break on type inverted *)
   | Return                            (* break from function body *)
   | Call of idx                       (* call function *)
   | CallRef of idx                    (* call function through reference *)

interpreter/syntax/free.ml

@@ -141,7 +141,8 @@ let rec instr (e : instr) =
   | Block (bt, es) | Loop (bt, es) -> block_type bt ++ block es
   | If (bt, es1, es2) -> block_type bt ++ block es1 ++ block es2
   | Br x | BrIf x | BrOnNull x | BrOnNonNull x -> labels (idx x)
-  | BrOnCast (x, t) | BrOnCastFail (x, t) -> labels (idx x) ++ ref_type t
+  | BrOnCast (x, t1, t2) | BrOnCastFail (x, t1, t2) ->
+    labels (idx x) ++ ref_type t1 ++ ref_type t2
   | BrTable (xs, x) -> list (fun x -> labels (idx x)) (x::xs)
   | Return -> empty
   | Call x | ReturnCall x -> funcs (idx x)

interpreter/syntax/operators.ml

@@ -29,10 +29,8 @@ let br_if x = BrIf x
 let br_table xs x = BrTable (xs, x)
 let br_on_null x = BrOnNull x
 let br_on_non_null x = BrOnNonNull x
-let br_on_cast x t = BrOnCast (x, (NoNull, t))
-let br_on_cast_null x t = BrOnCast (x, (Null, t))
-let br_on_cast_fail x t = BrOnCastFail (x, (NoNull, t))
-let br_on_cast_fail_null x t = BrOnCastFail (x, (Null, t))
+let br_on_cast x t1 t2 = BrOnCast (x, t1, t2)
+let br_on_cast_fail x t1 t2 = BrOnCastFail (x, t1, t2)
 
 let return = Return
 let call x = Call x
@@ -106,26 +104,24 @@ let data_drop x = DataDrop x
 
 let ref_is_null = RefIsNull
 let ref_as_non_null = RefAsNonNull  
-let ref_test t = RefTest (NoNull, t)
-let ref_test_null t = RefTest (Null, t)
-let ref_cast t = RefCast (NoNull, t)
-let ref_cast_null t = RefCast (Null, t)
+let ref_test t = RefTest t
+let ref_cast t = RefCast t
 let ref_eq = RefEq
 
 let i31_new = I31New
 let i31_get_u = I31Get ZX
 let i31_get_s = I31Get SX
-let struct_new_canon x = StructNew (x, Explicit)
-let struct_new_canon_default x = StructNew (x, Implicit)
+let struct_new x = StructNew (x, Explicit)
+let struct_new_default x = StructNew (x, Implicit)
 let struct_get x y = StructGet (x, y, None)
 let struct_get_u x y = StructGet (x, y, Some ZX)
 let struct_get_s x y = StructGet (x, y, Some SX)
 let struct_set x y = StructSet (x, y)
-let array_new_canon x = ArrayNew (x, Explicit)
-let array_new_canon_default x = ArrayNew (x, Implicit)
-let array_new_canon_fixed x n = ArrayNewFixed (x, n)
-let array_new_canon_elem x y = ArrayNewElem (x, y)
-let array_new_canon_data x y = ArrayNewData (x, y)
+let array_new x = ArrayNew (x, Explicit)
+let array_new_default x = ArrayNew (x, Implicit)
+let array_new_fixed x n = ArrayNewFixed (x, n)
+let array_new_elem x y = ArrayNewElem (x, y)
+let array_new_data x y = ArrayNewData (x, y)
 let array_get x = ArrayGet (x, None)
 let array_get_u x = ArrayGet (x, Some ZX)
 let array_get_s x = ArrayGet (x, Some SX)

interpreter/text/arrange.ml

@@ -82,17 +82,10 @@ let var_type = function
   | DynX _ -> assert false
   | RecX x -> "rec." ^ nat32 x
 
-let null = function
-  | NoNull -> ""
-  | Null -> "null "
-
 let final = function
   | NoFinal -> ""
   | Final -> " final"
 
-let ref_type_raw (nul, t) =
-  Atom (null nul ^ heap_type t)
-
 let decls kind ts = tab kind (atom val_type) ts
 
 let field_type (FieldT (mut, t)) =
@@ -512,8 +505,10 @@ let rec instr e =
       "br_table " ^ String.concat " " (list var (xs @ [x])), []
     | BrOnNull x -> "br_on_null " ^ var x, []
     | BrOnNonNull x -> "br_on_non_null " ^ var x, []
-    | BrOnCast (x, t) -> "br_on_cast " ^ var x, [ref_type_raw t]
-    | BrOnCastFail (x, t) -> "br_on_cast_fail " ^ var x, [ref_type_raw t]
+    | BrOnCast (x, t1, t2) ->
+      "br_on_cast " ^ var x, [Atom (ref_type t1); Atom (ref_type t2)]
+    | BrOnCastFail (x, t1, t2) ->
+      "br_on_cast_fail " ^ var x, [Atom (ref_type t1); Atom (ref_type t2)]
     | Return -> "return", []
     | Call x -> "call " ^ var x, []
     | CallRef x -> "call_ref " ^ var x, []
@@ -552,19 +547,19 @@ let rec instr e =
     | RefFunc x -> "ref.func " ^ var x, []
     | RefIsNull -> "ref.is_null", []
     | RefAsNonNull -> "ref.as_non_null", []
-    | RefTest t -> "ref.test", [ref_type_raw t]
-    | RefCast t -> "ref.cast", [ref_type_raw t]
+    | RefTest t -> "ref.test", [Atom (ref_type t)]
+    | RefCast t -> "ref.cast", [Atom (ref_type t)]
     | RefEq -> "ref.eq", []
     | I31New -> "i31.new", []
     | I31Get ext -> "i31.get" ^ extension ext, []
-    | StructNew (x, op) -> "struct.new_canon" ^ initop op ^ " " ^ var x, []
+    | StructNew (x, op) -> "struct.new" ^ initop op ^ " " ^ var x, []
     | StructGet (x, y, exto) ->
       "struct.get" ^ opt_s extension exto ^ " " ^ var x ^ " " ^ var y, []
     | StructSet (x, y) -> "struct.set " ^ var x ^ " " ^ var y, []
-    | ArrayNew (x, op) -> "array.new_canon" ^ initop op ^ " " ^ var x, []
-    | ArrayNewFixed (x, n) -> "array.new_canon_fixed " ^ var x ^ " " ^ nat32 n, []
-    | ArrayNewElem (x, y) -> "array.new_canon_elem " ^ var x ^ " " ^ var y, []
-    | ArrayNewData (x, y) -> "array.new_canon_data " ^ var x ^ " " ^ var y, []
+    | ArrayNew (x, op) -> "array.new" ^ initop op ^ " " ^ var x, []
+    | ArrayNewFixed (x, n) -> "array.new_fixed " ^ var x ^ " " ^ nat32 n, []
+    | ArrayNewElem (x, y) -> "array.new_elem " ^ var x ^ " " ^ var y, []
+    | ArrayNewData (x, y) -> "array.new_data " ^ var x ^ " " ^ var y, []
     | ArrayGet (x, exto) -> "array.get" ^ opt_s extension exto ^ " " ^ var x, []
     | ArraySet x -> "array.set " ^ var x, []
     | ArrayLen -> "array.len", []

interpreter/text/lexer.mll

@@ -187,10 +187,10 @@ rule token = parse
       | "br" -> BR
       | "br_if" -> BR_IF
       | "br_table" -> BR_TABLE
-      | "br_on_null" -> BR_ON_NULL
-      | "br_on_non_null" -> BR_ON_NON_NULL
-      | "br_on_cast" -> BR_ON_CAST (br_on_cast, br_on_cast_null)
-      | "br_on_cast_fail" -> BR_ON_CAST_FAIL (br_on_cast_fail, br_on_cast_fail_null)
+      | "br_on_null" -> BR_ON_NULL br_on_null
+      | "br_on_non_null" -> BR_ON_NULL br_on_non_null
+      | "br_on_cast" -> BR_ON_CAST br_on_cast
+      | "br_on_cast_fail" -> BR_ON_CAST br_on_cast_fail
       | "return" -> RETURN
       | "if" -> IF
       | "then" -> THEN
@@ -316,26 +316,26 @@ rule token = parse
 
       | "ref.is_null" -> REF_IS_NULL
       | "ref.as_non_null" -> REF_AS_NON_NULL
-      | "ref.test" -> REF_TEST (ref_test, ref_test_null)
-      | "ref.cast" -> REF_CAST (ref_cast, ref_cast_null)
+      | "ref.test" -> REF_TEST
+      | "ref.cast" -> REF_CAST
       | "ref.eq" -> REF_EQ
 
       | "i31.new" -> I31_NEW
       | "i31.get_u" -> I31_GET i31_get_u
       | "i31.get_s" -> I31_GET i31_get_s
 
-      | "struct.new_canon" -> STRUCT_NEW struct_new_canon
-      | "struct.new_canon_default" -> STRUCT_NEW struct_new_canon_default
+      | "struct.new" -> STRUCT_NEW struct_new
+      | "struct.new_default" -> STRUCT_NEW struct_new_default
       | "struct.get" -> STRUCT_GET struct_get
       | "struct.get_u" -> STRUCT_GET struct_get_u
       | "struct.get_s" -> STRUCT_GET struct_get_s
       | "struct.set" -> STRUCT_SET
 
-      | "array.new_canon" -> ARRAY_NEW array_new_canon
-      | "array.new_canon_default" -> ARRAY_NEW array_new_canon_default
-      | "array.new_canon_fixed" -> ARRAY_NEW_FIXED
-      | "array.new_canon_elem" -> ARRAY_NEW_ELEM
-      | "array.new_canon_data" -> ARRAY_NEW_DATA
+      | "array.new" -> ARRAY_NEW array_new
+      | "array.new_default" -> ARRAY_NEW array_new_default
+      | "array.new_fixed" -> ARRAY_NEW_FIXED
+      | "array.new_elem" -> ARRAY_NEW_ELEM
+      | "array.new_data" -> ARRAY_NEW_DATA
       | "array.get" -> ARRAY_GET array_get
       | "array.get_u" -> ARRAY_GET array_get_u
       | "array.get_s" -> ARRAY_GET array_get_s

interpreter/text/parser.mly

@@ -254,8 +254,9 @@ let inline_func_type_explicit (c : context) x ft at =
 %token MUT FIELD STRUCT ARRAY SUB FINAL REC
 %token UNREACHABLE NOP DROP SELECT
 %token BLOCK END IF THEN ELSE LOOP
-%token BR BR_IF BR_TABLE BR_ON_NULL BR_ON_NON_NULL
-%token<(Ast.idx -> Types.heap_type -> Ast.instr') * (Ast.idx -> Types.heap_type -> Ast.instr')> BR_ON_CAST BR_ON_CAST_FAIL
+%token BR BR_IF BR_TABLE
+%token<Ast.idx -> Ast.instr'> BR_ON_NULL
+%token<Ast.idx -> Types.ref_type -> Types.ref_type -> Ast.instr'> BR_ON_CAST
 %token CALL CALL_REF CALL_INDIRECT
 %token RETURN RETURN_CALL RETURN_CALL_REF RETURN_CALL_INDIRECT
 %token LOCAL_GET LOCAL_SET LOCAL_TEE GLOBAL_GET GLOBAL_SET
@@ -267,8 +268,7 @@ let inline_func_type_explicit (c : context) x ft at =
 %token<string Source.phrase -> Ast.instr' * Value.num> CONST
 %token<Ast.instr'> UNARY BINARY TEST COMPARE CONVERT
 %token REF_NULL REF_FUNC REF_I31 REF_STRUCT REF_ARRAY REF_EXTERN REF_HOST
-%token REF_EQ REF_IS_NULL REF_AS_NON_NULL
-%token<(Types.heap_type -> Ast.instr') * (Types.heap_type -> Ast.instr')> REF_TEST REF_CAST
+%token REF_EQ REF_IS_NULL REF_AS_NON_NULL REF_TEST REF_CAST
 %token I31_NEW
 %token<Ast.instr'> I31_GET
 %token<Ast.idx -> Ast.instr'> STRUCT_NEW ARRAY_NEW ARRAY_GET
@@ -506,12 +506,8 @@ plain_instr :
   | BR_TABLE var var_list
     { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in
       br_table xs x }
-  | BR_ON_NULL var { fun c -> br_on_null ($2 c label) }
-  | BR_ON_NON_NULL var { fun c -> br_on_non_null ($2 c label) }
-  | BR_ON_CAST var heap_type { fun c -> fst $1 ($2 c label) ($3 c) }
-  | BR_ON_CAST var NULL heap_type { fun c -> snd $1 ($2 c label) ($4 c) }
-  | BR_ON_CAST_FAIL var heap_type { fun c -> fst $1 ($2 c label) ($3 c) }
-  | BR_ON_CAST_FAIL var NULL heap_type { fun c -> snd $1 ($2 c label) ($4 c) }
+  | BR_ON_NULL var { fun c -> $1 ($2 c label) }
+  | BR_ON_CAST var ref_type ref_type { fun c -> $1 ($2 c label) ($3 c) ($4 c) }
   | RETURN { fun c -> return }
   | CALL var { fun c -> call ($2 c func) }
   | CALL_REF var { fun c -> call_ref ($2 c type_) }
@@ -557,20 +553,18 @@ plain_instr :
   | REF_FUNC var { fun c -> ref_func ($2 c func) }
   | REF_IS_NULL { fun c -> ref_is_null }
   | REF_AS_NON_NULL { fun c -> ref_as_non_null }
-  | REF_TEST heap_type { fun c -> fst $1 ($2 c) }
-  | REF_CAST heap_type { fun c -> fst $1 ($2 c) }
-  | REF_TEST NULL heap_type { fun c -> snd $1 ($3 c) }
-  | REF_CAST NULL heap_type { fun c -> snd $1 ($3 c) }
+  | REF_TEST ref_type { fun c -> ref_test ($2 c) }
+  | REF_CAST ref_type { fun c -> ref_cast ($2 c) }
   | REF_EQ { fun c -> ref_eq }
   | I31_NEW { fun c -> i31_new }
   | I31_GET { fun c -> $1 }
   | STRUCT_NEW var { fun c -> $1 ($2 c type_) }
   | STRUCT_GET var var { fun c -> $1 ($2 c type_) ($3 c field) }
   | STRUCT_SET var var { fun c -> struct_set ($2 c type_) ($3 c field) }
   | ARRAY_NEW var { fun c -> $1 ($2 c type_) }
-  | ARRAY_NEW_FIXED var nat32 { fun c -> array_new_canon_fixed ($2 c type_) $3 }
-  | ARRAY_NEW_ELEM var var { fun c -> array_new_canon_elem ($2 c type_) ($3 c elem) }
-  | ARRAY_NEW_DATA var var { fun c -> array_new_canon_data ($2 c type_) ($3 c data) }
+  | ARRAY_NEW_FIXED var nat32 { fun c -> array_new_fixed ($2 c type_) $3 }
+  | ARRAY_NEW_ELEM var var { fun c -> array_new_elem ($2 c type_) ($3 c elem) }
+  | ARRAY_NEW_DATA var var { fun c -> array_new_data ($2 c type_) ($3 c data) }
   | ARRAY_GET var { fun c -> $1 ($2 c type_) }
   | ARRAY_SET var { fun c -> array_set ($2 c type_) }
   | ARRAY_LEN { fun c -> array_len }