A => .gitignore +2 -0
@@ 1,2 @@
+/.build/
+__pycache__/
A => Makefile +23 -0
@@ 1,23 @@
+ISABELLE ?= isabelle
+
+.PHONY: all check payload clean
+
+all: .build/ready
+
+.build/ready: ROOT $(wildcard src/*.thy) cli/driver.ML Makefile
+ @test "$$('$(ISABELLE)' version)" = Isabelle2026
+ "$(ISABELLE)" build -D . -j 1 -o threads=1 -o parallel_proofs=0
+ "$(ISABELLE)" export -n -d . -O .build -x 'Remy.Export:code/remy.ML' Remy
+ REMY_ROOT="$(CURDIR)" "$$('$(ISABELLE)' getenv -b POLYML_HOME)/$$('$(ISABELLE)' getenv -b ISABELLE_PLATFORM64)/polyc" -o .build/remy cli/driver.ML
+ @touch $@
+
+check: all
+ python3 tests/native.py
+
+payload: all
+ @mkdir -p .build/payload
+ @set -e; for name in Rings Weave Cells; do .build/remy examples/$$name.remy .build/payload/$$name.BIN; .build/remy vectors examples/$$name.remy .build/payload/$$name.DAT; cp examples/$$name.remy .build/payload/$$name.TXT; done
+ cp guest/Remy.HC .build/payload/Remy.HC
+
+clean:
+ rm -rf .build
A => README.md +36 -0
@@ 1,36 @@
+Pixel expressions compile to native x86+64 for TempleOS through a compiler implemented in Isabelle/HOL with proofs of constant folding, lexical slot allocation, bounded stack execution and correspondence with a register and stack model
+
+[](media/demo.mp4)
+
+## Build
+
+```sh
+make check
+make payload
+```
+
+It uses:
+- Isabelle2026 and its bundled Poly/ML toolchain
+- Python
+
+Copy these files onto `C:/` in TempleOS and run:
+
+```c
+#include "C:/Remy.HC";
+Verify;
+Show(0);
+```
+
+## Correctness
+
+Each `let` pushes a binding onto the evaluation stack. [Compilation](src/Compiler.thy) adjusts variable offsets as intermediate values accumulate above those bindings and proves that execution leaves the result followed by the original stack whereas accepted programs stay within 512 evaluation words at every instruction boundary
+
+[Native lowering](src/Native.thy) puts the result in `rax` and preserves `r8`, `r9` and `rdx` which carry `x`, `y` and `t`. The temporary registers are `rax`, `rcx` and `rbx` while the [Encoding](src/Encoding.thy) proves decoder inversion and byte bounds for the emitted blocks including their immediate operands and stack displacements
+
+
+
+Arithmetic wraps modulo `2^64` and shifts mask their count to six bits
+
+Both branches of a nonconstant conditional run before selection which preserves the result because expressions have no side effects. The HolyC runner masks each pixel result to four bits for the TempleOS palette
+
+The execution theorem is relative to the instruction block model. Actual x86 execution + the HolyC calling bridge and the extracted runtime and the OS are outside its scope. Tests compare emitted code against an independent evaluator on Linux and against HOL results inside the recorded TempleOS guest
A => ROOT +18 -0
@@ 1,18 @@
+session Remybase = HOL +
+ options [document = false]
+ sessions "HOL-Library"
+ theories
+ "HOL-Library.Word"
+ "HOL-Library.Code_Target_Numeral"
+
+session Remy in src = Remybase +
+ options [document = false]
+ sessions "HOL-Library"
+ theories
+ Model
+ Compiler
+ Native
+ Encoding
+ Frontend
+ Examples
+ Export
A => cli/driver.ML +40 -0
@@ 1,40 @@
+val root = valOf (OS.Process.getEnv "REMY_ROOT");
+val _ = use (root ^ "/.build/Remy.Export/code/remy.ML");
+
+fun chars s = map (Remy.ascii o IntInf.fromInt o Char.ord) (String.explode s);
+fun text cs = String.implode (map (Char.chr o IntInf.toInt o Remy.ordinal) cs);
+
+fun read path =
+ let
+ val stream = TextIO.openIn path
+ val input = TextIO.inputN (stream, 65537)
+ handle exn => (TextIO.closeIn stream; raise exn)
+ val _ = TextIO.closeIn stream
+ in
+ if size input > 65536 then raise Fail "source exceeds 64 KiB" else chars input
+ end;
+
+fun write path bytes =
+ let
+ val stream = BinIO.openOut path
+ in
+ (BinIO.output (stream, Byte.stringToBytes (text bytes)); BinIO.closeOut stream)
+ handle exn => ((BinIO.closeOut stream handle _ => ()); raise exn)
+ end;
+
+fun output (ok, message) =
+ (TextIO.output (if ok then TextIO.stdOut else TextIO.stdErr, text message);
+ if ok then () else OS.Process.exit OS.Process.failure);
+
+fun main () =
+ (case CommandLine.arguments () of
+ ["vectors", source, destination] =>
+ (case Remy.vectors (read source) of (true, bytes) => write destination bytes | result => output result)
+ | ["eval", source, x, y, t] => output (Remy.reference (read source) (chars x) (chars y) (chars t))
+ | [source, destination] =>
+ let val ((ok, bytes), report) = Remy.artifact (read source)
+ in if ok then (write destination bytes; output (true,report)) else output (false,report) end
+ | _ => raise Fail "usage: remy source binary | remy vectors source data | remy eval source x y t")
+ handle exn =>
+ (TextIO.output (TextIO.stdErr, "remy: " ^ General.exnMessage exn ^ "\n");
+ OS.Process.exit OS.Process.failure);
A => examples/Cells.remy +5 -0
@@ 1,5 @@
+(let u (+ x (shr t 2))
+ (let cell (xor (shr u 4) (shr y 4))
+ (if (< (and cell 3) 1)
+ (and (+ (xor u y) t) 15)
+ (and (shr (+ (* u u) (* y y)) 7) 15))))
A => examples/Rings.remy +4 -0
@@ 1,4 @@
+(let dx (- x 80)
+ (let dy (- y 56)
+ (let radius (+ (* dx dx) (* dy dy))
+ (and (shr (+ radius (* t 32)) 6) 15))))
A => examples/Weave.remy +3 -0
@@ 1,3 @@
+(let drift (+ y (shr t 1))
+ (let warp (xor (* x drift) (* (+ x t) y))
+ (and (xor (shr warp 5) (shr (+ x drift) 3)) 15)))
A => guest/Remy.HC +93 -0
@@ 1,93 @@
+asm {
+_REMY::
+ PUSH RBP
+ MOV RBP,RSP
+ MOV RAX,U64 SF_ARG1[RBP]
+ MOV R8,U64 SF_ARG2[RBP]
+ MOV R9,U64 SF_ARG3[RBP]
+ MOV RDX,U64 SF_ARG4[RBP]
+ CALL RAX
+ POP RBP
+ RET1 32
+}
+
+_extern _REMY U64 Pixel(U8 *code,U64 x,U64 y,U64 t);
+
+U8 *names[3]={"Rings","Weave","Cells"};
+CDC *image=NULL;
+U8 *shader=NULL;
+U8 *program=NULL;
+I64 selected;
+
+U0 Verify()
+{
+ I64 i,j,size,total=0;
+ U8 *code,path[64];
+ U64 *rows;
+ for (i=0;i<3;i++) {
+ StrPrint(path,"C:/%s.BIN",names[i]);
+ code=FileRead(path,&size);
+ if (!code) throw('Code');
+ "%-6s %d bytes ",names[i],size;
+ StrPrint(path,"C:/%s.DAT",names[i]);
+ rows=FileRead(path,&size);
+ if (!rows || size!=16384) throw('Vectors');
+ for (j=0;j<size/32;j++) {
+ if (Pixel(code,rows[4*j],rows[4*j+1],rows[4*j+2])!=rows[4*j+3]) {
+ throw('Mismatch');
+ }
+ total++;
+ }
+ "%d comparisons passed\n",size/32;
+ Free(rows);
+ Free(code);
+ }
+ "native results match HOL evaluation (%d cases)\n",total;
+}
+
+U0 Draw(CTask *,CDC *dc)
+{
+ dc->color=BLUE;
+ GrPrint(dc,80,24,"remy %s",names[selected]);
+ dc->color=BLACK;
+ GrBlot(dc,80,64,image);
+ GrPrint(dc,80,416,"%s",program);
+}
+
+U0 Show(I64 which=0)
+{
+ I64 x,y,dy,t=0;
+ U8 color,path[64];
+ if (!(0<=which<3)) return;
+ selected=which;
+ StrPrint(path,"C:/%s.BIN",names[which]);
+ shader=FileRead(path);
+ if (!shader) throw('Code');
+ StrPrint(path,"C:/%s.TXT",names[which]);
+ program=FileRead(path);
+ if (!program) throw('Source');
+ image=DCNew(480,336);
+ SettingsPush;
+ AutoComplete(OFF);
+ WinMax;
+ DocClear;
+ Fs->draw_it=&Draw;
+ while (!ScanChar) {
+ for (y=0;y<112;y++) {
+ for (x=0;x<160;x++) {
+ color=Pixel(shader,x,y,t)&15;
+ for (dy=0;dy<3;dy++)
+ MemSet(image->body+(3*y+dy)*480+3*x,color,3);
+ }
+ }
+ t+=2;
+ Refresh;
+ Sleep(20);
+ }
+ Fs->draw_it=NULL;
+ SettingsPop;
+ DCDel(image);
+ Free(shader);
+ Free(program);
+ DocClear;
+}
A => media/correspondence.svg +17 -0
@@ 1,17 @@
+<svg xmlns="http://www.w3.org/2000/svg" width="720" height="208" viewBox="0 0 720 208">
+ <defs><marker id="arrow" viewBox="0 0 10 10" refX="9" refY="5" markerWidth="6" markerHeight="6" orient="auto-start-reverse"><path d="M 0 0 L 10 5 L 0 10 z" fill="#555"/></marker></defs>
+ <rect width="720" height="208" fill="white"/>
+ <g fill="none" stroke="#555" stroke-width="1.5" marker-end="url(#arrow)">
+ <path d="M 176 45 H 547"/><path d="M 140 64 V 143"/><path d="M 582 64 V 143"/><path d="M 176 164 H 547"/>
+ </g>
+ <g fill="white" stroke="#555">
+ <rect x="62" y="25" width="114" height="40" rx="3"/><rect x="547" y="25" width="113" height="40" rx="3"/>
+ <rect x="38" y="144" width="138" height="40" rx="3"/><rect x="547" y="144" width="138" height="40" rx="3"/>
+ </g>
+ <g font-family="monospace" font-size="14" fill="#222" text-anchor="middle">
+ <text x="119" y="50">expression</text><text x="603" y="50">64-bit value</text>
+ <text x="107" y="169">x86 blocks</text><text x="616" y="169">RAX + stack</text>
+ <text x="360" y="35">source evaluation</text><text x="360" y="153">native block execution</text>
+ <text x="360" y="106">optimisation + lexical slots + encoding</text>
+ </g>
+</svg>
A => media/demo.gif +0 -0
A => media/demo.mp4 +0 -0
A => media/poster.png +0 -0
A => src/Compiler.thy +237 -0
@@ 1,237 @@
+theory Compiler
+ imports Model
+begin
+
+datatype instruction = Constant pixel | Fetch input | Pick nat | Calculate operator | Choose | Slide
+
+fun step :: "(input \<Rightarrow> pixel) \<Rightarrow> instruction \<Rightarrow> pixel list \<Rightarrow> pixel list option" where
+ "step inputs (Constant v) s = Some (v # s)"
+| "step inputs (Fetch i) s = Some (inputs i # s)"
+| "step inputs (Pick i) s = (if i < length s then Some (s ! i # s) else None)"
+| "step inputs (Calculate op) (b # a # s) = Some (operate op a b # s)"
+| "step inputs Choose (b # a # c # s) = Some ((if c = 0 then b else a) # s)"
+| "step inputs Slide (b # a # s) = Some (b # s)"
+| "step inputs _ _ = None"
+
+fun execute :: "(input \<Rightarrow> pixel) \<Rightarrow> instruction list \<Rightarrow> pixel list \<Rightarrow> pixel list option" where
+ "execute inputs [] s = Some s"
+| "execute inputs (i # code) s = (case step inputs i s of None \<Rightarrow> None | Some t \<Rightarrow> execute inputs code t)"
+
+lemma execute_append:
+ "execute inputs (a @ b) s = Option.bind (execute inputs a s) (execute inputs b)"
+ by (induction a arbitrary: s) (auto split: option.splits bind_splits)
+
+fun compile :: "expression \<Rightarrow> nat list \<Rightarrow> instruction list" where
+ "compile (Literal v) slots = [Constant v]"
+| "compile (Input i) slots = [Fetch i]"
+| "compile (Variable i) slots = [Pick (slots ! i)]"
+| "compile (Binary op a b) slots = compile a slots @ compile b (map Suc slots) @ [Calculate op]"
+| "compile (Cond c a b) slots = compile c slots @ compile a (map Suc slots) @
+ compile b (map (\<lambda>i. Suc (Suc i)) slots) @ [Choose]"
+| "compile (Let a b) slots = compile a slots @ compile b (0 # map Suc slots) @ [Slide]"
+
+definition represents :: "nat list \<Rightarrow> pixel list \<Rightarrow> pixel list \<Rightarrow> bool" where
+ "represents slots s env \<longleftrightarrow> length slots = length env \<and>
+ (\<forall>i < length env. slots ! i < length s \<and> s ! (slots ! i) = env ! i)"
+
+lemma represents_push:
+ "represents slots s env \<Longrightarrow> represents (map Suc slots) (v # s) env"
+ by (auto simp: represents_def)
+
+lemma represents_push_two:
+ "represents slots s env \<Longrightarrow> represents (map (\<lambda>i. Suc (Suc i)) slots) (a # b # s) env"
+ by (auto simp: represents_def)
+
+lemma represents_bind:
+ "represents slots s env \<Longrightarrow> represents (0 # map Suc slots) (v # s) (v # env)"
+ by (auto simp: represents_def nth_Cons split: nat.splits)
+
+theorem compile_correct:
+ assumes "scoped (length env) e" "represents slots s env"
+ shows "execute inputs (compile e slots) s = Some (evaluate e env inputs # s)"
+ using assms
+proof (induction e arbitrary: slots s env)
+ case (Literal v)
+ then show ?case by simp
+next
+ case (Input i)
+ then show ?case by simp
+next
+ case (Variable i)
+ then show ?case by (simp add: represents_def)
+next
+ case (Binary op a b)
+ have a: "execute inputs (compile a slots) s = Some (evaluate a env inputs # s)"
+ using Binary.IH(1) Binary.prems by simp
+ have b: "execute inputs (compile b (map Suc slots)) (evaluate a env inputs # s) =
+ Some (evaluate b env inputs # evaluate a env inputs # s)"
+ using Binary.IH(2) Binary.prems represents_push by simp
+ show ?case by (simp add: execute_append a b)
+next
+ case (Cond c a b)
+ have c: "execute inputs (compile c slots) s = Some (evaluate c env inputs # s)"
+ using Cond.IH(1) Cond.prems by simp
+ have a: "execute inputs (compile a (map Suc slots)) (evaluate c env inputs # s) =
+ Some (evaluate a env inputs # evaluate c env inputs # s)"
+ using Cond.IH(2) Cond.prems represents_push by simp
+ have b: "execute inputs (compile b (map (\<lambda>i. Suc (Suc i)) slots))
+ (evaluate a env inputs # evaluate c env inputs # s) =
+ Some (evaluate b env inputs # evaluate a env inputs # evaluate c env inputs # s)"
+ using Cond.IH(3) Cond.prems represents_push_two by simp
+ show ?case by (simp add: execute_append c a b)
+next
+ case (Let a b)
+ have a: "execute inputs (compile a slots) s = Some (evaluate a env inputs # s)"
+ using Let.IH(1) Let.prems by simp
+ have b: "execute inputs (compile b (0 # map Suc slots)) (evaluate a env inputs # s) =
+ Some (evaluate b (evaluate a env inputs # env) inputs # evaluate a env inputs # s)"
+ using Let.IH(2) Let.prems represents_bind by simp
+ show ?case by (simp add: execute_append a b)
+qed
+
+corollary compile_closed:
+ "scoped 0 e \<Longrightarrow> execute inputs (compile (optimise e) []) [] = Some [evaluate e [] inputs]"
+ using compile_correct[where e="optimise e" and env="[]" and slots="[]" and s="[]" and inputs=inputs]
+ by (simp add: represents_def optimise_correct optimise_scoped)
+
+fun height :: "instruction \<Rightarrow> nat \<Rightarrow> nat option" where
+ "height (Constant v) n = Some (Suc n)"
+| "height (Fetch i) n = Some (Suc n)"
+| "height (Pick i) n = (if i < n then Some (Suc n) else None)"
+| "height (Calculate op) n = (if 2 \<le> n then Some (n - 1) else None)"
+| "height Choose n = (if 3 \<le> n then Some (n - 2) else None)"
+| "height Slide n = (if 2 \<le> n then Some (n - 1) else None)"
+
+fun check :: "instruction list \<Rightarrow> nat \<Rightarrow> nat option" where
+ "check [] n = Some n"
+| "check (i # code) n = Option.bind (height i n) (check code)"
+
+lemma check_append:
+ "check (a @ b) n = Option.bind (check a n) (check b)"
+ by (induction a arbitrary: n) (auto split: option.splits bind_splits)
+
+lemma step_height:
+ "height i (length s) = Some n \<Longrightarrow> \<exists>t. step inputs i s = Some t \<and> length t = n"
+ by (cases i; cases s; simp; rename_tac a xs; case_tac xs; simp;
+ rename_tac b ys; case_tac ys; auto split: if_splits)
+
+theorem check_sound:
+ "check code (length s) = Some n \<Longrightarrow> \<exists>t. execute inputs code s = Some t \<and> length t = n"
+proof (induction code arbitrary: s)
+ case Nil
+ then show ?case by simp
+next
+ case (Cons i code)
+ then obtain m where h: "height i (length s) = Some m" and c: "check code m = Some n"
+ by (auto simp: bind_eq_Some_conv)
+ obtain t where step: "step inputs i s = Some t" and len: "length t = m"
+ using step_height[OF h] by blast
+ obtain u where run: "execute inputs code t = Some u" and "length u = n"
+ using Cons.IH c len by blast
+ then show ?case using step by simp
+qed
+
+fun demand :: "expression \<Rightarrow> nat" where
+ "demand (Binary op a b) = max (demand a) (Suc (demand b))"
+| "demand (Cond c a b) = max (demand c) (max (Suc (demand a)) (2 + demand b))"
+| "demand (Let a b) = max (demand a) (Suc (demand b))"
+| "demand _ = 1"
+
+lemma demand_positive: "0 < demand e"
+ by (induction e) auto
+
+fun bounded :: "nat \<Rightarrow> instruction list \<Rightarrow> nat \<Rightarrow> bool" where
+ "bounded limit [] n = (n \<le> limit)"
+| "bounded limit (i # code) n = (n \<le> limit \<and> (case height i n of None \<Rightarrow> False | Some m \<Rightarrow> bounded limit code m))"
+
+lemma bounded_start: "bounded limit code n \<Longrightarrow> n \<le> limit"
+ by (cases code) auto
+
+lemma bounded_append:
+ "bounded limit (a @ b) n \<longleftrightarrow> bounded limit a n \<and> (\<exists>m. check a n = Some m \<and> bounded limit b m)"
+ by (induction a arbitrary: n) (auto dest: bounded_start split: option.splits bind_splits)
+
+lemma bounded_check:
+ "bounded limit code n \<Longrightarrow> \<exists>m. check code n = Some m \<and> m \<le> limit"
+ by (induction code arbitrary: n) (auto split: option.splits bind_splits)
+
+theorem compiled_height:
+ "scoped (length slots) e \<Longrightarrow> list_all (\<lambda>i. i < n) slots \<Longrightarrow>
+ check (compile e slots) n = Some (Suc n)"
+proof (induction e arbitrary: slots n)
+ case (Literal v)
+ then show ?case by simp
+next
+ case (Input i)
+ then show ?case by simp
+next
+ case (Variable i)
+ then show ?case by (simp add: list_all_length)
+next
+ case (Binary op a b)
+ then show ?case
+ by (simp add: check_append list_all_iff)
+next
+ case (Cond c a b)
+ then show ?case by (simp add: check_append list_all_iff)
+next
+ case (Let a b)
+ then show ?case by (simp add: check_append list_all_iff)
+qed
+
+fun snapshots :: "(input \<Rightarrow> pixel) \<Rightarrow> instruction list \<Rightarrow> pixel list \<Rightarrow> (pixel list list) option" where
+ "snapshots inputs [] s = Some [s]"
+| "snapshots inputs (i # code) s = Option.bind (step inputs i s)
+ (\<lambda>t. map_option ((#) s) (snapshots inputs code t))"
+
+lemma snapshots_nonempty:
+ "snapshots inputs code s = Some frames \<Longrightarrow> frames \<noteq> []"
+ by (cases code) (auto split: bind_splits option.splits)
+
+theorem snapshots_execute:
+ "snapshots inputs code s = Some frames \<Longrightarrow> execute inputs code s = Some (last frames)"
+proof (induction code arbitrary: s frames)
+ case Nil
+ then show ?case by auto
+next
+ case (Cons i code)
+ then obtain t rest where step: "step inputs i s = Some t"
+ and tail: "snapshots inputs code t = Some rest" and frames: "frames = s # rest"
+ by (auto split: bind_splits option.splits)
+ have "rest \<noteq> []" using snapshots_nonempty[OF tail] .
+ then show ?case using Cons.IH[OF tail] step frames by simp
+qed
+
+theorem bounded_execution:
+ "bounded limit code (length s) \<Longrightarrow>
+ \<exists>frames. snapshots inputs code s = Some frames \<and> list_all (\<lambda>t. length t \<le> limit) frames"
+proof (induction code arbitrary: s)
+ case Nil
+ then show ?case by simp
+next
+ case (Cons i code)
+ then obtain m where bound: "length s \<le> limit" and h: "height i (length s) = Some m"
+ and tail: "bounded limit code m"
+ by (auto split: option.splits)
+ obtain t where step: "step inputs i s = Some t" and len: "length t = m"
+ using step_height[OF h] by blast
+ obtain frames where trace: "snapshots inputs code t = Some frames"
+ and safe: "list_all (\<lambda>t. length t \<le> limit) frames"
+ using Cons.IH tail len by blast
+ show ?case using step trace safe bound by auto
+qed
+
+corollary bounded_result:
+ "bounded limit code (length s) \<Longrightarrow>
+ \<exists>t. execute inputs code s = Some t \<and> length t \<le> limit"
+proof -
+ assume bound: "bounded limit code (length s)"
+ obtain frames where trace: "snapshots inputs code s = Some frames"
+ and safe: "list_all (\<lambda>t. length t \<le> limit) frames"
+ using bounded_execution[OF bound] by blast
+ have "frames \<noteq> []" using snapshots_nonempty[OF trace] .
+ then have "length (last frames) \<le> limit" using safe by (simp add: list_all_iff)
+ then show ?thesis using snapshots_execute[OF trace] by blast
+qed
+
+end
A => src/Encoding.thy +158 -0
@@ 1,158 @@
+theory Encoding
+ imports Native
+begin
+
+fun octets :: "nat \<Rightarrow> nat \<Rightarrow> nat list" where
+ "octets 0 n = []"
+| "octets (Suc k) n = n mod 256 # octets k (n div 256)"
+
+fun integer :: "nat list \<Rightarrow> nat" where
+ "integer [] = 0"
+| "integer (b # bs) = b + 256 * integer bs"
+
+lemma octets_length [simp]: "length (octets k n) = k"
+ by (induction k arbitrary: n) auto
+
+lemma octets_bytes: "set (octets k n) \<subseteq> {..<256}"
+ by (induction k arbitrary: n) auto
+
+lemma integer_octets: "integer (octets k n) = n mod 256 ^ k"
+ by (induction k arbitrary: n) (simp_all add: power_Suc mod_mult2_eq add.commute)
+
+lemma literal_bound: "unat (v :: pixel) < 256 ^ 8"
+ using unsigned_less[of v, where ?'a=nat] by simp
+
+lemma integer_literal [simp]: "word_of_nat (integer (octets 8 (unat v))) = (v :: pixel)"
+ using literal_bound[of v] by (simp add: integer_octets)
+
+fun pushcode :: "register \<Rightarrow> nat list" where
+ "pushcode Rax = [80]"
+| "pushcode Rcx = [81]"
+| "pushcode Rbx = [83]"
+| "pushcode Rdx = [82]"
+| "pushcode R8 = [65,80]"
+| "pushcode R9 = [65,81]"
+
+fun popcode :: "register \<Rightarrow> nat list" where
+ "popcode Rax = [88]"
+| "popcode Rcx = [89]"
+| "popcode Rbx = [91]"
+| "popcode Rdx = [90]"
+| "popcode R8 = [65,88]"
+| "popcode R9 = [65,89]"
+
+fun arithmetic :: "operator \<Rightarrow> nat list" where
+ "arithmetic Add = [72,1,200]"
+| "arithmetic Sub = [72,145,72,41,200]"
+| "arithmetic Mul = [72,15,175,193]"
+| "arithmetic And = [72,33,200]"
+| "arithmetic Or = [72,9,200]"
+| "arithmetic Xor = [72,49,200]"
+| "arithmetic Shl = [72,145,72,211,224]"
+| "arithmetic Shr = [72,145,72,211,232]"
+| "arithmetic Less = [72,145,72,57,200,15,146,192,72,15,182,192]"
+
+fun encode :: "opcode \<Rightarrow> nat list" where
+ "encode (Immediate v) = [72,184] @ octets 8 (unat v)"
+| "encode (Push r) = pushcode r"
+| "encode (Pop r) = popcode r"
+| "encode (Peek i) = [72,139,132,36] @ octets 4 (8 * i)"
+| "encode (Arithmetic op) = arithmetic op"
+| "encode Conditional = [72,133,219,72,15,69,193]"
+
+fun encodable :: "opcode \<Rightarrow> bool" where
+ "encodable (Peek i) = (i < 2 ^ 28)"
+| "encodable _ = True"
+
+definition fixed :: "opcode list" where
+ "fixed = map Push [Rax,Rcx,Rbx,Rdx,R8,R9] @ map Pop [Rax,Rcx,Rbx,Rdx,R8,R9] @
+ map Arithmetic [Add,Sub,Mul,And,Or,Xor,Shl,Shr,Less] @ [Conditional]"
+
+definition decode :: "nat list \<Rightarrow> (opcode \<times> nat list) option" where
+ "decode bs = (if take 2 bs = [72,184] then
+ if 10 \<le> length bs \<and> list_all (\<lambda>b. b < 256) (take 8 (drop 2 bs)) then
+ Some (Immediate (word_of_nat (integer (take 8 (drop 2 bs)))), drop 10 bs) else None
+ else if take 4 bs = [72,139,132,36] then
+ let n = integer (take 4 (drop 4 bs)) in
+ if 8 \<le> length bs \<and> list_all (\<lambda>b. b < 256) (take 4 (drop 4 bs)) \<and>
+ n mod 8 = 0 \<and> n div 8 < 2 ^ 28 then Some (Peek (n div 8), drop 8 bs) else None
+ else map_option (\<lambda>op. (op, drop (length (encode op)) bs))
+ (List.find (\<lambda>op. take (length (encode op)) bs = encode op) fixed))"
+
+lemma octets_all [simp]: "list_all (\<lambda>b. b < 256) (octets k n)"
+ using octets_bytes[of k n] by (auto simp: list_all_iff)
+
+lemma peek_bound:
+ "(i :: nat) < 2 ^ 28 \<Longrightarrow> 8 * i < 256 ^ 4"
+ by (simp; linarith)
+
+theorem decode_encode:
+ assumes valid: "encodable op"
+ shows "decode (encode op @ tail) = Some (op, tail)"
+proof (cases op)
+ case (Immediate v)
+ then show ?thesis
+ by (simp add: decode_def take_add integer_literal)
+next
+ case (Push r)
+ then show ?thesis by (cases r) (simp_all add: decode_def fixed_def)
+next
+ case (Pop r)
+ then show ?thesis by (cases r) (simp_all add: decode_def fixed_def)
+next
+ case (Peek i)
+ have small: "i < 2 ^ 28" using valid Peek by simp
+ have bound: "8 * i < 4294967296" using peek_bound[OF small] by simp
+ show ?thesis using Peek small bound
+ by (simp add: decode_def integer_octets Let_def)
+next
+ case (Arithmetic op)
+ then show ?thesis by (cases op) (simp_all add: decode_def fixed_def)
+next
+ case Conditional
+ then show ?thesis by (simp add: decode_def fixed_def)
+qed
+
+theorem encode_bytes: "set (encode op) \<subseteq> {..<256}"
+proof (cases op)
+ case (Immediate v)
+ then show ?thesis using octets_bytes by auto
+next
+ case (Push r)
+ then show ?thesis by (cases r) auto
+next
+ case (Pop r)
+ then show ?thesis by (cases r) auto
+next
+ case (Peek i)
+ then show ?thesis using octets_bytes by auto
+next
+ case (Arithmetic op)
+ then show ?thesis by (cases op) auto
+next
+ case Conditional
+ then show ?thesis by simp
+qed
+
+theorem encode_injective:
+ "encodable a \<Longrightarrow> encodable b \<Longrightarrow> encode a = encode b \<longleftrightarrow> a = b"
+ using decode_encode[of a "[]"] decode_encode[of b "[]"]
+ by (metis append_Nil option.inject prod.inject)
+
+fun recover :: "nat \<Rightarrow> nat list \<Rightarrow> (opcode list \<times> nat list) option" where
+ "recover 0 bs = Some ([],bs)"
+| "recover (Suc n) bs = Option.bind (decode bs) (\<lambda>(op,tail).
+ map_option (\<lambda>(ops,rest). (op # ops,rest)) (recover n tail))"
+
+theorem recover_encode:
+ "list_all encodable ops \<Longrightarrow>
+ recover (length ops) (concat (map encode ops) @ tail) = Some (ops,tail)"
+ by (induction ops) (simp_all add: decode_encode)
+
+definition executable :: "expression \<Rightarrow> nat list" where
+ "executable e = concat (map encode (native (compile (optimise e) []))) @ [88,195]"
+
+theorem executable_bytes: "set (executable e) \<subseteq> {..<256}"
+ unfolding executable_def using encode_bytes by auto
+
+end
A => src/Examples.thy +71 -0
@@ 1,71 @@
+theory Examples
+ imports Frontend
+begin
+
+lemma overflow: "operate Add (-1) 1 = 0"
+ by eval
+
+lemma multiply_overflow: "operate Mul (2 ^ 63) 2 = 0"
+ by eval
+
+lemma shift_mask: "operate Shl 7 64 = 7"
+ by eval
+
+lemma shift_wrap: "operate Shl 7 65 = 14"
+ by eval
+
+lemma logical_shift: "operate Shr (-1) 63 = 1"
+ by eval
+
+lemma unsigned_comparison: "operate Less (-1) 1 = 0"
+ by eval
+
+lemma unsigned_high_bit: "operate Less 1 (2 ^ 63) = 1"
+ by eval
+
+lemma constant_fold:
+ "optimise (Binary Add (Literal (-1)) (Literal 1)) = Literal 0"
+ by eval
+
+lemma dead_branch:
+ "optimise (Cond (Literal 0) (Input X) (Input Y)) = Input Y"
+ by eval
+
+lemma literal_code:
+ "executable (Literal 42) = [72,184,42,0,0,0,0,0,0,0,80,88,195]"
+ by eval
+
+lemma opcode_roundtrip:
+ "decode [72,145,72,211,232,195] = Some (Arithmetic Shr,[195])"
+ by eval
+
+lemma truncated_literal: "decode [72,184,0,0] = None"
+ by eval
+
+lemma unaligned_slot: "decode [72,139,132,36,1,0,0,0] = None"
+ by eval
+
+lemma negative_slot: "decode [72,139,132,36,0,0,0,128] = None"
+ by eval
+
+lemma lexical_shadow:
+ "reference ''(let x 7 (let x (+ x 2) (* x x)))'' ''1'' ''2'' ''3'' = (True,''81'' @ newline)"
+ by eval
+
+lemma nested_temporaries:
+ "reference ''(+ 10 (let a 3 (+ a (let b 4 (* a b)))))'' ''0'' ''0'' ''0'' = (True,''25'' @ newline)"
+ by eval
+
+lemma unbound_rejected: "prepare ''(let a 3 b)'' = None"
+ by eval
+
+lemma trailing_rejected: "prepare ''(+ x y) 1'' = None"
+ by eval
+
+lemma literal_overflow_rejected: "prepare ''18446744073709551616'' = None"
+ by eval
+
+lemma incomplete_rejected: "prepare ''(if x y)'' = None"
+ by eval
+
+end
A => src/Export.thy +11 -0
@@ 1,11 @@
+theory Export
+ imports Examples
+begin
+
+definition ascii :: "integer \<Rightarrow> char" where "ascii = char_of"
+
+definition ordinal :: "char \<Rightarrow> integer" where "ordinal = of_char"
+
+export_code artifact vectors reference ascii ordinal in SML module_name Remy file_prefix remy
+
+end
A => src/Frontend.thy +137 -0
@@ 1,137 @@
+theory Frontend
+ imports Encoding
+begin
+
+fun finish :: "string \<Rightarrow> string list \<Rightarrow> string list" where
+ "finish [] out = out"
+| "finish word out = rev word # out"
+
+fun lex :: "string \<Rightarrow> string \<Rightarrow> string list \<Rightarrow> string list" where
+ "lex [] word out = rev (finish word out)"
+| "lex (c # cs) word out = (if c = CHR '' '' \<or> c = CHR 0x09 \<or> c = CHR 0x0A \<or> c = CHR 0x0D
+ then lex cs [] (finish word out)
+ else if c = CHR ''('' \<or> c = CHR '')'' then lex cs [] ([c] # finish word out)
+ else lex cs (c # word) out)"
+
+definition number :: "string \<Rightarrow> nat option" where
+ "number s = (if s = [] \<or> \<not> list_all (\<lambda>c. 48 \<le> nat_of_char c \<and> nat_of_char c < 58) s
+ then None else let n = foldl (\<lambda>n c. min (2 ^ 64) (10 * n + nat_of_char c - 48)) 0 s in
+ if n < 2 ^ 64 then Some n else None)"
+
+definition valid_name :: "string \<Rightarrow> bool" where
+ "valid_name s = (s \<noteq> [] \<and> list_all (\<lambda>c. (97 \<le> nat_of_char c \<and> nat_of_char c \<le> 122)) s
+ \<and> s \<noteq> ''let'' \<and> s \<noteq> ''if'')"
+
+fun lookup :: "string \<Rightarrow> string list \<Rightarrow> nat option" where
+ "lookup name [] = None"
+| "lookup name (x # xs) = (if name = x then Some 0 else map_option Suc (lookup name xs))"
+
+fun operator :: "string \<Rightarrow> operator option" where
+ "operator s = (if s = ''+'' then Some Add else if s = ''-'' then Some Sub else if s = ''*'' then Some Mul
+ else if s = ''and'' then Some And else if s = ''or'' then Some Or else if s = ''xor'' then Some Xor
+ else if s = ''shl'' then Some Shl else if s = ''shr'' then Some Shr else if s = ''<'' then Some Less else None)"
+
+definition atom :: "string list \<Rightarrow> string \<Rightarrow> expression option" where
+ "atom names s = (case lookup s names of Some i \<Rightarrow> Some (Variable i) | None \<Rightarrow>
+ if s = ''x'' then Some (Input X) else if s = ''y'' then Some (Input Y) else if s = ''t'' then Some (Input T)
+ else map_option (Literal \<circ> word_of_nat) (number s))"
+
+fun close :: "expression \<Rightarrow> string list \<Rightarrow> (expression \<times> string list) option" where
+ "close e (s # rest) = (if s = '')'' then Some (e,rest) else None)"
+| "close e [] = None"
+
+function parse :: "nat \<Rightarrow> string list \<Rightarrow> string list \<Rightarrow> (expression \<times> string list) option" where
+ "parse fuel names tokens = (if fuel = 0 then None else case tokens of [] \<Rightarrow> None | s # rest \<Rightarrow>
+ if s \<noteq> ''('' then map_option (\<lambda>e. (e,rest)) (atom names s)
+ else case rest of [] \<Rightarrow> None | op # args \<Rightarrow>
+ if op = ''let'' then (case args of [] \<Rightarrow> None | name # body \<Rightarrow>
+ if \<not> valid_name name then None else
+ Option.bind (parse (fuel - 1) names body) (\<lambda>(a,tail).
+ Option.bind (parse (fuel - 1) (name # names) tail) (\<lambda>(b,tail). close (Let a b) tail)))
+ else if op = ''if'' then
+ Option.bind (parse (fuel - 1) names args) (\<lambda>(c,tail).
+ Option.bind (parse (fuel - 1) names tail) (\<lambda>(a,tail).
+ Option.bind (parse (fuel - 1) names tail) (\<lambda>(b,tail). close (Cond c a b) tail)))
+ else Option.bind (operator op) (\<lambda>f.
+ Option.bind (parse (fuel - 1) names args) (\<lambda>(a,tail).
+ Option.bind (parse (fuel - 1) names tail) (\<lambda>(b,tail). close (Binary f a b) tail))))"
+ by pat_completeness auto
+termination by (relation "measure (\<lambda>(fuel,names,tokens). fuel)") auto
+
+definition prepare :: "string \<Rightarrow> expression option" where
+ "prepare s = (if \<not> list_all (\<lambda>c. nat_of_char c < 128) s then None else
+ Option.bind (parse 128 [] (lex s [] [])) (\<lambda>(e,rest).
+ if rest = [] \<and> scoped 0 e \<and> nodes e \<le> 4096 then
+ let code = compile (optimise e) [] in
+ if check code 0 = Some 1 \<and> bounded 512 code 0 \<and> list_all encodable (native code)
+ then Some e else None else None))"
+
+lemma prepare_scoped: "prepare s = Some e \<Longrightarrow> scoped 0 e"
+ by (auto simp: prepare_def Let_def split: if_splits bind_splits prod.splits)
+
+lemma prepare_bounded:
+ "prepare s = Some e \<Longrightarrow> bounded 512 (compile (optimise e) []) 0"
+ by (auto simp: prepare_def Let_def split: if_splits bind_splits prod.splits)
+
+lemma prepare_encodable:
+ "prepare s = Some e \<Longrightarrow> list_all encodable (native (compile (optimise e) []))"
+ by (auto simp: prepare_def Let_def split: if_splits bind_splits prod.splits)
+
+theorem prepared_correct:
+ "prepare source = Some e \<Longrightarrow>
+ execute values (compile (optimise e) []) [] = Some [evaluate e [] values]"
+ using compile_closed prepare_scoped by blast
+
+theorem prepared_native:
+ "prepare source = Some e \<Longrightarrow>
+ map_option observe (run (native (compile (optimise e) [])) s) =
+ Some (inputs s, evaluate e [] (inputs s) # stack s)"
+ using native_expression prepare_scoped by blast
+
+theorem prepared_bytes:
+ "prepare source = Some e \<Longrightarrow>
+ recover (length (native (compile (optimise e) []))) (executable e) =
+ Some (native (compile (optimise e) []), [88,195])"
+ unfolding executable_def using recover_encode prepare_encodable by blast
+
+theorem prepared_stacks:
+ "prepare source = Some e \<Longrightarrow>
+ \<exists>frames. snapshots values (compile (optimise e) []) [] = Some frames \<and>
+ list_all (\<lambda>s. length s \<le> 512) frames"
+ using bounded_execution[where s="[]" and limit=512] prepare_bounded by auto
+
+function decimal :: "nat \<Rightarrow> string" where
+ "decimal n = (if n < 10 then [char_of_nat (48+n)] else decimal (n div 10) @ [char_of_nat (48+n mod 10)])"
+ by pat_completeness auto
+termination by (relation "measure id") (auto simp: div_less_dividend)
+
+definition newline :: string where "newline = [CHR 0x0A]"
+
+definition artifact :: "string \<Rightarrow> (bool \<times> string) \<times> string" where
+ "artifact s = (case prepare s of None \<Rightarrow> ((False,[]), ''invalid source or resource limit'' @ newline)
+ | Some e \<Rightarrow> let opt = optimise e; bytes = executable e in
+ ((True, map char_of_nat bytes), decimal (nodes e) @ '' nodes -> '' @ decimal (nodes opt) @
+ '' nodes, '' @ decimal (length bytes) @ '' bytes, '' @ decimal (demand opt) @ '' stack words'' @ newline))"
+
+definition boundary :: "nat list" where
+ "boundary = [0,1,63,64,65,127,255,256,2 ^ 31,2 ^ 32,2 ^ 63,2 ^ 64 - 1]"
+
+definition sample :: "nat \<Rightarrow> input \<Rightarrow> pixel" where
+ "sample i = (\<lambda>v. word_of_nat (if i < 12 then boundary ! ((i + (case v of X \<Rightarrow> 0 | Y \<Rightarrow> 3 | T \<Rightarrow> 7)) mod 12)
+ else case v of X \<Rightarrow> (17*i) mod 257 | Y \<Rightarrow> (29*i) mod 131 | T \<Rightarrow> 13*i))"
+
+definition row :: "expression \<Rightarrow> nat \<Rightarrow> nat list" where
+ "row e i = concat (map (\<lambda>v. octets 8 (unat v))
+ [sample i X, sample i Y, sample i T, evaluate e [] (sample i)])"
+
+definition vectors :: "string \<Rightarrow> bool \<times> string" where
+ "vectors s = (case prepare s of None \<Rightarrow> (False, ''invalid source or resource limit'' @ newline)
+ | Some e \<Rightarrow> (True, map char_of_nat (concat (map (row e) [0..<512]))))"
+
+definition reference :: "string \<Rightarrow> string \<Rightarrow> string \<Rightarrow> string \<Rightarrow> bool \<times> string" where
+ "reference source x y t = (case (prepare source, number x, number y, number t) of
+ (Some e,Some a,Some b,Some c) \<Rightarrow>
+ (True, decimal (unat (evaluate e [] (\<lambda>v. word_of_nat (case v of X \<Rightarrow> a | Y \<Rightarrow> b | T \<Rightarrow> c)))) @ newline)
+ | _ \<Rightarrow> (False,''invalid source or input'' @ newline))"
+
+end
A => src/Model.thy +97 -0
@@ 1,97 @@
+theory Model
+ imports "HOL-Library.Word" "HOL-Library.Code_Target_Numeral"
+begin
+
+unbundle bit_operations_syntax
+
+type_synonym pixel = "64 word"
+
+datatype input = X | Y | T
+
+datatype operator = Add | Sub | Mul | And | Or | Xor | Shl | Shr | Less
+
+fun operate :: "operator \<Rightarrow> pixel \<Rightarrow> pixel \<Rightarrow> pixel" where
+ "operate Add a b = a + b"
+| "operate Sub a b = a - b"
+| "operate Mul a b = a * b"
+| "operate And a b = a AND b"
+| "operate Or a b = a OR b"
+| "operate Xor a b = a XOR b"
+| "operate Shl a b = push_bit (unat b mod 64) a"
+| "operate Shr a b = drop_bit (unat b mod 64) a"
+| "operate Less a b = (if a < b then 1 else 0)"
+
+datatype expression = Literal pixel | Input input | Variable nat
+ | Binary operator expression expression
+ | Cond expression expression expression
+ | Let expression expression
+
+fun evaluate :: "expression \<Rightarrow> pixel list \<Rightarrow> (input \<Rightarrow> pixel) \<Rightarrow> pixel" where
+ "evaluate (Literal v) env inputs = v"
+| "evaluate (Input i) env inputs = inputs i"
+| "evaluate (Variable i) env inputs = env ! i"
+| "evaluate (Binary op a b) env inputs = operate op (evaluate a env inputs) (evaluate b env inputs)"
+| "evaluate (Cond c a b) env inputs = (if evaluate c env inputs = 0 then evaluate b env inputs else evaluate a env inputs)"
+| "evaluate (Let a b) env inputs = evaluate b (evaluate a env inputs # env) inputs"
+
+fun scoped :: "nat \<Rightarrow> expression \<Rightarrow> bool" where
+ "scoped n (Literal v) = True"
+| "scoped n (Input i) = True"
+| "scoped n (Variable i) = (i < n)"
+| "scoped n (Binary op a b) = (scoped n a \<and> scoped n b)"
+| "scoped n (Cond c a b) = (scoped n c \<and> scoped n a \<and> scoped n b)"
+| "scoped n (Let a b) = (scoped n a \<and> scoped (Suc n) b)"
+
+fun fold_binary :: "operator \<Rightarrow> expression \<Rightarrow> expression \<Rightarrow> expression" where
+ "fold_binary op (Literal a) (Literal b) = Literal (operate op a b)"
+| "fold_binary op a b = Binary op a b"
+
+fun fold_cond :: "expression \<Rightarrow> expression \<Rightarrow> expression \<Rightarrow> expression" where
+ "fold_cond (Literal c) a b = (if c = 0 then b else a)"
+| "fold_cond c a b = Cond c a b"
+
+fun optimise :: "expression \<Rightarrow> expression" where
+ "optimise (Binary op a b) = fold_binary op (optimise a) (optimise b)"
+| "optimise (Cond c a b) = fold_cond (optimise c) (optimise a) (optimise b)"
+| "optimise (Let a b) = Let (optimise a) (optimise b)"
+| "optimise e = e"
+
+lemma fold_binary_value:
+ "evaluate (fold_binary op a b) env inputs = operate op (evaluate a env inputs) (evaluate b env inputs)"
+ by (cases a; cases b) auto
+
+lemma fold_cond_value:
+ "evaluate (fold_cond c a b) env inputs = (if evaluate c env inputs = 0 then evaluate b env inputs else evaluate a env inputs)"
+ by (cases c) auto
+
+theorem optimise_correct:
+ "evaluate (optimise e) env inputs = evaluate e env inputs"
+ by (induction e arbitrary: env) (simp_all add: fold_binary_value fold_cond_value)
+
+lemma fold_binary_scoped:
+ "scoped n a \<Longrightarrow> scoped n b \<Longrightarrow> scoped n (fold_binary op a b)"
+ by (cases a; cases b) auto
+
+lemma fold_cond_scoped:
+ "scoped n c \<Longrightarrow> scoped n a \<Longrightarrow> scoped n b \<Longrightarrow> scoped n (fold_cond c a b)"
+ by (cases c) auto
+
+theorem optimise_scoped: "scoped n e \<Longrightarrow> scoped n (optimise e)"
+ by (induction e arbitrary: n) (auto intro: fold_binary_scoped fold_cond_scoped)
+
+fun nodes :: "expression \<Rightarrow> nat" where
+ "nodes (Binary op a b) = Suc (nodes a + nodes b)"
+| "nodes (Cond c a b) = Suc (nodes c + nodes a + nodes b)"
+| "nodes (Let a b) = Suc (nodes a + nodes b)"
+| "nodes _ = 1"
+
+lemma fold_binary_nodes: "nodes (fold_binary op a b) \<le> Suc (nodes a + nodes b)"
+ by (cases a; cases b) auto
+
+lemma fold_cond_nodes: "nodes (fold_cond c a b) \<le> Suc (nodes c + nodes a + nodes b)"
+ by (cases c) auto
+
+theorem optimise_size: "nodes (optimise e) \<le> nodes e"
+ by (induction e) (auto intro: order_trans[OF fold_binary_nodes] order_trans[OF fold_cond_nodes])
+
+end
A => src/Native.thy +163 -0
@@ 1,163 @@
+theory Native
+ imports Compiler
+begin
+
+datatype register = Rax | Rcx | Rbx | Rdx | R8 | R9
+
+datatype opcode = Immediate pixel | Push register | Pop register | Peek nat
+ | Arithmetic operator | Conditional
+
+record machine =
+ registers :: "register \<Rightarrow> pixel"
+ stack :: "pixel list"
+
+fun input_register :: "input \<Rightarrow> register" where
+ "input_register X = R8"
+| "input_register Y = R9"
+| "input_register T = Rdx"
+
+definition inputs :: "machine \<Rightarrow> input \<Rightarrow> pixel" where
+ "inputs s i = registers s (input_register i)"
+
+fun exchanges :: "operator \<Rightarrow> bool" where
+ "exchanges Sub = True"
+| "exchanges Shl = True"
+| "exchanges Shr = True"
+| "exchanges Less = True"
+| "exchanges _ = False"
+
+fun transition :: "opcode \<Rightarrow> machine \<Rightarrow> machine option" where
+ "transition (Immediate v) s = Some (s\<lparr>registers := (registers s)(Rax := v)\<rparr>)"
+| "transition (Push r) s = Some (s\<lparr>stack := registers s r # stack s\<rparr>)"
+| "transition (Pop r) s = (case stack s of [] \<Rightarrow> None | v # vs \<Rightarrow>
+ Some (s\<lparr>registers := (registers s)(r := v), stack := vs\<rparr>))"
+| "transition (Peek i) s = (if i < length (stack s) then
+ Some (s\<lparr>registers := (registers s)(Rax := stack s ! i)\<rparr>) else None)"
+| "transition (Arithmetic op) s = Some (s\<lparr>registers :=
+ (registers s)(Rcx := if exchanges op then registers s Rax else registers s Rcx,
+ Rax := operate op (registers s Rcx) (registers s Rax))\<rparr>)"
+| "transition Conditional s = Some (s\<lparr>registers :=
+ (registers s)(Rax := if registers s Rbx = 0 then registers s Rax else registers s Rcx)\<rparr>)"
+
+fun run :: "opcode list \<Rightarrow> machine \<Rightarrow> machine option" where
+ "run [] s = Some s"
+| "run (i # code) s = Option.bind (transition i s) (run code)"
+
+lemma run_append:
+ "run (a @ b) s = Option.bind (run a s) (run b)"
+ by (induction a arbitrary: s) (auto split: option.splits bind_splits)
+
+fun lower :: "instruction \<Rightarrow> opcode list" where
+ "lower (Constant v) = [Immediate v, Push Rax]"
+| "lower (Fetch i) = [Push (input_register i)]"
+| "lower (Pick i) = [Peek i, Push Rax]"
+| "lower (Calculate op) = [Pop Rax, Pop Rcx, Arithmetic op, Push Rax]"
+| "lower Choose = [Pop Rax, Pop Rcx, Pop Rbx, Conditional, Push Rax]"
+| "lower Slide = [Pop Rax, Pop Rcx, Push Rax]"
+
+definition observe :: "machine \<Rightarrow> (input \<Rightarrow> pixel) \<times> pixel list" where
+ "observe s = (inputs s, stack s)"
+
+lemma input_scratch [simp]:
+ "input_register i \<noteq> Rax"
+ "input_register i \<noteq> Rcx"
+ "input_register i \<noteq> Rbx"
+ by (cases i; simp)+
+
+lemma inputs_update [simp]:
+ "inputs (s\<lparr>registers := (registers s)(Rax := a)\<rparr>) = inputs s"
+ "inputs (s\<lparr>registers := (registers s)(Rcx := a)\<rparr>) = inputs s"
+ "inputs (s\<lparr>registers := (registers s)(Rbx := a)\<rparr>) = inputs s"
+ "inputs (s\<lparr>stack := vs\<rparr>) = inputs s"
+ by (auto simp: inputs_def fun_eq_iff split: input.splits)
+
+theorem lower_correct:
+ "map_option observe (run (lower i) s) =
+ map_option (\<lambda>vs. (inputs s, vs)) (step (inputs s) i (stack s))"
+proof (cases i)
+ case (Constant v)
+ then show ?thesis by (simp add: observe_def)
+next
+ case (Fetch i)
+ then show ?thesis by (simp add: observe_def inputs_def)
+next
+ case (Pick i)
+ then show ?thesis by (simp add: observe_def)
+next
+ case (Calculate op)
+ then show ?thesis
+ by (cases "stack s"; simp add: observe_def inputs_def fun_eq_iff split: list.splits input.splits)
+next
+ case Choose
+ then show ?thesis
+ by (cases "stack s"; simp add: observe_def inputs_def fun_eq_iff split: list.splits input.splits)
+next
+ case Slide
+ then show ?thesis
+ by (cases "stack s"; simp add: observe_def inputs_def fun_eq_iff split: list.splits input.splits)
+qed
+
+definition native :: "instruction list \<Rightarrow> opcode list" where
+ "native code = concat (map lower code)"
+
+theorem native_correct:
+ "map_option observe (run (native code) s) =
+ map_option (\<lambda>vs. (inputs s, vs)) (execute (inputs s) code (stack s))"
+proof (induction code arbitrary: s)
+ case Nil
+ then show ?case by (simp add: native_def observe_def)
+next
+ case (Cons i code)
+ show ?case
+ using Cons.IH lower_correct[of i s]
+ by (auto simp: native_def run_append observe_def split: option.splits bind_splits)
+qed
+
+corollary native_expression:
+ assumes "scoped 0 e"
+ shows "map_option observe (run (native (compile (optimise e) [])) s) =
+ Some (inputs s, evaluate e [] (inputs s) # stack s)"
+proof -
+ have code: "execute (inputs s) (compile (optimise e) []) (stack s) =
+ Some (evaluate e [] (inputs s) # stack s)"
+ using compile_correct[where e="optimise e" and env="[]" and slots="[]" and s="stack s" and inputs="inputs s"]
+ assms optimise_scoped
+ by (simp add: represents_def optimise_correct)
+ show ?thesis using native_correct[of "compile (optimise e) []" s] code by simp
+qed
+
+theorem native_return:
+ assumes "scoped 0 e"
+ shows "\<exists>q. run (native (compile (optimise e) []) @ [Pop Rax]) s = Some q \<and>
+ registers q Rax = evaluate e [] (inputs s) \<and> stack q = stack s \<and> inputs q = inputs s"
+proof -
+ obtain q where run: "run (native (compile (optimise e) [])) s = Some q"
+ and ins: "inputs q = inputs s" and stk: "stack q = evaluate e [] (inputs s) # stack s"
+ using native_expression[OF assms, of s]
+ by (auto simp: observe_def split: option.splits)
+ show ?thesis using run ins stk
+ by (auto simp: run_append inputs_def fun_eq_iff)
+qed
+
+fun writes :: "opcode \<Rightarrow> register set" where
+ "writes (Immediate v) = {Rax}"
+| "writes (Pop r) = {r}"
+| "writes (Peek i) = {Rax}"
+| "writes (Arithmetic op) = {Rax,Rcx}"
+| "writes Conditional = {Rax}"
+| "writes _ = {}"
+
+lemma transition_preserves:
+ "transition i s = Some t \<Longrightarrow> r \<notin> writes i \<Longrightarrow> registers t r = registers s r"
+ by (cases i) (auto split: list.splits if_splits)
+
+theorem run_preserves:
+ "run code s = Some t \<Longrightarrow> list_all (\<lambda>i. r \<notin> writes i) code \<Longrightarrow>
+ registers t r = registers s r"
+ by (induction code arbitrary: s) (auto dest: transition_preserves split: option.splits bind_splits)
+
+lemma lower_scratch:
+ "list_all (\<lambda>i. writes i \<subseteq> {Rax,Rcx,Rbx}) (lower op)"
+ by (cases op) auto
+
+end
A => tests/native.py +102 -0
@@ 1,102 @@
+import ctypes
+import mmap
+from pathlib import Path
+import platform
+import random
+import struct
+import subprocess
+import tempfile
+
+
+ROOT = Path(__file__).resolve().parents[1]
+MASK = (1 << 64) - 1
+OPERATORS = ("+", "-", "*", "and", "or", "xor", "shl", "shr", "<")
+
+
+def evaluate(e, env):
+ if isinstance(e, int):
+ return e
+ if isinstance(e, str):
+ return env[e]
+ op, *args = e
+ if op == "let":
+ name, a, b = args
+ return evaluate(b, {**env, name: evaluate(a, env)})
+ if op == "if":
+ c, a, b = args
+ return evaluate(a if evaluate(c, env) else b, env)
+ a, b = (evaluate(x, env) for x in args)
+ return {"+": lambda: a + b, "-": lambda: a - b, "*": lambda: a * b,
+ "and": lambda: a & b, "or": lambda: a | b, "xor": lambda: a ^ b,
+ "shl": lambda: a << (b & 63), "shr": lambda: a >> (b & 63),
+ "<": lambda: int(a < b)}[op]() & MASK
+
+
+def source(e):
+ return "(" + " ".join(map(source, e)) + ")" if isinstance(e, tuple) else str(e)
+
+
+def native(code):
+ image = mmap.mmap(-1, len(code), prot=mmap.PROT_READ | mmap.PROT_WRITE | mmap.PROT_EXEC)
+ image.write(code)
+ address = ctypes.addressof(ctypes.c_char.from_buffer(image))
+ bridge = bytes.fromhex("53 49 89 f8 49 89 f1 48 b8") + struct.pack("<Q", address) + bytes.fromhex("ff d0 5b c3")
+ thunk = mmap.mmap(-1, len(bridge), prot=mmap.PROT_READ | mmap.PROT_WRITE | mmap.PROT_EXEC)
+ thunk.write(bridge)
+ function = ctypes.CFUNCTYPE(ctypes.c_uint64, ctypes.c_uint64, ctypes.c_uint64, ctypes.c_uint64)(
+ ctypes.addressof(ctypes.c_char.from_buffer(thunk)))
+ return function, image, thunk
+
+
+def generate(rng, depth, names):
+ if depth == 0 or rng.randrange(5) == 0:
+ return rng.choice([0, 1, 63, 64, 65, MASK, 1 << 63, *names])
+ kind = rng.randrange(5)
+ if kind == 0:
+ name = rng.choice(("a", "b", "c", "x"))
+ return ("let", name, generate(rng, depth - 1, names), generate(rng, depth - 1, [*names, name]))
+ if kind == 1:
+ return ("if", *(generate(rng, depth - 1, names) for _ in range(3)))
+ return (rng.choice(OPERATORS), *(generate(rng, depth - 1, names) for _ in range(2)))
+
+
+def main():
+ if platform.system() != "Linux" or platform.machine() != "x86_64":
+ raise RuntimeError("native differential tests require an x86-64 Linux host")
+ rng = random.Random(0x52454D59)
+ cases = [(op, "x", "y") for op in OPERATORS]
+ cases += [("let", "a", ("+", "x", 3), ("+", "y", ("let", "b", "t", ("*", "a", "b")))),
+ ("let", "x", "y", ("if", "t", ("+", "x", 1), ("-", "x", 1)))]
+ cases += [generate(rng, 5, ["x", "y", "t"]) for _ in range(117)]
+ comparisons = 0
+ with tempfile.TemporaryDirectory() as directory:
+ path, binary = Path(directory) / "source", Path(directory) / "binary"
+ for case in cases:
+ path.write_text(source(case))
+ result = subprocess.run([ROOT / ".build/remy", path, binary], capture_output=True, text=True, timeout=30)
+ assert result.returncode == 0, (case, result.stderr)
+ function, image, thunk = native(binary.read_bytes())
+ vectors = [(a, b, a ^ b) for a in (0, 1, MASK, 1 << 63) for b in (0, 1, 63, 64, 65, MASK)]
+ vectors += [tuple(rng.getrandbits(64) for _ in range(3)) for _ in range(24)]
+ for x, y, t in vectors:
+ expected = evaluate(case, {"x": x, "y": y, "t": t})
+ actual = function(x, y, t)
+ assert actual == expected, (source(case), x, y, t, expected, actual)
+ comparisons += 1
+ result = subprocess.run([ROOT / ".build/remy", "eval", path, str(x), str(y), str(t)],
+ capture_output=True, text=True, timeout=30)
+ assert result.returncode == 0 and int(result.stdout) == expected, (case, result.stdout, result.stderr)
+ del function
+ image.close()
+ thunk.close()
+ for bad in ("", "(+ x)", "(+ x y) 1", "(let a 3 b)", "(if 1 2)", "(let if 3 4)",
+ "18446744073709551616", "(+ x z)", "(div x y)", "é", " " * 65537):
+ path.write_text(bad)
+ binary.write_bytes(b"preserve")
+ result = subprocess.run([ROOT / ".build/remy", path, binary], capture_output=True, timeout=30)
+ assert result.returncode != 0 and binary.read_bytes() == b"preserve", bad
+ print(f"{len(cases)} programs, {comparisons} native comparisons, HOL reference checks and 11 rejection cases passed")
+
+
+if __name__ == "__main__":
+ main()
