[interpreter] Custom descriptor syntax

interpreter/binary/decode.ml

@@ -259,17 +259,33 @@ let str_type s =
   | -0x22 -> DefArrayT (array_type s)
   | _ -> error s (pos s - 1) "malformed definition type"
 
+let described_type s =
+  match peek s with
+  | Some i when i = -0x33 land 0x7f ->
+     skip 1 s;
+     let x = var_type u32 s in
+     DescriptorT (VarHT x, str_type s)
+  | _ -> NoDescriptorT (str_type s)
+
+let describing_type s =
+  match peek s with
+  | Some i when i = -0x34 land 0x7f ->
+     skip 1 s;
+     let x = var_type u32 s in
+     DescribesT (VarHT x, described_type s)
+  | _ -> NoDescribesT (described_type s)
+
 let sub_type s =
   match peek s with
   | Some i when i = -0x30 land 0x7f ->
     skip 1 s;
     let xs = vec (var_type u32) s in
-    SubT (NoFinal, List.map (fun x -> VarHT x) xs, str_type s)
+    SubT (NoFinal, List.map (fun x -> VarHT x) xs, describing_type s)
   | Some i when i = -0x31 land 0x7f ->
     skip 1 s;
     let xs = vec (var_type u32) s in
-    SubT (Final, List.map (fun x -> VarHT x) xs, str_type s)
-  | _ -> SubT (Final, [], str_type s)
+    SubT (Final, List.map (fun x -> VarHT x) xs, describing_type s)
+  | _ -> SubT (Final, [], describing_type s)
 
 let rec_type s =
   match peek s with

interpreter/binary/encode.ml

@@ -185,10 +185,18 @@ struct
     | DefArrayT at -> s7 (-0x22); array_type at
     | DefFuncT ft -> s7 (-0x20); func_type ft
 
+  let described_type = function
+    | DescriptorT (ht, st) -> s7 (-0x33); var_heap_type ht; str_type st
+    | NoDescriptorT st -> str_type st
+
+  let described_type = function
+    | DescribesT (ht, dt) -> s7 (-0x34); var_heap_type ht; described_type dt
+    | NoDescribesT dt -> described_type dt
+
   let sub_type = function
-    | SubT (Final, [], st) -> str_type st
-    | SubT (Final, hts, st) -> s7 (-0x31); vec var_heap_type hts; str_type st
-    | SubT (NoFinal, hts, st) -> s7 (-0x30); vec var_heap_type hts; str_type st
+    | SubT (Final, [], dt) -> described_type dt
+    | SubT (Final, hts, dt) -> s7 (-0x31); vec var_heap_type hts; described_type dt
+    | SubT (NoFinal, hts, dt) -> s7 (-0x30); vec var_heap_type hts; described_type dt
 
   let rec_type = function
     | RecT [st] -> sub_type st

interpreter/custom/handler_name.ml

@@ -402,7 +402,14 @@ let check_error at msg = raise (Custom.Invalid (at, msg))
 let check (m : module_) (fmt : format) =
   let subtypes =
     List.concat (List.map (fun {it = RecT ss; _} -> ss) m.it.types) in
-  let comptypes = List.map (fun (SubT (_, _, ct)) -> ct) subtypes in
+  let comptypes = List.map (fun (SubT (_, _, dt)) ->
+                      let dt = match dt with
+                        | DescribesT (_, dt) -> dt
+                        | NoDescribesT dt -> dt in
+                      let ct = match dt with
+                        | DescriptorT (_, ct) -> ct
+                        | NoDescriptorT ct -> ct in
+                      ct) subtypes in
   IdxMap.iter (fun x name ->
     if I32.ge_u x (Lib.List32.length m.it.funcs) then
       check_error name.at ("custom @name: invalid function index " ^

interpreter/host/spectest.ml

@@ -32,7 +32,7 @@ let memory =
   ExternMemory (Memory.alloc mt)
 
 let func f ft =
-  let dt = DefT (RecT [SubT (Final, [], DefFuncT ft)], 0l) in
+  let dt = DefT (RecT [SubT (Final, [], NoDescribesT (NoDescriptorT (DefFuncT ft)))], 0l) in
   ExternFunc (Func.alloc_host dt (f ft))
 
 let print_value v =

interpreter/script/js.ml

@@ -324,7 +324,7 @@ let value v =
   | Ref _ -> assert false
 
 let invoke ft vs at =
-  let dt = RecT [SubT (Final, [], DefFuncT ft)] in
+  let dt = RecT [SubT (Final, [], NoDescribesT (NoDescriptorT (DefFuncT ft)))] in
   [dt @@ at], FuncImport (subject_type_idx @@ at) @@ at,
   List.concat (List.map value vs) @ [Call (subject_idx @@ at) @@ at]
 
@@ -493,7 +493,7 @@ let i32 = NumT I32T
 let anyref = RefT (Null, AnyHT)
 let eqref = RefT (Null, EqHT)
 let func_rec_type ts1 ts2 at =
-  RecT [SubT (Final, [], DefFuncT (FuncT (ts1, ts2)))] @@ at
+  RecT [SubT (Final, [], NoDescribesT (NoDescriptorT (DefFuncT (FuncT (ts1, ts2)))))] @@ at
 
 let wrap item_name wrap_action wrap_assertion at =
   let itypes, idesc, action = wrap_action at in

interpreter/syntax/free.ml

@@ -111,8 +111,16 @@ let str_type = function
   | DefArrayT at -> array_type at
   | DefFuncT ft -> func_type ft
 
+let described_type = function
+  | DescriptorT (ht, st) -> heap_type ht ++ str_type st
+  | NoDescriptorT st -> str_type st
+
+let describing_type = function
+  | DescribesT (ht, dt) -> heap_type ht ++ described_type dt
+  | NoDescribesT dt -> described_type dt
+
 let sub_type = function
-  | SubT (_fin, hts, st) -> list heap_type hts ++ str_type st
+  | SubT (_fin, hts, dt) -> list heap_type hts ++ describing_type dt
 
 let rec_type = function
   | RecT sts -> list sub_type sts

interpreter/syntax/types.ml

@@ -41,7 +41,15 @@ and str_type =
   | DefArrayT of array_type
   | DefFuncT of func_type
 
-and sub_type = SubT of final * heap_type list * str_type
+and described_type =
+  | DescriptorT of heap_type * str_type
+  | NoDescriptorT of str_type
+
+and describing_type =
+  | DescribesT of heap_type * described_type
+  | NoDescribesT of described_type
+
+and sub_type = SubT of final * heap_type list * describing_type
 and rec_type = RecT of sub_type list
 and def_type = DefT of rec_type * int32
 
@@ -223,9 +231,19 @@ let subst_str_type s = function
   | DefArrayT at -> DefArrayT (subst_array_type s at)
   | DefFuncT ft -> DefFuncT (subst_func_type s ft)
 
+let subst_described_type s = function
+  | DescriptorT (ht, st) ->
+    DescriptorT (subst_heap_type s ht, subst_str_type s st)
+  | NoDescriptorT st -> NoDescriptorT (subst_str_type s st)
+
+let subst_describing_type s = function
+  | DescribesT (ht, dt) ->
+    DescribesT (subst_heap_type s ht, subst_described_type s dt)
+  | NoDescribesT dt -> NoDescribesT (subst_described_type s dt)
+
 let subst_sub_type s = function
-  | SubT (fin, hts, st) ->
-    SubT (fin, List.map (subst_heap_type s) hts, subst_str_type s st)
+  | SubT (fin, hts, dt) ->
+    SubT (fin, List.map (subst_heap_type s) hts, subst_describing_type s dt)
 
 let subst_rec_type s = function
   | RecT sts -> RecT (List.map (subst_sub_type s) sts)
@@ -298,9 +316,13 @@ let unroll_def_type (dt : def_type) : sub_type =
   Lib.List32.nth sts i
 
 let expand_def_type (dt : def_type) : str_type =
-  let SubT (_, _, st) = unroll_def_type dt in
-  st
-
+  let SubT (_, _, dt) = unroll_def_type dt in
+  let dt = match dt with
+    | DescribesT (_, dt) -> dt
+    | NoDescribesT dt -> dt in
+  match dt with
+  | DescriptorT (_, st) -> st
+  | NoDescriptorT st -> st
 
 (* String conversion *)
 
@@ -403,12 +425,22 @@ and string_of_str_type = function
   | DefArrayT at -> "array " ^ string_of_array_type at
   | DefFuncT ft -> "func " ^ string_of_func_type ft
 
+and string_of_described_type = function
+  | DescriptorT (ht, st) ->
+    "(descriptor " ^ string_of_heap_type ht ^ " " ^ string_of_str_type st ^ ")"
+  | NoDescriptorT st -> string_of_str_type st
+
+and string_of_describing_type = function
+  | DescribesT (ht, dt) ->
+    "(describes " ^ string_of_heap_type ht ^ " " ^ string_of_described_type dt ^ ")"
+  | NoDescribesT dt -> string_of_described_type dt
+
 and string_of_sub_type = function
-  | SubT (Final, [], st) -> string_of_str_type st
-  | SubT (fin, hts, st) ->
+  | SubT (Final, [], dt) -> string_of_describing_type dt
+  | SubT (fin, hts, dt) ->
     String.concat " "
       (("sub" ^ string_of_final fin) :: List.map string_of_heap_type hts) ^
-    " (" ^ string_of_str_type st ^ ")"
+    " (" ^ string_of_describing_type dt ^ ")"
 
 and string_of_rec_type = function
   | RecT [st] -> string_of_sub_type st

interpreter/text/arrange.ml

@@ -106,11 +106,21 @@ let str_type st =
   | DefArrayT at -> array_type at
   | DefFuncT ft -> func_type ft
 
+let described_type dt =
+  match dt with
+  | DescriptorT (ht, st) -> Node ("descriptor", [atom heap_type ht; str_type st])
+  | NoDescriptorT st -> str_type st
+
+let describing_type dt =
+  match dt with
+  | DescribesT (ht, dt) -> Node ("describes", [atom heap_type ht; described_type dt])
+  | NoDescribesT dt -> described_type dt
+
 let sub_type = function
-  | SubT (Final, [], st) -> str_type st
-  | SubT (fin, xs, st) ->
+  | SubT (Final, [], dt) -> describing_type dt
+  | SubT (fin, xs, dt) ->
     Node (String.concat " "
-      (("sub" ^ final fin ):: List.map heap_type xs), [str_type st])
+      (("sub" ^ final fin ):: List.map heap_type xs), [describing_type dt])
 
 let rec_type i j st =
   Node ("type $" ^ nat (i + j), [sub_type st])

interpreter/text/lexer.mll

@@ -89,7 +89,7 @@ let character =
     [^'"''\\''\x00'-'\x1f''\x7f'-'\xff']
   | utf8enc
   | '\\'escape
-  | '\\'hexdigit hexdigit 
+  | '\\'hexdigit hexdigit
   | "\\u{" hexnum '}'
 
 let nat = num | "0x" hexnum
@@ -184,6 +184,8 @@ rule token = parse
       | "struct" -> STRUCT
       | "field" -> FIELD
       | "mut" -> MUT
+      | "descriptor" -> DESCRIPTOR
+      | "describes" -> DESCRIBES
       | "sub" -> SUB
       | "final" -> FINAL
       | "rec" -> REC

interpreter/text/parser.mly

@@ -238,7 +238,7 @@ let anon_fields (c : context) x n loc =
 
 
 let inline_func_type (c : context) ft loc =
-  let st = SubT (Final, [], DefFuncT ft) in
+  let st = SubT (Final, [], NoDescribesT (NoDescriptorT (DefFuncT ft))) in
   match
     Lib.List.index_where (function
       | DefT (RecT [st'], 0l) -> st = st'
@@ -299,7 +299,7 @@ let parse_annots (m : module_) : Custom.section list =
 %token ANYREF NULLREF EQREF I31REF STRUCTREF ARRAYREF
 %token FUNCREF NULLFUNCREF EXNREF NULLEXNREF EXTERNREF NULLEXTERNREF
 %token ANY NONE EQ I31 REF NOFUNC EXN NOEXN EXTERN NOEXTERN NULL
-%token MUT FIELD STRUCT ARRAY SUB FINAL REC
+%token MUT FIELD STRUCT ARRAY DESCRIPTOR DESCRIBES SUB FINAL REC
 %token UNREACHABLE NOP DROP SELECT
 %token BLOCK END IF THEN ELSE LOOP
 %token BR BR_IF BR_TABLE
@@ -466,12 +466,22 @@ str_type :
   | LPAR ARRAY array_type RPAR { fun c x -> DefArrayT ($3 c) }
   | LPAR FUNC func_type RPAR { fun c x -> DefFuncT ($3 c) }
 
+described_type :
+  | str_type { fun c x -> NoDescriptorT ($1 c x) }
+  | LPAR DESCRIPTOR var str_type RPAR
+    { fun c x -> DescriptorT ((fun y -> VarHT (StatX y.it)) ($3 c type_), ($4 c x)) }
+
+describing_type :
+  | described_type { fun c x -> NoDescribesT ($1 c x) }
+  | LPAR DESCRIBES var described_type RPAR
+    { fun c x -> DescribesT ((fun y -> VarHT (StatX y.it)) ($3 c type_), ($4 c x)) }
+
 sub_type :
-  | str_type { fun c x -> SubT (Final, [], $1 c x) }
-  | LPAR SUB var_list str_type RPAR
+  | describing_type { fun c x -> SubT (Final, [], $1 c x) }
+  | LPAR SUB var_list describing_type RPAR
     { fun c x -> SubT (NoFinal,
         List.map (fun y -> VarHT (StatX y.it)) ($3 c type_), $4 c x) }
-  | LPAR SUB FINAL var_list str_type RPAR
+  | LPAR SUB FINAL var_list describing_type RPAR
     { fun c x -> SubT (Final,
         List.map (fun y -> VarHT (StatX y.it)) ($4 c type_), $5 c x) }
 

interpreter/valid/valid.ml

@@ -180,16 +180,40 @@ let check_str_type (c : context) (st : str_type) at =
   | DefArrayT rt -> check_array_type c rt at
   | DefFuncT ft -> check_func_type c ft at
 
+let check_described_type (c : context) (dt : described_type) at =
+  match dt with
+  | DescriptorT (ht, st) -> check_heap_type c ht at; check_str_type c st at
+  | NoDescriptorT st -> check_str_type c st at
+
+let check_describing_type (c : context) (dt : describing_type) at =
+  match dt with
+  | DescribesT (ht, dt) -> check_heap_type c ht at; check_described_type c dt at
+  | NoDescribesT dt -> check_described_type c dt at
+
+(* TODO: check validity of descriptor and describes clauses *)
+
 let check_sub_type (c : context) (sut : sub_type) at =
-  let SubT (_fin, hts, st) = sut in
+  let SubT (_fin, hts, dt) = sut in
   List.iter (fun ht -> check_heap_type c ht at) hts;
-  check_str_type c st at
+  check_describing_type c dt at
 
 let check_sub_type_sub (c : context) (sut : sub_type) x at =
-  let SubT (_fin, hts, st) = sut in
+  let SubT (_fin, hts, dt) = sut in
+  let dt = match dt with
+    | DescribesT (_, dt) -> dt
+    | NoDescribesT dt -> dt in
+  let st = match dt with
+    | DescriptorT (_, st) -> st
+    | NoDescriptorT st -> st in
   List.iter (fun hti ->
     let xi = match hti with VarHT (StatX xi) -> xi | _ -> assert false in
-    let SubT (fini, _, sti) = unroll_def_type (type_ c (xi @@ at)) in
+    let SubT (fini, _, dti) = unroll_def_type (type_ c (xi @@ at)) in
+    let dti = match dti with
+      | DescribesT (_, dt) -> dt
+      | NoDescribesT dt -> dt in
+    let sti = match dti with
+      | DescriptorT (_, st) -> st
+      | NoDescriptorT st -> st in
     require (xi < x) at ("forward use of type " ^ I32.to_string_u xi ^
       " in sub type definition");
     require (fini = NoFinal) at ("sub type " ^ I32.to_string_u x ^
@@ -605,7 +629,7 @@ let rec check_instr (c : context) (e : instr) (s : infer_result_type) : infer_in
 
   | TableFill x ->
     let TableT (at, _lim, rt) = table c x in
-    [NumT (num_type_of_addr_type at); RefT rt; 
+    [NumT (num_type_of_addr_type at); RefT rt;
       NumT (num_type_of_addr_type at)] --> [], []
 
   | TableCopy (x, y) ->

test/core/descriptors.wast

@@ -0,0 +1,31 @@
+;; Test custom descriptors
+
+(module
+  (rec
+    (type (descriptor 1 (struct)))
+    (type (describes 0 (struct)))
+  )
+)
+
+(module
+  (rec
+    (type $super (sub (descriptor $super-desc (struct))))
+    (type $super-desc (sub (describes $super (struct))))
+  )
+  (rec
+    (type $sub (sub $super (descriptor $sub-desc (struct))))
+    (type $sub-desc (sub $super-desc (describes $sub (struct))))
+  )
+)
+
+(module
+  (type $super (sub (struct)))
+  (rec
+    (type $other (sub (descriptor $super-desc (struct))))
+    (type $super-desc (sub (describes $other (struct))))
+  )
+  (rec
+    (type $sub (sub $super (descriptor $sub-desc (struct))))
+    (type $sub-desc (sub $super-desc (describes $sub (struct))))
+  )
+)