Implement block signatures

ml-proto/README.md

@@ -140,22 +140,28 @@ offset: offset=<nat>
 align: align=(1|2|4|8|...)
 cvtop: trunc_s | trunc_u | extend_s | extend_u | ...
 
+block_sig : <type>*
+func_sig:   ( type <var> ) | <param>* <result>*
+global_sig: <type> | ( mut <type> )
+table_sig:  <nat> <nat>? <elem_type>
+memory_sig: <nat> <nat>?
+
 expr:
   ( <op> )
   ( <op> <expr>+ )                                                   ;; = <expr>+ (<op>)
-  ( block <name>? <instr>* )
-  ( loop <name>? <instr>* )
-  ( if ( then <name>? <instr>* ) ( else <name>? <instr>* )? )
-  ( if <expr> ( then <name>? <instr>* ) ( else <name>? <instr>* )? ) ;; = (if <expr> (then <name>? <instr>*) (else <name>? <instr>*)?)
-  ( if <expr> <expr> <expr>? )                                       ;; = (if <expr> (then <expr>) (else <expr>?))
+  ( block <name>? <block_sig>? <instr>* )
+  ( loop <name>? <block_sig>? <instr>* )
+  ( if <name>? <block_sig>? ( then <instr>* ) ( else <instr>* )? )
+  ( if <name>? <block_sig>? <expr> ( then <instr>* ) ( else <instr>* )? ) ;; = (if <name>? <block_sig>? <expr> (then <instr>*) (else <instr>*)?)
+  ( if <name>? <block_sig>? <expr> <expr> <expr>? )                  ;; = (if <name>? <block_sig>? <expr> (then <expr>) (else <expr>?))
 
 instr:
   <expr>
   <op>                                                               ;; = (<op>)
-  block <name>? <instr>* end                                         ;; = (block <name>? <instr>*)
-  loop <name>? <instr>* end                                          ;; = (loop <name>? <instr>*)
-  if <name>? <instr>* end                                            ;; = (if (then <name>? <instr>*))
-  if <name>? <instr>* else <name>? <instr>* end                      ;; = (if (then <name>? instr>*) (else <name>? <instr>*))
+  block <name>? <block_sig>? <instr>* end                            ;; = (block <name>? <block_sig>? <instr>*)
+  loop <name>? <block_sig>? <instr>* end                             ;; = (loop <name>? <block_sig>? <instr>*)
+  if <name>? <block_sig>? <instr>* end                               ;; = (if <name>? <block_sig>? (then <instr>*))
+  if <name>? <block_sig>? <instr>* else <instr>* end                 ;; = (if <name>? <block_sig>? (then <instr>*) (else <instr>*))
 
 op:
   unreachable
@@ -189,11 +195,6 @@ param:   ( param <type>* ) | ( param <name> <type> )
 result:  ( result <type> )
 local:   ( local <type>* ) | ( local <name> <type> )
 
-func_sig:   ( type <var> ) | <param>* <result>?
-global_sig: <type> | ( mut <type> )
-table_sig:  <nat> <nat>? <elem_type>
-memory_sig: <nat> <nat>?
-
 global:  ( global <name>? <global_sig> )
          ( global <name>? ( export <string> ) <global_sig> )                ;; = (export <string> (global <N>)) (global <name>? <global_sig>)
          ( global <name>? ( import <string> <string> ) <global_sig> )       ;; = (import <name>? <string> <string> (global <global_sig>))

ml-proto/host/arrange.ml

@@ -53,6 +53,8 @@ let elem_type t = string_of_elem_type t
 
 let decls kind ts = tab kind (atom value_type) ts
 
+let stack_type ts = list (atom value_type) ts
+
 let func_type (FuncType (ins, out)) =
   Node ("func", decls "param" ins @ decls "result" out)
 
@@ -214,15 +216,16 @@ let rec instr e =
     | Unreachable -> "unreachable", []
     | Nop -> "nop", []
     | Drop -> "drop", []
-    | Block es -> "block", list instr es
-    | Loop es -> "loop", list instr es
-    | Br (n, x) -> "br " ^ int n ^ " " ^ var x, []
-    | BrIf (n, x) -> "br_if " ^ int n ^ " " ^ var x, []
-    | BrTable (n, xs, x) ->
-      "br_table " ^ int n ^ " " ^ String.concat " " (list var (xs @ [x])), []
+    | Block (ts, es) -> "block", stack_type ts @ list instr es
+    | Loop (ts, es) -> "loop", stack_type ts @ list instr es
+    | Br x -> "br " ^ var x, []
+    | BrIf x -> "br_if " ^ var x, []
+    | BrTable (xs, x) ->
+      "br_table " ^ String.concat " " (list var (xs @ [x])), []
     | Return -> "return", []
-    | If (es1, es2) ->
-      "if", [Node ("then", list instr es1); Node ("else", list instr es2)]
+    | If (ts, es1, es2) ->
+      "if", stack_type ts @
+        [Node ("then", list instr es1); Node ("else", list instr es2)]
     | Select -> "select", []
     | Call x -> "call " ^ var x, []
     | CallIndirect x -> "call_indirect " ^ var x, []

ml-proto/host/encode.ml

@@ -3,6 +3,12 @@
 let version = 0x0cl
 
 
+(* Errors *)
+
+module Code = Error.Make ()
+exception Code = Code.Error
+
+
 (* Encoding stream *)
 
 type stream =
@@ -52,15 +58,20 @@ let encode m =
 
     let vu32 i = vu64 (Int64.of_int32 i)
     let vs32 i = vs64 (Int64.of_int32 i)
-    let vu i = vu64 (Int64.of_int i)
     let f32 x = u32 (F32.to_bits x)
     let f64 x = u64 (F64.to_bits x)
 
+    let len i =
+      if Int32.to_int (Int32.of_int i) <> i then
+        Code.error Source.no_region
+          "cannot encode length with more than 32 bit";
+      vu32 (Int32.of_int i)
+
     let bool b = u8 (if b then 1 else 0)
-    let string bs = vu (String.length bs); put_string s bs
+    let string bs = len (String.length bs); put_string s bs
     let list f xs = List.iter f xs
     let opt f xo = Lib.Option.app f xo
-    let vec f xs = vu (List.length xs); list f xs
+    let vec f xs = len (List.length xs); list f xs
     let vec1 f xo = bool (xo <> None); opt f xo
 
     let gap32 () = let p = pos s in u32 0l; u8 0; p
@@ -86,6 +97,13 @@ let encode m =
     let elem_type = function
       | AnyFuncType -> u8 0x20
 
+    let stack_type = function
+      | [] -> u8 0x00
+      | [t] -> value_type t
+      | _ ->
+        Code.error Source.no_region
+          "cannot encode stack type with arity > 1 (yet)"
+
     let func_type = function
       | FuncType (ins, out) -> u8 0x40; vec value_type ins; vec value_type out
 
@@ -105,32 +123,13 @@ let encode m =
     let global_type = function
       | GlobalType (t, mut) -> value_type t; mutability mut
 
-    let limits vu {min; max} =
-      bool (max <> None); vu min; opt vu max
-
-    let table_type = function
-      | TableType (lim, t) -> elem_type t; limits vu32 lim
-
-    let memory_type = function
-      | MemoryType lim -> limits vu32 lim
-
-    let mutability = function
-      | Immutable -> u8 0
-      | Mutable -> u8 1
-
-    let global_type = function
-      | GlobalType (t, mut) -> value_type t; mutability mut
-
     (* Expressions *)
 
     open Source
     open Ast
     open Values
     open Memory
 
-    let arity xs = vu (List.length xs)
-    let arity1 xo = bool (xo <> None)
-
     let op n = u8 n
     let memop {align; offset; _} =
       vu32 (I32.ctz (Int32.of_int align));
@@ -141,16 +140,16 @@ let encode m =
     let rec instr e =
       match e.it with
       | Unreachable -> op 0x00
-      | Block es -> op 0x01; list instr es; op 0x0f
-      | Loop es -> op 0x02; list instr es; op 0x0f
-      | If (es1, es2) ->
-        op 0x03; list instr es1;
+      | Block (ts, es) -> op 0x01; stack_type ts; list instr es; op 0x0f
+      | Loop (ts, es) -> op 0x02; stack_type ts; list instr es; op 0x0f
+      | If (ts, es1, es2) ->
+        op 0x03; stack_type ts; list instr es1;
         if es2 <> [] then op 0x04;
         list instr es2; op 0x0f
       | Select -> op 0x05
-      | Br (n, x) -> op 0x06; vu n; var x
-      | BrIf (n, x) -> op 0x07; vu n; var x
-      | BrTable (n, xs, x) -> op 0x08; vu n; vec var xs; var x
+      | Br x -> op 0x06; var x
+      | BrIf x -> op 0x07; var x
+      | BrTable (xs, x) -> op 0x08; vec var xs; var x
       | Return -> op 0x09
       | Nop -> op 0x0a
       | Drop -> op 0x0b
@@ -449,7 +448,7 @@ let encode m =
         | ts -> (t, 1) :: ts
       in List.fold_right combine ts []
 
-    let local (t, n) = vu n; value_type t
+    let local (t, n) = len n; value_type t
 
     let code f =
       let {locals; body; _} = f.it in

ml-proto/host/encode.mli

@@ -1,3 +1,5 @@
+exception Code of Source.region * string
+
 val version : int32
 val encode : Ast.module_ -> string
 

ml-proto/host/js.ml

@@ -126,7 +126,7 @@ let assert_return lits ts at =
     [ Const lit @@ at;
       Compare (eq_of (Values.type_of lit.it)) @@ at;
       Test (Values.I32 I32Op.Eqz) @@ at;
-      BrIf (0, 0l @@ at) @@ at ]
+      BrIf (0l @@ at) @@ at ]
   in [], List.flatten (List.rev_map test lits)
 
 let assert_return_nan ts at =
@@ -136,7 +136,7 @@ let assert_return_nan ts at =
     [ GetLocal (var i) @@ at;
       GetLocal (var i) @@ at;
       Compare (eq_of t) @@ at;
-      BrIf (0, 0l @@ at) @@ at ]
+      BrIf (0l @@ at) @@ at ]
   in ts, List.flatten (List.mapi init ts @ List.mapi test ts)
 
 let wrap module_name item_name wrap_action wrap_assertion at =
@@ -148,7 +148,9 @@ let wrap module_name item_name wrap_action wrap_assertion at =
   let ekind = FuncExport @@ at in
   let exports = [{name = "run"; ekind; item} @@ at] in
   let body =
-    [Block (action @ assertion @ [Return @@ at]) @@ at; Unreachable @@ at] in
+    [ Block ([], action @ assertion @ [Return @@ at]) @@ at;
+      Unreachable @@ at ]
+  in
   let funcs = [{ftype = 0l @@ at; locals; body} @@ at] in
   let m = {empty_module with types; funcs; imports; exports} @@ at in
   Encode.encode m

ml-proto/host/parser.mly

@@ -254,10 +254,6 @@ type_use :
 
 /* Expressions */
 
-nat :
-  | NAT { int_of_string $1 }
-;
-
 literal :
   | NAT { $1 @@ at () }
   | INT { $1 @@ at () }
@@ -297,21 +293,19 @@ align_opt :
 
 instr :
   | plain_instr { let at = at () in fun c -> [$1 c @@ at] }
-  | ctrl_instr { let at = at () in fun c -> [$1 c @@ at] }
+  | block_instr { let at = at () in fun c -> [$1 c @@ at] }
   | expr { $1 } /* Sugar */
 ;
 plain_instr :
   | UNREACHABLE { fun c -> unreachable }
   | NOP { fun c -> nop }
   | DROP { fun c -> drop }
   | SELECT { fun c -> select }
-  | BR nat var { fun c -> br $2 ($3 c label) }
-  | BR_IF nat var { fun c -> br_if $2 ($3 c label) }
-  | BR_TABLE var /*nat*/ var var_list
-    { fun c -> let xs, x = Lib.List.split_last ($3 c label :: $4 c label) in
-      (* TODO: remove hack once arities are gone *)
-      let n = $2 c (fun _ -> error x.at "syntax error") in
-      br_table (Int32.to_int n.it) xs x }
+  | BR var { fun c -> br ($2 c label) }
+  | BR_IF var { fun c -> br_if ($2 c label) }
+  | BR_TABLE var var_list
+    { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in
+      br_table xs x }
   | RETURN { fun c -> return }
   | CALL var { fun c -> call ($2 c func) }
   | CALL_INDIRECT var { fun c -> call_indirect ($2 c type_) }
@@ -331,15 +325,18 @@ plain_instr :
   | CURRENT_MEMORY { fun c -> current_memory }
   | GROW_MEMORY { fun c -> grow_memory }
 ;
-ctrl_instr :
-  | BLOCK labeling_opt instr_list END
-    { fun c -> let c' = $2 c in block ($3 c') }
-  | LOOP labeling_opt instr_list END
-    { fun c -> let c' = $2 c in loop ($3 c') }
-  | IF labeling_opt instr_list END
-    { fun c -> let c' = $2 c in if_ ($3 c') [] }
-  | IF labeling_opt instr_list ELSE labeling_opt instr_list END
-    { fun c -> let c1 = $2 c in let c2 = $5 c in if_ ($3 c1) ($6 c2) }
+block_instr :
+  | BLOCK labeling_opt block END
+    { fun c -> let c' = $2 c in let ts, es = $3 c' in block ts es }
+  | LOOP labeling_opt block END
+    { fun c -> let c' = $2 c in let ts, es = $3 c' in loop ts es }
+  | IF labeling_opt block END
+    { fun c -> let c' = $2 c in let ts, es = $3 c' in if_ ts es [] }
+  | IF labeling_opt block ELSE instr_list END
+    { fun c -> let c' = $2 c in let ts, es1 = $3 c' in if_ ts es1 ($5 c') }
+;
+block :
+  | value_type_list instr_list { fun c -> $1, $2 c }
 ;
 
 expr :  /* Sugar */
@@ -348,31 +345,27 @@ expr :  /* Sugar */
 ;
 expr1 :  /* Sugar */
   | plain_instr expr_list { fun c -> snd ($2 c), $1 c }
-  /* TODO: remove special-casing of branches here once arities are gone */
-  | BR var expr_list { fun c -> let n, es = $3 c in es, br n ($2 c label) }
-  | BR_IF var expr expr_list
-    { fun c ->
-      let es1 = $3 c and n, es2 = $4 c in es1 @ es2, br_if n ($2 c label) }
-  | BR_TABLE var var_list expr expr_list
-    { fun c -> let xs, x = Lib.List.split_last ($2 c label :: $3 c label) in
-      let es1 = $4 c and n, es2 = $5 c in es1 @ es2, br_table n xs x }
-  | BLOCK labeling_opt instr_list
-    { fun c -> let c' = $2 c in [], block ($3 c') }
-  | LOOP labeling_opt instr_list
-    { fun c -> let c' = $2 c in [], loop ($3 c') }
-  | IF expr expr { fun c -> let c' = anon_label c in $2 c, if_ ($3 c') [] }
-  | IF expr expr expr
-    { fun c -> let c' = anon_label c in $2 c, if_ ($3 c') ($4 c') }
-  | IF expr LPAR THEN labeling_opt instr_list RPAR
-    { fun c -> let c' = $5 c in $2 c, if_ ($6 c') [] }
-  | IF expr LPAR THEN labeling_opt instr_list RPAR LPAR
-    ELSE labeling_opt instr_list RPAR
-    { fun c -> let c1 = $5 c in let c2 = $10 c in $2 c, if_ ($6 c1) ($11 c2) }
-  | IF LPAR THEN labeling_opt instr_list RPAR
-    { fun c -> let c' = $4 c in [], if_ ($5 c') [] }
-  | IF LPAR THEN labeling_opt instr_list RPAR
-       LPAR ELSE labeling_opt instr_list RPAR
-    { fun c -> let c1 = $4 c in let c2 = $9 c in [], if_ ($5 c1) ($10 c2) }
+  | BLOCK labeling_opt block
+    { fun c -> let c' = $2 c in let ts, es = $3 c' in [], block ts es }
+  | LOOP labeling_opt block
+    { fun c -> let c' = $2 c in let ts, es = $3 c' in [], loop ts es }
+  | IF labeling_opt value_type_list if_
+    { fun c -> let c' = $2 c in
+      let es, es1, es2 = $4 c c' in es, if_ $3 es1 es2 }
+;
+if_ :
+  | LPAR THEN instr_list RPAR LPAR ELSE instr_list RPAR
+    { fun c c' -> [], $3 c', $7 c' }
+  | LPAR THEN instr_list RPAR  /* Sugar */
+    { fun c c' -> [], $3 c', [] }
+  | expr LPAR THEN instr_list RPAR LPAR ELSE instr_list RPAR  /* Sugar */
+    { fun c c' -> $1 c, $4 c', $8 c' }
+  | expr LPAR THEN instr_list RPAR  /* Sugar */
+    { fun c c' -> $1 c, $4 c', [] }
+  | expr expr expr  /* Sugar */
+    { fun c c' -> $1 c, $2 c', $3 c' }
+  | expr expr  /* Sugar */
+    { fun c c' -> $1 c, $2 c', [] }
 ;
 
 instr_list :

ml-proto/host/run.ml

@@ -104,6 +104,7 @@ let input_from get_script run =
   | Eval.Link (at, msg) -> error at "link failure" msg
   | Eval.Trap (at, msg) -> error at "runtime trap" msg
   | Eval.Crash (at, msg) -> error at "runtime crash" msg
+  | Encode.Code (at, msg) -> error at "encoding error" msg
   | IO (at, msg) -> error at "i/o error" msg
   | Assert (at, msg) -> error at "assertion failure" msg
   | Abort _ -> false

ml-proto/spec/ast.ml

@@ -72,13 +72,13 @@ and instr' =
   | Nop                               (* do nothing *)
   | Drop                              (* forget a value *)
   | Select                            (* branchless conditional *)
-  | Block of instr list               (* execute in sequence *)
-  | Loop of instr list                (* loop header *)
-  | Br of int * var                   (* break to n-th surrounding label *)
-  | BrIf of int * var                 (* conditional break *)
-  | BrTable of int * var list * var   (* indexed break *)
+  | Block of stack_type * instr list  (* execute in sequence *)
+  | Loop of stack_type * instr list   (* loop header *)
+  | Br of var                         (* break to n-th surrounding label *)
+  | BrIf of var                       (* conditional break *)
+  | BrTable of var list * var         (* indexed break *)
   | Return                            (* break from function body *)
-  | If of instr list * instr list     (* conditional *)
+  | If of stack_type * instr list * instr list  (* conditional *)
   | Call of var                       (* call function *)
   | CallIndirect of var               (* call function through table *)
   | GetLocal of var                   (* read local variable *)