diff --git a/interpreter/binary/decode.ml b/interpreter/binary/decode.ml index 0686703613..5a7aa6f5c5 100644 --- a/interpreter/binary/decode.ml +++ b/interpreter/binary/decode.ml @@ -5,12 +5,11 @@ type stream = name : string; bytes : string; pos : int ref; - need_data_count : bool ref; } exception EOS -let stream name bs = {name; bytes = bs; pos = ref 0; need_data_count = ref false} +let stream name bs = {name; bytes = bs; pos = ref 0} let len s = String.length s.bytes let pos s = !(s.pos) @@ -208,9 +207,8 @@ let misc_instr s = | 0x08 -> let x = at var s in zero_flag s; - s.need_data_count := true; memory_init x - | 0x09 -> s.need_data_count := true; data_drop (at var s) + | 0x09 -> data_drop (at var s) | 0x0a -> zero_flag s; zero_flag s; memory_copy | 0x0b -> zero_flag s; memory_fill | 0x0c -> @@ -727,7 +725,8 @@ let module_ s = s (len s) "function and code section have inconsistent lengths"; require (data_count = None || data_count = Some (Lib.List32.length datas)) s (len s) "data count and data section have inconsistent lengths"; - require (not !(s.need_data_count) || data_count <> None) + require (data_count <> None || + List.for_all Free.(fun f -> (func f).datas = Set.empty) func_bodies) s (len s) "data count section required"; let funcs = List.map2 Source.(fun t f -> {f.it with ftype = t} @@ f.at) diff --git a/interpreter/binary/encode.ml b/interpreter/binary/encode.ml index 87abace93d..6d60a74b21 100644 --- a/interpreter/binary/encode.ml +++ b/interpreter/binary/encode.ml @@ -515,8 +515,8 @@ let encode m = section 11 (vec memory_segment) datas (datas <> []) (* Data count section *) - let data_count_section datas = - section 12 len (List.length datas) true + let data_count_section datas m = + section 12 len (List.length datas) Free.((module_ m).datas <> Set.empty) (* Module *) @@ -532,7 +532,7 @@ let encode m = export_section m.it.exports; start_section m.it.start; elem_section m.it.elems; - data_count_section m.it.datas; + data_count_section m.it.datas m; code_section m.it.funcs; data_section m.it.datas end diff --git a/interpreter/syntax/free.ml b/interpreter/syntax/free.ml new file mode 100644 index 0000000000..46727fc634 --- /dev/null +++ b/interpreter/syntax/free.ml @@ -0,0 +1,141 @@ +open Source +open Ast + +module Set = Set.Make(Int32) + +type t = +{ + types : Set.t; + globals : Set.t; + tables : Set.t; + memories : Set.t; + funcs : Set.t; + elems : Set.t; + datas : Set.t; + locals : Set.t; + labels : Set.t; +} + +let empty : t = +{ + types = Set.empty; + globals = Set.empty; + tables = Set.empty; + memories = Set.empty; + funcs = Set.empty; + elems = Set.empty; + datas = Set.empty; + locals = Set.empty; + labels = Set.empty; +} + +let union (s1 : t) (s2 : t) : t = +{ + types = Set.union s1.types s2.types; + globals = Set.union s1.globals s2.globals; + tables = Set.union s1.tables s2.tables; + memories = Set.union s1.memories s2.memories; + funcs = Set.union s1.funcs s2.funcs; + elems = Set.union s1.elems s2.elems; + datas = Set.union s1.datas s2.datas; + locals = Set.union s1.locals s2.locals; + labels = Set.union s1.labels s2.labels; +} + +let types s = {empty with types = s} +let globals s = {empty with globals = s} +let tables s = {empty with tables = s} +let memories s = {empty with memories = s} +let funcs s = {empty with funcs = s} +let elems s = {empty with elems = s} +let datas s = {empty with datas = s} +let locals s = {empty with locals = s} +let labels s = {empty with labels = s} + +let var x = Set.singleton x.it +let zero = Set.singleton 0l +let shift s = Set.map (Int32.add (-1l)) (Set.remove 0l s) + +let (++) = union +let list free xs = List.fold_left union empty (List.map free xs) + +let rec instr (e : instr) = + match e.it with + | Unreachable | Nop | Drop | Select -> empty + | Const _ | Test _ | Compare _ | Unary _ | Binary _ | Convert _ -> empty + | Block (_, es) | Loop (_, es) -> block es + | If (_, es1, es2) -> block es1 ++ block es2 + | Br x | BrIf x -> labels (var x) + | BrTable (xs, x) -> list (fun x -> labels (var x)) (x::xs) + | Return -> empty + | Call x -> funcs (var x) + | CallIndirect x -> types (var x) ++ tables zero + | LocalGet x | LocalSet x | LocalTee x -> locals (var x) + | GlobalGet x | GlobalSet x -> globals (var x) + | Load _ | Store _ | MemorySize | MemoryGrow | MemoryCopy | MemoryFill -> + memories zero + | MemoryInit x -> memories zero ++ datas (var x) + | TableCopy -> tables zero + | TableInit x -> tables zero ++ elems (var x) + | DataDrop x -> datas (var x) + | ElemDrop x -> elems (var x) + +and block (es : instr list) = + let free = list instr es in {free with labels = shift free.labels} + +let const (c : const) = block c.it + +let global (g : global) = const g.it.value +let func (f : func) = {(block f.it.body) with locals = Set.empty} +let table (t : table) = empty +let memory (m : memory) = empty + +let elem (e : elem) = + match e.it with + | Null -> empty + | Func x -> funcs (var x) + +let table_segment (s : table_segment) = + match s.it with + | Active {index; offset; init} -> + tables (var index) ++ const offset ++ list elem init + | Passive {etype; data} -> list elem data + +let memory_segment (s : memory_segment) = + match s.it with + | Active {index; offset; init} -> memories (var index) ++ const offset + | Passive {etype; data} -> empty + +let type_ (t : type_) = empty + +let export_desc (d : export_desc) = + match d.it with + | FuncExport x -> funcs (var x) + | TableExport x -> tables (var x) + | MemoryExport x -> memories (var x) + | GlobalExport x -> globals (var x) + +let import_desc (d : import_desc) = + match d.it with + | FuncImport x -> types (var x) + | TableImport tt -> empty + | MemoryImport mt -> empty + | GlobalImport gt -> empty + +let export (e : export) = export_desc e.it.edesc +let import (i : import) = import_desc i.it.idesc + +let start (s : var option) = + funcs (Lib.Option.get (Lib.Option.map var s) Set.empty) + +let module_ (m : module_) = + list type_ m.it.types ++ + list global m.it.globals ++ + list table m.it.tables ++ + list memory m.it.memories ++ + list func m.it.funcs ++ + start m.it.start ++ + list table_segment m.it.elems ++ + list memory_segment m.it.datas ++ + list import m.it.imports ++ + list export m.it.exports diff --git a/interpreter/syntax/free.mli b/interpreter/syntax/free.mli new file mode 100644 index 0000000000..b7ea2d7480 --- /dev/null +++ b/interpreter/syntax/free.mli @@ -0,0 +1,34 @@ +module Set : Set.S with type elt = int32 + +type t = +{ + types : Set.t; + globals : Set.t; + tables : Set.t; + memories : Set.t; + funcs : Set.t; + elems : Set.t; + datas : Set.t; + locals : Set.t; + labels : Set.t; +} + +val empty : t +val union : t -> t -> t + +val instr : Ast.instr -> t +val block : Ast.instr list -> t +val const : Ast.const -> t + +val type_ : Ast.type_ -> t +val global : Ast.global -> t +val func : Ast.func -> t +val table : Ast.table -> t +val memory : Ast.memory -> t +val table_segment : Ast.table_segment -> t +val memory_segment : Ast.memory_segment -> t +val export : Ast.export -> t +val import : Ast.import -> t +val start : Ast.var option -> t + +val module_ : Ast.module_ -> t