Coerce result of void functions to None & remove host_eval

ml-proto/host/parser.mly

@@ -345,20 +345,32 @@ module_ :
 
 cmd :
   | module_ { Define $1 @@ at () }
+  | LPAR INVOKE TEXT const_list RPAR { Invoke ($3, $4) @@ at () }
   | LPAR ASSERT_INVALID module_ TEXT RPAR { AssertInvalid ($3, $4) @@ at () }
-  | LPAR INVOKE TEXT expr_list RPAR { Invoke ($3, $4 (c0 ())) @@ at () }
-  | LPAR ASSERT_RETURN LPAR INVOKE TEXT expr_list RPAR expr RPAR
-    { AssertReturn ($5, $6 (c0 ()), $8 (c0 ())) @@ at () }
-  | LPAR ASSERT_RETURN_NAN LPAR INVOKE TEXT expr_list RPAR RPAR
-    { AssertReturnNaN ($5, $6 (c0 ())) @@ at () }
-  | LPAR ASSERT_TRAP LPAR INVOKE TEXT expr_list RPAR TEXT RPAR
-    { AssertTrap ($5, $6 (c0 ()), $8) @@ at () }
+  | LPAR ASSERT_RETURN LPAR INVOKE TEXT const_list RPAR const_opt RPAR
+    { AssertReturn ($5, $6, $8) @@ at () }
+  | LPAR ASSERT_RETURN_NAN LPAR INVOKE TEXT const_list RPAR RPAR
+    { AssertReturnNaN ($5, $6) @@ at () }
+  | LPAR ASSERT_TRAP LPAR INVOKE TEXT const_list RPAR TEXT RPAR
+    { AssertTrap ($5, $6, $8) @@ at () }
 ;
 cmd_list :
   | /* empty */ { [] }
   | cmd cmd_list { $1 :: $2 }
 ;
 
+const :
+  | LPAR CONST literal RPAR { literal $3 $2 }
+;
+const_opt :
+  | /* empty */ { None }
+  | const { Some $1 }
+;
+const_list :
+  | /* empty */ { [] }
+  | const const_list { $1 :: $2 }
+;
+
 script :
   | cmd_list EOF { $1 }
 ;

ml-proto/host/script.ml

@@ -4,16 +4,17 @@
 
 open Source
 
+
 (* Script representation *)
 
 type command = command' phrase
 and command' =
   | Define of Ast.module_
+  | Invoke of string * Ast.literal list
   | AssertInvalid of Ast.module_ * string
-  | Invoke of string * Ast.expr list
-  | AssertReturn of string * Ast.expr list * Ast.expr
-  | AssertReturnNaN of string * Ast.expr list
-  | AssertTrap of string * Ast.expr list * string
+  | AssertReturn of string * Ast.literal list * Ast.literal option
+  | AssertReturnNaN of string * Ast.literal list
+  | AssertTrap of string * Ast.literal list * string
 
 type script = command list
 
@@ -24,13 +25,6 @@ let trace name = if !Flags.trace then print_endline ("-- " ^ name)
 
 let current_module : Eval.instance option ref = ref None
 
-let eval_args es at =
-  let evs = List.map Eval.host_eval es in
-  let reject_none = function
-    | Some v -> v
-    | None -> Error.error at "unexpected () value" in
-  List.map reject_none evs
-
 let get_module at = match !current_module with
   | Some m -> m
   | None -> Error.error at "no module defined to invoke"
@@ -71,89 +65,91 @@ let run_command cmd =
     let host_params = {Eval.page_size = Params.page_size} in
     current_module := Some (Eval.init m imports host_params)
 
-  | AssertInvalid (m, re) ->
-    trace "Checking invalid...";
-    assert_error (fun () -> Check.check_module m) "invalid module" re cmd.at
-
   | Invoke (name, es) ->
     trace "Invoking...";
     let m = get_module cmd.at in
-    let vs = eval_args es cmd.at in
-    let v = Eval.invoke m name vs in
+    let v = Eval.invoke m name (List.map it es) in
     if v <> None then Print.print_value v
 
-  | AssertReturn (name, arg_es, expect_e) ->
+  | AssertInvalid (m, re) ->
+    trace "Asserting invalid...";
+    assert_error (fun () -> Check.check_module m) "invalid module" re cmd.at
+
+  | AssertReturn (name, es, expect_e) ->
     let open Values in
-    trace "AssertReturn invoking...";
+    trace "Asserting return...";
     let m = get_module cmd.at in
-    let arg_vs = eval_args arg_es cmd.at in
-    let got_v = Eval.invoke m name arg_vs in
-    let expect_v = Eval.host_eval expect_e in
+    let got_v = Eval.invoke m name (List.map it es) in
+    let expect_v = Lib.Option.map it expect_e in
     (match got_v, expect_v with
-     | Some Int32 got_i32, Some Int32 expect_i32 ->
-       if got_i32 <> expect_i32 then begin
-         show_result_expect got_v expect_v;
-         Error.error cmd.at "assert_return i32 operands are not equal"
-       end
-     | Some Int64 got_i64, Some Int64 expect_i64 ->
-       if got_i64 <> expect_i64 then begin
-         show_result_expect got_v expect_v;
-         Error.error cmd.at "assert_return i64 operands are not equal"
-       end
-     | Some Float32 got_f32, Some Float32 expect_f32 ->
-       if (F32.to_bits got_f32) <> (F32.to_bits expect_f32) then begin
-         show_result_expect got_v expect_v;
-         Error.error cmd.at
-                     "assert_return f32 operands have different bit patterns"
-       end
-     | Some Float64 got_f64, Some Float64 expect_f64 ->
-       if (F64.to_bits got_f64) <> (F64.to_bits expect_f64) then begin
-         show_result_expect got_v expect_v;
-         Error.error cmd.at
-                     "assert_return f64 operands have different bit patterns"
-       end
-     | _, _ -> begin
-         show_result_expect got_v expect_v;
-         Error.error cmd.at "assert_return operands must be the same type"
-       end)
-
-  | AssertReturnNaN (name, arg_es) ->
+    | None, None -> ()
+    | Some (Int32 got_i32), Some (Int32 expect_i32) ->
+      if got_i32 <> expect_i32 then begin
+        show_result_expect got_v expect_v;
+        Error.error cmd.at "assert_return i32 operands are not equal"
+      end
+    | Some (Int64 got_i64), Some (Int64 expect_i64) ->
+      if got_i64 <> expect_i64 then begin
+        show_result_expect got_v expect_v;
+        Error.error cmd.at "assert_return i64 operands are not equal"
+      end
+    | Some (Float32 got_f32), Some (Float32 expect_f32) ->
+      if (F32.to_bits got_f32) <> (F32.to_bits expect_f32) then begin
+        show_result_expect got_v expect_v;
+        Error.error cmd.at
+          "assert_return f32 operands have different bit patterns"
+      end
+    | Some (Float64 got_f64), Some (Float64 expect_f64) ->
+      if (F64.to_bits got_f64) <> (F64.to_bits expect_f64) then begin
+        show_result_expect got_v expect_v;
+        Error.error cmd.at
+          "assert_return f64 operands have different bit patterns"
+      end
+    | _, _ ->
+      begin
+        show_result_expect got_v expect_v;
+        Error.error cmd.at "assert_return operands must be the same type"
+      end
+    )
+
+  | AssertReturnNaN (name, es) ->
     let open Values in
-    trace "AssertReturnNaN invoking...";
+    trace "Asserting return...";
     let m = get_module cmd.at in
-    let arg_vs = eval_args arg_es cmd.at in
-    let got_v = Eval.invoke m name arg_vs in
+    let got_v = Eval.invoke m name (List.map it es) in
     (match got_v with
-     | Some Float32 got_f32 ->
-       if (F32.eq got_f32 got_f32) then begin
-         show_result got_v;
-         Error.error cmd.at "assert_return_nan f32 operand is not a NaN"
-       end
-     | Some Float64 got_f64 ->
-       if (F64.eq got_f64 got_f64) then begin
-         show_result got_v;
-         Error.error cmd.at "assert_return_nan f64 operand is not a NaN"
-       end
-     | _ -> begin
-         show_result got_v;
-         Error.error cmd.at "assert_return_nan operand must be f32 or f64"
-       end)
+    | Some (Float32 got_f32) ->
+      if (F32.eq got_f32 got_f32) then begin
+        show_result got_v;
+        Error.error cmd.at "assert_return_nan f32 operand is not a NaN"
+      end
+    | Some (Float64 got_f64) ->
+      if (F64.eq got_f64 got_f64) then begin
+        show_result got_v;
+        Error.error cmd.at "assert_return_nan f64 operand is not a NaN"
+      end
+    | _ ->
+      begin
+        show_result got_v;
+        Error.error cmd.at "assert_return_nan operand must be f32 or f64"
+      end
+    )
 
   | AssertTrap (name, es, re) ->
-    trace "AssertTrap invoking...";
+    trace "Asserting trap...";
     let m = get_module cmd.at in
-    let vs = eval_args es cmd.at in
-    assert_error (fun () -> Eval.invoke m name vs) "trap" re cmd.at
+    assert_error (fun () -> Eval.invoke m name (List.map it es))
+      "trap" re cmd.at
 
 let dry_command cmd =
   match cmd.it with
   | Define m ->
     Check.check_module m;
     if !Flags.print_sig then Print.print_module_sig m
-  | AssertInvalid _ -> ()
-  | Invoke _ -> ()
-  | AssertReturn _ -> ()
-  | AssertReturnNaN _ -> ()
+  | Invoke _
+  | AssertInvalid _
+  | AssertReturn _
+  | AssertReturnNaN _
   | AssertTrap _ -> ()
 
 let run script =

ml-proto/host/script.mli

@@ -5,11 +5,11 @@
 type command = command' Source.phrase
 and command' =
   | Define of Ast.module_
+  | Invoke of string * Ast.literal list
   | AssertInvalid of Ast.module_ * string
-  | Invoke of string * Ast.expr list
-  | AssertReturn of string * Ast.expr list * Ast.expr
-  | AssertReturnNaN of string * Ast.expr list
-  | AssertTrap of string * Ast.expr list * string
+  | AssertReturn of string * Ast.literal list * Ast.literal option
+  | AssertReturnNaN of string * Ast.literal list
+  | AssertTrap of string * Ast.literal list * string
 
 type script = command list
 

ml-proto/spec/eval.ml

@@ -253,12 +253,15 @@ and eval_case c vo stage case =
   | `Seek, false | `Done _, _ ->
     stage
 
-and eval_func (m : instance) (f : func) (evs : value list) =
-  let args = List.map ref evs in
+and eval_func (m : instance) f vs =
+  let args = List.map ref vs in
   let vars = List.map (fun t -> ref (default_value t.it)) f.it.locals in
   let locals = args @ vars in
   let c = {instance = m; locals; labels = []} in
-  eval_expr c f.it.body
+  coerce f.it.result (eval_expr c f.it.body)
+
+and coerce et vo =
+  if et = None then None else vo
 
 
 (* Host operators *)
@@ -309,10 +312,3 @@ let invoke m name vs =
     eval_func m f vs
   with Stack_overflow -> callstack_exhaustion no_region
 
-(* This function is not part of the spec. *)
-let host_eval e =
-  let f = {params = []; result = None; locals = []; body = e} @@ no_region in
-  let exports = ExportMap.singleton "eval" f in
-  let host = {page_size = 1L} in
-  let m = {imports = []; exports; tables = []; funcs = [f]; memory = None; host}
-  in eval_func m f []

ml-proto/spec/eval.mli

@@ -11,5 +11,3 @@ val init : Ast.module_ -> import list -> host_params -> instance
 val invoke : instance -> string -> value list -> value option
   (* raise Error.Error *)
 
-(* This function is not part of the spec. *)
-val host_eval : Ast.expr -> value option (* raise Error.Error *)

ml-proto/test/float_memory.wast

@@ -35,13 +35,13 @@
 (module
   (memory 8 8)
 
-  (func $store_i64 (param $x i64)
+  (func $store_i64 (param $x i64) (result i64)
     (i64.store (i32.const 0) (get_local $x)))
 
   (func $load_i64 (result i64)
     (i64.load (i32.const 0)))
 
-  (func $store_f64 (param $x f64)
+  (func $store_f64 (param $x f64) (result f64)
     (f64.store (i32.const 0) (get_local $x)))
 
   (func $load_f64 (result f64)

ml-proto/test/functions.wast

@@ -0,0 +1,7 @@
+(module
+  (func $return-none (i32.const 1))
+  (export "return-none" $return-none)
+)
+
+(assert_return (invoke "return-none"))
+