[interpreter] Unify assert_result* assertions (#1104)

Author: rossberg

interpreter/README.md

@@ -324,16 +324,22 @@ action:
   ( get <name>? <string> )                   ;; get global export
 
 assertion:
-  ( assert_return <action> <expr>* )         ;; assert action has expected results
-  ( assert_return_canonical_nan <action> )   ;; assert action results in NaN in a canonical form
-  ( assert_return_arithmetic_nan <action> )  ;; assert action results in NaN with 1 in MSB of fraction field
+  ( assert_return <action> <result>* )       ;; assert action has expected results
   ( assert_trap <action> <failure> )         ;; assert action traps with given failure string
   ( assert_exhaustion <action> <failure> )   ;; assert action exhausts system resources
   ( assert_malformed <module> <failure> )    ;; assert module cannot be decoded with given failure string
   ( assert_invalid <module> <failure> )      ;; assert module is invalid with given failure string
   ( assert_unlinkable <module> <failure> )   ;; assert module fails to link
   ( assert_trap <module> <failure> )         ;; assert module traps on instantiation
 
+result:
+  ( <val_type>.const <numpat> )
+
+numpat:
+  <value>                                    ;; literal result
+  nan:canonical                              ;; NaN in canonical form
+  nan:arithmetic                             ;; NaN with 1 in MSB of payload
+
 meta:
   ( script <name>? <script> )                ;; name a subscript
   ( input <name>? <string> )                 ;; read script or module from file

interpreter/exec/float.ml

@@ -30,6 +30,8 @@ sig
   type bits
   val pos_nan : t
   val neg_nan : t
+  val is_inf : t -> bool
+  val is_nan : t -> bool
   val of_float : float -> t
   val to_float : t -> float
   val of_string : string -> t

interpreter/script/js.ml

@@ -122,27 +122,21 @@ function assert_exhaustion(action) {
 
 function assert_return(action, expected) {
   let actual = action();
-  if (!Object.is(actual, expected)) {
-    throw new Error("Wasm return value " + expected + " expected, got " + actual);
-  };
-}
-
-function assert_return_canonical_nan(action) {
-  let actual = action();
-  // Note that JS can't reliably distinguish different NaN values,
-  // so there's no good way to test that it's a canonical NaN.
-  if (!Number.isNaN(actual)) {
-    throw new Error("Wasm return value NaN expected, got " + actual);
-  };
-}
-
-function assert_return_arithmetic_nan(action) {
-  // Note that JS can't reliably distinguish different NaN values,
-  // so there's no good way to test for specific bitpatterns here.
-  let actual = action();
-  if (!Number.isNaN(actual)) {
-    throw new Error("Wasm return value NaN expected, got " + actual);
-  };
+  switch (expected) {
+    case "nan:canonical":
+    case "nan:arithmetic":
+    case "nan:any":
+      // Note that JS can't reliably distinguish different NaN values,
+      // so there's no good way to test that it's a canonical NaN.
+      if (!Number.isNaN(actual)) {
+        throw new Error("Wasm return value NaN expected, got " + actual);
+      };
+      return;
+    default:
+      if (!Object.is(actual, expected)) {
+        throw new Error("Wasm return value " + expected + " expected, got " + actual);
+      };
+  }
 }
 |}
 
@@ -220,36 +214,38 @@ let get t at =
 let run ts at =
   [], []
 
-let assert_return lits ts at =
-  let test lit =
-    let t', reinterpret = reinterpret_of (Values.type_of lit.it) in
-    [ reinterpret @@ at;
-      Const lit @@ at;
-      reinterpret @@ at;
-      Compare (eq_of t') @@ at;
-      Test (Values.I32 I32Op.Eqz) @@ at;
-      BrIf (0l @@ at) @@ at ]
-  in [], List.flatten (List.rev_map test lits)
-
-let assert_return_nan_bitpattern nan_bitmask_of ts at =
-  let test t =
-    let t', reinterpret = reinterpret_of t in
-    [ reinterpret @@ at;
-      Const (nan_bitmask_of t' @@ at) @@ at;
-      Binary (and_of t') @@ at;
-      Const (canonical_nan_of t' @@ at) @@ at;
-      Compare (eq_of t') @@ at;
-      Test (Values.I32 I32Op.Eqz) @@ at;
-      BrIf (0l @@ at) @@ at ]
-  in [], List.flatten (List.rev_map test ts)
-
-let assert_return_canonical_nan =
-  (* The result may only differ from the canonical NaN in its sign bit *)
-  assert_return_nan_bitpattern abs_mask_of
-
-let assert_return_arithmetic_nan =
-  (* The result can be any NaN that's one everywhere the canonical NaN is one *)
-  assert_return_nan_bitpattern canonical_nan_of
+let assert_return ress ts at =
+  let test res =
+    match res.it with
+    | LitResult lit ->
+      let t', reinterpret = reinterpret_of (Values.type_of lit.it) in
+      [ reinterpret @@ at;
+        Const lit @@ at;
+        reinterpret @@ at;
+        Compare (eq_of t') @@ at;
+        Test (Values.I32 I32Op.Eqz) @@ at;
+        BrIf (0l @@ at) @@ at ]
+    | NanResult nanop ->
+      let nan =
+        match nanop.it with
+        | Values.I32 _ | Values.I64 _ -> assert false
+        | Values.F32 n | Values.F64 n -> n
+      in
+      let nan_bitmask_of =
+        match nan with
+        | CanonicalNan -> abs_mask_of (* must only differ from the canonical NaN in its sign bit *)
+        | ArithmeticNan -> canonical_nan_of (* can be any NaN that's one everywhere the canonical NaN is one *)
+      in
+      let t = Values.type_of nanop.it in
+      let t', reinterpret = reinterpret_of t in
+      [ reinterpret @@ at;
+        Const (nan_bitmask_of t' @@ at) @@ at;
+        Binary (and_of t') @@ at;
+        Const (canonical_nan_of t' @@ at) @@ at;
+        Compare (eq_of t') @@ at;
+        Test (Values.I32 I32Op.Eqz) @@ at;
+        BrIf (0l @@ at) @@ at ]
+  in [], List.flatten (List.rev_map test ress)
 
 let wrap module_name item_name wrap_action wrap_assertion at =
   let itypes, idesc, action = wrap_action at in
@@ -321,6 +317,18 @@ let of_literal lit =
   | Values.F32 z -> of_float (F32.to_float z)
   | Values.F64 z -> of_float (F64.to_float z)
 
+let of_nan = function
+  | CanonicalNan -> "nan:canonical"
+  | ArithmeticNan -> "nan:arithmetic"
+
+let of_result res =
+  match res.it with
+  | LitResult lit -> of_literal lit
+  | NanResult nanop ->
+    match nanop.it with
+    | Values.I32 _ | Values.I64 _ -> assert false
+    | Values.F32 n | Values.F64 n -> of_nan n
+
 let rec of_definition def =
   match def.it with
   | Textual m -> of_bytes (Encode.encode m)
@@ -377,13 +385,9 @@ let of_assertion mods ass =
     "assert_unlinkable(" ^ of_definition def ^ ");"
   | AssertUninstantiable (def, _) ->
     "assert_uninstantiable(" ^ of_definition def ^ ");"
-  | AssertReturn (act, lits) ->
-    of_assertion' mods act "assert_return" (List.map of_literal lits)
-      (Some (assert_return lits))
-  | AssertReturnCanonicalNaN act ->
-    of_assertion' mods act "assert_return_canonical_nan" [] (Some assert_return_canonical_nan)
-  | AssertReturnArithmeticNaN act ->
-    of_assertion' mods act "assert_return_arithmetic_nan" [] (Some assert_return_arithmetic_nan)
+  | AssertReturn (act, ress) ->
+    of_assertion' mods act "assert_return" (List.map of_result ress)
+      (Some (assert_return ress))
   | AssertTrap (act, _) ->
     of_assertion' mods act "assert_trap" [] None
   | AssertExhaustion (act, _) ->

interpreter/script/run.ml

@@ -238,12 +238,39 @@ let print_module x_opt m =
   List.iter (print_export m) m.it.Ast.exports;
   flush_all ()
 
-let print_result vs =
+let print_values vs =
   let ts = List.map Values.type_of vs in
   Printf.printf "%s : %s\n"
     (Values.string_of_values vs) (Types.string_of_value_types ts);
   flush_all ()
 
+let string_of_nan = function
+  | CanonicalNan -> "nan:canonical"
+  | ArithmeticNan -> "nan:arithmetic"
+
+let type_of_result r =
+  match r with
+  | LitResult v -> Values.type_of v.it
+  | NanResult n -> Values.type_of n.it
+
+let string_of_result r =
+  match r with
+  | LitResult v -> Values.string_of_value v.it
+  | NanResult nanop ->
+    match nanop.it with
+    | Values.I32 _ | Values.I64 _ -> assert false
+    | Values.F32 n | Values.F64 n -> string_of_nan n
+
+let string_of_results = function
+  | [r] -> string_of_result r
+  | rs -> "[" ^ String.concat " " (List.map string_of_result rs) ^ "]"
+
+let print_results rs =
+  let ts = List.map type_of_result rs in
+  Printf.printf "%s : %s\n"
+    (string_of_results rs) (Types.string_of_value_types ts);
+  flush_all ()
+
 
 (* Configuration *)
 
@@ -281,7 +308,7 @@ let lookup_registry module_name item_name _t =
 
 (* Running *)
 
-let rec run_definition def =
+let rec run_definition def : Ast.module_ =
   match def.it with
   | Textual m -> m
   | Encoded (name, bs) ->
@@ -292,7 +319,7 @@ let rec run_definition def =
     let def' = Parse.string_to_module s in
     run_definition def'
 
-let run_action act =
+let run_action act : Values.value list =
   match act.it with
   | Invoke (x_opt, name, vs) ->
     trace ("Invoking function \"" ^ Ast.string_of_name name ^ "\"...");
@@ -313,10 +340,28 @@ let run_action act =
     | None -> Assert.error act.at "undefined export"
     )
 
-let assert_result at correct got print_expect expect =
-  if not correct then begin
-    print_string "Result: "; print_result got;
-    print_string "Expect: "; print_expect expect;
+let assert_result at got expect =
+  let open Values in
+  if
+    List.length got <> List.length expect ||
+    List.exists2 (fun v r ->
+      match r with
+      | LitResult v' -> v <> v'.it
+      | NanResult nanop ->
+        match nanop.it, v with
+        | F32 CanonicalNan, F32 z -> z <> F32.pos_nan && z <> F32.neg_nan
+        | F64 CanonicalNan, F64 z -> z <> F64.pos_nan && z <> F64.neg_nan
+        | F32 ArithmeticNan, F32 z ->
+          let pos_nan = F32.to_bits F32.pos_nan in
+          Int32.logand (F32.to_bits z) pos_nan <> pos_nan
+        | F64 ArithmeticNan, F64 z ->
+          let pos_nan = F64.to_bits F64.pos_nan in
+          Int64.logand (F64.to_bits z) pos_nan <> pos_nan
+        | _, _ -> false
+    ) got expect
+  then begin
+    print_string "Result: "; print_values got;
+    print_string "Expect: "; print_results expect;
     Assert.error at "wrong return values"
   end
 
@@ -377,35 +422,11 @@ let run_assertion ass =
     | _ -> Assert.error ass.at "expected instantiation error"
     )
 
-  | AssertReturn (act, vs) ->
-    trace ("Asserting return...");
-    let got_vs = run_action act in
-    let expect_vs = List.map (fun v -> v.it) vs in
-    assert_result ass.at (got_vs = expect_vs) got_vs print_result expect_vs
-
-  | AssertReturnCanonicalNaN act ->
-    trace ("Asserting return...");
-    let got_vs = run_action act in
-    let is_canonical_nan =
-      match got_vs with
-      | [Values.F32 got_f32] -> got_f32 = F32.pos_nan || got_f32 = F32.neg_nan
-      | [Values.F64 got_f64] -> got_f64 = F64.pos_nan || got_f64 = F64.neg_nan
-      | _ -> false
-    in assert_result ass.at is_canonical_nan got_vs print_endline "nan"
-
-  | AssertReturnArithmeticNaN act ->
+  | AssertReturn (act, rs) ->
     trace ("Asserting return...");
     let got_vs = run_action act in
-    let is_arithmetic_nan =
-      match got_vs with
-      | [Values.F32 got_f32] ->
-        let pos_nan = F32.to_bits F32.pos_nan in
-        Int32.logand (F32.to_bits got_f32) pos_nan = pos_nan
-      | [Values.F64 got_f64] ->
-        let pos_nan = F64.to_bits F64.pos_nan in
-        Int64.logand (F64.to_bits got_f64) pos_nan = pos_nan
-      | _ -> false
-    in assert_result ass.at is_arithmetic_nan got_vs print_endline "nan"
+    let expect_rs = List.map (fun r -> r.it) rs in
+    assert_result ass.at got_vs expect_rs
 
   | AssertTrap (act, re) ->
     trace ("Asserting trap...");
@@ -457,7 +478,7 @@ let rec run_command cmd =
     quote := cmd :: !quote;
     if not !Flags.dry then begin
       let vs = run_action act in
-      if vs <> [] then print_result vs
+      if vs <> [] then print_values vs
     end
 
   | Assertion ass ->

interpreter/script/script.ml

@@ -11,15 +11,22 @@ and action' =
   | Invoke of var option * Ast.name * Ast.literal list
   | Get of var option * Ast.name
 
+type nanop = nanop' Source.phrase
+and nanop' = (unit, unit, nan, nan) Values.op
+and nan = CanonicalNan | ArithmeticNan
+
+type result = result' Source.phrase
+and result' =
+  | LitResult of Ast.literal
+  | NanResult of nanop
+
 type assertion = assertion' Source.phrase
 and assertion' =
   | AssertMalformed of definition * string
   | AssertInvalid of definition * string
   | AssertUnlinkable of definition * string
   | AssertUninstantiable of definition * string
-  | AssertReturn of action * Ast.literal list
-  | AssertReturnCanonicalNaN of action
-  | AssertReturnArithmeticNaN of action
+  | AssertReturn of action * result list
   | AssertTrap of action * string
   | AssertExhaustion of action * string
 

interpreter/text/arrange.ml

@@ -417,6 +417,19 @@ let action act =
   | Get (x_opt, name) ->
     Node ("get" ^ access x_opt name, [])
 
+let nan = function
+  | CanonicalNan -> "nan:canonical"
+  | ArithmeticNan -> "nan:arithmetic"
+
+let result res =
+  match res.it with
+  | LitResult lit -> literal lit
+  | NanResult nanop ->
+    match nanop.it with
+    | Values.I32 _ | Values.I64 _ -> assert false
+    | Values.F32 n -> Node ("f32.const " ^ nan n, [])
+    | Values.F64 n -> Node ("f64.const " ^ nan n, [])
+
 let assertion mode ass =
   match ass.it with
   | AssertMalformed (def, re) ->
@@ -427,12 +440,8 @@ let assertion mode ass =
     Node ("assert_unlinkable", [definition mode None def; Atom (string re)])
   | AssertUninstantiable (def, re) ->
     Node ("assert_trap", [definition mode None def; Atom (string re)])
-  | AssertReturn (act, lits) ->
-    Node ("assert_return", action act :: List.map literal lits)
-  | AssertReturnCanonicalNaN act ->
-    Node ("assert_return_canonical_nan", [action act])
-  | AssertReturnArithmeticNaN act ->
-    Node ("assert_return_arithmetic_nan", [action act])
+  | AssertReturn (act, results) ->
+    Node ("assert_return", action act :: List.map result results)
   | AssertTrap (act, re) ->
     Node ("assert_trap", [action act; Atom (string re)])
   | AssertExhaustion (act, re) ->

interpreter/text/lexer.mll

@@ -344,10 +344,10 @@ rule token = parse
   | "assert_invalid" { ASSERT_INVALID }
   | "assert_unlinkable" { ASSERT_UNLINKABLE }
   | "assert_return" { ASSERT_RETURN }
-  | "assert_return_canonical_nan" { ASSERT_RETURN_CANONICAL_NAN }
-  | "assert_return_arithmetic_nan" { ASSERT_RETURN_ARITHMETIC_NAN }
   | "assert_trap" { ASSERT_TRAP }
   | "assert_exhaustion" { ASSERT_EXHAUSTION }
+  | "nan:canonical" { NAN Script.CanonicalNan }
+  | "nan:arithmetic" { NAN Script.ArithmeticNan }
   | "input" { INPUT }
   | "output" { OUTPUT }