Extend block types

interpreter/binary/decode.ml

@@ -249,10 +249,16 @@ let memop s =
   Int32.to_int align, offset
 
 let block_type s =
+  let xs =
+    either [
+      (fun s -> expect 0x41 s ""; vec (at var));
+      (fun s -> fun _ -> []);
+    ] s s
+  in
   either [
-    (fun s -> VarBlockType (var_type s));
-    (fun s -> expect 0x40 s ""; ValBlockType None);
-    (fun s -> ValBlockType (Some (value_type s)));
+    (fun s -> VarBlockType (var_type s, xs));
+    (fun s -> expect 0x40 s ""; ValBlockType (None, xs));
+    (fun s -> ValBlockType (Some (value_type s), xs));
   ] s
 
 let local s =

interpreter/binary/encode.ml

@@ -165,10 +165,13 @@ struct
   let var x = u32 x.it
 
   let block_type = function
-    | ValBlockType None -> s33 (-0x40l)
-    | ValBlockType (Some t) -> value_type t
-    | VarBlockType (SynVar x) -> s33 x
-    | VarBlockType (SemVar _) -> assert false
+    | ValBlockType (None, []) -> s33 (-0x40l)
+    | ValBlockType (Some t, []) -> value_type t
+    | VarBlockType (SynVar x, []) -> s33 x
+    | ValBlockType (None, xs) -> s33 (-0x3fl); vec var xs; s33 (-0x40l)
+    | ValBlockType (Some t, xs) -> s33 (-0x3fl); vec var xs; value_type t
+    | VarBlockType (SynVar x, xs) -> s33 (-0x3fl); vec var xs; s33 x
+    | VarBlockType (SemVar _, _) -> assert false
 
   let local (t, n) = len n; value_type t.it
 

interpreter/exec/eval.ml

@@ -49,7 +49,7 @@ type 'a stack = 'a list
 type frame =
 {
   inst : module_inst;
-  locals : value ref list;
+  locals : value option ref list;
 }
 
 type code = value stack * admin_instr list
@@ -74,8 +74,8 @@ type config =
   budget : int;  (* to model stack overflow *)
 }
 
-let frame inst = {inst; locals = []}
-let config inst vs es = {frame = frame inst; code = vs, es; budget = 300}
+let frame inst locals = {inst; locals}
+let config inst vs es = {frame = frame inst []; code = vs, es; budget = 300}
 
 let plain e = Plain e.it @@ e.at
 
@@ -111,10 +111,10 @@ let func_ref inst x i at =
 
 let block_type inst bt at =
   match bt with
-  | ValBlockType None -> FuncType ([], [])
-  | ValBlockType (Some t) -> FuncType ([], [t])
-  | VarBlockType (SynVar x) -> func_type inst (x @@ at)
-  | VarBlockType (SemVar x) -> as_func_def_type (def_of x)
+  | ValBlockType (None, _) -> FuncType ([], [])
+  | ValBlockType (Some t, _) -> FuncType ([], [t])
+  | VarBlockType (SynVar x, _) -> func_type inst (x @@ at)
+  | VarBlockType (SemVar x, _) -> as_func_def_type (def_of x)
 
 let take n (vs : 'a stack) at =
   try Lib.List.take n vs with Failure _ -> Crash.error at "stack underflow"
@@ -279,14 +279,19 @@ let rec step (c : config) : config =
           v1 :: vs', []
 
       | LocalGet x, vs ->
-        !(local c.frame x) :: vs, []
+        (match !(local c.frame x) with
+        | Some v ->
+          v :: vs, []
+        | None ->
+          Crash.error e.at "read of uninitialized local"
+        )
 
       | LocalSet x, v :: vs' ->
-        local c.frame x := v;
+        local c.frame x := Some v;
         vs', []
 
       | LocalTee x, v :: vs' ->
-        local c.frame x := v;
+        local c.frame x := Some v;
         v :: vs', []
 
       | GlobalGet x, vs ->
@@ -655,7 +660,7 @@ let rec step (c : config) : config =
 
       | _ ->
         let s1 = string_of_values (List.rev vs) in
-        let s2 = string_of_result_type (List.map type_of_value (List.rev vs)) in
+        let s2 = string_of_value_types (List.map type_of_value (List.rev vs)) in
         Crash.error e.at
           ("missing or ill-typed operand on stack (" ^ s1 ^ " : " ^ s2 ^ ")")
       )
@@ -696,9 +701,11 @@ let rec step (c : config) : config =
       vs' @ vs, [e']
 
     | Local (n, vs0, code'), vs ->
-      let frame' = {c.frame with locals = List.map ref vs0 @ c.frame.locals} in
+      let locals = List.map (fun v -> ref (Some v)) vs0 in
+      let frame' = {c.frame with locals = locals @ c.frame.locals} in
       let c' = step {c with frame = frame'; code = code'} in
-      let vs0' = List.map (!) (take (List.length vs0) c'.frame.locals e.at) in
+      let vs0' = List.map (fun loc -> Option.get (!loc))
+        (take (List.length vs0) c'.frame.locals e.at) in
       vs, [Local (n, vs0', c'.code) @@ e.at]
 
     | Frame (n, frame', (vs', [])), vs ->
@@ -723,17 +730,17 @@ let rec step (c : config) : config =
 
     | Invoke f, vs ->
       let FuncType (ts1, ts2) = Func.type_of f in
-      let args, vs' = split (List.length ts1) vs e.at in
+      let n1, n2 = List.length ts1, List.length ts2 in
+      let args, vs' = split n1 vs e.at in
       (match f with
       | Func.AstFunc (_, inst', func) ->
         let {locals; body; _} = func.it in
         let m = Lib.Promise.value inst' in
         let ts = List.map (fun t -> Types.sem_value_type m.types t.it) locals in
-        let vs0 = List.rev args @ List.map default_value ts in
-        let locals' = List.map (fun t -> t @@ func.at) ts1 @ locals in
-        let bt = VarBlockType (SemVar (alloc (FuncDefType (FuncType ([], ts2))))) in
-        let es0 = [Plain (Let (bt, locals', body)) @@ func.at] in
-        vs', [Frame (List.length ts2, frame m, (List.rev vs0, es0)) @@ e.at]
+        let locals' = List.rev (List.map Option.some args) @ List.map default_value ts in
+        let frame' = {inst = m; locals = List.map ref locals'} in
+        let instr' = [Label (n2, [], ([], List.map plain body)) @@ func.at] in
+        vs', [Frame (n2, frame', ([], instr')) @@ e.at]
 
       | Func.HostFunc (_, f) ->
         (try List.rev (f (List.rev args)) @ vs', []

interpreter/host/spectest.ml

@@ -29,10 +29,10 @@ let print_value v =
   Printf.printf "%s : %s\n"
     (string_of_value v) (string_of_value_type (type_of_value v))
 
-let print (FuncType (_, out)) vs =
+let print _ vs =
   List.iter print_value vs;
   flush_all ();
-  List.map default_value out
+  []
 
 
 let lookup name t =

interpreter/runtime/value.ml

@@ -133,22 +133,22 @@ let eq v1 v2 =
 (* Defaults *)
 
 let default_num = function
-  | I32Type -> I32 I32.zero
-  | I64Type -> I64 I64.zero
-  | F32Type -> F32 F32.zero
-  | F64Type -> F64 F64.zero
+  | I32Type -> Some (Num (I32 I32.zero))
+  | I64Type -> Some (Num (I64 I64.zero))
+  | F32Type -> Some (Num (F32 F32.zero))
+  | F64Type -> Some (Num (F64 F64.zero))
 
 let default_vec = function
-  | V128Type -> V128 V128.zero
+  | V128Type -> Some (Vec (V128 V128.zero))
 
 let default_ref = function
-  | (Nullable, t) -> NullRef t
-  | (NonNullable, _) -> assert false
+  | (Nullable, t) -> Some (Ref (NullRef t))
+  | (NonNullable, _) -> None
 
 let default_value = function
-  | NumType t' -> Num (default_num t')
-  | VecType t' -> Vec (default_vec t')
-  | RefType t' -> Ref (default_ref t')
+  | NumType t' -> default_num t'
+  | VecType t' -> default_vec t'
+  | RefType t' -> default_ref t'
   | BotType -> assert false
 
 

interpreter/script/js.ml

@@ -427,7 +427,7 @@ let wrap 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 (ValBlockType None, 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/script/run.ml

@@ -220,7 +220,7 @@ let print_module x_opt m =
 let print_values vs =
   let ts = List.map Value.type_of_value vs in
   Printf.printf "%s : %s\n%!"
-    (Value.string_of_values vs) (Types.string_of_result_type ts)
+    (Value.string_of_values vs) (Types.string_of_value_types ts)
 
 let string_of_nan = function
   | CanonicalNan -> "nan:canonical"
@@ -267,7 +267,7 @@ let string_of_results = function
 let print_results rs =
   let ts = List.map type_of_result rs in
   Printf.printf "%s : %s\n%!"
-    (string_of_results rs) (Types.string_of_result_type ts)
+    (string_of_results rs) (Types.string_of_value_types ts)
 
 
 (* Configuration *)

interpreter/syntax/ast.ml

@@ -137,7 +137,9 @@ type name = Utf8.unicode
 type local = local' Source.phrase
 and local' = value_type
 
-type block_type = VarBlockType of var | ValBlockType of value_type option
+type block_type =
+  | VarBlockType of var * idx list
+  | ValBlockType of value_type option * idx list
 
 type instr = instr' Source.phrase
 and instr' =

interpreter/syntax/free.ml

@@ -95,8 +95,8 @@ let def_type = function
   | FuncDefType ft -> func_type ft
 
 let block_type = function
-  | VarBlockType x -> var_type x
-  | ValBlockType t -> opt value_type t
+  | VarBlockType (x, xs) -> var_type x ++ list (fun x -> locals (idx x)) xs
+  | ValBlockType (t, xs) -> opt value_type t ++ list (fun x -> locals (idx x)) xs
 
 let rec instr (e : instr) =
   match e.it with

interpreter/syntax/types.ml

@@ -1,11 +1,14 @@
 (* Types *)
 
-type name = int list
+type type_idx = int32
+type local_idx = int32
+type name = Utf8.unicode
 
-and syn_var = int32
+and syn_var = type_idx
 and sem_var = def_type Lib.Promise.t
 and var = SynVar of syn_var | SemVar of sem_var
 
+and init = Initialized | Uninitialized
 and nullability = NonNullable | Nullable
 and num_type = I32Type | I64Type | F32Type | F64Type
 and vec_type = V128Type
@@ -15,15 +18,17 @@ and heap_type =
 and value_type =
   NumType of num_type | VecType of vec_type | RefType of ref_type | BotType
 
-and result_type = value_type list
-and func_type = FuncType of result_type * result_type
+and result_type = ResultType of value_type list * local_idx Source.phrase list
+and instr_type = InstrType of value_type list * value_type list * local_idx Source.phrase list
+and func_type = FuncType of value_type list * value_type list
 and def_type = FuncDefType of func_type
 
 type 'a limits = {min : 'a; max : 'a option}
 type mutability = Immutable | Mutable
 type table_type = TableType of Int32.t limits * ref_type
 type memory_type = MemoryType of Int32.t limits
 type global_type = GlobalType of value_type * mutability
+type local_type = LocalType of value_type * init
 type extern_type =
   | ExternFuncType of func_type
   | ExternTableType of table_type
@@ -207,10 +212,13 @@ let string_of_name n =
   List.iter escape n;
   Buffer.contents b
 
+let string_of_idx x = I32.to_string_u x
+let string_of_local_idx x = string_of_idx x.Source.it
+
 let rec string_of_var =
   let inner = ref false in
   function
-  | SynVar x -> I32.to_string_u x
+  | SynVar x -> string_of_idx x
   | SemVar x ->
     if !inner then "..." else
     ( inner := true;
@@ -249,12 +257,22 @@ and string_of_value_type = function
   | RefType t -> string_of_ref_type t
   | BotType -> "(something)"
 
-and string_of_result_type ts =
+and string_of_value_types ts =
   "[" ^ String.concat " " (List.map string_of_value_type ts) ^ "]"
 
+and string_of_result_type = function
+  | ResultType (ts, xs) ->
+    String.concat " "
+      (string_of_value_types ts :: List.map string_of_local_idx xs)
+
+and stirng_of_instr_type = function
+  | InstrType (ts1, ts2, xs) ->
+    string_of_value_types ts1 ^ " -> " ^
+      string_of_result_type (ResultType (ts2, xs))
+
 and string_of_func_type = function
-  | FuncType (ins, out) ->
-    string_of_result_type ins ^ " -> " ^ string_of_result_type out
+  | FuncType (ts1, ts2) ->
+    string_of_value_types ts1 ^ " -> " ^ string_of_value_types ts2
 
 and string_of_def_type = function
   | FuncDefType ft -> "func " ^ string_of_func_type ft

interpreter/text/arrange.ml

@@ -429,10 +429,14 @@ let vec v = string_of_vec v.it
 let constop v = num_type (type_of_num v) ^ ".const"
 let vec_constop v = vec_type (type_of_vec v) ^ ".const i32x4"
 
+let inits = function
+  | [] -> []
+  | xs -> [Node ("set " ^ String.concat " " (list var xs), [])]
+
 let block_type = function
-  | VarBlockType (SynVar x) -> [Node ("type " ^ nat32 x, [])]
-  | VarBlockType (SemVar _) -> assert false
-  | ValBlockType ts -> decls "result" (list_of_opt ts)
+  | VarBlockType (SynVar x, xs) -> Node ("type " ^ nat32 x, []) :: inits xs
+  | VarBlockType (SemVar _, _) -> assert false
+  | ValBlockType (ts, xs) -> decls "result" (list_of_opt ts) @ inits xs
 
 let rec instr e =
   let head, inner =

interpreter/text/lexer.mll

@@ -152,6 +152,7 @@ rule token = parse
       | "ref" -> REF
       | "null" -> NULL
       | "mut" -> MUT
+      | "set" -> SET
 
       | "nop" -> NOP
       | "unreachable" -> UNREACHABLE