diff --git a/interpreter/binary/decode.ml b/interpreter/binary/decode.ml index f5e4edf9..88551a15 100644 --- a/interpreter/binary/decode.ml +++ b/interpreter/binary/decode.ml @@ -303,8 +303,13 @@ let rec instr s = let y = at var s in let x = at var s in call_indirect x y + | 0x12 -> return_call (at var s) + | 0x13 -> + let y = at var s in + let x = at var s in + return_call_indirect x y - | 0x12 | 0x13 | 0x14 | 0x15 | 0x16 | 0x17 as b -> illegal s pos b + | 0x14 | 0x15 | 0x16 | 0x17 as b -> illegal s pos b | 0x18 -> error s pos "misplaced DELEGATE opcode" | 0x19 -> error s pos "misplaced CATCH_ALL opcode" diff --git a/interpreter/binary/encode.ml b/interpreter/binary/encode.ml index 7e59a2f1..50ee0000 100644 --- a/interpreter/binary/encode.ml +++ b/interpreter/binary/encode.ml @@ -187,6 +187,8 @@ struct | Return -> op 0x0f | Call x -> op 0x10; var x | CallIndirect (x, y) -> op 0x11; var y; var x + | ReturnCall x -> op 0x12; var x + | ReturnCallIndirect (x, y) -> op 0x13; var y; var x | Throw x -> op 0x08; var x | Rethrow x -> op 0x09; var x diff --git a/interpreter/exec/eval.ml b/interpreter/exec/eval.ml index 97b11362..56834621 100644 --- a/interpreter/exec/eval.ml +++ b/interpreter/exec/eval.ml @@ -63,6 +63,7 @@ and admin_instr' = | Invoke of func_inst | Trapping of string | Returning of value stack + | ReturningInvoke of value stack * func_inst | Breaking of int32 * value stack | Throwing of Tag.t * value stack | Rethrowing of int32 * (admin_instr -> admin_instr) @@ -214,6 +215,21 @@ let rec step (c : config) : config = else vs, [Invoke func @@ e.at] + | ReturnCall x, vs -> + (match (step {c with code = (vs, [Plain (Call x) @@ e.at])}).code with + | vs', [{it = Invoke a; at}] -> vs', [ReturningInvoke (vs', a) @@ at] + | _ -> assert false + ) + + | ReturnCallIndirect (x, y), vs -> + (match + (step {c with code = (vs, [Plain (CallIndirect (x, y)) @@ e.at])}).code + with + | vs', [{it = Invoke a; at}] -> vs', [ReturningInvoke (vs', a) @@ at] + | vs', [{it = Trapping s; at}] -> vs', [Trapping s @@ at] + | _ -> assert false + ) + | Throw x, vs -> let t = tag frame.inst x in let FuncType (ts, _) = Tag.type_of t in @@ -629,7 +645,8 @@ let rec step (c : config) : config = | Trapping msg, vs -> assert false - | Returning vs', vs -> + | Returning _, vs + | ReturningInvoke _, vs -> Crash.error e.at "undefined frame" | Breaking (k, vs'), vs -> @@ -653,6 +670,9 @@ let rec step (c : config) : config = | Label (n, es0, (vs', {it = Returning vs0; at} :: es')), vs -> vs, [Returning vs0 @@ at] + | Label (n, es0, (vs', {it = ReturningInvoke (vs0, f); at} :: es')), vs -> + vs, [ReturningInvoke (vs0, f) @@ at] + | Label (n, es0, (vs', {it = Breaking (0l, vs0); at} :: es')), vs -> take n vs0 e.at @ vs, List.map plain es0 @@ -684,6 +704,10 @@ let rec step (c : config) : config = | Frame (n, frame', (vs', {it = Returning vs0; at} :: es')), vs -> take n vs0 e.at @ vs, [] + | Frame (n, frame', (vs', {it = ReturningInvoke (vs0, f); at} :: es')), vs -> + let FuncType (ins, out) = Func.type_of f in + take (Lib.List32.length ins) vs0 e.at @ vs, [Invoke f @@ at] + | Frame (n, frame', (vs', {it = Throwing (a, vs0); at} :: es')), vs -> vs, [Throwing (a, vs0) @@ at] @@ -694,7 +718,7 @@ let rec step (c : config) : config = | Catch (n, cts, ca, (vs', [])), vs -> vs' @ vs, [] - | Catch (n, cts, ca, (vs', ({it = Trapping _ | Breaking _ | Returning _ | Delegating _; at} as e) :: es')), vs -> + | Catch (n, cts, ca, (vs', ({it = Trapping _ | Breaking _ | Returning _ | ReturningInvoke _ | Delegating _; at} as e) :: es')), vs -> vs, [e] | Catch (n, cts, ca, (vs', {it = Rethrowing (k, cont); at} :: es')), vs -> @@ -719,7 +743,7 @@ let rec step (c : config) : config = | Caught (n, a, vs0, (vs', [])), vs -> vs' @ vs, [] - | Caught (n, a, vs0, (vs', ({it = Trapping _ | Breaking _ | Returning _ | Throwing _ | Delegating _; at} as e) :: es')), vs -> + | Caught (n, a, vs0, (vs', ({it = Trapping _ | Breaking _ | Returning _ | ReturningInvoke _ | Throwing _ | Delegating _; at} as e) :: es')), vs -> vs, [e] | Caught (n, a, vs0, (vs', {it = Rethrowing (0l, cont); at} :: es')), vs -> @@ -735,7 +759,7 @@ let rec step (c : config) : config = | Delegate (l, (vs', [])), vs -> vs' @ vs, [] - | Delegate (l, (vs', ({it = Trapping _ | Breaking _ | Returning _ | Rethrowing _ | Delegating _; at} as e) :: es')), vs -> + | Delegate (l, (vs', ({it = Trapping _ | Breaking _ | Returning _ | ReturningInvoke _ | Rethrowing _ | Delegating _; at} as e) :: es')), vs -> vs, [e] | Delegate (l, (vs', {it = Throwing (a, vs0); at} :: es')), vs -> diff --git a/interpreter/syntax/ast.ml b/interpreter/syntax/ast.ml index b1750ee3..4a717781 100644 --- a/interpreter/syntax/ast.ml +++ b/interpreter/syntax/ast.ml @@ -149,6 +149,8 @@ and instr' = | Return (* break from function body *) | Call of var (* call function *) | CallIndirect of var * var (* call function through table *) + | ReturnCall of var (* tail-call function *) + | ReturnCallIndirect of var * var (* tail-call function through table *) | LocalGet of var (* read local variable *) | LocalSet of var (* write local variable *) | LocalTee of var (* write local variable and keep value *) diff --git a/interpreter/syntax/free.ml b/interpreter/syntax/free.ml index 774b2d03..fdc5f363 100644 --- a/interpreter/syntax/free.ml +++ b/interpreter/syntax/free.ml @@ -79,8 +79,9 @@ let rec instr (e : instr) = | Br x | BrIf x -> labels (var x) | BrTable (xs, x) -> list (fun x -> labels (var x)) (x::xs) | Return -> empty - | Call x -> funcs (var x) - | CallIndirect (x, y) -> tables (var x) ++ types (var y) + | Call x | ReturnCall x -> funcs (var x) + | CallIndirect (x, y) | ReturnCallIndirect (x, y) -> + tables (var x) ++ types (var y) | LocalGet x | LocalSet x | LocalTee x -> locals (var x) | GlobalGet x | GlobalSet x -> globals (var x) | TableGet x | TableSet x | TableSize x | TableGrow x | TableFill x -> diff --git a/interpreter/syntax/operators.ml b/interpreter/syntax/operators.ml index bb44e4f9..487c3051 100644 --- a/interpreter/syntax/operators.ml +++ b/interpreter/syntax/operators.ml @@ -29,6 +29,8 @@ let br_table xs x = BrTable (xs, x) let return = Return let call x = Call x let call_indirect x y = CallIndirect (x, y) +let return_call x = ReturnCall x +let return_call_indirect x y = ReturnCallIndirect (x, y) let throw x = Throw x let rethrow x = Rethrow x diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml index 76e14bba..ba3f2bcf 100644 --- a/interpreter/text/arrange.ml +++ b/interpreter/text/arrange.ml @@ -453,6 +453,9 @@ let rec instr e = | Call x -> "call " ^ var x, [] | CallIndirect (x, y) -> "call_indirect " ^ var x, [Node ("type " ^ var y, [])] + | ReturnCall x -> "return_call " ^ var x, [] + | ReturnCallIndirect (x, y) -> + "return_call_indirect " ^ var x, [Node ("type " ^ var y, [])] | LocalGet x -> "local.get " ^ var x, [] | LocalSet x -> "local.set " ^ var x, [] | LocalTee x -> "local.tee " ^ var x, [] diff --git a/interpreter/text/lexer.mll b/interpreter/text/lexer.mll index 9c709b13..9a7a5482 100644 --- a/interpreter/text/lexer.mll +++ b/interpreter/text/lexer.mll @@ -168,6 +168,8 @@ rule token = parse | "select" -> SELECT | "call" -> CALL | "call_indirect" -> CALL_INDIRECT + | "return_call" -> RETURN_CALL + | "return_call_indirect" -> RETURN_CALL_INDIRECT | "local.get" -> LOCAL_GET | "local.set" -> LOCAL_SET diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly index af25869c..806ee509 100644 --- a/interpreter/text/parser.mly +++ b/interpreter/text/parser.mly @@ -218,7 +218,7 @@ let inline_type_explicit (c : context) x ft at = %token UNREACHABLE NOP DROP SELECT %token BLOCK END IF THEN ELSE LOOP BR BR_IF BR_TABLE TRY DO CATCH CATCH_ALL %token DELEGATE -%token CALL CALL_INDIRECT RETURN +%token CALL CALL_INDIRECT RETURN RETURN_CALL RETURN_CALL_INDIRECT %token LOCAL_GET LOCAL_SET LOCAL_TEE GLOBAL_GET GLOBAL_SET %token TABLE_GET TABLE_SET %token TABLE_SIZE TABLE_GROW TABLE_FILL TABLE_COPY TABLE_INIT ELEM_DROP @@ -395,6 +395,7 @@ plain_instr : br_table xs x } | RETURN { fun c -> return } | CALL var { fun c -> call ($2 c func) } + | RETURN_CALL var { fun c -> return_call ($2 c func) } | THROW var { fun c -> throw ($2 c tag) } | RETHROW var { fun c -> rethrow ($2 c label) } | LOCAL_GET var { fun c -> local_get ($2 c local) } @@ -477,6 +478,14 @@ call_instr_instr_list : { let at1 = ati 1 in fun c -> let x, es = $2 c in (call_indirect (0l @@ at1) x @@ at1) :: es } + | RETURN_CALL_INDIRECT var call_instr_type_instr_list + { let at1 = ati 1 in + fun c -> let x, es = $3 c in + (return_call_indirect ($2 c table) x @@ at1) :: es } + | RETURN_CALL_INDIRECT call_instr_type_instr_list /* Sugar */ + { let at1 = ati 1 in + fun c -> let x, es = $2 c in + (return_call_indirect (0l @@ at1) x @@ at1) :: es } call_instr_type_instr_list : | type_use call_instr_params_instr_list @@ -600,6 +609,11 @@ expr1 : /* Sugar */ | CALL_INDIRECT call_expr_type /* Sugar */ { let at1 = ati 1 in fun c -> let x, es = $2 c in es, call_indirect (0l @@ at1) x } + | RETURN_CALL_INDIRECT var call_expr_type + { fun c -> let x, es = $3 c in es, return_call_indirect ($2 c table) x } + | RETURN_CALL_INDIRECT call_expr_type /* Sugar */ + { let at1 = ati 1 in + fun c -> let x, es = $2 c in es, return_call_indirect (0l @@ at1) x } | BLOCK labeling_opt block { fun c -> let c' = $2 c [] in let bt, es = $3 c' in [], block bt es } | LOOP labeling_opt block diff --git a/interpreter/valid/valid.ml b/interpreter/valid/valid.ml index 34707dbd..f6d8a921 100644 --- a/interpreter/valid/valid.ml +++ b/interpreter/valid/valid.ml @@ -302,6 +302,17 @@ let rec check_instr (c : context) (e : instr) (s : infer_result_type) : op_type " but table has " ^ string_of_ref_type t); (ts1 @ [NumType I32Type]) --> ts2 + | ReturnCall x -> + let FuncType (ins, out) = func c x in + require (out = c.results) e.at "type mismatch in function result"; + ins -->... [] + + | ReturnCallIndirect (x, y) -> + let TableType (lim, t) = table c x in + let FuncType (ins, out) = type_ c y in + require (out = c.results) e.at "type mismatch in function result"; + (ins @ [NumType I32Type]) -->... [] + | Throw x -> let TagType y = tag c x in let FuncType (ts1, _) = type_ c (y @@ e.at) in