[interpreter] Implement func.bind (#17)

rossberg · web-flow · commit 47536320e105 · 2020-03-26T09:14:11.000+01:00
Plus some minor fixes and more tests.
diff --git a/interpreter/README.md b/interpreter/README.md
@@ -216,6 +216,8 @@ instr:
 op:
   unreachable
   nop
+  drop
+  select
   br <var>
   br_if <var>
   br_table <var>+
@@ -225,8 +227,7 @@ op:
   call_indirect <var>? <func_type>
   call_ref
   return_call_ref
-  drop
-  select
+  func.bind <func_type>
   local.get <var>
   local.set <var>
   local.tee <var>
diff --git a/interpreter/binary/decode.ml b/interpreter/binary/decode.ml
@@ -279,15 +279,16 @@ let rec instr s =
 
   | 0x14 -> call_ref
   | 0x15 -> return_call_ref
+  | 0x16 -> func_bind (at var s)
 
-  | 0x16 ->
+  | 0x17 ->
     let bt = stack_type s in
     let locs = locals s in
     let es = instr_block s in
     end_ s;
     let_ bt locs es
 
-  | 0x17 | 0x18 | 0x19 as b -> illegal s pos b
+  | 0x18 | 0x19 as b -> illegal s pos b
 
   | 0x1a -> drop
   | 0x1b -> select None
diff --git a/interpreter/binary/encode.ml b/interpreter/binary/encode.ml
@@ -172,7 +172,7 @@ let encode m =
         if es2 <> [] then op 0x05;
         list instr es2; end_ ()
       | Let (bt, locs, es) ->
-        op 0x16; stack_type bt; locals locs; list instr es; end_ ()
+        op 0x17; stack_type bt; locals locs; list instr es; end_ ()
 
       | Br x -> op 0x0c; var x
       | BrIf x -> op 0x0d; var x
@@ -183,6 +183,7 @@ let encode m =
       | CallRef -> op 0x14
       | CallIndirect (x, y) -> op 0x11; var y; var x
       | ReturnCallRef -> op 0x15
+      | FuncBind x -> op 0x16; var x
 
       | Drop -> op 0x1a
       | Select None -> op 0x1b
diff --git a/interpreter/exec/eval.ml b/interpreter/exec/eval.ml
@@ -218,13 +218,29 @@ let rec step (c : config) : config =
         else
           vs, [Trapping "indirect call type mismatch" @@ e.at]
 
+      | ReturnCallRef, Ref NullRef :: vs ->
+        vs, [Trapping "null function reference" @@ e.at]
+
       | ReturnCallRef, vs ->
         (match (step {c with code = (vs, [Plain CallRef @@ 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
         )
 
+      | FuncBind x, Ref NullRef :: vs ->
+        vs, [Trapping "null function reference" @@ e.at]
+
+      | FuncBind x, Ref (FuncRef f) :: vs ->
+        let FuncType (ins, out) = Func.type_of f in
+        let FuncType (ins', out') = func_type frame.inst x in
+        let args, vs' =
+          try split (List.length ins - List.length ins') vs e.at
+          with Failure _ -> Crash.error e.at "type mismatch at function bind"
+        in
+        let f' = Func.alloc_closure f args in
+        Ref (FuncRef f') :: vs', []
+
       | Drop, v :: vs' ->
         vs', []
 
@@ -553,23 +569,27 @@ let rec step (c : config) : config =
       let c' = step {frame = frame'; code = code'; budget = c.budget - 1} in
       vs, [Frame (n, inst, c'.code) @@ e.at]
 
-    | Invoke func, vs when c.budget = 0 ->
+    | Invoke f, vs when c.budget = 0 ->
       Exhaustion.error e.at "call stack exhausted"
 
-    | Invoke func, vs ->
-      let FuncType (ins, out) = Func.type_of func in
+    | Invoke f, vs ->
+      let FuncType (ins, out) = Func.type_of f in
       let args, vs' = split (List.length ins) vs e.at in
-      (match func with
-      | Func.AstFunc (t, inst', f) ->
-        let ts = List.map Source.it f.it.locals in
-        let locals' = List.map (fun t -> t @@ f.at) ins @ f.it.locals in
+      (match f with
+      | Func.AstFunc (ft, inst', func) ->
+        let {locals; body; _} = func.it in
+        let ts = List.map Source.it locals in
+        let locals' = List.map (fun t -> t @@ func.at) ins @ locals in
         let vs0 = List.rev args @ List.map default_value ts in
-        let es0 = [Plain (Let (out, locals', f.it.body)) @@ f.at] in
+        let es0 = [Plain (Let (out, locals', body)) @@ func.at] in
         vs', [Frame (List.length out, !inst', (List.rev vs0, es0)) @@ e.at]
 
-      | Func.HostFunc (t, f) ->
-        try List.rev (f (List.rev args)) @ vs', []
-        with Crash (_, msg) -> Crash.error e.at msg
+      | Func.HostFunc (_ft, f) ->
+        (try List.rev (f (List.rev args)) @ vs', []
+        with Crash (_, msg) -> Crash.error e.at msg)
+
+      | Func.ClosureFunc (f', args') ->
+        args @ args' @ vs', [Invoke f' @@ e.at]
       )
   in {c with code = vs', es' @ List.tl es}
 
@@ -588,8 +608,13 @@ let rec eval (c : config) : value stack =
 
 (* Functions & Constants *)
 
+let rec at_func = function
+ | Func.AstFunc (_, _, f) -> f.at
+ | Func.HostFunc _ -> no_region
+ | Func.ClosureFunc (func, _) -> at_func func
+
 let invoke (func : func_inst) (vs : value list) : value list =
-  let at = match func with Func.AstFunc (_, _, f) -> f.at | _ -> no_region in
+  let at = at_func func in
   let FuncType (ins, out) = Func.type_of func in
   if List.length vs <> List.length ins then
     Crash.error at "wrong number of arguments";
diff --git a/interpreter/runtime/func.ml b/interpreter/runtime/func.ml
@@ -5,10 +5,15 @@ type 'inst t = 'inst func
 and 'inst func =
   | AstFunc of func_type * 'inst * Ast.func
   | HostFunc of func_type * (value list -> value list)
+  | ClosureFunc of 'inst func * value list
 
 let alloc ft inst f = AstFunc (ft, inst, f)
 let alloc_host ft f = HostFunc (ft, f)
+let alloc_closure func vs = ClosureFunc (func, vs)
 
-let type_of = function
+let rec type_of = function
   | AstFunc (ft, _, _) -> ft
   | HostFunc (ft, _) -> ft
+  | ClosureFunc (f, vs) ->
+    let FuncType (ins, out) = type_of f in
+    FuncType (Lib.List.drop (List.length vs) ins, out)
diff --git a/interpreter/runtime/func.mli b/interpreter/runtime/func.mli
@@ -5,7 +5,9 @@ type 'inst t = 'inst func
 and 'inst func =
   | AstFunc of func_type * 'inst * Ast.func
   | HostFunc of func_type * (value list -> value list)
+  | ClosureFunc of 'inst func * value list
 
 val alloc : func_type -> 'inst -> Ast.func -> 'inst func
 val alloc_host : func_type -> (value list -> value list) -> 'inst func
+val alloc_closure : 'inst func -> value list -> 'inst func
 val type_of : 'inst func -> func_type
diff --git a/interpreter/runtime/instance.ml b/interpreter/runtime/instance.ml
@@ -39,7 +39,7 @@ let () =
       let x =
         match func with
         | Func.AstFunc (_, _, f) -> f.Source.it.Ast.ftype.Source.it
-        | Func.HostFunc _ -> 0l  (* HACK! *)
+        | _ -> 0l  (* HACK! *)
       in
       DefRefType (NonNullable, x)
     | r -> type_of_ref' r
diff --git a/interpreter/syntax/ast.ml b/interpreter/syntax/ast.ml
@@ -88,6 +88,7 @@ and instr' =
   | CallRef                           (* call function through reference *)
   | CallIndirect of idx * idx         (* call function through table *)
   | ReturnCallRef                     (* tail call through reference *)
+  | FuncBind of idx                   (* closure creation *)
   | LocalGet of idx                   (* read local idxiable *)
   | LocalSet of idx                   (* write local idxiable *)
   | LocalTee of idx                   (* write local idxiable and keep value *)
diff --git a/interpreter/syntax/free.ml b/interpreter/syntax/free.ml
@@ -101,6 +101,7 @@ let rec instr (e : instr) =
   | Return | CallRef | ReturnCallRef -> empty
   | Call x -> funcs (idx x)
   | CallIndirect (x, y) -> tables (idx x) ++ types (idx y)
+  | FuncBind x -> types (idx x)
   | LocalGet x | LocalSet x | LocalTee x -> locals (idx x)
   | GlobalGet x | GlobalSet x -> globals (idx x)
   | TableGet x | TableSet x | TableSize x | TableGrow x | TableFill x ->
diff --git a/interpreter/syntax/operators.ml b/interpreter/syntax/operators.ml
@@ -34,6 +34,7 @@ let call x = Call x
 let call_ref = CallRef
 let call_indirect x y = CallIndirect (x, y)
 let return_call_ref = ReturnCallRef
+let func_bind x = FuncBind x
 
 let local_get x = LocalGet x
 let local_set x = LocalSet x
diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml
@@ -249,6 +249,7 @@ let rec instr e =
     | CallIndirect (x, y) ->
       "call_indirect " ^ var x, [Node ("type " ^ var y, [])]
     | ReturnCallRef -> "return_call_ref", []
+    | FuncBind x -> "func.bind", [Node ("type " ^ var x, [])]
     | 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
@@ -207,6 +207,7 @@ rule token = parse
   | "call_ref" { CALL_REF }
   | "call_indirect" { CALL_INDIRECT }
   | "return_call_ref" { RETURN_CALL_REF }
+  | "func.bind" { FUNC_BIND }
 
   | "local.get" { LOCAL_GET }
   | "local.set" { LOCAL_SET }
diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly
@@ -184,7 +184,7 @@ let inline_func_type_explicit (c : context) x ft at =
 %token UNREACHABLE NOP DROP SELECT
 %token BLOCK END IF THEN ELSE LOOP LET
 %token BR BR_IF BR_TABLE BR_ON_NULL
-%token CALL CALL_REF CALL_INDIRECT RETURN RETURN_CALL_REF
+%token CALL CALL_REF CALL_INDIRECT RETURN RETURN_CALL_REF FUNC_BIND
 %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
@@ -443,6 +443,8 @@ call_instr :
     { let at = at () in fun c -> call_indirect ($2 c table) ($3 c) @@ at }
   | CALL_INDIRECT call_instr_type  /* Sugar */
     { let at = at () in fun c -> call_indirect (0l @@ at) ($2 c) @@ at }
+  | FUNC_BIND call_instr_type
+    { let at = at () in fun c -> func_bind ($2 c) @@ at }
 
 call_instr_type :
   | type_use call_instr_params
@@ -475,6 +477,9 @@ call_instr_instr :
   | CALL_INDIRECT call_instr_type_instr  /* Sugar */
     { let at1 = ati 1 in
       fun c -> let x, es = $2 c in call_indirect (0l @@ at1) x @@ at1, es }
+  | FUNC_BIND call_instr_type_instr
+    { let at1 = ati 1 in
+      fun c -> let x, es = $2 c in func_bind x @@ at1, es }
 
 call_instr_type_instr :
   | type_use call_instr_params_instr
@@ -561,6 +566,8 @@ 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 }
+  | FUNC_BIND call_expr_type
+    { fun c -> let x, es = $2 c in es, func_bind x }
   | BLOCK labeling_opt block
     { fun c -> let c' = $2 c [] in let ts, es = $3 c' in [], block ts es }
   | LOOP labeling_opt block
diff --git a/interpreter/util/lib.ml b/interpreter/util/lib.ml
@@ -78,6 +78,13 @@ struct
     | n, _::xs' when n > 0 -> drop (n - 1) xs'
     | _ -> failwith "drop"
 
+  let rec split n xs = split' n [] xs
+  and split' n xs ys =
+    match n, ys with
+    | 0, _ -> List.rev xs, ys
+    | n, y::ys' when n > 0 -> split' (n - 1) (y::xs) ys'
+    | _ -> failwith "split"
+
   let rec last = function
     | x::[] -> x
     | _::xs -> last xs
diff --git a/interpreter/util/lib.mli b/interpreter/util/lib.mli
@@ -16,6 +16,7 @@ sig
   val table : int -> (int -> 'a) -> 'a list
   val take : int -> 'a list -> 'a list (* raises Failure *)
   val drop : int -> 'a list -> 'a list (* raises Failure *)
+  val split : int -> 'a list -> 'a list * 'a list (* raises Failure *)
 
   val last : 'a list -> 'a (* raises Failure *)
   val split_last : 'a list -> 'a list * 'a (* raises Failure *)
diff --git a/interpreter/valid/valid.ml b/interpreter/valid/valid.ml
@@ -238,9 +238,10 @@ let check_memop (c : context) (memop : 'a memop) get_sz at =
  * declarative typing rules.
  *)
 
-let check_local (c : context) (t : local) =
+let check_local (c : context) (defaults : bool) (t : local) =
   check_value_type c t.it t.at;
-  require (defaultable_value_type t.it) t.at "non-defaultable local type"
+  require (not defaults || defaultable_value_type t.it) t.at
+    "non-defaultable local type"
 
 let rec check_instr (c : context) (e : instr) (s : infer_stack_type) : op_type =
   match e.it with
@@ -288,7 +289,7 @@ let rec check_instr (c : context) (e : instr) (s : infer_stack_type) : op_type =
   | Let (ts, locals, es) ->
     List.iter (fun t -> check_value_type c t e.at) ts;
     check_arity (List.length ts) e.at;
-    List.iter (check_local c) locals;
+    List.iter (check_local c false) locals;
     let c' =
       { c with
         labels = ts :: c.labels;
@@ -331,8 +332,8 @@ let rec check_instr (c : context) (e : instr) (s : infer_stack_type) : op_type =
     | RefType (DefRefType (nul, x)) ->
       let FuncType (ins, out) = func_type c (x @@ e.at) in
       (ins @ [RefType (DefRefType (nul, x))]) --> out
-    | t ->
-      [t] -->... []
+    | BotType -> [] -->... []
+    | _ -> [RefType NullRefType] -->... []
     )
 
   | CallIndirect (x, y) ->
@@ -351,7 +352,24 @@ let rec check_instr (c : context) (e : instr) (s : infer_stack_type) : op_type =
         "type mismatch in function result";
       (ins @ [RefType (DefRefType (nul, x))]) -->... []
     | BotType -> [] -->... []
-    | _ -> [BotType] --> []
+    | _ -> [RefType NullRefType] -->... []
+    )
+
+  | FuncBind x ->
+    (match peek 0 s with
+    | RefType (DefRefType (nul, y)) ->
+      let FuncType (ins, out) = func_type c (y @@ e.at) in
+      let FuncType (ins', _) as ft' = func_type c x in
+      require (List.length ins >= List.length ins') x.at
+        "type mismatch in function arguments";
+      let ts1, ts2 = Lib.List.split (List.length ins - List.length ins') ins in
+      (* TODO: not necessary if we can insert the new semantic FuncType below *)
+      require (Match.match_func_type c.types [] (FuncType (ts2, out)) ft') e.at
+        "type mismatch in function type";
+      (ts1 @ [RefType (DefRefType (nul, y))]) -->
+      [RefType (DefRefType (NonNullable, x.it))]
+    | BotType -> [] -->... [RefType (DefRefType (NonNullable, x.it))]
+    | _ -> [RefType NullRefType] -->... [RefType (DefRefType (NonNullable, x.it))]
     )
 
   | LocalGet x ->
@@ -531,7 +549,7 @@ let check_type (c : context) (t : type_) =
 let check_func (c : context) (f : func) =
   let {ftype; locals; body} = f.it in
   let FuncType (ins, out) = func_type c ftype in
-  List.iter (check_local c) locals;
+  List.iter (check_local c true) locals;
   let c' =
     { c with
       locals = ins @ List.map Source.it locals;
diff --git a/proposals/function-references/Overview.md b/proposals/function-references/Overview.md
@@ -81,7 +81,7 @@ The following function calls it and then applies the result twice:
 ```wasm
 (func $main (result i32)
   (call $mk-adder (i32.const 7))
-  (let (local $f (ref $i32-i32)) (result i32)  ;; binds $f to top of stack
+  (let (result i32) (local $f (ref $i32-i32))  ;; binds $f to top of stack
     (i32.mul
       (call_ref (i32.const 10) (local.get $f))
       (call_ref (i32.const 12) (local.get $f))
@@ -211,9 +211,11 @@ The following rules, now defined in terms of constructed types, replace and exte
      - and `t2* <: C.result`
 
 * Optional extension: `func.bind` creates or extends a closure by binding one or several parameters
-  - `func.bind $t' : [t1^n (ref $t)] -> [(ref $t')]`
-    - iff `$t = [t1^n t1'*] -> [t2*]`
-    - and `$t' = [t1'*] -> [t2*]`
+  - `func.bind $t' : [t0* (ref $t)] -> [(ref $t')]`
+    - iff `$t = [t0* t1*] -> [t2*]`
+    - and `$t' = [t1'*] -> [t2'*]`
+    - and `t1'* <: t1*`
+    - and `t2* <: t2'*`
 
 
 #### Optional References
diff --git a/test/core/call_ref.wast b/test/core/call_ref.wast
diff --git a/test/core/func_bind.wast b/test/core/func_bind.wast
diff --git a/test/core/let.wast b/test/core/let.wast
diff --git a/test/core/return_call_ref.wast b/test/core/return_call_ref.wast
