Labels for blocks, loops, & switches

ml-proto/README.md

@@ -165,13 +165,15 @@ cvtop: trunc_s | trunc_u | extend_s | extend_u | ...
 expr:
   ( nop )
   ( block <expr>+ )
+  ( block <var> <expr>+ )                        ;; = (label <var> (block <expr>+))
   ( if <expr> <expr> <expr> )
-  ( if <expr> <expr> )                     ;; = (if <expr> <expr> (nop))
-  ( loop <expr>* )                         ;; = (loop (block <expr>*))
-  ( label <name>? <expr>* )                ;; = (label (block <expr>*))
+  ( if <expr> <expr> )                           ;; = (if <expr> <expr> (nop))
+  ( loop <expr>* )                               ;; = (loop (block <expr>*))
+  ( loop <var> <var>? <expr>* )                  ;; = (label <var> (loop (block <var>? <expr>*)))
+  ( label <var>? <expr> )
   ( break <var> <expr>? )
-  ( break )                                ;; = (break 0)
   ( <type>.switch <expr> <case>* <expr> )
+  ( <type>.switch <var> <expr> <case>* <expr> )  ;; = (label <var> (<type>.switch <expr> <case>* <expr>))
   ( call <var> <expr>* )
   ( call_import <var> <expr>* )
   ( call_indirect <var> <expr> <expr>* )

ml-proto/src/Makefile

@@ -14,12 +14,13 @@ OCB_FLAGS += 	-libs str,bigarray
 OCB_FLAGS += 	-I host -I given -I spec
 OCB =		ocamlbuild $(OCB_FLAGS)
 
-all:		$(NAME) unopt
+all:		$(NAME)
+unopt:		$(NAME).unopt
 
 $(NAME):	main.native
 		mv $< $@
 
-unopt:		main.byte
+$(NAME).unopt:	main.byte
 		mv $< $@
 
 main.native:	$(MAKEFILE)
@@ -40,4 +41,4 @@ zip:
 		git archive --format=zip --prefix=$(NAME)/ \
 			-o $(NAME).zip HEAD
 
-.PHONY:		all clean check zip
+.PHONY:		all unopt clean check zip

ml-proto/src/host/parser.mly

@@ -56,7 +56,7 @@ let c0 () =
 
 let enter_func c =
   assert (VarMap.is_empty c.labels);
-  {c with locals = empty ()}
+  {c with labels = VarMap.add "return" 0 c.labels; locals = empty ()}
 
 let lookup category space x =
   try VarMap.find x.it space.map
@@ -80,8 +80,6 @@ let bind_func c x = bind "function" c.funcs x
 let bind_import c x = bind "import" c.imports x
 let bind_local c x = bind "local" c.locals x
 let bind_label c x =
-  if VarMap.mem x.it c.labels then
-    Error.error x.at ("duplicate label " ^ x.it);
   {c with labels = VarMap.add x.it 0 (VarMap.map ((+) 1) c.labels)}
 
 let anon space n = space.count <- space.count + n
@@ -159,24 +157,40 @@ expr :
 oper :
   | NOP { fun c -> Nop }
   | BLOCK expr expr_list { fun c -> Block ($2 c :: $3 c) }
+  | BLOCK bind_var expr expr_list  /* Sugar */
+    { let at = at() in
+      fun c -> let c' = bind_label c $2 in
+        Label (Block ($3 c' :: $4 c') @@ at) }
   | IF expr expr expr { fun c -> If ($2 c, $3 c, $4 c) }
   | IF expr expr  /* Sugar */
     { let at1 = ati 1 in fun c -> If ($2 c, $3 c, Nop @@ at1) }
   | LOOP expr_block { fun c -> Loop ($2 c) }
-  | LABEL expr_block { fun c -> Label ($2 (anon_label c)) }
-  | LABEL bind_var expr_block  /* Sugar */
-    { fun c -> Label ($3 (bind_label c $2)) }
+  | LOOP bind_var expr_block  /* Sugar */
+    { let at = at() in
+      fun c -> let c' = bind_label c $2 in Label (Loop ($3 c') @@ at) }
+  | LOOP bind_var bind_var expr_block  /* Sugar */
+    { let at = at() in
+      fun c -> let c' = bind_label (bind_label c $2) $3 in
+        Label (Loop (Label ($4 c') @@ at) @@ at) }
+  | LABEL expr { fun c -> let c' = anon_label c in Label ($2 c') }
+  | LABEL bind_var expr  /* Sugar */
+    { fun c -> let c' = bind_label c $2 in Label ($3 c') }
   | BREAK var expr_opt { fun c -> Break ($2 c label, $3 c) }
-  | BREAK { let at = at() in fun c -> Break (0 @@ at, None) }  /* Sugar */
   | SWITCH expr arms
     { let at1 = ati 1 in
       fun c -> let x, y = $3 c in
         Switch ($1 @@ at1, $2 c, List.map (fun a -> a $1) x, y) }
+  | SWITCH bind_var expr arms  /* Sugar */
+    { let at = at() in let at2 = ati 2 in
+      fun c -> let c' = bind_label c $2 in let x, y = $4 c' in
+        Label (Switch ($1 @@ at2, $3 c', List.map (fun a -> a $1) x, y) @@ at) }
   | CALL var expr_list { fun c -> Call ($2 c func, $3 c) }
   | CALLIMPORT var expr_list { fun c -> CallImport ($2 c import, $3 c) }
   | CALLINDIRECT var expr expr_list
     { fun c -> CallIndirect ($2 c table, $3 c, $4 c) }
-  | RETURN expr_opt { fun c -> Return ($2 c) }
+  | RETURN expr_opt  /* Sugar */
+    { let at1 = ati 1 in
+      fun c -> Break (label c ("return" @@ at1) @@ at1, $2 c) }
   | GETLOCAL var { fun c -> GetLocal ($2 c local) }
   | SETLOCAL var expr { fun c -> SetLocal ($2 c local, $3 c) }
   | LOAD expr { fun c -> Load ($1, $2 c) }
@@ -233,7 +247,9 @@ func_fields :
     { let at = at() in
       fun c -> {params = []; result = None; locals = []; body = Nop @@ at} }
   | expr_block
-    { fun c -> {params = []; result = None; locals = []; body = $1 c} }
+    { let at = at() in
+      fun c ->
+        {params = []; result = None; locals = []; body = Label ($1 c) @@ at} }
   | LPAR PARAM value_type_list RPAR func_fields
     { fun c -> anon_locals c $3; let f = $5 c in
       {f with params = $3 @ f.params} }

ml-proto/src/spec/ast.ml

@@ -84,7 +84,6 @@ and expr' =
   | Call of var * expr list
   | CallImport of var * expr list
   | CallIndirect of var * expr * expr list
-  | Return of expr option
   | GetLocal of var
   | SetLocal of var * expr
   | Load of memop * expr

ml-proto/src/spec/check.ml

@@ -164,9 +164,6 @@ let rec check_expr c et e =
     check_exprs c ins es;
     check_type out et e.at
 
-  | Return eo ->
-    check_expr_option c c.return eo e.at
-
   | GetLocal x ->
     check_type (Some (local c x)) et e.at
 

ml-proto/src/spec/eval.ml

@@ -38,8 +38,7 @@ type config =
 {
   modul : instance;
   locals : value ref list;
-  labels : label list;
-  return : label
+  labels : label list
 }
 
 let page_size c =
@@ -157,9 +156,6 @@ let rec eval_expr (c : config) (e : expr) =
     (* TODO: The conversion to int could overflow. *)
     eval_func c.modul (table c x (Int32.to_int i @@ e1.at)) vs
 
-  | Return eo ->
-    raise (c.return (eval_expr_option c eo))
-
   | GetLocal x ->
     Some !(local c x)
 
@@ -261,13 +257,11 @@ and eval_arm c vo stage arm =
     stage
 
 and eval_func (m : instance) (f : func) (evs : value list) =
-  let module Return = MakeLabel () in
   let args = List.map ref evs in
   let vars = List.map (fun t -> ref (default_value t.it)) f.it.locals in
   let locals = args @ vars in
-  let c = {modul = m; locals; labels = []; return = Return.label} in
-  try eval_expr c f.it.body
-  with Return.Label vo -> vo
+  let c = {modul = m; locals; labels = []} in
+  eval_expr c f.it.body
 
 
 (* Modules *)

ml-proto/test/memory.wase

@@ -86,7 +86,7 @@
       (loop
         (if
           (i32.eq (get_local 0) (i32.const 0))
-          (break)
+          (break 0)
         )
         (set_local 2 (i32.mul (get_local 0) (i32.const 4)))
         (i32.store (get_local 2) (get_local 0))
@@ -109,7 +109,7 @@
       (loop
         (if
           (i32.eq (get_local 0) (i32.const 0))
-          (break)
+          (break 0)
         )
         (set_local 2 (f64.convert_s/i32 (get_local 0)))
         (f64.store/1 (get_local 0) (get_local 2))

ml-proto/test/switch.wase

@@ -10,8 +10,8 @@
         (case 0 (return (get_local $i)))
         (case 1 (nop) fallthrough)
         (case 2)  ;; implicit fallthrough
-        (case 3 (set_local $j (i32.sub (i32.const 0) (get_local $i))) (break))
-        (case 4 (break))
+        (case 3 (set_local $j (i32.sub (i32.const 0) (get_local $i))) (break 0))
+        (case 4 (break 0))
         (case 5 (set_local $j (i32.const 101)))
         (case 6 (set_local $j (i32.const 101)) fallthrough)
         (;default;) (set_local $j (i32.const 102))