Merge pull request #2 from WebAssembly/interpreter

interpreter/Makefile

@@ -120,12 +120,12 @@ debugtest:	$(UNOPT)
 test/%:		$(OPT)
 		../test/core/run.py --wasm `pwd`/$(OPT) $(if $(JS),--js '$(JS)',) $(@:test/%=../test/core/%.wast)
 debugtest/%:	$(UNOPT)
-		../test/core/run.py --wasm `pwd`/$(UNOPT) $(if $(JS),--js '$(JS)',) $(@:test/%=../test/core/%.wast)
+		../test/core/run.py --wasm `pwd`/$(UNOPT) $(if $(JS),--js '$(JS)',) $(@:debugtest/%=../test/core/%.wast)
 
 run/%:		$(OPT)
 		./$(OPT) $(@:run/%=../test/core/%.wast)
-debugrun/%:		$(UNOPT)
-		./$(UNOPT) $(@:run/%=../test/core/%.wast)
+debug/%:	$(UNOPT)
+		./$(UNOPT) $(@:debug/%=../test/core/%.wast)
 
 
 # Miscellaneous targets

interpreter/binary/decode.ml

@@ -98,6 +98,7 @@ let vu1 s = Int64.to_int (vuN 1 s)
 let vu32 s = Int64.to_int32 (vuN 32 s)
 let vs7 s = Int64.to_int (vsN 7 s)
 let vs32 s = Int64.to_int32 (vsN 32 s)
+let vs33 s = I32_convert.wrap_i64 (vsN 33 s)
 let vs64 s = vsN 64 s
 let f32 s = F32.of_bits (u32 s)
 let f64 s = F64.of_bits (u64 s)
@@ -144,16 +145,12 @@ let elem_type s =
   | -0x10 -> AnyFuncType
   | _ -> error s (pos s - 1) "invalid element type"
 
-let stack_type s =
-  match peek s with
-  | Some 0x40 -> skip 1 s; []
-  | _ -> [value_type s]
-
+let stack_type s = vec value_type s
 let func_type s =
   match vs7 s with
   | -0x20 ->
-    let ins = vec value_type s in
-    let out = vec value_type s in
+    let ins = stack_type s in
+    let out = stack_type s in
     FuncType (ins, out)
   | _ -> error s (pos s - 1) "invalid function type"
 
@@ -200,33 +197,39 @@ let memop s =
   let offset = vu32 s in
   Int32.to_int align, offset
 
+let block_type s =
+  match peek s with
+  | Some 0x40 -> skip 1 s; ValBlockType None
+  | Some b when b land 0xc0 = 0x40 -> ValBlockType (Some (value_type s))
+  | _ -> VarBlockType (at vs33 s)
+
 let rec instr s =
   let pos = pos s in
   match op s with
   | 0x00 -> unreachable
   | 0x01 -> nop
 
   | 0x02 ->
-    let ts = stack_type s in
+    let bt = block_type s in
     let es' = instr_block s in
     end_ s;
-    block ts es'
+    block bt es'
   | 0x03 ->
-    let ts = stack_type s in
+    let bt = block_type s in
     let es' = instr_block s in
     end_ s;
-    loop ts es'
+    loop bt es'
   | 0x04 ->
-    let ts = stack_type s in
+    let bt = block_type s in
     let es1 = instr_block s in
     if peek s = Some 0x05 then begin
       expect 0x05 s "ELSE or END opcode expected";
       let es2 = instr_block s in
       end_ s;
-      if_ ts es1 es2
+      if_ bt es1 es2
     end else begin
       end_ s;
-      if_ ts es1 []
+      if_ bt es1 []
     end
 
   | 0x05 -> error s pos "misplaced ELSE opcode"

interpreter/binary/encode.ml

@@ -60,6 +60,7 @@ let encode m =
     let vu32 i = vu64 Int64.(logand (of_int32 i) 0xffffffffL)
     let vs7 i = vs64 (Int64.of_int i)
     let vs32 i = vs64 (Int64.of_int32 i)
+    let vs33 i = vs64 (I64_convert.extend_s_i32 i)
     let f32 x = u32 (F32.to_bits x)
     let f64 x = u64 (F64.to_bits x)
 
@@ -99,15 +100,9 @@ let encode m =
     let elem_type = function
       | AnyFuncType -> vs7 (-0x10)
 
-    let stack_type = function
-      | [] -> vs7 (-0x40)
-      | [t] -> value_type t
-      | _ ->
-        Code.error Source.no_region
-          "cannot encode stack type with arity > 1 (yet)"
-
+    let stack_type = vec value_type
     let func_type = function
-      | FuncType (ins, out) -> vs7 (-0x20); vec value_type ins; vec value_type out
+      | FuncType (ins, out) -> vs7 (-0x20); stack_type ins; stack_type out
 
     let limits vu {min; max} =
       bool (max <> None); vu min; opt vu max
@@ -139,15 +134,20 @@ let encode m =
 
     let var x = vu32 x.it
 
+    let block_type = function
+      | VarBlockType x -> vs33 x.it
+      | ValBlockType None -> vs7 (-0x40)
+      | ValBlockType (Some t) -> value_type t
+
     let rec instr e =
       match e.it with
       | Unreachable -> op 0x00
       | Nop -> op 0x01
 
-      | Block (ts, es) -> op 0x02; stack_type ts; list instr es; end_ ()
-      | Loop (ts, es) -> op 0x03; stack_type ts; list instr es; end_ ()
-      | If (ts, es1, es2) ->
-        op 0x04; stack_type ts; list instr es1;
+      | Block (bt, es) -> op 0x02; block_type bt; list instr es; end_ ()
+      | Loop (bt, es) -> op 0x03; block_type bt; list instr es; end_ ()
+      | If (bt, es1, es2) ->
+        op 0x04; block_type bt; list instr es1;
         if es2 <> [] then op 0x05;
         list instr es2; end_ ()
 

interpreter/exec/eval.ml

@@ -44,7 +44,7 @@ and admin_instr' =
   | Plain of instr'
   | Trapped of string
   | Break of int32 * value stack
-  | Label of stack_type * instr list * value stack * admin_instr list
+  | Label of int32 * instr list * value stack * admin_instr list
   | Local of instance * value ref list * value stack * admin_instr list
   | Invoke of closure
 
@@ -90,11 +90,17 @@ let func_type_of = function
   | AstFunc (inst, f) -> (lookup "type" (!inst).module_.it.types f.it.ftype).it
   | HostFunc (t, _) -> t
 
+let block_type inst bt =
+  match bt with
+  | VarBlockType x -> (type_ inst x).it
+  | ValBlockType None -> FuncType ([], [])
+  | ValBlockType (Some t) -> FuncType ([], [t])
+
 let take n (vs : 'a stack) at =
-  try Lib.List.take n vs with Failure _ -> Crash.error at "stack underflow"
+  try Lib.List32.take n vs with Failure _ -> Crash.error at "stack underflow"
 
 let drop n (vs : 'a stack) at =
-  try Lib.List.drop n vs with Failure _ -> Crash.error at "stack underflow"
+  try Lib.List32.drop n vs with Failure _ -> Crash.error at "stack underflow"
 
 
 (* Evaluation *)
@@ -120,17 +126,24 @@ let rec step (inst : instance) (c : config) : config =
       | Nop, vs ->
         vs, []
 
-      | Block (ts, es'), vs ->
-        vs, [Label (ts, [], [], List.map plain es') @@ e.at]
+      | Block (bt, es'), vs ->
+        let FuncType (ts1, ts2) = block_type inst bt in
+        let n1 = Lib.List32.length ts1 in
+        let n2 = Lib.List32.length ts2 in
+        let args, vs' = take n1 vs e.at, drop n1 vs e.at in
+        vs', [Label (n2, [], args, List.map plain es') @@ e.at]
 
-      | Loop (ts, es'), vs ->
-        vs, [Label ([], [e' @@ e.at], [], List.map plain es') @@ e.at]
+      | Loop (bt, es'), vs ->
+        let FuncType (ts1, ts2) = block_type inst bt in
+        let n1 = Lib.List32.length ts1 in
+        let args, vs' = take n1 vs e.at, drop n1 vs e.at in
+        vs', [Label (n1, [e' @@ e.at], args, List.map plain es') @@ e.at]
 
-      | If (ts, es1, es2), I32 0l :: vs' ->
-        vs', [Plain (Block (ts, es2)) @@ e.at]
+      | If (bt, es1, es2), I32 0l :: vs' ->
+        vs', [Plain (Block (bt, es2)) @@ e.at]
 
-      | If (ts, es1, es2), I32 i :: vs' ->
-        vs', [Plain (Block (ts, es1)) @@ e.at]
+      | If (bt, es1, es2), I32 i :: vs' ->
+        vs', [Plain (Block (bt, es1)) @@ e.at]
 
       | Br x, vs ->
         [], [Break (x.it, vs) @@ e.at]
@@ -256,21 +269,21 @@ let rec step (inst : instance) (c : config) : config =
     | Break (k, vs'), vs ->
       Crash.error e.at "undefined label"
 
-    | Label (ts, es0, vs', []), vs ->
+    | Label (n, es0, vs', []), vs ->
       vs' @ vs, []
 
-    | Label (ts, es0, vs', {it = Trapped msg; at} :: es'), vs ->
+    | Label (n, es0, vs', {it = Trapped msg; at} :: es'), vs ->
       vs, [Trapped msg @@ at]
 
-    | Label (ts, es0, vs', {it = Break (0l, vs0); at} :: es'), vs ->
-      take (List.length ts) vs0 e.at @ vs, List.map plain es0
+    | Label (n, es0, vs', {it = Break (0l, vs0); at} :: es'), vs ->
+      take n vs0 e.at @ vs, List.map plain es0
 
-    | Label (ts, es0, vs', {it = Break (k, vs0); at} :: es'), vs ->
+    | Label (n, es0, vs', {it = Break (k, vs0); at} :: es'), vs ->
       vs, [Break (Int32.sub k 1l, vs0) @@ at]
 
-    | Label (ts, es0, values, instrs), vs ->
+    | Label (n, es0, values, instrs), vs ->
       let c' = step inst {c with values; instrs; depth = c.depth + 1} in
-      vs, [Label (ts, es0, c'.values, c'.instrs) @@ e.at]
+      vs, [Label (n, es0, c'.values, c'.instrs) @@ e.at]
 
     | Local (inst', locals, vs', []), vs ->
       vs' @ vs, []
@@ -287,12 +300,12 @@ let rec step (inst : instance) (c : config) : config =
 
     | Invoke clos, vs ->
       let FuncType (ins, out) = func_type_of clos in
-      let n = List.length ins in
-      let args, vs' = take n vs e.at, drop n vs e.at in
+      let n1, n2 = Lib.List32.length ins, Lib.List32.length out in
+      let args, vs' = take n1 vs e.at, drop n1 vs e.at in
       (match clos with
       | AstFunc (inst', f) ->
         let locals' = List.rev args @ List.map default_value f.it.locals in
-        let instrs' = [Plain (Block (out, f.it.body)) @@ f.at] in
+        let instrs' = [Label (n2, [], [], List.map plain f.it.body) @@ f.at] in
         vs', [Local (!inst', List.map ref locals', [], instrs') @@ e.at]
 
       | HostFunc (t, f) ->

interpreter/script/js.ml

@@ -249,7 +249,7 @@ let wrap module_name item_name wrap_action wrap_assertion at =
   let edesc = FuncExport item @@ at in
   let exports = [{name = Utf8.decode "run"; edesc} @@ at] in
   let body =
-    [ Block ([], action @ assertion @ [Return @@ at]) @@ at;
+    [ Block (ValBlockType None, action @ assertion @ [Return @@ at]) @@ at;
       Unreachable @@ at ]
   in
   let funcs = [{ftype = 0l @@ at; locals; body} @@ at] in

interpreter/syntax/ast.ml

@@ -67,13 +67,15 @@ type var = int32 Source.phrase
 type literal = Values.value Source.phrase
 type name = int list
 
+type block_type = VarBlockType of var | ValBlockType of value_type option
+
 type instr = instr' Source.phrase
 and instr' =
   | Unreachable                       (* trap unconditionally *)
   | Nop                               (* do nothing *)
-  | Block of stack_type * instr list  (* execute in sequence *)
-  | Loop of stack_type * instr list   (* loop header *)
-  | If of stack_type * instr list * instr list  (* conditional *)
+  | Block of block_type * instr list  (* execute in sequence *)
+  | Loop of block_type * instr list   (* loop header *)
+  | If of block_type * instr list * instr list  (* conditional *)
   | Br of var                         (* break to n-th surrounding label *)
   | BrIf of var                       (* conditional break *)
   | BrTable of var list * var         (* indexed break *)

interpreter/syntax/operators.ml

@@ -13,14 +13,14 @@ let f64_const n = Const (F64 n.it @@ n.at)
 let unreachable = Unreachable
 let nop = Nop
 let drop = Drop
-let block ts es = Block (ts, es)
-let loop ts es = Loop (ts, es)
+let select = Select
+let block bt es = Block (bt, es)
+let loop bt es = Loop (bt, es)
+let if_ bt es1 es2 = If (bt, es1, es2)
 let br x = Br x
 let br_if x = BrIf x
 let br_table xs x = BrTable (xs, x)
 let return = Return
-let if_ ts es1 es2 = If (ts, es1, es2)
-let select = Select
 
 let call x = Call x
 let call_indirect x = CallIndirect x

interpreter/text/arrange.ml

@@ -61,8 +61,6 @@ let elem_type t = string_of_elem_type t
 
 let decls kind ts = tab kind (atom value_type) ts
 
-let stack_type ts = decls "result" ts
-
 let func_type (FuncType (ins, out)) =
   Node ("func", decls "param" ins @ decls "result" out)
 
@@ -218,15 +216,19 @@ let var x = nat32 x.it
 let value v = string_of_value v.it
 let constop v = value_type (type_of v.it) ^ ".const"
 
+let block_type = function
+  | VarBlockType x -> [Node ("type " ^ var x, [])]
+  | ValBlockType ts -> decls "result" (list_of_opt ts)
+
 let rec instr e =
   let head, inner =
     match e.it with
     | Unreachable -> "unreachable", []
     | Nop -> "nop", []
-    | Block (ts, es) -> "block", stack_type ts @ list instr es
-    | Loop (ts, es) -> "loop", stack_type ts @ list instr es
-    | If (ts, es1, es2) ->
-      "if", stack_type ts @
+    | Block (bt, es) -> "block", block_type bt @ list instr es
+    | Loop (bt, es) -> "loop", block_type bt @ list instr es
+    | If (bt, es1, es2) ->
+      "if", block_type bt @
         [Node ("then", list instr es1); Node ("else", list instr es2)]
     | Br x -> "br " ^ var x, []
     | BrIf x -> "br_if " ^ var x, []