From 4009c3de21a43220df7e2d2a32069b55e17b2d33 Mon Sep 17 00:00:00 2001 From: zapashcanon Date: Thu, 19 Dec 2024 02:02:47 +0100 Subject: [PATCH] clean some code in the fuzzer --- src/ast/types.ml | 4 +++- test/fuzz/basic.ml | 8 +++++--- test/fuzz/env.ml | 24 ++++++++++++------------ test/fuzz/interprets.ml | 10 ++++++---- test/fuzz/type_stack.ml | 4 ++-- 5 files changed, 28 insertions(+), 22 deletions(-) diff --git a/src/ast/types.ml b/src/ast/types.ml index d61b60952..539aaff97 100644 --- a/src/ast/types.ml +++ b/src/ast/types.ml @@ -70,7 +70,7 @@ let pp_num_type fmt = function let num_type_eq t1 t2 = match (t1, t2) with | I32, I32 | I64, I64 | F32, F32 | F64, F64 -> true - | _, _ -> false + | (I32 | I64 | F32 | F64), _ -> false let compare_num_type t1 t2 = let to_int = function I32 -> 0 | I64 -> 1 | F32 -> 2 | F64 -> 3 in @@ -101,6 +101,8 @@ type nonrec mut = let pp_mut fmt = function Const -> () | Var -> pf fmt "mut" +let is_mut = function Const -> false | Var -> true + type nonrec nn = | S32 | S64 diff --git a/test/fuzz/basic.ml b/test/fuzz/basic.ml index 7cb2247c5..774ea4a55 100644 --- a/test/fuzz/basic.ml +++ b/test/fuzz/basic.ml @@ -418,7 +418,7 @@ let memory_exists (env : Env.t) = Option.is_some env.memory let memarg nsize = let* offset = int32 in - let offset = if offset < 0l then Int32.sub 0l offset else offset in + let offset = if Owi.Int32.lt offset 0l then Int32.sub 0l offset else offset in let+ align = match nsize with | NS8 -> const 0 @@ -549,11 +549,13 @@ let table_copy (env : Env.t) = let instr = let* name_x, (_lim_x, rt_x) = choose tables in let* name_y, (_lim_y, rt_y) = choose tables in - if rt_x = rt_y then + match (rt_x, rt_y) with + | ((Null, ht1), (Null, ht2) | (No_null, ht1), (No_null, ht2)) + when heap_type_eq ht1 ht2 -> pair (const (Table_copy (Text name_x, Text name_y))) (const [ S.Pop; S.Pop; S.Pop ]) - else pair (const Nop) (const [ S.Nothing ]) + | _ -> pair (const Nop) (const [ S.Nothing ]) (* TODO: avoid if ... then ... else pair (const (Nop)) (const [ S.Nothing ]) https://github.com/OCamlPro/owi/pull/28#discussion_r1275222846 *) in diff --git a/test/fuzz/env.ml b/test/fuzz/env.ml index 4e4596495..b31099ca0 100644 --- a/test/fuzz/env.ml +++ b/test/fuzz/env.ml @@ -63,7 +63,7 @@ let get_blocks env = env.blocks let add_data env = let n = env.next_data in - let name = Format.sprintf "d%d" n in + let name = Fmt.str "d%d" n in env.datas <- name :: env.datas; env.next_data <- succ n; name @@ -72,57 +72,57 @@ let add_memory env = match env.memory with | None -> let n = env.next_memory in - let name = Format.sprintf "m%d" n in + let name = Fmt.str "m%d" n in env.memory <- Some name; env.next_memory <- succ n; name - | Some _ -> failwith "a memory already exists" + | Some _ -> assert false let add_type env typ = let n = env.next_type in - let name = Format.sprintf "ty%d" n in + let name = Fmt.str "ty%d" n in env.types <- (name, typ) :: env.types; env.next_type <- succ n; name let add_elem env typ = let n = env.next_elem in - let name = Format.sprintf "e%d" n in + let name = Fmt.str "e%d" n in env.elems <- (name, typ) :: env.elems; env.next_elem <- succ n; name let add_table env typ = let n = env.next_table in - let name = Format.sprintf "t%d" n in + let name = Fmt.str "t%d" n in env.tables <- (name, typ) :: env.tables; env.next_table <- succ n; name let add_global env typ = let n = env.next_global in - let name = Format.sprintf "g%d" n in + let name = Fmt.str "g%d" n in env.globals <- (name, typ) :: env.globals; env.next_global <- succ n; name let add_local env typ = let n = env.next_local in - let name = Format.sprintf "l%d" n in + let name = Fmt.str "l%d" n in env.locals <- (name, typ) :: env.locals; env.next_local <- succ n; name let add_block env typ bkind = let n = env.next_block in - let name = Format.sprintf "b%d" n in + let name = Fmt.str "b%d" n in env.blocks <- (bkind, name, typ) :: env.blocks; env.next_block <- succ n; name let add_func env typ = let n = env.next_fun in - let name = Format.sprintf "f%d" n in + let name = Fmt.str "f%d" n in env.next_fun <- succ n; env.funcs <- (name, typ) :: env.funcs; name @@ -131,7 +131,7 @@ let get_globals ntyp env ~only_mut = let is_typ global = let _, (m, v) = global in match v with - | Num_type nt -> nt = ntyp && ((not only_mut) || m = Owi.Types.Var) + | Num_type nt -> num_type_eq ntyp nt && ((not only_mut) || is_mut m) | Ref_type _ -> false in List.filter is_typ env.globals @@ -139,7 +139,7 @@ let get_globals ntyp env ~only_mut = let get_locals ntyp env = let is_typ local = let _, v = local in - match v with Num_type nt -> nt = ntyp | Ref_type _ -> false + match v with Num_type nt -> num_type_eq nt ntyp | Ref_type _ -> false in List.filter is_typ env.locals diff --git a/test/fuzz/interprets.ml b/test/fuzz/interprets.ml index 053199670..6e7f4a2c0 100644 --- a/test/fuzz/interprets.ml +++ b/test/fuzz/interprets.ml @@ -19,10 +19,12 @@ let set = let raise n = if n = -2 then raise Timeout in fun () -> Sys.set_signal Sys.sigalrm (Sys.Signal_handle raise); - ignore - @@ ( Unix.setitimer Unix.ITIMER_REAL - { Unix.it_interval = 0.; Unix.it_value = Param.max_time_execution } - : Unix.interval_timer_status ) + let _ : Unix.interval_timer_status = + ( Unix.setitimer Unix.ITIMER_REAL + { Unix.it_interval = 0.; Unix.it_value = Param.max_time_execution } + : Unix.interval_timer_status ) + in + () let timeout_call_run (run : unit -> unit Result.t) : 'a Result.t = try diff --git a/test/fuzz/type_stack.ml b/test/fuzz/type_stack.ml index 6dce710c3..d77f5e5a1 100644 --- a/test/fuzz/type_stack.ml +++ b/test/fuzz/type_stack.ml @@ -21,8 +21,8 @@ let rec is_stack_compatible st1 st2 = match (st1, st2) with | _, [] -> true | [], _ -> false - | s1 :: st1, s2 :: st2 -> s1 = s2 && is_stack_compatible st1 st2 + | s1 :: st1, s2 :: st2 -> val_type_eq s1 s2 && is_stack_compatible st1 st2 let is_stack_compatible_param stack pt = - let s = List.map (fun p -> snd p) pt in + let s = List.map snd pt in is_stack_compatible stack s