[interpreter] Handle custom sections and annotations

interpreter/Makefile

@@ -17,7 +17,7 @@ ZIP =		$(NAME).zip
 JSLIB =		wast
 WINMAKE =	winmake.bat
 
-DIRS =		util syntax binary text valid runtime exec script host main tests
+DIRS =		util syntax binary text valid runtime exec custom script host main tests
 LIBS =		
 FLAGS = 	-lexflags -ml -cflags '-w +a-4-27-42-44-45-70 -warn-error +a-3'
 OCBA =		ocamlbuild $(FLAGS) $(DIRS:%=-I %)
@@ -37,10 +37,10 @@ unopt:		$(UNOPT)
 libopt:		_build/$(LIB).cmx _build/$(LIB).cmxa
 libunopt:	_build/$(LIB).cmo _build/$(LIB).cma
 jslib:		$(JSLIB).js
-all:		unopt opt libunopt libopt test
+all:		unopt opt libunopt libopt alltest
+alltest:	unittest test customtest
 land:		$(WINMAKE) all
 zip: 		$(ZIP)
-smallint:	smallint.native
 ci:			land wast.js dunebuild
 
 dunebuild:
@@ -135,21 +135,18 @@ $(WINMAKE):	clean
 		>>$@
 
 
-# Executing test suite
+# Executing core 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)
 TESTS =		$(TESTFILES:%.wast=%)
 
-.PHONY:		test debugtest partest dune-test
+.PHONY:		test debugtest partest dune-test quiettest
 
-test:		$(OPT) smallint
+test:		$(OPT)
 		$(TESTDIR)/run.py --wasm `pwd`/$(OPT) $(if $(JS),--js '$(JS)',)
-		./smallint.native
-debugtest:	$(UNOPT) smallint
+debugtest:	$(UNOPT)
 		$(TESTDIR)/run.py --wasm `pwd`/$(UNOPT) $(if $(JS),--js '$(JS)',)
-		./smallint.native
 
 test/%:		$(OPT)
 		$(TESTDIR)/run.py --wasm `pwd`/$(OPT) $(if $(JS),--js '$(JS)',) $(TESTDIR)/$*.wast
@@ -171,9 +168,52 @@ quiettest/%:	$(OPT)
 		) || \
 		cat $(@F).out || rm $(@F).out || exit 1
 
-smallinttest:	smallint
+
+# Executing custom test suite
+
+CUSTOMTESTDIR =	../test/custom
+CUSTOMTESTDIRS =	$(shell cd $(CUSTOMTESTDIR); ls -d [a-z]*)
+CUSTOMTESTFILES =	$(shell cd $(CUSTOMTESTDIR); ls [a-z]*/*.wast)
+CUSTOMTESTS =		$(CUSTOMTESTFILES:%.wast=%)
+CUSTOMOPTS = -c custom $(CUSTOMTESTDIRS:%=-c %)
+
+.PHONY:		customtest customdebugtest custompartest customquiettest
+
+customtest:		$(OPT)
+		$(TESTDIR)/run.py --wasm `pwd`/$(OPT) --opts '$(CUSTOMOPTS)' $(if $(JS),--js '$(JS)',) $(CUSTOMTESTFILES:%=$(CUSTOMTESTDIR)/%)
+customdebugtest:	$(UNOPT)
+		$(TESTDIR)/run.py --wasm `pwd`/$(UNOPT) --opts '$(CUSTOMOPTS)' $(if $(JS),--js '$(JS)',) $(CUSTOMTESTFILES:%=$(CUSTOMTESTDIR)/%)
+
+customtest/%:		$(OPT)
+		$(TESTDIR)/run.py --wasm `pwd`/$(OPT) --opts '$(CUSTOMOPTS) ' $(if $(JS),--js '$(JS)',) $(CUSTOMTESTDIR)/$*.wast
+customdebugtest/%:	$(UNOPT)
+		$(TESTDIR)/run.py --wasm `pwd`/$(UNOPT) --opts '$(CUSTOMOPTS)' $(if $(JS),--js '$(JS)',) $(CUSTOMTESTDIR)/$*.wast
+
+customrun/%:		$(OPT)
+		./$(OPT) $(CUSTOMOPTS) $(CUSTOMTESTDIR)/$*.wast
+customdebug/%:	$(UNOPT)
+		./$(UNOPT) $(CUSTOMOPTS) $(CUSTOMTESTDIR)/$*.wast
+
+custompartest: 	$(CUSTOMTESTS:%=customquiettest/%)
+		@echo All custom tests passed.
+
+customquiettest/%:	$(OPT)
+		@ ( \
+		  $(TESTDIR)/run.py 2>$(@F).out --wasm `pwd`/$(OPT) --opts '$(CUSTOMOPTS)' $(if $(JS),--js '$(JS)',) $(TESTDIR)/$*.wast && \
+		  rm $(@F).out \
+		) || \
+		cat $(@F).out || rm $(@F).out || exit 1
+
+
+# Executing unit tests
+
+.PHONY: unittest
+
+unittest:	smallint
 		@./smallint.native
 
+smallint:	smallint.native
+
 dunetest:
 	dune test
 

interpreter/binary/decode.ml

@@ -798,19 +798,19 @@ let id s =
   let bo = peek s in
   Lib.Option.map
     (function
-    | 0 -> `CustomSection
-    | 1 -> `TypeSection
-    | 2 -> `ImportSection
-    | 3 -> `FuncSection
-    | 4 -> `TableSection
-    | 5 -> `MemorySection
-    | 6 -> `GlobalSection
-    | 7 -> `ExportSection
-    | 8 -> `StartSection
-    | 9 -> `ElemSection
-    | 10 -> `CodeSection
-    | 11 -> `DataSection
-    | 12 -> `DataCountSection
+    | 0 -> Custom.Custom
+    | 1 -> Custom.Type
+    | 2 -> Custom.Import
+    | 3 -> Custom.Func
+    | 4 -> Custom.Table
+    | 5 -> Custom.Memory
+    | 6 -> Custom.Global
+    | 7 -> Custom.Export
+    | 8 -> Custom.Start
+    | 9 -> Custom.Elem
+    | 10 -> Custom.Code
+    | 11 -> Custom.Data
+    | 12 -> Custom.DataCount
     | _ -> error s (pos s) "malformed section id"
     ) bo
 
@@ -828,7 +828,7 @@ let section tag f default s =
 let type_ s = at func_type s
 
 let type_section s =
-  section `TypeSection (vec type_) [] s
+  section Custom.Type (vec type_) [] s
 
 
 (* Import section *)
@@ -848,13 +848,13 @@ let import s =
   {module_name; item_name; idesc}
 
 let import_section s =
-  section `ImportSection (vec (at import)) [] s
+  section Custom.Import (vec (at import)) [] s
 
 
 (* Function section *)
 
 let func_section s =
-  section `FuncSection (vec (at var)) [] s
+  section Custom.Func (vec (at var)) [] s
 
 
 (* Table section *)
@@ -864,7 +864,7 @@ let table s =
   {ttype}
 
 let table_section s =
-  section `TableSection (vec (at table)) [] s
+  section Custom.Table (vec (at table)) [] s
 
 
 (* Memory section *)
@@ -874,7 +874,7 @@ let memory s =
   {mtype}
 
 let memory_section s =
-  section `MemorySection (vec (at memory)) [] s
+  section Custom.Memory (vec (at memory)) [] s
 
 
 (* Global section *)
@@ -885,7 +885,7 @@ let global s =
   {gtype; ginit}
 
 let global_section s =
-  section `GlobalSection (vec (at global)) [] s
+  section Custom.Global (vec (at global)) [] s
 
 
 (* Export section *)
@@ -904,7 +904,7 @@ let export s =
   {name; edesc}
 
 let export_section s =
-  section `ExportSection (vec (at export)) [] s
+  section Custom.Export (vec (at export)) [] s
 
 
 (* Start section *)
@@ -914,7 +914,7 @@ let start s =
   {sfunc}
 
 let start_section s =
-  section `StartSection (opt (at start) true) None s
+  section Custom.Start (opt (at start) true) None s
 
 
 (* Code section *)
@@ -939,7 +939,7 @@ let code _ s =
   {locals; body; ftype = -1l @@ no_region}
 
 let code_section s =
-  section `CodeSection (vec (at (sized code))) [] s
+  section Custom.Code (vec (at (sized code))) [] s
 
 
 (* Element section *)
@@ -1012,7 +1012,7 @@ let elem s =
   | _ -> error s (pos s - 1) "malformed elements segment kind"
 
 let elem_section s =
-  section `ElemSection (vec (at elem)) [] s
+  section Custom.Elem (vec (at elem)) [] s
 
 
 (* Data section *)
@@ -1034,7 +1034,7 @@ let data s =
   | _ -> error s (pos s - 1) "malformed data segment kind"
 
 let data_section s =
-  section `DataSection (vec (at data)) [] s
+  section Custom.Data (vec (at data)) [] s
 
 
 (* DataCount section *)
@@ -1043,62 +1043,64 @@ let data_count s =
   Some (u32 s)
 
 let data_count_section s =
-  section `DataCountSection data_count None s
+  section Custom.DataCount data_count None s
 
 
 (* Custom section *)
 
-let custom size s =
+let custom place size s =
   let start = pos s in
-  let id = name s in
-  let bs = get_string (size - (pos s - start)) s in
-  Some (id, bs)
+  let name = name s in
+  let content = get_string (size - (pos s - start)) s in
+  Custom.{name; content; place}
 
-let custom_section s =
-  section_with_size `CustomSection custom None s
+let some_custom place size s =
+  Some (at (custom place size) s)
 
-let non_custom_section s =
-  match id s with
-  | None | Some `CustomSection -> None
-  | _ -> skip 1 s; sized skip s; Some ()
+let custom_section place s =
+  section_with_size Custom.Custom (some_custom place) None s
 
 
 (* Modules *)
 
-let rec iterate f s = if f s <> None then iterate f s
+let rec iterate f s =
+  match f s with
+  | None -> []
+  | Some x -> x :: iterate f s
 
 let magic = 0x6d736100l
 
 let module_ s =
+  let open Custom in
   let header = word32 s in
   require (header = magic) s 0 "magic header not detected";
   let version = word32 s in
   require (version = Encode.version) s 4 "unknown binary version";
-  iterate custom_section s;
+  let customs = iterate (custom_section (Before Type)) s in
   let types = type_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Type)) s in
   let imports = import_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Import)) s in
   let func_types = func_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Func)) s in
   let tables = table_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Table)) s in
   let memories = memory_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Memory)) s in
   let globals = global_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Global)) s in
   let exports = export_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Export)) s in
   let start = start_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Start)) s in
   let elems = elem_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Elem)) s in
   let data_count = data_count_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After DataCount)) s in
   let func_bodies = code_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Code)) s in
   let datas = data_section s in
-  iterate custom_section s;
+  let customs = customs @ iterate (custom_section (After Data)) s in
   require (pos s = len s) s (len s) "unexpected content after last section";
   require (List.length func_types = List.length func_bodies)
     s (len s) "function and code section have inconsistent lengths";
@@ -1108,23 +1110,37 @@ let module_ s =
     List.for_all Free.(fun f -> (func f).datas = Set.empty) func_bodies)
     s (len s) "data count section required";
   let funcs =
-    List.map2 (fun t f -> {f.it with ftype = t} @@ f.at) func_types func_bodies
-  in {types; tables; memories; globals; funcs; imports; exports; elems; datas; start}
-
-
-let decode name bs = at module_ (stream name bs)
-
-let all_custom tag s =
-  let header = word32 s in
-  require (header = magic) s 0 "magic header not detected";
-  let version = word32 s in
-  require (version = Encode.version) s 4 "unknown binary version";
-  let rec collect () =
-    iterate non_custom_section s;
-    match custom_section s with
-    | None -> []
-    | Some (n, s) when n = tag -> s :: collect ()
-    | Some _ -> collect ()
-  in collect ()
-
-let decode_custom tag name bs = all_custom tag (stream name bs)
+    List.map2 Source.(fun t f -> {f.it with ftype = t} @@ f.at)
+      func_types func_bodies
+  in
+  {types; tables; memories; globals; funcs; imports; exports; elems; datas; start},
+  customs
+
+
+let decode_custom m bs custom =
+  let open Source in
+  let Custom.{name; content; place} = custom.it in
+  match Custom.handler name, Custom.handler (Utf8.decode "custom") with
+  | Some (module Handler), _ ->
+    let fmt = Handler.decode m bs custom in
+    let module S = struct module Handler = Handler let it = fmt end in
+    [(module S : Custom.Section)]
+  | None, Some (module Handler') ->
+    let fmt = Handler'.decode m bs custom in
+    let module S = struct module Handler = Handler' let it = fmt end in
+    [(module S : Custom.Section)]
+  | None, None ->
+    if !Flags.custom_reject then
+      raise (Custom.Code (custom.at,
+        "unknown custom section \"" ^ Utf8.encode name ^ "\""))
+    else
+      []
+
+let decode_with_custom name bs =
+  let m_cs = at module_ (stream name bs) in
+  let open Source in
+  let m', cs = m_cs.it in
+  let m = m' @@ m_cs.at in
+  m, List.flatten (List.map (decode_custom m bs) cs)
+
+let decode name bs = fst (decode_with_custom name bs)

interpreter/binary/decode.mli

@@ -1,5 +1,4 @@
 exception Code of Source.region * string
 
 val decode : string -> string -> Ast.module_ (* raises Code *)
-
-val decode_custom : Ast.name -> string -> string -> string list (* raises Code *)
+val decode_with_custom : string -> string -> Ast.module_ * Custom.section list (* raises Code *)