Fuzzing

src/dune

@@ -40,15 +40,7 @@
   types
   value
   wutf8)
- (private_modules
-  convert
-  float32
-  float64
-  lexer
-  menhir_parser
-  spectest
-  stack
-  wutf8)
+ (private_modules convert lexer menhir_parser spectest stack wutf8)
  (libraries integers menhirLib ocaml_intrinsics ppxlib sedlex uutf)
  (preprocess
   (pps sedlex.ppx))

src/menhir_parser.mly

@@ -660,7 +660,7 @@ let expr_aux ==
     let bt = match pt, rt with
     | [], [] -> bt
     | pt, rt ->
-      let pt = List.rev_map (fun t -> None, t) pt in
+      let pt = List.map (fun t -> None, t) pt in
       let raw = pt, rt in
       begin match bt with
       | Some (Arg.Bt_ind type_use) -> Some (bt_raw (Some type_use) raw)

src/optimize.ml

@@ -199,7 +199,7 @@ let locals_func body_expr =
   let rec aux_instr instr =
     match instr with
     | Local_get ind | Local_set ind | Local_tee ind ->
-      Hashtbl.add locals_hashtbl ind ()
+      Hashtbl.replace locals_hashtbl ind ()
     | Block (_, _, e) -> aux_expr e
     | Loop (_, _, e) -> aux_expr e
     | If_else (_, _, e1, e2) ->
@@ -263,91 +263,107 @@ let locals_func body_expr =
   aux_expr body_expr;
   locals_hashtbl
 
-let locals_used_in_func locals nb_args body_expr =
-  let loc_hashtbl = locals_func body_expr in
-  let remove_local idx body_expr =
-    let rec aux_instr instr =
-      match instr with
-      | Local_get ind when ind >= idx -> Local_get (ind - 1)
-      | Local_set ind when ind >= idx -> Local_set (ind - 1)
-      | Local_tee ind when ind >= idx -> Local_tee (ind - 1)
-      | Block (m, t, e) -> Block (m, t, aux_expr e)
-      | Loop (m, t, e) -> Loop (m, t, aux_expr e)
-      | If_else (m, t, e1, e2) -> If_else (m, t, aux_expr e1, aux_expr e2)
-      | I64_extend32_s | I32_wrap_i64 | F32_demote_f64 | F64_promote_f32
-      | Ref_is_null | Ref_as_non_null | Ref_eq | Drop | Memory_size
-      | Memory_grow | Memory_fill | Memory_copy | Nop | Unreachable | Return
-      | Array_len | I31_get_u | I31_get_s | I31_new | Extern_externalize
-      | Extern_internalize | I32_const _ | I64_const _ | F32_const _
-      | F64_const _
-      | I_unop (_, _)
-      | F_unop (_, _)
-      | I_binop (_, _)
-      | F_binop (_, _)
-      | I_testop (_, _)
-      | I_relop (_, _)
-      | F_relop (_, _)
-      | I_extend8_s _ | I_extend16_s _ | I64_extend_i32 _
-      | I_trunc_f (_, _, _)
-      | I_trunc_sat_f (_, _, _)
-      | F_convert_i (_, _, _)
-      | I_reinterpret_f (_, _)
-      | F_reinterpret_i (_, _)
-      | Ref_null _ | Ref_func _
-      | Ref_cast (_, _)
-      | Ref_test (_, _)
-      | Select _ | Local_get _ | Local_set _ | Local_tee _ | Global_get _
-      | Global_set _ | Table_get _ | Table_set _ | Table_size _ | Table_grow _
-      | Table_fill _
-      | Table_copy (_, _)
-      | Table_init (_, _)
-      | Elem_drop _
-      | I_load (_, _)
-      | F_load (_, _)
-      | I_store (_, _)
-      | F_store (_, _)
-      | I_load8 (_, _, _)
-      | I_load16 (_, _, _)
-      | I64_load32 (_, _)
-      | I_store8 (_, _)
-      | I_store16 (_, _)
-      | I64_store32 _ | Memory_init _ | Data_drop _ | Br _ | Br_if _
-      | Br_table (_, _)
-      | Br_on_cast (_, _, _)
-      | Br_on_cast_fail (_, _, _)
-      | Br_on_non_null _ | Br_on_null _ | Return_call _
-      | Return_call_indirect (_, _)
-      | Call _
-      | Call_indirect (_, _)
-      | Call_ref _ | Return_call_ref _ | Array_get _ | Array_get_u _
-      | Array_new _
-      | Array_new_data (_, _)
-      | Array_new_default _
-      | Array_new_elem (_, _)
-      | Array_new_fixed (_, _)
-      | Array_set _
-      | Struct_get (_, _)
-      | Struct_get_s (_, _)
-      | Struct_new _ | Struct_new_default _
-      | Struct_set (_, _) ->
-        instr
-    and aux_expr expr = List.map aux_instr expr in
-    aux_expr body_expr
+let remove_local map body =
+  let new_x x = match Hashtbl.find_opt map x with None -> x | Some x -> x in
+  let rec aux_instr instr =
+    match instr with
+    | Local_get ind -> Local_get (new_x ind)
+    | Local_set ind -> Local_set (new_x ind)
+    | Local_tee ind -> Local_tee (new_x ind)
+    | Block (m, t, e) -> Block (m, t, aux_expr e)
+    | Loop (m, t, e) -> Loop (m, t, aux_expr e)
+    | If_else (m, t, e1, e2) -> If_else (m, t, aux_expr e1, aux_expr e2)
+    | I64_extend32_s | I32_wrap_i64 | F32_demote_f64 | F64_promote_f32
+    | Ref_is_null | Ref_as_non_null | Ref_eq | Drop | Memory_size | Memory_grow
+    | Memory_fill | Memory_copy | Nop | Unreachable | Return | Array_len
+    | I31_get_u | I31_get_s | I31_new | Extern_externalize | Extern_internalize
+    | I32_const _ | I64_const _ | F32_const _ | F64_const _
+    | I_unop (_, _)
+    | F_unop (_, _)
+    | I_binop (_, _)
+    | F_binop (_, _)
+    | I_testop (_, _)
+    | I_relop (_, _)
+    | F_relop (_, _)
+    | I_extend8_s _ | I_extend16_s _ | I64_extend_i32 _
+    | I_trunc_f (_, _, _)
+    | I_trunc_sat_f (_, _, _)
+    | F_convert_i (_, _, _)
+    | I_reinterpret_f (_, _)
+    | F_reinterpret_i (_, _)
+    | Ref_null _ | Ref_func _
+    | Ref_cast (_, _)
+    | Ref_test (_, _)
+    | Select _ | Global_get _ | Global_set _ | Table_get _ | Table_set _
+    | Table_size _ | Table_grow _ | Table_fill _
+    | Table_copy (_, _)
+    | Table_init (_, _)
+    | Elem_drop _
+    | I_load (_, _)
+    | F_load (_, _)
+    | I_store (_, _)
+    | F_store (_, _)
+    | I_load8 (_, _, _)
+    | I_load16 (_, _, _)
+    | I64_load32 (_, _)
+    | I_store8 (_, _)
+    | I_store16 (_, _)
+    | I64_store32 _ | Memory_init _ | Data_drop _ | Br _ | Br_if _
+    | Br_table (_, _)
+    | Br_on_cast (_, _, _)
+    | Br_on_cast_fail (_, _, _)
+    | Br_on_non_null _ | Br_on_null _ | Return_call _
+    | Return_call_indirect (_, _)
+    | Call _
+    | Call_indirect (_, _)
+    | Call_ref _ | Return_call_ref _ | Array_get _ | Array_get_u _ | Array_new _
+    | Array_new_data (_, _)
+    | Array_new_default _
+    | Array_new_elem (_, _)
+    | Array_new_fixed (_, _)
+    | Array_set _
+    | Struct_get (_, _)
+    | Struct_get_s (_, _)
+    | Struct_new _ | Struct_new_default _
+    | Struct_set (_, _) ->
+      instr
+  and aux_expr expr = List.map aux_instr expr in
+  aux_expr body
+
+let remove_unused_locals locals nb_args body =
+  let unused_locals =
+    let used_locals = locals_func body in
+    let locals = List.mapi (fun i _x -> nb_args + i) locals in
+    List.filter (fun x -> not @@ Hashtbl.mem used_locals x) locals
   in
-  let loop (idx, param_l, body_expr) param : int * param list * expr =
-    match Hashtbl.find_opt loc_hashtbl (idx + nb_args) with
-    | None -> (idx + 1, param_l, remove_local (idx + nb_args) body_expr)
-    | Some _ -> (idx + 1, List.append param_l [ param ], body_expr)
+  let rename_map = Hashtbl.create 16 in
+  List.iteri
+    (fun j x ->
+      let name, _ = x in
+      let _x = Option.value name ~default:"anon" in
+      let count = ref 0 in
+      for i = 0 to j do
+        if List.mem (nb_args + i) unused_locals then incr count
+      done;
+      if not @@ List.mem (nb_args + j) unused_locals then begin
+        Hashtbl.replace rename_map (nb_args + j) (nb_args + j - !count)
+      end )
+    locals;
+  let locals = List.mapi (fun i x -> (nb_args + i, x)) locals in
+  let locals =
+    List.filter_map
+      (fun (i, x) -> if List.mem i unused_locals then None else Some x)
+      locals
   in
-  let _, l, b = List.fold_left loop (0, [], body_expr) locals in
-  (l, b)
+  let body = remove_local rename_map body in
+  (locals, body)
 
 let optimize_func func =
   let { type_f; locals; body; id } = func in
   let body = optimize_expr body in
   let pt, _ = type_f in
   let nb_args = List.length pt in
-  let locals, body = locals_used_in_func locals nb_args body in
+  let locals, body = remove_unused_locals locals nb_args body in
   { type_f; locals; body; id }
 
 let optimize_runtime_func f =

src/symbolic.ml

@@ -145,10 +145,10 @@ module Pp = struct
   let data_mode fmt = function
     | Data_passive -> ()
     | Data_active (i, e) ->
-      Format.fprintf fmt "(%a %a)" symb_indice_opt i expr e
+      Format.fprintf fmt "(memory %a) (offset %a)" symb_indice_opt i expr e
 
   let data fmt (d : data) =
-    Format.fprintf fmt {|(data %a %S)|} data_mode d.mode d.init
+    Format.fprintf fmt {|(data %a %a %S)|} id_opt d.id data_mode d.mode d.init
 
   let elem fmt (e : elem) =
     Format.fprintf fmt "@[<hov 2>(elem %a %a %a %a)@]" id_opt e.id elem_mode

src/typecheck.ml

@@ -284,9 +284,6 @@ let rec typecheck_instr (env : env) (stack : stack) (instr : instr) :
     let t = Env.global_get i env in
     Stack.pop [ typ_of_val_type t ] stack
   | If_else (_id, block_type, e1, e2) ->
-    let block_type =
-      Option.map (fun (pt, rt) -> (List.rev pt, rt)) block_type
-    in
     let* stack = Stack.pop [ i32 ] stack in
     let* stack_e1 = typecheck_expr env e1 ~is_loop:false block_type ~stack in
     let* _stack_e2 = typecheck_expr env e2 ~is_loop:false block_type ~stack in
@@ -441,7 +438,7 @@ let rec typecheck_instr (env : env) (stack : stack) (instr : instr) :
     let* stack = Stack.pop [ i32 ] stack in
     let jt = Env.block_type_get i env in
     let* stack = Stack.pop jt stack in
-    Stack.push (List.rev jt) stack
+    Stack.push jt stack
   | Br_table (branches, i) ->
     let* stack = Stack.pop [ i32 ] stack in
     let default_jt = Env.block_type_get i env in
@@ -499,7 +496,10 @@ and typecheck_expr env expr ~is_loop (block_type : func_type option)
     error_s "type mismatch block %a" Stack.pp_error (rt, stack)
   else
     match Stack.match_prefix ~prefix:pt ~stack:previous_stack with
-    | None -> Error "type mismatch (param type)"
+    | None ->
+      error_s
+        "type mismatch (param type: prefix is %a and previous_stack is %a)"
+        Stack.pp pt Stack.pp previous_stack
     | Some stack_to_push -> Stack.push rt stack_to_push
 
 let typecheck_function (modul : modul) func refs =

src/types.ml

@@ -451,7 +451,10 @@ struct
 
     let mut fmt = function Const -> () | Var -> Format.fprintf fmt "mut"
 
-    let global_type fmt (m, vt) = Format.fprintf fmt "(%a %a)" mut m val_type vt
+    let global_type fmt (m, vt) =
+      match m with
+      | Var -> Format.fprintf fmt "(mut %a)" val_type vt
+      | Const -> Format.fprintf fmt "%a" val_type vt
 
     let local fmt (id, t) =
       Format.fprintf fmt "(local %a %a)" id_opt id val_type t
@@ -528,10 +531,15 @@ struct
       | S32 -> Format.fprintf fmt "32"
       | S64 -> Format.fprintf fmt "64"
 
-    (* TODO: when offset is 0 then do not print anything, if offset is N (memargN) then print nothing ? *)
     let memarg fmt { offset; align } =
-      if offset = 0 && align = 0 then ()
-      else Format.fprintf fmt "offset=%d align=%d" offset align
+      let pow_2 n =
+        assert (n >= 0);
+        1 lsl n
+      in
+      let off fmt offset =
+        if offset > 0 then Format.fprintf fmt "offset=%d" offset
+      in
+      Format.fprintf fmt "%a align=%d" off offset (pow_2 align)
 
     let rec instr fmt = function
       | I32_const i -> Format.fprintf fmt "i32.const %ld" i