diff --git a/ml-proto/README.md b/ml-proto/README.md index 33e6d55689..66d9f1f9ca 100644 --- a/ml-proto/README.md +++ b/ml-proto/README.md @@ -165,13 +165,15 @@ cvtop: trunc_s | trunc_u | extend_s | extend_u | ... expr: ( nop ) ( block + ) + ( block + ) ;; = (label (block +)) ( if ) - ( if ) ;; = (if (nop)) - ( loop * ) ;; = (loop (block *)) - ( label ? * ) ;; = (label (block *)) + ( if ) ;; = (if (nop)) + ( loop * ) ;; = (loop (block *)) + ( loop ? * ) ;; = (label (loop (block ? *))) + ( label ? ) ( break ? ) - ( break ) ;; = (break 0) ( .switch * ) + ( .switch * ) ;; = (label (.switch * )) ( call * ) ( call_import * ) ( call_indirect * ) diff --git a/ml-proto/src/Makefile b/ml-proto/src/Makefile index 6cfebf08a7..0682f4e498 100644 --- a/ml-proto/src/Makefile +++ b/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 diff --git a/ml-proto/src/host/parser.mly b/ml-proto/src/host/parser.mly index c671035a39..1a401716b5 100644 --- a/ml-proto/src/host/parser.mly +++ b/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} } diff --git a/ml-proto/src/spec/ast.ml b/ml-proto/src/spec/ast.ml index 1605f68b9b..a29340fa43 100644 --- a/ml-proto/src/spec/ast.ml +++ b/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 diff --git a/ml-proto/src/spec/check.ml b/ml-proto/src/spec/check.ml index 1ca52be718..e69f770c4f 100644 --- a/ml-proto/src/spec/check.ml +++ b/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 diff --git a/ml-proto/src/spec/eval.ml b/ml-proto/src/spec/eval.ml index 16eab27afa..3241f9043d 100644 --- a/ml-proto/src/spec/eval.ml +++ b/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 *) diff --git a/ml-proto/test/memory.wase b/ml-proto/test/memory.wase index d2a35f9744..c060b4b4e9 100644 --- a/ml-proto/test/memory.wase +++ b/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)) diff --git a/ml-proto/test/switch.wase b/ml-proto/test/switch.wase index df8f0172fc..1f460a0b2c 100644 --- a/ml-proto/test/switch.wase +++ b/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))