[interpreter] Fix registry to be per-thread

interpreter/Makefile

@@ -1,6 +1,6 @@
 # This Makefile uses dune but does not rely on ocamlfind or the Opam
 # package manager to build. However, Opam package management is available
-# optionally through the check/install/uninstall targets.
+# optionally through the install target.
 #
 # The $(JSLIB).js target requires Js_of_ocaml (using ocamlfind).
 #
@@ -9,80 +9,92 @@
 
 # Configuration
 
-NAME = wasm
-OPT =		$(NAME).exe
-ZIP =		$(NAME).zip
+NAME =		wasm
+LIB =		$(NAME)
 JSLIB =		wast.js
+ZIP =		$(NAME).zip
 
-BUILDDIR = _build/default
+BUILDDIR =	_build/default
 
 JS =		# set to JS shell command to run JS tests, empty to skip
 
 
 # Main targets
 
-.PHONY:		default opt jslib all zip smallint
+.PHONY:		default all ci jslib zip
+
+default:	$(NAME)
+all:		default partest
+ci:		all jslib zip
 
-default:	$(OPT)
 jslib:		$(JSLIB)
-all:		$(OPT) test
 zip:		$(ZIP)
-smallint:	smallint.exe
-ci:		all jslib
 
-# Building executable
-.PHONY:		$(NAME).exe
-$(NAME).exe:
-	rm -f $(NAME)
-	dune build $@
-	cp $(BUILDDIR)/$(OPT) $(NAME)
 
-.PHONY:		smallint.exe
-smallint.exe:
-	dune build $@
+# Building
+
+.PHONY:                $(NAME) $(JSLIB)
+
+$(NAME):
+	rm -f $@
+	dune build [email protected]
+	ln $(BUILDDIR)/[email protected] $@
+
+$(JSLIB):
+	rm -f $@
+	dune build $(@:%.js=%.bc.js)
+	ln $(BUILDDIR)/$(@:%.js=%.bc.js) $@
+
+
+# Unit tests
+
+UNITTESTDIR =	unittest
+UNITTESTFILES =	$(shell cd $(UNITTESTDIR) > /dev/null; ls *.ml)
+UNITTESTS =	$(UNITTESTFILES:%.ml=%)
 
-# Building JavaScript library
+.PHONY: unittest
 
-$(JSLIB):	$(BUILDDIR)/$(JSLIB)
-	cp $< $@
+unittest: $(UNITTESTS:%=unittest/%)
 
-$(BUILDDIR)/$(JSLIB):
-	dune build $(JSLIB)
+unittest/%:
+	dune build $(@F).exe
+	dune exec ./$(@F).exe
 
-# Executing test suite
+
+# Test suite
 
 TESTDIR =	../test/core
-# Skip _output directory, since that's a tmp directory, and list all other wast files.
-TESTFILES =	$(shell cd $(TESTDIR); ls *.wast; ls [a-z]*/*.wast)
+TESTFILES =	$(shell cd $(TESTDIR) > /dev/null; ls *.wast; ls [a-z]*/*.wast)
 TESTS =		$(TESTFILES:%.wast=%)
 
-.PHONY:		test partest dune-test
+.PHONY: test partest quiettest
+
+test: $(NAME) unittest
+	$(TESTDIR)/run.py --wasm `pwd`/$(NAME) $(if $(JS),--js '$(JS)',)
 
-test:		$(OPT) smallint
-		$(TESTDIR)/run.py --wasm `pwd`/$(BUILDDIR)/$(OPT) $(if $(JS),--js '$(JS)',)
-		dune exec ./smallint.exe
+test/%: $(NAME)
+	$(TESTDIR)/run.py --wasm `pwd`/$(NAME) $(if $(JS),--js '$(JS)',) $(TESTDIR)/$*.wast
 
-test/%:		$(OPT)
-		$(TESTDIR)/run.py --wasm `pwd`/$(BUILDDIR)/$(OPT) $(if $(JS),--js '$(JS)',) $(TESTDIR)/$*.wast
+run/%: $(NAME)
+	./$(NAME) $(TESTDIR)/$*.wast
 
-run/%:		$(OPT)
-		./$(OPT) $(TESTDIR)/$*.wast
+partest: $(NAME) unittest
+	make -j10 quiettest
 
-partest:	$(TESTS:%=quiettest/%)
-		@echo All tests passed.
+quiettest: $(TESTS:%=quiettest/%)
+	@echo All tests passed.
 
-quiettest/%:	$(OPT)
-		@ ( \
-		  $(TESTDIR)/run.py 2>$(@F).out --wasm `pwd`/$(BUILDDIR)/$(OPT) $(if $(JS),--js '$(JS)',) $(TESTDIR)/$*.wast && \
-		  rm $(@F).out \
-		) || \
-		cat $(@F).out || rm $(@F).out || exit 1
+quiettest/%: $(NAME)
+	@ ( \
+	  $(TESTDIR)/run.py 2>$(@F).out --wasm `pwd`/$(NAME) $(if $(JS),--js '$(JS)',) $(TESTDIR)/$*.wast && \
+	  rm $(@F).out \
+	) || \
+	(cat $(@F).out && rm $(@F).out && exit 1)
 
-smallinttest:	smallint
-	dune exec ./smallint.exe
 
-dunetest:
-	dune test
+# Packaging
+
+.PHONY: install
 
 install:
 	dune build -p $(NAME) @install
@@ -101,15 +113,16 @@ opam-release/%:
 	rm opam-$*.zip
 	@echo Created file ./opam, submit to github opam-repository/packages/wasm/wasm.$*/opam
 
-# Miscellaneous targets
-
-.PHONY:		clean
-
 $(ZIP):
 	git archive --format=zip --prefix=$(NAME)/ -o $@ HEAD
 
+
+# Cleanup
+
+.PHONY: clean distclean
+
 clean:
 	dune clean
 
 distclean: clean
-	rm -f $(NAME) $(JSLIB)
+	rm -f $(NAME) $(JSLIB) $(ZIP)

interpreter/binary/encode.ml

@@ -59,7 +59,6 @@ struct
     if -64L <= i && i < 64L then byte b
     else (byte (b lor 0x80); s64 (Int64.shift_right i 7))
 
-  let u1 i = u64 Int64.(logand (of_int i) 1L)
   let u32 i = u64 Int64.(logand (of_int32 i) 0xffffffffL)
   let s7 i = s64 (Int64.of_int i)
   let s32 i = s64 (Int64.of_int32 i)

interpreter/host/env.ml

@@ -41,6 +41,6 @@ let exit vs =
 
 let lookup name t =
   match Utf8.encode name, t with
-  | "abort", ExternFuncType t -> ExternFunc (Func.alloc_host t abort)
-  | "exit", ExternFuncType t -> ExternFunc (Func.alloc_host t exit)
-  | _ -> raise Not_found
+  | "abort", ExternFuncType t -> Some (ExternFunc (Func.alloc_host t abort))
+  | "exit", ExternFuncType t -> Some (ExternFunc (Func.alloc_host t exit))
+  | _ -> None

interpreter/host/spectest.ml

@@ -37,7 +37,7 @@ let print (FuncType (_, out)) vs =
   List.map default_value out
 
 
-let lookup name t =
+let lookup' name t =
   match Utf8.encode name, t with
   | "print", _ -> ExternFunc (func print (FuncType ([], [])))
   | "print_i32", _ -> ExternFunc (func print (FuncType ([NumType I32Type], [])))
@@ -55,3 +55,6 @@ let lookup name t =
   | "table", _ -> ExternTable table
   | "memory", _ -> ExternMemory memory
   | _ -> raise Not_found
+
+let lookup name t =
+  try Some (lookup' name t) with Not_found -> None

interpreter/main/main.ml

@@ -2,8 +2,8 @@ let name = "wasm"
 let version = "2.0.1"
 
 let configure () =
-  Import.register (Utf8.decode "spectest") Spectest.lookup;
-  Import.register (Utf8.decode "env") Env.lookup
+  Import.register_global (Utf8.decode "spectest") Spectest.lookup;
+  Import.register_global (Utf8.decode "env") Env.lookup
 
 let banner () =
   print_endline (name ^ " " ^ version ^ " reference interpreter")

interpreter/script/import.ml

@@ -1,20 +1,36 @@
 open Source
+open Types
 open Ast
 
 module Unknown = Error.Make ()
 exception Unknown = Unknown.Error  (* indicates unknown import name *)
 
 module Registry = Map.Make(struct type t = Ast.name let compare = compare end)
-let registry = ref Registry.empty
 
-let register name lookup = registry := Registry.add name lookup !registry
+type registry = (name -> extern_type -> Instance.extern option) Registry.t ref
 
-let lookup (m : module_) (im : import) : Instance.extern =
+type lookup_export = name -> extern_type -> Instance.extern option
+
+
+let global : registry = ref Registry.empty
+let registry () : registry = ref !global
+
+let register r name lookup = r := Registry.add name lookup !r
+let register_global name lookup = register global name lookup
+
+let lookup r module_name item_name et : Instance.extern option =
+  match Registry.find_opt module_name !r with
+  | Some f -> f item_name et
+  | None -> None
+
+let lookup_import r (m : module_) (im : import) : Instance.extern =
   let {module_name; item_name; idesc} = im.it in
-  let t = import_type m im in
-  try Registry.find module_name !registry item_name t with Not_found ->
-    Unknown.error im.at
-      ("unknown import \"" ^ string_of_name module_name ^
-        "\".\"" ^ string_of_name item_name ^ "\"")
+  let et = import_type m im in
+    match lookup r module_name item_name et with
+    | Some ext -> ext
+    | None ->
+      Unknown.error im.at
+        ("unknown import \"" ^ string_of_name module_name ^
+          "\".\"" ^ string_of_name item_name ^ "\"")
 
-let link m = List.map (lookup m) m.it.imports
+let link r m = List.map (lookup_import r m) m.it.imports

interpreter/script/import.mli

@@ -1,8 +1,17 @@
+open Types
+open Ast
+
+type registry
+
 exception Unknown of Source.region * string
 
-val link : Ast.module_ -> Instance.extern list (* raises Unknown *)
+val registry : unit -> registry
+
+val lookup : registry -> name -> name -> extern_type -> Instance.extern option
+val link : registry -> module_ -> Instance.extern list (* raises Unknown *)
+
+
+type lookup_export = name -> extern_type -> Instance.extern option
 
-val register :
-  Ast.name ->
-  (Ast.name -> Types.extern_type -> Instance.extern (* raises Not_found *)) ->
-  unit
+val register : registry -> name -> lookup_export -> unit
+val register_global : name -> lookup_export -> unit

interpreter/script/js.ml

@@ -179,6 +179,15 @@ function assert_return(action, ...expected) {
         };
         return;
       default:
+        if (Array.isArray(expected)) {
+          for (let j = 0; j < expected[i].length; ++j) {
+            try {
+              match_result(actual[i], expected[i][j]);
+              return;
+            } catch (e) {}
+          }
+          throw new Error("Wasm return value in " + expected[i] + " expected, got " + actual[i]);
+        }
         if (!Object.is(actual[i], expected[i])) {
           throw new Error("Wasm return value " + expected[i] + " expected, got " + actual[i]);
         };
@@ -279,7 +288,7 @@ let run ts at =
   [], []
 
 let assert_return ress ts at =
-  let test res =
+  let rec test res =
     let nan_bitmask_of = function
       | 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 *)
@@ -375,6 +384,17 @@ let assert_return ress ts at =
       [ Call (is_ref_idx @@ at) @@ at;
         Test (Values.I32 I32Op.Eqz) @@ at;
         BrIf (0l @@ at) @@ at ]
+    | EitherResult ress ->
+      [ Block (ValBlockType None,
+          List.map (fun res ->
+            Block (ValBlockType None,
+              test res @
+              [Br (1l @@ res.at) @@ res.at]
+            ) @@ res.at
+          ) ress @
+          [Br (1l @@ at) @@ at]
+        ) @@ at
+      ]
   in [], List.flatten (List.rev_map test ress)
 
 let wrap item_name wrap_action wrap_assertion at =
@@ -515,11 +535,13 @@ let of_ref_pat = function
   | RefPat r -> of_ref r.it
   | RefTypePat t -> "\"ref." ^ string_of_refed_type t ^ "\""
 
-let of_result res =
+let rec of_result res =
   match res.it with
   | NumResult np -> of_num_pat np
   | VecResult vp -> of_vec_pat vp
   | RefResult rp -> of_ref_pat rp
+  | EitherResult ress ->
+    "[" ^ String.concat ", " (List.map of_result ress) ^ "]"
 
 let rec of_definition def =
   match def.it with
@@ -606,8 +628,8 @@ let of_command mods cmd =
     of_assertion' mods act "run" [] None ^ "\n"
   | Assertion ass ->
     of_assertion mods ass ^ "\n"
-  | Thread _ -> failwith "JS translation of Thread is NYI"
-  | Wait _ -> failwith "JS translation of Wait is NYI"
+  | Thread _ -> "" (* TODO: failwith "JS translation of Thread is NYI" *)
+  | Wait _ -> "" (* TODO: failwith "JS translation of Wait is NYI" *)
   | Meta _ -> assert false
 
 let of_script scr =