perf(frontend): use verified tail recursive parsing and resolution
2 files changed, +42 −0
- src/Frontend.thy modified +39 −0
- tests/cli.py modified +3 −0
src/Frontend.thy modified
| @@ -8,6 +8,9 @@ fun bind :: "'a result \<Rightarrow> ('a \<Rightarrow> 'b result) \<Rightarrow> | ||
| 8 | 8 | "bind (Error e) f = Error e" |
| 9 | 9 | | "bind (Ok x) f = f x" |
| 10 | 10 | |
| 11 | +lemma bind_assoc: "bind (bind r f) g = bind r (\<lambda>x. bind (f x) g)" | |
| 12 | + by (cases r) auto | |
| 13 | + | |
| 11 | 14 | function decimal :: "nat \<Rightarrow> string" where |
| 12 | 15 | "decimal n = (if n < 10 then [char_of_nat (48 + n)] else decimal (n div 10) @ [char_of_nat (48 + n mod 10)])" |
| 13 | 16 | by pat_completeness auto |
| @@ -47,6 +50,20 @@ fun parse_lines :: "nat \<Rightarrow> string list \<Rightarrow> statement list r | ||
| 47 | 50 | | "parse_lines n (s # ss) = bind (parse_line n (words s)) (\<lambda>xs. |
| 48 | 51 | bind (parse_lines (Suc n) ss) (\<lambda>ys. Ok (xs @ ys)))" |
| 49 | 52 | |
| 53 | +fun parse_acc :: "nat \<Rightarrow> string list \<Rightarrow> statement list \<Rightarrow> statement list result" where | |
| 54 | + "parse_acc n [] acc = Ok (rev acc)" | |
| 55 | +| "parse_acc n (s # ss) acc = (case parse_line n (words s) of Error e \<Rightarrow> Error e | |
| 56 | + | Ok xs \<Rightarrow> parse_acc (Suc n) ss (rev xs @ acc))" | |
| 57 | + | |
| 58 | +lemma parse_acc_correct: | |
| 59 | + "parse_acc n ss acc = bind (parse_lines n ss) (\<lambda>xs. Ok (rev acc @ xs))" | |
| 60 | + by (induction ss arbitrary: n acc) (auto simp: bind_assoc split: result.splits) | |
| 61 | + | |
| 62 | +declare parse_lines.simps [code drop] | |
| 63 | + | |
| 64 | +lemma parse_lines_code [code]: "parse_lines n ss = parse_acc n ss []" | |
| 65 | + by (cases "parse_lines n ss") (simp_all add: parse_acc_correct) | |
| 66 | + | |
| 50 | 67 | fun count :: "statement \<Rightarrow> nat" where |
| 51 | 68 | "count (Label l) = 0" |
| 52 | 69 | | "count (Emit op) = 1" |
| @@ -73,6 +90,28 @@ fun resolve_all :: "(string \<times> nat) list \<Rightarrow> statement list \<Ri | ||
| 73 | 90 | bind (resolve_all env ss) (\<lambda>xs. Ok (x # xs)))" |
| 74 | 91 | | "resolve_all env (Pad n # ss) = bind (resolve_all env ss) (\<lambda>xs. Ok (replicate n Nop @ xs))" |
| 75 | 92 | |
| 93 | +fun resolve_acc :: "(string \<times> nat) list \<Rightarrow> statement list \<Rightarrow> nat instruction list \<Rightarrow> nat instruction list result" where | |
| 94 | + "resolve_acc env [] acc = Ok (rev acc)" | |
| 95 | +| "resolve_acc env (Label l # ss) acc = resolve_acc env ss acc" | |
| 96 | +| "resolve_acc env (Emit op # ss) acc = (case resolve env op of Error e \<Rightarrow> Error e | |
| 97 | + | Ok x \<Rightarrow> resolve_acc env ss (x # acc))" | |
| 98 | +| "resolve_acc env (Pad n # ss) acc = resolve_acc env ss (replicate n Nop @ acc)" | |
| 99 | + | |
| 100 | +lemma resolve_acc_correct: | |
| 101 | + "resolve_acc env ss acc = bind (resolve_all env ss) (\<lambda>xs. Ok (rev acc @ xs))" | |
| 102 | +proof (induction ss arbitrary: acc) | |
| 103 | + case Nil | |
| 104 | + then show ?case by simp | |
| 105 | +next | |
| 106 | + case (Cons s ss) | |
| 107 | + then show ?case by (cases s) (auto simp: bind_assoc split: result.splits) | |
| 108 | +qed | |
| 109 | + | |
| 110 | +declare resolve_all.simps [code drop] | |
| 111 | + | |
| 112 | +lemma resolve_all_code [code]: "resolve_all env ss = resolve_acc env ss []" | |
| 113 | + by (cases "resolve_all env ss") (simp_all add: resolve_acc_correct) | |
| 114 | + | |
| 76 | 115 | definition source :: "string \<Rightarrow> nat instruction list result" where |
| 77 | 116 | "source s = (if \<not> list_all (\<lambda>c. let n = nat_of_char c in |
| 78 | 117 | n = 9 \<or> n = 10 \<or> n = 13 \<or> (32 \<le> n \<and> n < 127)) s |
tests/cli.py modified
| @@ -122,6 +122,9 @@ def main(): | ||
| 122 | 122 | ]: |
| 123 | 123 | check(message in cli("assemble", "-", text=text, ok=False), message) |
| 124 | 124 | check("16-bit range" in cli("assemble", "examples/overflow.span", ok=False), "overflow accepted") |
| 125 | + check("65536 instructions, 65536 bytes" in cli("assemble", "-", text="nop\n" * 65536), "maximum line count") | |
| 126 | + check("invalid instruction at line 4097" in cli("assemble", "-", text="nop\n" * 4096 + "invalid\npad -1", ok=False), "first parse error changed") | |
| 127 | + check("undefined label first" in cli("assemble", "-", text="pad 3\njmp first\njmp second", ok=False), "first resolution error changed") | |
| 125 | 128 | for padding, width in [(127, 2), (128, 3), (32767, 3)]: |
| 126 | 129 | report = cli("assemble", "-", text=f"jmp end\npad {padding}\nlabel end\nhalt") |
| 127 | 130 | check(f"{padding + width + 1} bytes" in report, "forward range boundary") |