[interpreter] Cherry-pick tail call support

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"

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
 

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 ->

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 *)

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 ->

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
 

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, []

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

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

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