diff --git a/interpreter/binary/decode.ml b/interpreter/binary/decode.ml index 53c7294c8..9bb116f06 100644 --- a/interpreter/binary/decode.ml +++ b/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 diff --git a/interpreter/binary/encode.ml b/interpreter/binary/encode.ml index c58bd33b1..1a92dc1b6 100644 --- a/interpreter/binary/encode.ml +++ b/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 diff --git a/interpreter/custom/handler_name.ml b/interpreter/custom/handler_name.ml index dde5e28d7..484c501a2 100644 --- a/interpreter/custom/handler_name.ml +++ b/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 " ^ diff --git a/interpreter/host/spectest.ml b/interpreter/host/spectest.ml index 8d6c039bf..f196f990d 100644 --- a/interpreter/host/spectest.ml +++ b/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 = diff --git a/interpreter/script/js.ml b/interpreter/script/js.ml index 2d5ff3a0d..4676b91af 100644 --- a/interpreter/script/js.ml +++ b/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 diff --git a/interpreter/syntax/free.ml b/interpreter/syntax/free.ml index 37ab763fe..a6b3472a0 100644 --- a/interpreter/syntax/free.ml +++ b/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 diff --git a/interpreter/syntax/types.ml b/interpreter/syntax/types.ml index 6deb708d7..7cb26a989 100644 --- a/interpreter/syntax/types.ml +++ b/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 diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index b1e1bf454..3af15ace1 100644 --- a/interpreter/text/arrange.ml +++ b/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]) diff --git a/interpreter/text/lexer.mll b/interpreter/text/lexer.mll index 02430dea7..b919f227c 100644 --- a/interpreter/text/lexer.mll +++ b/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 diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly index 1fbeeeccc..ac182e1a3 100644 --- a/interpreter/text/parser.mly +++ b/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) } diff --git a/interpreter/valid/valid.ml b/interpreter/valid/valid.ml index ba4e8bb55..e104676c9 100644 --- a/interpreter/valid/valid.ml +++ b/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) -> diff --git a/test/core/descriptors.wast b/test/core/descriptors.wast new file mode 100644 index 000000000..91e805a7e --- /dev/null +++ b/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)))) + ) +)