Reference interpreter

.github/workflows/ci-interpreter.yml

@@ -33,4 +33,4 @@ jobs:
       - name: Run tests
         # TODO: reactiate node once it supports all of Wasm 3.0
         # run: cd interpreter && opam exec make JS=node ci
-        run: cd interpreter && opam exec make ci
+        run: cd interpreter && opam exec make test

interpreter/binary/decode.ml

@@ -180,6 +180,7 @@ let heap_type s =
     (fun s -> VarHT (var_type s33 s));
     (fun s ->
       match s7 s with
+      | -0x0b -> NoContHT
       | -0x0c -> NoExnHT
       | -0x0d -> NoFuncHT
       | -0x0e -> NoExternHT
@@ -192,13 +193,15 @@ let heap_type s =
       | -0x15 -> StructHT
       | -0x16 -> ArrayHT
       | -0x17 -> ExnHT
+      | -0x18 -> ContHT
       | _ -> error s pos "malformed heap type"
     )
   ] s
 
 let ref_type s =
   let pos = pos s in
   match s7 s with
+  | -0x0b -> (Null, NoContHT)
   | -0x0c -> (Null, NoExnHT)
   | -0x0d -> (Null, NoFuncHT)
   | -0x0e -> (Null, NoExternHT)
@@ -211,6 +214,7 @@ let ref_type s =
   | -0x15 -> (Null, StructHT)
   | -0x16 -> (Null, ArrayHT)
   | -0x17 -> (Null, ExnHT)
+  | -0x18 -> (Null, ContHT)
   | -0x1c -> (NoNull, heap_type s)
   | -0x1d -> (Null, heap_type s)
   | _ -> error s pos "malformed reference type"
@@ -253,11 +257,15 @@ let func_type s =
   let ts2 = result_type s in
   FuncT (ts1, ts2)
 
+let cont_type s =
+  ContT (heap_type s)
+
 let str_type s =
   match s7 s with
   | -0x20 -> DefFuncT (func_type s)
   | -0x21 -> DefStructT (struct_type s)
   | -0x22 -> DefArrayT (array_type s)
+  | -0x23 -> DefContT (cont_type s) (* TODO(dhil): See comment in encode.ml *)
   | _ -> error s (pos s - 1) "malformed definition type"
 
 let sub_type s =
@@ -293,14 +301,15 @@ let memory_type s =
   let lim = limits u32 s in
   MemoryT lim
 
+let tag_type s =
+  zero s;
+  at var s
+
 let global_type s =
   let t = val_type s in
   let mut = mutability s in
   GlobalT (mut, t)
 
-let tag_type s =
-  zero s; at var s
-
 
 (* Instructions *)
 
@@ -340,6 +349,16 @@ let locals s =
     s pos "too many locals";
   List.flatten (List.map (Lib.Fun.uncurry Lib.List32.make) nts)
 
+let on_clause s =
+  match byte s with
+  | 0x00 ->
+    let x = at var s in
+    let y = at var s in
+    (x, OnLabel y)
+  | 0x01 ->
+    let x = at var s in
+    (x, OnSwitch)
+  | _ -> error s (pos s) "ON opcode expected"
 
 let rec instr s =
   let pos = pos s in
@@ -399,7 +418,10 @@ let rec instr s =
   | 0x14 -> call_ref (at var s)
   | 0x15 -> return_call_ref (at var s)
 
-  | 0x16 | 0x17 | 0x18 | 0x19 as b -> illegal s pos b
+  | (0x16 | 0x17) as b -> illegal s pos b
+
+  | 0x18 -> error s pos "misplaced DELEGATE opcode"
+  | 0x19 -> error s pos "misplaced CATCH_ALL opcode"
 
   | 0x1a -> drop
   | 0x1b -> select None
@@ -607,6 +629,26 @@ let rec instr s =
   | 0xd5 -> br_on_null (at var s)
   | 0xd6 -> br_on_non_null (at var s)
 
+  | 0xe0 -> cont_new (at var s)
+  | 0xe1 ->
+    let x = at var s in
+    let y = at var s in
+    cont_bind x y
+  | 0xe2 -> suspend (at var s)
+  | 0xe3 ->
+    let x = at var s in
+    let xls = vec on_clause s in
+    resume x xls
+  | 0xe4 ->
+    let x   = at var s in
+    let tag = at var s in
+    let xls = vec on_clause s in
+    resume_throw x tag xls
+  | 0xe5 ->
+    let x = at var s in
+    let y = at var s in
+    switch x y
+
   | 0xfb as b ->
     (match u32 s with
     | 0x00l -> struct_new (at var s)
@@ -971,11 +1013,11 @@ let rec instr s =
 and instr_block s = List.rev (instr_block' s [])
 and instr_block' s es =
   match peek s with
-  | None | Some (0x05 | 0x0b) -> es
+  | None | Some (0x05 | 0x07 | 0x0b | 0x19) -> es
   | _ ->
     let pos = pos s in
     let e' = instr s in
-    instr_block' s ((e' @@ region s pos pos) :: es)
+    instr_block' s (Source.(e' @@ region s pos pos) :: es)
 
 and catch s =
   match byte s with
@@ -1045,7 +1087,7 @@ let import_desc s =
   | 0x01 -> TableImport (table_type s)
   | 0x02 -> MemoryImport (memory_type s)
   | 0x03 -> GlobalImport (global_type s)
-  | 0x04 -> TagImport (tag_type s)
+  | 0x04 -> TagImport (at var s)
   | _ -> error s (pos s - 1) "malformed import kind"
 
 let import s =
@@ -1106,6 +1148,7 @@ let tag_section s =
   section Custom.Tag (vec (at tag)) [] s
 
 
+
 (* Global section *)
 
 let global s =
@@ -1336,7 +1379,6 @@ let module_ s =
     imports; exports; elems; datas; start },
   customs
 
-
 let decode_custom m bs custom =
   let open Source in
   let Custom.{name; content; place} = custom.it in

interpreter/binary/encode.ml

@@ -130,6 +130,8 @@ struct
     | NoExnHT -> s7 (-0x0c)
     | ExternHT -> s7 (-0x11)
     | NoExternHT -> s7 (-0x0e)
+    | ContHT -> s7 (-0x18)
+    | NoContHT -> s7 (-0x0b)
     | VarHT x -> var_type s33 x
     | DefHT _ | BotHT -> assert false
 
@@ -150,6 +152,8 @@ struct
     | (Null, NoExnHT) -> s7 (-0x0c)
     | (Null, ExternHT) -> s7 (-0x11)
     | (Null, NoExternHT) -> s7 (-0x0e)
+    | (Null, ContHT) -> s7 (-0x18)
+    | (Null, NoContHT) -> s7 (-0x0b)
     | (Null, t) -> s7 (-0x1d); heap_type t
     | (NoNull, t) -> s7 (-0x1c); heap_type t
 
@@ -180,10 +184,17 @@ struct
   let func_type = function
     | FuncT (ts1, ts2) -> vec val_type ts1; vec val_type ts2
 
+  let cont_type = function
+    | ContT ht -> heap_type ht
+
   let str_type = function
     | DefStructT st -> s7 (-0x21); struct_type st
     | DefArrayT at -> s7 (-0x22); array_type at
     | DefFuncT ft -> s7 (-0x20); func_type ft
+    | DefContT ct -> s7 (-0x23); cont_type ct
+    (* TODO(dhil): This might need to change again in the future as a
+       different proposal might claim this opcode! GC proposal claimed
+       the previous opcode we were using. *)
 
   let sub_type = function
     | SubT (Final, [], st) -> str_type st
@@ -206,9 +217,7 @@ struct
   let global_type = function
     | GlobalT (mut, t) -> val_type t; mutability mut
 
-  let tag_type x =
-    u32 0x00l; var x
-
+  let tag_type x = u32 0x00l; var x
 
   (* Expressions *)
 
@@ -245,6 +254,16 @@ struct
       | nlocs -> (1, loc) :: nlocs
     in vec local (List.fold_right combine locs [])
 
+  let on_clause (x, y) =
+    match y with
+    | OnSwitch ->
+       byte 0x01; var x
+    | OnLabel y ->
+       byte 0x00; var x; var y
+
+  let resumetable xls =
+    vec on_clause xls
+
   let rec instr e =
     match e.it with
     | Unreachable -> op 0x00
@@ -278,6 +297,13 @@ struct
     | ReturnCallRef x -> op 0x15; var x
     | ReturnCallIndirect (x, y) -> op 0x13; var y; var x
 
+    | ContNew x -> op 0xe0; var x
+    | ContBind (x, y) -> op 0xe1; var x; var y
+    | Suspend x -> op 0xe2; var x
+    | Resume (x, xls) -> op 0xe3; var x; resumetable xls
+    | ResumeThrow (x, y, xls) -> op 0xe4; var x; var y; resumetable xls
+    | Switch (x, y) -> op 0xe5; var x; var y
+
     | Throw x -> op 0x08; var x
     | ThrowRef -> op 0x0a
 
@@ -925,7 +951,7 @@ struct
     | TableImport t -> byte 0x01; table_type t
     | MemoryImport t -> byte 0x02; memory_type t
     | GlobalImport t -> byte 0x03; global_type t
-    | TagImport t -> byte 0x04; tag_type t
+    | TagImport t -> byte 0x04; var t
 
   let import im =
     let {module_name; item_name; idesc} = im.it in
@@ -966,14 +992,6 @@ struct
     section 5 (vec memory) mems (mems <> [])
 
 
-  (* Tag section *)
-
-  let tag (t : tag) = byte 0x00; var t.it.tgtype
-
-  let tag_section ts =
-    section 13 (vec tag) ts (ts <> [])
-
-
   (* Global section *)
 
   let global g =
@@ -983,6 +1001,12 @@ struct
   let global_section gs =
     section 6 (vec global) gs (gs <> [])
 
+  (* Tag section *)
+  let tag tag =
+    tag_type tag.it.tgtype
+
+  let tag_section ts =
+    section 13 (vec tag) ts (ts <> [])
 
   (* Export section *)