Merge pull request #497 from ngzhian/script-pat-cleanup

Small cleanup to num_pat to remove redundant Source.phrase
WebAssembly · Apr 7, 2021 · 291d2ec · 291d2ec
2 parents c972ba6 + 886123e
commit 291d2ec
Show file tree

Hide file tree

Showing 5 changed files with 44 additions and 66 deletions.
diff --git a/interpreter/script/js.ml b/interpreter/script/js.ml
@@ -288,27 +288,27 @@ let assert_return ress ts at =
       | ArithmeticNan -> canonical_nan_of (* can be any NaN that's one everywhere the canonical NaN is one *)
     in
     match res.it with
-    | NumResult {it = LitPat {it = Values.Num num; at = at'}; _} ->
+    | NumResult (LitPat {it = Values.Num num; at = at'}) ->
       let t', reinterpret = reinterpret_of (Values.type_of_num num) in
       [ reinterpret @@ at;
         Const (num @@ at')  @@ at;
         reinterpret @@ at;
         Compare (eq_of t') @@ at;
         Test (Values.I32 I32Op.Eqz) @@ at;
         BrIf (0l @@ at) @@ at ]
-    | NumResult {it = LitPat {it = Values.Ref (Values.NullRef t); _}; _} ->
+    | NumResult (LitPat {it = Values.Ref (Values.NullRef t); _}) ->
       [ RefIsNull @@ at;
         Test (Values.I32 I32Op.Eqz) @@ at;
         BrIf (0l @@ at) @@ at ]
-    | NumResult {it = LitPat {it = Values.Ref (ExternRef n); _}; _} ->
+    | NumResult (LitPat {it = Values.Ref (ExternRef n); _}) ->
       [ Const (Values.I32 n @@ at) @@ at;
         Call (externref_idx @@ at) @@ at;
         Call (eq_externref_idx @@ at)  @@ at;
         Test (Values.I32 I32Op.Eqz) @@ at;
         BrIf (0l @@ at) @@ at ]
-    | NumResult {it = LitPat {it = Values.Ref _; _}; _} ->
+    | NumResult (LitPat {it = Values.Ref _; _}) ->
       assert false
-    | NumResult {it = NanPat nanop; _ } ->
+    | NumResult (NanPat nanop) ->
       let nan =
         match nanop.it with
         | Values.I32 _ | Values.I64 _ | Values.V128 _ -> assert false
@@ -339,7 +339,7 @@ let assert_return ress ts at =
         | NanPat {it = F64 nan; _} -> nan_bitmask_of nan I64Type, canonical_nan_of I64Type
         | _ -> assert false
       in
-      let masks, canons = List.split (List.map (fun p -> mask_and_canonical p.it) pats) in
+      let masks, canons = List.split (List.map (fun p -> mask_and_canonical p) pats) in
       let all_ones = V128.of_i32x4 (List.init 4 (fun _ -> Int32.minus_one)) in
       let mask, expected = match shape with
         | Simd.I8x16 -> all_ones, V128.of_i8x16 (List.map (I32Num.of_num 0) canons)
@@ -489,9 +489,9 @@ let of_numpat = function
 
 let of_result res =
   match res.it with
-  | NumResult n -> of_numpat n.it
+  | NumResult n -> of_numpat n
   | SimdResult (shape, pats) ->
-    Printf.sprintf "v128(\"%s\")" (String.concat " " (List.map (fun x -> of_numpat x.it) pats))
+    Printf.sprintf "v128(\"%s\")" (String.concat " " (List.map (fun x -> of_numpat x) pats))
   | RefResult t -> "\"ref." ^ string_of_refed_type t ^ "\""
 
 let rec of_definition def =

diff --git a/interpreter/script/run.ml b/interpreter/script/run.ml
@@ -252,13 +252,13 @@ let string_of_nan = function
 
 let type_of_result r =
   match r with
-  | NumResult { it = LitPat v ; _ } -> Values.type_of_value v.it
-  | NumResult { it = NanPat v ; _ } -> Types.NumType (Values.type_of_num v.it)
+  | NumResult (LitPat v) -> Values.type_of_value v.it
+  | NumResult (NanPat v) -> Types.NumType (Values.type_of_num v.it)
   | SimdResult (_, _) -> Types.NumType Types.V128Type
   | RefResult t -> Types.RefType t
 
 let string_of_num_pat (p : num_pat) =
-  match p.it with
+  match p with
   | LitPat v -> Values.string_of_value v.it
   | NanPat nanop ->
     match nanop.it with
@@ -361,7 +361,7 @@ let run_action act : Values.value list =
 
 let assert_num_pat at v p =
   let open Values in
-  match p.it with
+  match p with
     | (LitPat v') -> v <> v'.it
     | (NanPat nanop) ->
       match nanop.it, v with
@@ -384,46 +384,25 @@ let assert_result at got expect =
       | NumResult v' -> assert_num_pat at v v'
       | SimdResult (shape, vs) ->
         begin
-            let open Simd in
-            match shape, v with
-            | I8x16, Num (V128 v) ->
-              List.exists2
-                (fun v r -> assert_num_pat at v r)
-                (List.init 16 (fun i -> Num (I32 (V128.I8x16.extract_lane_s i v))))
-                vs
-            | I16x8, Num (V128 v) ->
-              List.exists2
-                (fun v r -> assert_num_pat at v r)
-                (List.init 8 (fun i -> Num (I32 (V128.I16x8.extract_lane_s i v))))
-                vs
-            | I32x4, Num (V128 v) ->
-              let l0 = Num (I32 (V128.I32x4.extract_lane_s 0 v)) in
-              let l1 = Num (I32 (V128.I32x4.extract_lane_s 1 v)) in
-              let l2 = Num (I32 (V128.I32x4.extract_lane_s 2 v)) in
-              let l3 = Num (I32 (V128.I32x4.extract_lane_s 3 v)) in
-                List.exists2 (fun v r ->
-                    assert_num_pat at v r
-                ) [l0; l1; l2; l3]  vs
-            | I64x2, Num (V128 v) ->
-              List.exists2
-                (fun v r -> assert_num_pat at v r)
-                (List.init 2 (fun i -> Num (I64 (V128.I64x2.extract_lane_s i v))))
-                vs
-            | F32x4, Num (V128 v) ->
-              let l0 = Num (F32 (V128.F32x4.extract_lane 0 v)) in
-              let l1 = Num (F32 (V128.F32x4.extract_lane 1 v)) in
-              let l2 = Num (F32 (V128.F32x4.extract_lane 2 v)) in
-              let l3 = Num (F32 (V128.F32x4.extract_lane 3 v)) in
-                List.exists2 (fun v r ->
-                    assert_num_pat at v r
-                ) [l0; l1; l2; l3]  vs
-            | F64x2, Num (V128 v) ->
-              let l0 = Num (F64 (V128.F64x2.extract_lane 0 v)) in
-              let l1 = Num (F64 (V128.F64x2.extract_lane 1 v)) in
-                List.exists2 (fun v r ->
-                    assert_num_pat at v r
-                ) [l0; l1]  vs
-            | _ -> failwith "impossible"
+          let open Simd in
+          let assert_simd_result to_num extract v =
+            List.exists2
+              (assert_num_pat at)
+              (List.init (lanes shape) (fun i -> Num (to_num (extract i v)))) vs in
+          match shape, v with
+          | I8x16, Num (V128 v) ->
+            assert_simd_result I32Num.to_num V128.I8x16.extract_lane_s v
+          | I16x8, Num (V128 v) ->
+            assert_simd_result I32Num.to_num V128.I16x8.extract_lane_s v
+          | I32x4, Num (V128 v) ->
+            assert_simd_result I32Num.to_num V128.I32x4.extract_lane_s v
+          | I64x2, Num (V128 v) ->
+            assert_simd_result I64Num.to_num V128.I64x2.extract_lane_s v
+          | F32x4, Num (V128 v) ->
+            assert_simd_result F32Num.to_num V128.F32x4.extract_lane v
+          | F64x2, Num (V128 v) ->
+            assert_simd_result F64Num.to_num V128.F64x2.extract_lane v
+          | _ -> failwith "impossible"
         end
       | RefResult t ->
         (match t, v with

diff --git a/interpreter/script/script.ml b/interpreter/script/script.ml
@@ -18,8 +18,7 @@ type nanop = nanop' Source.phrase
 and nanop' = (Lib.void, Lib.void, nan, nan, Lib.void) Values.op
 and nan = CanonicalNan | ArithmeticNan
 
-type num_pat = num_pat' Source.phrase
-and num_pat' =
+type num_pat =
   | LitPat of literal
   | NanPat of nanop
 

diff --git a/interpreter/text/arrange.ml b/interpreter/text/arrange.ml
@@ -813,7 +813,7 @@ let result_simd mode res shape pats =
   (* A different text generation for SIMD, since the literals within
    * a SimdResult do not need the i32.const instruction *)
   let num_pat mode res =
-    match res.it with
+    match res with
     | LitPat lit -> literal mode lit (Some shape)
     | NanPat {it = Values.F32 n; _}
     | NanPat {it = Values.F64 n; _} -> nan n
@@ -826,7 +826,7 @@ let result_simd mode res shape pats =
 let result mode res =
   match res.it with
   | SimdResult (shape, pats) -> result_simd mode res shape pats
-  | NumResult n -> result_numpat mode n.it
+  | NumResult n -> result_numpat mode n
   | RefResult t -> Node ("ref." ^ refed_type t, [])
 
 let assertion mode ass =

diff --git a/interpreter/text/parser.mly b/interpreter/text/parser.mly
@@ -51,20 +51,20 @@ let simd_literal shape ss at =
 let simd_lane_nan shape l at =
   let open Simd in
   match shape with
-  | F32x4 -> NanPat (Values.F32 l @@ at) @@ at
-  | F64x2 -> NanPat (Values.F64 l @@ at) @@ at
+  | F32x4 -> NanPat (Values.F32 l @@ at)
+  | F64x2 -> NanPat (Values.F64 l @@ at)
   | _ -> error at "invalid simd constant"
 
 let simd_lane_lit shape l at =
   let open Simd in
   let open Values in
   match shape with
-  | I8x16 -> LitPat (Num (I32 (I8.of_string l)) @@ at) @@ at
-  | I16x8 -> LitPat (Num (I32 (I16.of_string l)) @@ at) @@ at
-  | I32x4 -> LitPat (Num (I32 (I32.of_string l)) @@ at) @@ at
-  | I64x2 -> LitPat (Num (I64 (I64.of_string l)) @@ at) @@ at
-  | F32x4 -> LitPat (Num (F32 (F32.of_string l)) @@ at) @@ at
-  | F64x2 -> LitPat (Num (F64 (F64.of_string l)) @@ at) @@ at
+  | I8x16 -> LitPat (Num (I32 (I8.of_string l)) @@ at)
+  | I16x8 -> LitPat (Num (I32 (I16.of_string l)) @@ at)
+  | I32x4 -> LitPat (Num (I32 (I32.of_string l)) @@ at)
+  | I64x2 -> LitPat (Num (I64 (I64.of_string l)) @@ at)
+  | F32x4 -> LitPat (Num (F32 (F32.of_string l)) @@ at)
+  | F64x2 -> LitPat (Num (F64 (F64.of_string l)) @@ at)
 
 let simd_lane_index s at =
   match int_of_string s with
@@ -1127,8 +1127,8 @@ numpat_list:
   | numpat numpat_list { $1 :: $2 }
 
 result :
-  | const { NumResult (LitPat $1 @@ at ()) @@ at () }
-  | LPAR CONST NAN RPAR { NumResult (NanPat (nanop $2 ($3 @@ ati 3)) @@ at ()) @@ at () }
+  | const { NumResult (LitPat $1) @@ at () }
+  | LPAR CONST NAN RPAR { NumResult (NanPat (nanop $2 ($3 @@ ati 3))) @@ at () }
   | LPAR REF_FUNC RPAR { RefResult FuncRefType @@ at () }
   | LPAR REF_EXTERN RPAR { RefResult ExternRefType @@ at () }
   | LPAR V128_CONST SIMD_SHAPE numpat_list RPAR {