backup

src/init.ml

@@ -68,7 +68,7 @@ let module_ _registered_modules modules module_indice =
         | Imported (mi, Symbolic name) ->
           let i =
             match Hashtbl.find_opt modules.(mi).exported_funcs name with
-            | None -> failwith @@ Format.sprintf "unbound imported func %s" name
+            | None -> failwith "unknown import"
             | Some i -> i
           in
           Imported (mi, Raw i)
@@ -85,8 +85,7 @@ let module_ _registered_modules modules module_indice =
         | Imported (mi, Symbolic name) ->
           let i =
             match Hashtbl.find_opt modules.(mi).exported_memories name with
-            | None ->
-              failwith @@ Format.sprintf "unbound imported memories %s" name
+            | None -> failwith "unknown import"
             | Some i -> i
           in
           Imported (mi, Raw i)
@@ -103,8 +102,7 @@ let module_ _registered_modules modules module_indice =
         | Imported (mi, Symbolic name) ->
           let i =
             match Hashtbl.find_opt modules.(mi).exported_tables name with
-            | None ->
-              failwith @@ Format.sprintf "unbound imported tables %s" name
+            | None -> failwith "unknown import"
             | Some i -> i
           in
           Imported (mi, Raw i)
@@ -121,8 +119,7 @@ let module_ _registered_modules modules module_indice =
         | Imported (mi, Symbolic name) ->
           let i =
             match Hashtbl.find_opt modules.(mi).exported_globals name with
-            | None ->
-              failwith @@ Format.sprintf "unbound imported globals %s" name
+            | None -> failwith "unknown import"
             | Some i -> i
           in
           Imported (mi, Raw i)

src/interpret.ml

@@ -1007,17 +1007,24 @@ let exec_assert env = function
         assert (msg = expected)
     end;
     env
-  | SAssert_exhaustion (_action, _expected) -> (* TODO *) env
+  | SAssert_exhaustion (action, expected) -> (
+    try
+      ignore @@ exec_action env action;
+      Format.eprintf "@.@.@. EXPECTED : `%S` @.@.@. " expected;
+      assert false
+    with Stack_overflow ->
+      assert (expected = "call stack exhausted");
+      env )
   | SAssert_invalid (_mod, _failure) -> (* TODO *) env
   | SAssert_invalid_quote (_mod, _failure) -> (* TODO *) env
-  | SAssert_invalid_binary (_mod, _failure) -> (* TODO *) env
-  | SAssert_unlinkable (_mod, _failure) -> (* TODO *) env
 
 let exec_register env name i =
   Hashtbl.replace env.registered_modules name i;
   env
 
 let exec_module env module_indice =
+  Debug.debug Format.err_formatter "EXEC START@\n";
+  let m = env.modules.(module_indice) in
   try
     Init.module_ env.registered_modules env.modules module_indice;
     Option.iter
@@ -1027,14 +1034,32 @@ let exec_module env module_indice =
         in
         let _res = exec_func env module_indice func [] in
         () )
-      env.modules.(module_indice).start;
+      m.start;
+    (* TODO: re-enable later to avoid missing some errors
+       if Option.is_some m.should_trap || Option.is_some m.should_not_link then
+         assert false;
+    *)
     env
-  with Trap msg -> (
-    match env.modules.(module_indice).should_trap with
+  with
+  | Trap msg -> (
+    match m.should_trap with
     | None -> raise @@ Trap msg
     | Some expected ->
       assert (msg = expected);
       env )
+  | Failure msg as exn -> (
+    match m.should_not_link with
+    | None -> raise exn
+    | Some expected ->
+      (* TODO: I'm not convinced it's the best behaviour, maybe open an issue to discuss it ? *)
+      if msg = "unknown import" && expected = "incompatible import type" then
+        env
+      else if msg <> expected then begin
+        Format.eprintf "got:      `%s`@\n" msg;
+        Format.eprintf "expected: `%s`@\n" expected;
+        assert false
+      end
+      else env )
 
 let exec_cmd env = function
   | Module_indice i -> exec_module env i

src/menhir_parser.mly

@@ -6,17 +6,23 @@
 
 let u32 s =
   try Unsigned.UInt32.to_int (Unsigned.UInt32.of_string s)
-  with Failure _ -> failwith (Format.sprintf "error u32 constant `%s` out of range" s)
+  with Failure _msg -> failwith "i32 constant"
 
 let i32 s =
   try Int32.of_string s
-  with Failure _msg -> failwith "i32 constant out of range"
+  with Failure _msg -> failwith "constant out of range"
 
-let i64 s = Int64.of_string s
+let i64 s =
+  try Int64.of_string s
+  with Failure _msg -> failwith "constant out of range"
 
-let f64 s = Float64.of_string s
+let f64 s =
+  try Float64.of_string s
+  with Failure _msg -> failwith "constant out of range"
 
-let f32 s = Float32.of_string s
+let f32 s =
+  try Float32.of_string s
+  with Failure _msg -> failwith "constant out of range"
 
 open Types
 

src/simplify.ml

@@ -30,6 +30,7 @@ type module_ =
   ; exported_tables : (string, int) Hashtbl.t
   ; start : int option
   ; should_trap : string option
+  ; should_not_link : string option
   }
 
 type action =
@@ -42,8 +43,6 @@ type assert_ =
   | SAssert_exhaustion of action * string
   | SAssert_invalid of Types.module_ * string
   | SAssert_invalid_quote of string list * string
-  | SAssert_invalid_binary of string list * string
-  | SAssert_unlinkable of Types.module_ * string
 
 type cmd =
   | Module_indice of int
@@ -266,25 +265,13 @@ let mk_module registered_modules m =
           let desc =
             match desc with
             | Export_func indice ->
-              Export_func
-                (Option.map
-                   (fun indice -> map_symb_raw find_func indice)
-                   indice )
+              Export_func (Option.map (map_symb_raw find_func) indice)
             | Export_table indice ->
-              Export_table
-                (Option.map
-                   (fun indice -> map_symb_raw find_table indice)
-                   indice )
+              Export_table (Option.map (map_symb_raw find_table) indice)
             | Export_global indice ->
-              Export_global
-                (Option.map
-                   (fun indice -> map_symb_raw find_global indice)
-                   indice )
+              Export_global (Option.map (map_symb_raw find_global) indice)
             | Export_mem indice ->
-              Export_mem
-                (Option.map
-                   (fun indice -> map_symb_raw find_memory indice)
-                   indice )
+              Export_mem (Option.map (map_symb_raw find_memory) indice)
           in
           let f = MExport { name; desc } in
           f :: fields
@@ -480,6 +467,7 @@ let mk_module registered_modules m =
   ; exported_memories
   ; exported_tables
   ; should_trap = None
+  ; should_not_link = None
   }
 
 let assert_ curr_module last_module seen_modules =
@@ -505,9 +493,12 @@ let assert_ curr_module last_module seen_modules =
     (curr_module, SAssert_invalid (module_, failure))
   | Assert_invalid_quote (m, failure) ->
     (curr_module, SAssert_invalid_quote (m, failure))
-  | Assert_invalid_binary (m, failure) ->
-    (curr_module, SAssert_invalid_binary (m, failure))
-  | Assert_unlinkable (m, s) -> (curr_module, SAssert_unlinkable (m, s))
+  | Assert_invalid_binary (_m, _failure) ->
+    (* This should have been checked before and removed ! *)
+    assert false
+  | Assert_unlinkable (_m, _s) ->
+    (* This should have been handled before and turned into a module with `should_not_link` set ! *)
+    assert false
 
 let rec script scr =
   let scr =
@@ -561,6 +552,31 @@ let rec script scr =
               ; body = []
               ; id = Some "print_f64_f64"
               }
+          ; MFunc
+              { type_f = Bt_raw (None, ([], []))
+              ; locals = []
+              ; body = []
+              ; id = Some "func"
+              }
+          ; MFunc
+              { type_f = Bt_raw (None, ([ (None, Num_type I32) ], []))
+              ; locals = []
+              ; body = []
+              ; id = Some "func-i32"
+              }
+          ; MFunc
+              { type_f = Bt_raw (None, ([], [ Num_type I32 ]))
+              ; locals = []
+              ; body = []
+              ; id = Some "func->i32"
+              }
+          ; MFunc
+              { type_f =
+                  Bt_raw (None, ([ (None, Num_type I32) ], [ Num_type I32 ]))
+              ; locals = []
+              ; body = []
+              ; id = Some "func-i32->i32"
+              }
           ; MTable (Some "table", ({ min = 10; max = Some 20 }, Func_ref))
           ; MGlobal
               { type_ = (Var, Num_type I32)
@@ -582,6 +598,20 @@ let rec script scr =
               ; init = [ F64_const Float64.zero ]
               ; id = Some "global_f64"
               }
+          ; MExport
+              { name = "func"; desc = Export_func (Some (Symbolic "func")) }
+          ; MExport
+              { name = "func-i32"
+              ; desc = Export_func (Some (Symbolic "func-i32"))
+              }
+          ; MExport
+              { name = "func->i32"
+              ; desc = Export_func (Some (Symbolic "func->i32"))
+              }
+          ; MExport
+              { name = "func-i32->i32"
+              ; desc = Export_func (Some (Symbolic "func-i32->i32"))
+              }
           ; MExport
               { name = "memory"; desc = Export_mem (Some (Symbolic "memory")) }
           ; MExport
@@ -641,16 +671,19 @@ let rec script scr =
       (fun (curr_module, modules, scr) -> function
         | Module m ->
           let curr_module = curr_module + 1 in
-          Debug.debug Format.err_formatter "simplifying module %d@." curr_module;
+          Debug.debug Format.err_formatter "simplifying module %d... "
+            curr_module;
           Option.iter
             (fun id -> Hashtbl.replace seen_modules id curr_module)
             m.id;
           let cmd = Module_indice curr_module in
           let modules = mk_module registered_modules m :: modules in
+          Debug.debug Format.err_formatter "done !@\n";
           (curr_module, modules, cmd :: scr)
         | Assert (Assert_trap_module (m, msg)) ->
           let curr_module = curr_module + 1 in
-          Debug.debug Format.err_formatter "simplifying module %d@." curr_module;
+          Debug.debug Format.err_formatter "simplifying assert module %d@."
+            curr_module;
           Option.iter
             (fun id -> Hashtbl.replace seen_modules id curr_module)
             m.id;
@@ -659,12 +692,19 @@ let rec script scr =
           let module_ = { module_ with should_trap = Some msg } in
           (curr_module, module_ :: modules, cmd :: scr)
         | Assert (Assert_malformed_binary _) ->
+          Debug.debug Format.err_formatter
+            "simplifying assert malformed binary... ";
+          Debug.debug Format.err_formatter "done !";
           (* TODO: check this when binary format is supported *)
           (curr_module, modules, scr)
         | Assert (Assert_malformed_quote (m, msg)) ->
+          Debug.debug Format.err_formatter
+            "simplifying assert malformed quote... ";
           ( try
+              Debug.debug Format.err_formatter "TRY@\n";
               match Parse.from_string (String.concat "\n" m) with
               | Ok scr -> (
+                Debug.debug Format.err_formatter "OK@\n";
                 try
                   Check.script scr;
                   let _script, _modules = script scr in
@@ -679,6 +719,7 @@ let rec script scr =
                     assert false
                   end )
               | Error e ->
+                Debug.debug Format.err_formatter "ERROR@\n";
                 let ok =
                   if msg = "unknown operator" then
                     (* TODO: open an issue on wasm to avoid having to do this... *)
@@ -691,13 +732,107 @@ let rec script scr =
                   assert false
                 end
             with Failure e as exn ->
+              Debug.debug Format.err_formatter "EXN@\n";
               let ok = e = msg in
               if not ok then begin
                 Format.eprintf "expected: `%s`@." msg;
                 Format.eprintf "got     : `%s`@." e;
                 raise exn
               end );
+          Debug.debug Format.err_formatter "done !";
           (curr_module, modules, scr)
+        | Assert (Assert_invalid_binary _) ->
+          (* TODO: check this when binary format is supported *)
+          (curr_module, modules, scr)
+        | Assert (Assert_invalid (m, msg)) ->
+          (* TODO: re-enable all ignored errors  *)
+          let ignore_tmp =
+            [ "type mismatch"
+            ; "unknown local"
+            ; "unknown global"
+            ; "unknown function"
+            ; "unknown label"
+            ; "unknown elem segment 0"
+            ; "unknown elem segment 4"
+            ; "unknown table 0"
+            ; "unknown table"
+            ; "size minimum must not be greater than maximum"
+            ; "start function"
+            ; "invalid result arity"
+            ; "unknown data segment"
+            ; "unknown function 7"
+            ; "unknown memory 0"
+            ; "undeclared function reference"
+            ; "unknown data segment 1"
+            ; "unknown type"
+            ; "multiple memories"
+            ; "unknown memory"
+            ; "memory size must be at most 65536 pages (4GiB)"
+            ; "global is immutable"
+            ; "constant expression required"
+            ; "duplicate export name"
+            ; "unknown global 0"
+            ; "unknown global 1"
+            ]
+          in
+          if not @@ List.mem msg ignore_tmp then (
+            Format.eprintf "MODULE = `%a`@\n@\nmsg = `%s`@\n@\n" Pp.module_ m
+              msg;
+            assert false );
+          (curr_module, modules, scr)
+        | Assert (Assert_invalid_quote (m, msg)) ->
+          (* TODO: re-enable all ignored errors  *)
+          let ignore_tmp =
+            [ "type mismatch"
+            ; "unknown local"
+            ; "unknown global"
+            ; "unknown function"
+            ; "unknown label"
+            ; "unknown elem segment 0"
+            ; "unknown elem segment 4"
+            ; "unknown table 0"
+            ; "unknown table"
+            ; "size minimum must not be greater than maximum"
+            ; "start function"
+            ; "invalid result arity"
+            ; "unknown data segment"
+            ; "unknown function 7"
+            ; "unknown memory 0"
+            ; "undeclared function reference"
+            ; "unknown data segment 1"
+            ; "unknown type"
+            ; "multiple memories"
+            ; "unknown memory"
+            ; "memory size must be at most 65536 pages (4GiB)"
+            ; "global is immutable"
+            ; "constant expression required"
+            ; "duplicate export name"
+            ; "unknown global 0"
+            ; "unknown global 1"
+            ]
+          in
+          let m =
+            match Parse.from_string (String.concat "\n" m) with
+            | Error _e -> assert false
+            | Ok [ Module m ] -> m
+            | Ok _ -> assert false
+          in
+          if not @@ List.mem msg ignore_tmp then (
+            Format.eprintf "MODULE = `%a`@\n@\nmsg = `%s`@\n@\n" Pp.module_ m
+              msg;
+            assert false );
+          (curr_module, modules, scr)
+        | Assert (Assert_unlinkable (m, msg)) ->
+          let curr_module = curr_module + 1 in
+          Debug.debug Format.err_formatter
+            "simplifying (unlinkable) module %d@." curr_module;
+          Option.iter
+            (fun id -> Hashtbl.replace seen_modules id curr_module)
+            m.id;
+          let cmd = Module_indice curr_module in
+          let module_ = mk_module registered_modules m in
+          let module_ = { module_ with should_not_link = Some msg } in
+          (curr_module, module_ :: modules, cmd :: scr)
         | Assert a ->
           let curr_module, cmd =
             assert_ curr_module (Some curr_module) seen_modules a
@@ -718,4 +853,6 @@ let rec script scr =
   let script = List.rev scr in
   let modules = List.rev modules |> Array.of_list in
 
+  Debug.debug Format.err_formatter "END OF SIMPLIFY@\n";
+
   (script, modules)

test/main.ml

@@ -2,6 +2,10 @@ let count_total = ref 0
 
 let count_total_failed = ref 0
 
+let pp_red fmt s = Format.fprintf fmt "\x1b[31m%s\x1b[0m" s
+
+let pp_green fmt s = Format.fprintf fmt "\x1b[32m%s\x1b[0m" s
+
 let test_file f =
   Format.printf "testing file     : `%a`... " Fpath.pp f;
   match Woi.Parse.from_file (Fpath.to_string f) with
@@ -10,7 +14,7 @@ let test_file f =
       Woi.Check.script script;
       let script, modules = Woi.Simplify.script script in
       Woi.Interpret.exec script modules;
-      Format.printf "OK !@.";
+      Format.printf "%a !@." pp_green "OK";
       Ok ()
     with
     | Assert_failure (s, _, _)
@@ -18,7 +22,7 @@ let test_file f =
     | Failure s
     | Invalid_argument s
     ->
-      Format.printf "FAILED: `%s` !@."
+      Format.printf "%a: `%s` !@." pp_red "FAILED"
         (String.concat " " @@ String.split_on_char '\n' s);
       Error s
   end