From 23c8b97cb1258d589591c5ecac7be36679c9d153 Mon Sep 17 00:00:00 2001 From: giles Date: Tue, 24 Mar 2026 01:20:00 +0000 Subject: [PATCH] VM spec in SX + 72 tests passing on both JS and OCaml MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit spec/vm.sx — bytecode VM written in SX (the spec): - Stack-based interpreter for bytecode from compiler.sx - 24 opcodes: constants, variables (local/upvalue/global), control flow, function calls (with TCO), closures with upvalue capture, collections, string concat, define - Upvalue cells for shared mutable closure variables - Call dispatch: vm-closure (fast path), native-fn, CEK fallback - Platform interface: 7 primitives (vm-stack-*, call-primitive, cek-call, get-primitive, env-parent) spec/tests/test-vm.sx — 72 tests exercising compile→bytecode→VM pipeline: constants, arithmetic, comparison, control flow (if/when/cond/case/and/or), let bindings, lambda, closures, upvalue mutation, TCO (10K iterations), collections, strings, define, letrec, quasiquote, threading, integration (fibonacci, recursive map/filter/reduce, compose) spec/compiler.sx — fix :else keyword detection in case/cond compilation (was comparing Keyword object to evaluated string, now checks type) Platform primitives added (JS + OCaml): make-vm-stack, vm-stack-get, vm-stack-set!, vm-stack-length, vm-stack-copy!, primitive?, get-primitive, call-primitive, set-nth! (JS) Test runners updated to load bytecode.sx + compiler.sx + vm.sx for --full. Co-Authored-By: Claude Opus 4.6 (1M context) --- hosts/javascript/platform.py | 41 +- hosts/javascript/run_tests.js | 20 +- hosts/ocaml/bin/run_tests.ml | 14 +- hosts/ocaml/lib/sx_primitives.ml | 52 ++- shared/static/scripts/sx-browser.js | 35 +- spec/compiler.sx | 6 +- spec/tests/test-vm.sx | 418 ++++++++++++++++++++ spec/vm.sx | 590 ++++++++++++++++++++++++++++ 8 files changed, 1169 insertions(+), 7 deletions(-) create mode 100644 spec/tests/test-vm.sx create mode 100644 spec/vm.sx diff --git a/hosts/javascript/platform.py b/hosts/javascript/platform.py index f8f782f..a9c20a4 100644 --- a/hosts/javascript/platform.py +++ b/hosts/javascript/platform.py @@ -63,11 +63,12 @@ SPEC_MODULES = { "signals": ("signals.sx", "signals (reactive signal runtime)"), "page-helpers": ("page-helpers.sx", "page-helpers (pure data transformation helpers)"), "types": ("types.sx", "types (gradual type system)"), + "vm": ("vm.sx", "vm (bytecode virtual machine)"), } # Note: frames and cek are now part of evaluator.sx (always loaded as core) # Explicit ordering for spec modules with dependencies. -SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "types"] +SPEC_MODULE_ORDER = ["deps", "page-helpers", "router", "signals", "types", "vm"] EXTENSION_NAMES = {"continuations"} @@ -1139,6 +1140,44 @@ PRIMITIVES_JS_MODULES: dict[str, str] = { } PRIMITIVES["scope-emit!"] = scopeEmit; PRIMITIVES["scope-peek"] = scopePeek; + + // ---- VM stack primitives ---- + // The VM spec (vm.sx) requires these array-like operations. + // In JS, a plain Array serves as the stack. + PRIMITIVES["make-vm-stack"] = function(size) { + var a = new Array(size); + for (var i = 0; i < size; i++) a[i] = NIL; + return a; + }; + PRIMITIVES["vm-stack-get"] = function(stack, idx) { return stack[idx]; }; + PRIMITIVES["vm-stack-set!"] = function(stack, idx, value) { stack[idx] = value; return NIL; }; + PRIMITIVES["vm-stack-length"] = function(stack) { return stack.length; }; + PRIMITIVES["vm-stack-copy!"] = function(src, dst, count) { + for (var i = 0; i < count; i++) dst[i] = src[i]; + return NIL; + }; + PRIMITIVES["get-primitive"] = function(name) { + if (name in PRIMITIVES) return PRIMITIVES[name]; + throw new Error("VM undefined: " + name); + }; + PRIMITIVES["call-primitive"] = function(name, args) { + if (!(name in PRIMITIVES)) throw new Error("VM undefined: " + name); + var fn = PRIMITIVES[name]; + return fn.apply(null, Array.isArray(args) ? args : []); + }; + PRIMITIVES["primitive?"] = function(name) { + return name in PRIMITIVES; + }; + PRIMITIVES["set-nth!"] = function(lst, idx, val) { + lst[idx] = val; + return NIL; + }; + PRIMITIVES["env-parent"] = function(env) { + if (env && Object.getPrototypeOf(env) !== Object.prototype && + Object.getPrototypeOf(env) !== null) + return Object.getPrototypeOf(env); + return NIL; + }; ''', } # Modules to include by default (all) diff --git a/hosts/javascript/run_tests.js b/hosts/javascript/run_tests.js index 98cac29..1f83367 100644 --- a/hosts/javascript/run_tests.js +++ b/hosts/javascript/run_tests.js @@ -81,6 +81,7 @@ env["env-extend"] = function(e) { return Object.create(e); }; env["env-merge"] = function(a, b) { return Object.assign({}, a, b); }; // Missing primitives referenced by tests +// primitive? is now in platform.py PRIMITIVES env["upcase"] = function(s) { return s.toUpperCase(); }; env["downcase"] = function(s) { return s.toLowerCase(); }; env["make-keyword"] = function(name) { return new Sx.Keyword(name); }; @@ -277,6 +278,23 @@ for (const expr of frameworkExprs) { Sx.eval(expr, env); } +// Load compiler + VM spec when running full tests +if (fullBuild) { + const specDir = path.join(projectDir, "spec"); + for (const specFile of ["bytecode.sx", "compiler.sx", "vm.sx"]) { + const specPath = path.join(specDir, specFile); + if (fs.existsSync(specPath)) { + const src = fs.readFileSync(specPath, "utf8"); + const exprs = Sx.parse(src); + for (const expr of exprs) { + try { Sx.eval(expr, env); } catch (e) { + console.error(`Error loading ${specFile}: ${e.message}`); + } + } + } + } +} + // Determine which tests to run const args = process.argv.slice(2).filter(a => !a.startsWith("--")); let testFiles = []; @@ -293,7 +311,7 @@ if (args.length > 0) { } } else { // Tests requiring optional modules (only run with --full) - const requiresFull = new Set(["test-continuations.sx", "test-types.sx", "test-freeze.sx"]); + const requiresFull = new Set(["test-continuations.sx", "test-continuations-advanced.sx", "test-types.sx", "test-freeze.sx", "test-vm.sx"]); // All spec tests for (const f of fs.readdirSync(specTests).sort()) { if (f.startsWith("test-") && f.endsWith(".sx") && f !== "test-framework.sx") { diff --git a/hosts/ocaml/bin/run_tests.ml b/hosts/ocaml/bin/run_tests.ml index c087140..2313c59 100644 --- a/hosts/ocaml/bin/run_tests.ml +++ b/hosts/ocaml/bin/run_tests.ml @@ -637,12 +637,24 @@ let run_spec_tests env test_files = Printf.printf "\nLoading test framework...\n%!"; load_and_eval framework_path; + (* Load compiler + VM spec for test-vm.sx *) + let spec_dir = Filename.concat project_dir "spec" in + List.iter (fun name -> + let path = Filename.concat spec_dir name in + if Sys.file_exists path then begin + Printf.printf "Loading %s...\n%!" name; + (try load_and_eval path + with e -> Printf.eprintf "Warning: %s: %s\n%!" name (Printexc.to_string e)) + end + ) ["bytecode.sx"; "compiler.sx"; "vm.sx"]; + (* Determine test files *) let files = if test_files = [] then begin let entries = Sys.readdir spec_tests_dir in Array.sort String.compare entries; let requires_full = ["test-continuations.sx"; "test-types.sx"; "test-freeze.sx"; - "test-continuations-advanced.sx"; "test-signals-advanced.sx"] in + "test-continuations-advanced.sx"; "test-signals-advanced.sx"; + "test-vm.sx"] in Array.to_list entries |> List.filter (fun f -> String.length f > 5 && diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index 3318fd2..0656e81 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -594,7 +594,8 @@ let () = | _ -> raise (Eval_error "error: 1 arg")); register "apply" (fun args -> match args with - | [NativeFn (_, f); List a] -> f a + | [NativeFn (_, f); (List a | ListRef { contents = a })] -> f a + | [NativeFn (_, f); Nil] -> f [] | _ -> raise (Eval_error "apply: function and list")); register "identical?" (fun args -> match args with [a; b] -> Bool (a == b) | _ -> raise (Eval_error "identical?: 2 args")); @@ -668,4 +669,53 @@ let () = Bool (List.for_all (fun x -> sx_truthy (call_any f [x])) items) | [_; Nil] -> Bool true | _ -> raise (Eval_error "every?: expected (fn list)")); + + (* ---- VM stack primitives (vm.sx platform interface) ---- *) + register "make-vm-stack" (fun args -> + match args with + | [Number n] -> ListRef (ref (List.init (int_of_float n) (fun _ -> Nil))) + | _ -> raise (Eval_error "make-vm-stack: expected (size)")); + register "vm-stack-get" (fun args -> + match args with + | [ListRef r; Number n] -> List.nth !r (int_of_float n) + | _ -> raise (Eval_error "vm-stack-get: expected (stack idx)")); + register "vm-stack-set!" (fun args -> + match args with + | [ListRef r; Number n; v] -> + let i = int_of_float n in + r := List.mapi (fun j x -> if j = i then v else x) !r; Nil + | _ -> raise (Eval_error "vm-stack-set!: expected (stack idx val)")); + register "vm-stack-length" (fun args -> + match args with + | [ListRef r] -> Number (float_of_int (List.length !r)) + | _ -> raise (Eval_error "vm-stack-length: expected (stack)")); + register "vm-stack-copy!" (fun args -> + match args with + | [ListRef src; ListRef dst; Number n] -> + let count = int_of_float n in + let src_items = !src in + dst := List.mapi (fun i x -> if i < count then List.nth src_items i else x) !dst; Nil + | _ -> raise (Eval_error "vm-stack-copy!: expected (src dst count)")); + register "primitive?" (fun args -> + match args with + | [String name] -> Bool (Hashtbl.mem primitives name) + | _ -> Bool false); + register "get-primitive" (fun args -> + match args with + | [String name] -> + (match Hashtbl.find_opt primitives name with + | Some fn -> NativeFn (name, fn) + | None -> raise (Eval_error ("VM undefined: " ^ name))) + | _ -> raise (Eval_error "get-primitive: expected (name)")); + register "call-primitive" (fun args -> + match args with + | [String name; (List a | ListRef { contents = a })] -> + (match Hashtbl.find_opt primitives name with + | Some fn -> fn a + | None -> raise (Eval_error ("VM undefined: " ^ name))) + | [String name; Nil] -> + (match Hashtbl.find_opt primitives name with + | Some fn -> fn [] + | None -> raise (Eval_error ("VM undefined: " ^ name))) + | _ -> raise (Eval_error "call-primitive: expected (name args-list)")); () diff --git a/shared/static/scripts/sx-browser.js b/shared/static/scripts/sx-browser.js index c960f32..a7af9c0 100644 --- a/shared/static/scripts/sx-browser.js +++ b/shared/static/scripts/sx-browser.js @@ -14,7 +14,7 @@ // ========================================================================= var NIL = Object.freeze({ _nil: true, toString: function() { return "nil"; } }); - var SX_VERSION = "2026-03-23T23:55:49Z"; + var SX_VERSION = "2026-03-24T01:05:46Z"; function isNil(x) { return x === NIL || x === null || x === undefined; } function isSxTruthy(x) { return x !== false && !isNil(x); } @@ -521,6 +521,39 @@ PRIMITIVES["scope-emit!"] = scopeEmit; PRIMITIVES["scope-peek"] = scopePeek; + // ---- VM stack primitives ---- + // The VM spec (vm.sx) requires these array-like operations. + // In JS, a plain Array serves as the stack. + PRIMITIVES["make-vm-stack"] = function(size) { + var a = new Array(size); + for (var i = 0; i < size; i++) a[i] = NIL; + return a; + }; + PRIMITIVES["vm-stack-get"] = function(stack, idx) { return stack[idx]; }; + PRIMITIVES["vm-stack-set!"] = function(stack, idx, value) { stack[idx] = value; return NIL; }; + PRIMITIVES["vm-stack-length"] = function(stack) { return stack.length; }; + PRIMITIVES["vm-stack-copy!"] = function(src, dst, count) { + for (var i = 0; i < count; i++) dst[i] = src[i]; + return NIL; + }; + PRIMITIVES["get-primitive"] = function(name) { + if (name in PRIMITIVES) return PRIMITIVES[name]; + throw new Error("VM undefined: " + name); + }; + PRIMITIVES["primitive?"] = function(name) { + return name in PRIMITIVES; + }; + PRIMITIVES["set-nth!"] = function(lst, idx, val) { + lst[idx] = val; + return NIL; + }; + PRIMITIVES["env-parent"] = function(env) { + if (env && Object.getPrototypeOf(env) !== Object.prototype && + Object.getPrototypeOf(env) !== null) + return Object.getPrototypeOf(env); + return NIL; + }; + function isPrimitive(name) { return name in PRIMITIVES; } function getPrimitive(name) { return PRIMITIVES[name]; } diff --git a/spec/compiler.sx b/spec/compiler.sx index 44c615e..0a6f221 100644 --- a/spec/compiler.sx +++ b/spec/compiler.sx @@ -558,7 +558,8 @@ (let ((test (first args)) (body (nth args 1)) (rest-clauses (if (> (len args) 2) (slice args 2) (list)))) - (if (or (= test :else) (= test true)) + (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) + (= test true)) ;; else clause — just compile the body (compile-expr em body scope tail?) (do @@ -590,7 +591,8 @@ (let ((test (first clauses)) (body (nth clauses 1)) (rest-clauses (if (> (len clauses) 2) (slice clauses 2) (list)))) - (if (or (= test :else) (= test true)) + (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) + (= test true)) (do (emit-op em 5) ;; POP match-val (compile-expr em body scope tail?)) (do diff --git a/spec/tests/test-vm.sx b/spec/tests/test-vm.sx new file mode 100644 index 0000000..01ff02b --- /dev/null +++ b/spec/tests/test-vm.sx @@ -0,0 +1,418 @@ +;; ========================================================================== +;; test-vm.sx — Tests for the bytecode VM (spec/vm.sx) +;; +;; Requires: test-framework.sx, compiler.sx, vm.sx loaded. +;; Tests the compile → bytecode → VM execution pipeline. +;; ========================================================================== + + +;; Helper: compile an SX expression and execute it on the VM. +;; Returns the result value. +(define vm-eval + (fn (expr) + (let ((code (compile expr))) + (vm-execute-module + (code-from-value code) + {})))) + +;; Helper: compile and run with a pre-populated globals dict. +(define vm-eval-with + (fn (expr globals) + (let ((code (compile expr))) + (vm-execute-module (code-from-value code) globals)))) + + +;; -------------------------------------------------------------------------- +;; Constants and literals +;; -------------------------------------------------------------------------- + +(defsuite "vm-constants" + (deftest "number constant" + (assert-equal 42 (vm-eval 42))) + + (deftest "string constant" + (assert-equal "hello" (vm-eval "hello"))) + + (deftest "boolean true" + (assert-equal true (vm-eval true))) + + (deftest "boolean false" + (assert-equal false (vm-eval false))) + + (deftest "nil constant" + (assert-nil (vm-eval nil))) + + (deftest "negative number" + (assert-equal -7 (vm-eval -7))) + + (deftest "float constant" + (assert-equal 3.14 (vm-eval 3.14)))) + + +;; -------------------------------------------------------------------------- +;; Arithmetic via primitives +;; -------------------------------------------------------------------------- + +(defsuite "vm-arithmetic" + (deftest "addition" + (assert-equal 5 (vm-eval '(+ 2 3)))) + + (deftest "subtraction" + (assert-equal 7 (vm-eval '(- 10 3)))) + + (deftest "multiplication" + (assert-equal 24 (vm-eval '(* 6 4)))) + + (deftest "division" + (assert-equal 5 (vm-eval '(/ 10 2)))) + + (deftest "nested arithmetic" + (assert-equal 14 (vm-eval '(+ (* 3 4) 2)))) + + (deftest "three-arg addition" + (assert-equal 15 (vm-eval '(+ 5 4 6))))) + + +;; -------------------------------------------------------------------------- +;; Comparison and logic +;; -------------------------------------------------------------------------- + +(defsuite "vm-comparison" + (deftest "equal numbers" + (assert-equal true (vm-eval '(= 1 1)))) + + (deftest "unequal numbers" + (assert-equal false (vm-eval '(= 1 2)))) + + (deftest "less than" + (assert-equal true (vm-eval '(< 1 2)))) + + (deftest "greater than" + (assert-equal true (vm-eval '(> 5 3)))) + + (deftest "not" + (assert-equal true (vm-eval '(not false)))) + + (deftest "not truthy" + (assert-equal false (vm-eval '(not 42))))) + + +;; -------------------------------------------------------------------------- +;; Control flow — if, when, cond, and, or +;; -------------------------------------------------------------------------- + +(defsuite "vm-control-flow" + (deftest "if true branch" + (assert-equal 1 (vm-eval '(if true 1 2)))) + + (deftest "if false branch" + (assert-equal 2 (vm-eval '(if false 1 2)))) + + (deftest "if without else returns nil" + (assert-nil (vm-eval '(if false 1)))) + + (deftest "when true evaluates body" + (assert-equal 42 (vm-eval '(when true 42)))) + + (deftest "when false returns nil" + (assert-nil (vm-eval '(when false 42)))) + + (deftest "and short-circuits on false" + (assert-equal false (vm-eval '(and true false 42)))) + + (deftest "and returns last truthy" + (assert-equal 3 (vm-eval '(and 1 2 3)))) + + (deftest "or short-circuits on true" + (assert-equal 1 (vm-eval '(or 1 false 2)))) + + (deftest "or returns false when all falsy" + (assert-equal false (vm-eval '(or false false false)))) + + (deftest "cond first match" + (assert-equal "one" (vm-eval '(cond (= 1 1) "one" (= 2 2) "two")))) + + (deftest "cond else clause" + (assert-equal "none" (vm-eval '(cond (= 1 2) "one" :else "none")))) + + (deftest "case match" + (assert-equal "two" (vm-eval '(case 2 1 "one" 2 "two" :else "other")))) + + (deftest "case else" + (assert-equal "other" (vm-eval '(case 99 1 "one" 2 "two" :else "other"))))) + + +;; -------------------------------------------------------------------------- +;; Let bindings +;; -------------------------------------------------------------------------- + +(defsuite "vm-let" + (deftest "single binding" + (assert-equal 10 (vm-eval '(let ((x 10)) x)))) + + (deftest "multiple bindings" + (assert-equal 30 (vm-eval '(let ((x 10) (y 20)) (+ x y))))) + + (deftest "bindings are sequential" + (assert-equal 11 (vm-eval '(let ((x 10) (y (+ x 1))) y)))) + + (deftest "nested let" + (assert-equal 3 (vm-eval '(let ((x 1)) (let ((y 2)) (+ x y)))))) + + (deftest "inner let shadows outer" + (assert-equal 99 (vm-eval '(let ((x 1)) (let ((x 99)) x))))) + + (deftest "let body returns last expression" + (assert-equal 3 (vm-eval '(let ((x 1)) 1 2 3))))) + + +;; -------------------------------------------------------------------------- +;; Lambda and function calls +;; -------------------------------------------------------------------------- + +(defsuite "vm-lambda" + (deftest "lambda call" + (assert-equal 7 (vm-eval '(let ((f (fn (x) (+ x 2)))) (f 5))))) + + (deftest "lambda with multiple params" + (assert-equal 11 (vm-eval '(let ((add (fn (a b) (+ a b)))) (add 5 6))))) + + (deftest "higher-order: pass lambda to lambda" + (assert-equal 10 + (vm-eval '(let ((apply-fn (fn (f x) (f x))) + (double (fn (n) (* n 2)))) + (apply-fn double 5))))) + + (deftest "lambda returns lambda" + (assert-equal 15 + (vm-eval '(let ((make-adder (fn (n) (fn (x) (+ n x))))) + (let ((add10 (make-adder 10))) + (add10 5)))))) + + (deftest "immediately invoked lambda" + (assert-equal 42 (vm-eval '((fn (x) (* x 2)) 21))))) + + +;; -------------------------------------------------------------------------- +;; Closures and upvalues +;; -------------------------------------------------------------------------- + +(defsuite "vm-closures" + (deftest "closure captures local" + (assert-equal 10 + (vm-eval '(let ((x 10)) + (let ((f (fn () x))) + (f)))))) + + (deftest "closure captures through two levels" + (assert-equal 30 + (vm-eval '(let ((x 10)) + (let ((y 20)) + (let ((f (fn () (+ x y)))) + (f))))))) + + (deftest "two closures share upvalue" + (assert-equal 42 + (vm-eval '(let ((x 0)) + (let ((set-x (fn (v) (set! x v))) + (get-x (fn () x))) + (set-x 42) + (get-x)))))) + + (deftest "closure mutation visible to sibling" + (assert-equal 3 + (vm-eval '(let ((counter 0)) + (let ((inc! (fn () (set! counter (+ counter 1))))) + (inc!) + (inc!) + (inc!) + counter)))))) + + +;; -------------------------------------------------------------------------- +;; Tail call optimization +;; -------------------------------------------------------------------------- + +(defsuite "vm-tco" + (deftest "tail-recursive loop doesn't overflow" + ;; Count down from 10000 — would overflow without TCO + (assert-equal 0 + (vm-eval '(let ((loop (fn (n) + (if (<= n 0) 0 + (loop (- n 1)))))) + (loop 10000))))) + + (deftest "tail-recursive accumulator" + (assert-equal 5050 + (vm-eval '(let ((sum (fn (n acc) + (if (<= n 0) acc + (sum (- n 1) (+ acc n)))))) + (sum 100 0)))))) + + +;; -------------------------------------------------------------------------- +;; Collections +;; -------------------------------------------------------------------------- + +(defsuite "vm-collections" + (deftest "list construction" + (assert-equal (list 1 2 3) (vm-eval '(list 1 2 3)))) + + (deftest "empty list" + (assert-equal (list) (vm-eval '(list)))) + + (deftest "dict construction" + (let ((d (vm-eval '{:a 1 :b 2}))) + (assert-equal 1 (get d "a")) + (assert-equal 2 (get d "b")))) + + (deftest "list operations" + (assert-equal 1 (vm-eval '(first (list 1 2 3)))) + (assert-equal 3 (vm-eval '(len (list 1 2 3))))) + + (deftest "nested list" + (assert-equal (list 1 (list 2 3)) + (vm-eval '(list 1 (list 2 3)))))) + + +;; -------------------------------------------------------------------------- +;; String operations +;; -------------------------------------------------------------------------- + +(defsuite "vm-strings" + (deftest "str concat" + (assert-equal "hello world" (vm-eval '(str "hello" " " "world")))) + + (deftest "string-length" + (assert-equal 5 (vm-eval '(string-length "hello")))) + + (deftest "str coerces numbers" + (assert-equal "42" (vm-eval '(str 42))))) + + +;; -------------------------------------------------------------------------- +;; Define — top-level and local +;; -------------------------------------------------------------------------- + +(defsuite "vm-define" + (deftest "top-level define" + (assert-equal 42 + (vm-eval '(do (define x 42) x)))) + + (deftest "define function then call" + (assert-equal 10 + (vm-eval '(do + (define double (fn (n) (* n 2))) + (double 5))))) + + (deftest "local define inside fn" + (assert-equal 30 + (vm-eval '(let ((f (fn (x) + (define y (* x 2)) + (+ x y)))) + (f 10))))) + + (deftest "define with forward reference" + (assert-equal 120 + (vm-eval '(do + (define fact (fn (n) + (if (<= n 1) 1 (* n (fact (- n 1)))))) + (fact 5)))))) + + +;; -------------------------------------------------------------------------- +;; Letrec — mutual recursion +;; -------------------------------------------------------------------------- + +(defsuite "vm-letrec" + (deftest "letrec self-recursion" + (assert-equal 55 + (vm-eval '(letrec ((sum-to (fn (n) + (if (<= n 0) 0 + (+ n (sum-to (- n 1))))))) + (sum-to 10))))) + + (deftest "letrec mutual recursion" + (assert-equal true + (vm-eval '(letrec ((my-even? (fn (n) + (if (= n 0) true (my-odd? (- n 1))))) + (my-odd? (fn (n) + (if (= n 0) false (my-even? (- n 1)))))) + (my-even? 10)))))) + + +;; -------------------------------------------------------------------------- +;; Quasiquote +;; -------------------------------------------------------------------------- + +(defsuite "vm-quasiquote" + (deftest "simple quasiquote" + (assert-equal (list 1 2 3) + (vm-eval '(let ((x 2)) `(1 ,x 3))))) + + (deftest "quasiquote with splice" + (assert-equal (list 1 2 3 4) + (vm-eval '(let ((xs (list 2 3))) `(1 ,@xs 4)))))) + + +;; -------------------------------------------------------------------------- +;; Thread macro +;; -------------------------------------------------------------------------- + +(defsuite "vm-threading" + (deftest "thread-first" + (assert-equal 7 + (vm-eval '(-> 5 (+ 2))))) + + (deftest "thread-first chain" + (assert-equal 12 + (vm-eval '(-> 10 (+ 5) (- 3)))))) + + +;; -------------------------------------------------------------------------- +;; Integration: compile then execute +;; -------------------------------------------------------------------------- + +(defsuite "vm-integration" + (deftest "fibonacci" + (assert-equal 55 + (vm-eval '(do + (define fib (fn (n) + (if (<= n 1) n + (+ (fib (- n 1)) (fib (- n 2)))))) + (fib 10))))) + + (deftest "map via recursive define" + (assert-equal (list 2 4 6) + (vm-eval '(do + (define my-map (fn (f lst) + (if (empty? lst) (list) + (cons (f (first lst)) (my-map f (rest lst)))))) + (my-map (fn (x) (* x 2)) (list 1 2 3)))))) + + (deftest "filter via recursive define" + (assert-equal (list 2 4) + (vm-eval '(do + (define my-filter (fn (pred lst) + (if (empty? lst) (list) + (if (pred (first lst)) + (cons (first lst) (my-filter pred (rest lst))) + (my-filter pred (rest lst)))))) + (my-filter (fn (x) (even? x)) (list 1 2 3 4 5)))))) + + (deftest "reduce via recursive define" + (assert-equal 15 + (vm-eval '(do + (define my-reduce (fn (f acc lst) + (if (empty? lst) acc + (my-reduce f (f acc (first lst)) (rest lst))))) + (my-reduce (fn (acc x) (+ acc x)) 0 (list 1 2 3 4 5)))))) + + (deftest "nested function calls" + (assert-equal 42 + (vm-eval '(do + (define compose (fn (f g) (fn (x) (f (g x))))) + (define inc (fn (x) (+ x 1))) + (define double (fn (x) (* x 2))) + (let ((inc-then-double (compose double inc))) + (inc-then-double 20))))))) diff --git a/spec/vm.sx b/spec/vm.sx new file mode 100644 index 0000000..0014fb5 --- /dev/null +++ b/spec/vm.sx @@ -0,0 +1,590 @@ +;; ========================================================================== +;; vm.sx — SX bytecode virtual machine +;; +;; Stack-based interpreter for bytecode produced by compiler.sx. +;; Written in SX — transpiled to each target (OCaml, JS, WASM). +;; +;; Architecture: +;; - Array-based value stack (no allocation per step) +;; - Frame list for call stack (one frame per function invocation) +;; - Upvalue cells for shared mutable closure variables +;; - Iterative dispatch loop (no host-stack growth) +;; - TCO via frame replacement on OP_TAIL_CALL +;; +;; Platform interface: +;; The host must provide: +;; - make-vm-stack, vm-stack-get, vm-stack-set!, vm-stack-grow +;; - cek-call (fallback for Lambda/Component) +;; - get-primitive (primitive lookup) +;; Everything else is defined here. +;; ========================================================================== + + +;; -------------------------------------------------------------------------- +;; 1. Types — VM data structures +;; -------------------------------------------------------------------------- + +;; Upvalue cell — shared mutable reference for captured variables. +;; When a closure captures a local, both the parent frame and the +;; closure read/write through this cell. +(define make-upvalue-cell + (fn (value) + {:uv-value value})) + +(define uv-get (fn (cell) (get cell "uv-value"))) +(define uv-set! (fn (cell value) (dict-set! cell "uv-value" value))) + +;; VM code object — compiled bytecode + constant pool. +;; Produced by compiler.sx, consumed by the VM. +(define make-vm-code + (fn (arity locals bytecode constants) + {:vc-arity arity + :vc-locals locals + :vc-bytecode bytecode + :vc-constants constants})) + +;; VM closure — code + captured upvalues + globals reference. +(define make-vm-closure + (fn (code upvalues name globals closure-env) + {:vm-code code + :vm-upvalues upvalues + :vm-name name + :vm-globals globals + :vm-closure-env closure-env})) + +;; VM frame — one per active function invocation. +(define make-vm-frame + (fn (closure base) + {:closure closure + :ip 0 + :base base + :local-cells {}})) + +;; VM state — the virtual machine. +(define make-vm + (fn (globals) + {:stack (make-vm-stack 4096) + :sp 0 + :frames (list) + :globals globals})) + + +;; -------------------------------------------------------------------------- +;; 2. Stack operations +;; -------------------------------------------------------------------------- + +(define vm-push + (fn (vm value) + (let ((sp (get vm "sp")) + (stack (get vm "stack"))) + ;; Grow stack if needed + (when (>= sp (vm-stack-length stack)) + (let ((new-stack (make-vm-stack (* sp 2)))) + (vm-stack-copy! stack new-stack sp) + (dict-set! vm "stack" new-stack) + (set! stack new-stack))) + (vm-stack-set! stack sp value) + (dict-set! vm "sp" (+ sp 1))))) + +(define vm-pop + (fn (vm) + (let ((sp (- (get vm "sp") 1))) + (dict-set! vm "sp" sp) + (vm-stack-get (get vm "stack") sp)))) + +(define vm-peek + (fn (vm) + (vm-stack-get (get vm "stack") (- (get vm "sp") 1)))) + + +;; -------------------------------------------------------------------------- +;; 3. Operand reading — read from bytecode stream +;; -------------------------------------------------------------------------- + +(define frame-read-u8 + (fn (frame) + (let ((ip (get frame "ip")) + (bc (get (get (get frame "closure") "vm-code") "vc-bytecode"))) + (let ((v (nth bc ip))) + (dict-set! frame "ip" (+ ip 1)) + v)))) + +(define frame-read-u16 + (fn (frame) + (let ((lo (frame-read-u8 frame)) + (hi (frame-read-u8 frame))) + (+ lo (* hi 256))))) + +(define frame-read-i16 + (fn (frame) + (let ((v (frame-read-u16 frame))) + (if (>= v 32768) (- v 65536) v)))) + + +;; -------------------------------------------------------------------------- +;; 4. Frame management +;; -------------------------------------------------------------------------- + +;; Push a closure frame onto the VM. +;; Lays out args as locals, pads remaining locals with nil. +(define vm-push-frame + (fn (vm closure args) + (let ((frame (make-vm-frame closure (get vm "sp")))) + (for-each (fn (a) (vm-push vm a)) args) + ;; Pad remaining local slots with nil + (let ((arity (len args)) + (total-locals (get (get closure "vm-code") "vc-locals"))) + (let ((pad-count (- total-locals arity))) + (when (> pad-count 0) + (let ((i 0)) + (define pad-loop + (fn () + (when (< i pad-count) + (vm-push vm nil) + (set! i (+ i 1)) + (pad-loop)))) + (pad-loop))))) + (dict-set! vm "frames" (cons frame (get vm "frames")))))) + + +;; -------------------------------------------------------------------------- +;; 5. Code loading — convert compiler output to VM structures +;; -------------------------------------------------------------------------- + +(define code-from-value + (fn (v) + "Convert a compiler output dict to a vm-code object." + (if (not (dict? v)) + (make-vm-code 0 16 (list) (list)) + (let ((bc-raw (get v "bytecode")) + (bc (if (nil? bc-raw) (list) bc-raw)) + (consts-raw (get v "constants")) + (consts (if (nil? consts-raw) (list) consts-raw)) + (arity-raw (get v "arity")) + (arity (if (nil? arity-raw) 0 arity-raw))) + (make-vm-code arity (+ arity 16) bc consts))))) + + +;; -------------------------------------------------------------------------- +;; 6. Call dispatch — route calls by value type +;; -------------------------------------------------------------------------- + +;; vm-call dispatches a function call within the VM. +;; VmClosure: push frame on current VM (fast path, enables TCO). +;; NativeFn: call directly, push result. +;; Lambda/Component: fall back to CEK evaluator. +(define vm-closure? + (fn (v) + (and (dict? v) (has-key? v "vm-code")))) + +(define vm-call + (fn (vm f args) + (cond + (vm-closure? f) + ;; Fast path: push frame on current VM + (vm-push-frame vm f args) + + (callable? f) + ;; Native function or primitive + (vm-push vm (apply f args)) + + (or (= (type-of f) "lambda") (= (type-of f) "component") (= (type-of f) "island")) + ;; CEK fallback — the host provides cek-call + (vm-push vm (cek-call f args)) + + :else + (error (str "VM: not callable: " (type-of f)))))) + + +;; -------------------------------------------------------------------------- +;; 7. Local/upvalue access helpers +;; -------------------------------------------------------------------------- + +(define frame-local-get + (fn (vm frame slot) + "Read a local variable — check shared cells first, then stack." + (let ((cells (get frame "local-cells")) + (key (str slot))) + (if (has-key? cells key) + (uv-get (get cells key)) + (vm-stack-get (get vm "stack") (+ (get frame "base") slot)))))) + +(define frame-local-set + (fn (vm frame slot value) + "Write a local variable — to shared cell if captured, else to stack." + (let ((cells (get frame "local-cells")) + (key (str slot))) + (if (has-key? cells key) + (uv-set! (get cells key) value) + (vm-stack-set! (get vm "stack") (+ (get frame "base") slot) value))))) + +(define frame-upvalue-get + (fn (frame idx) + (uv-get (nth (get (get frame "closure") "vm-upvalues") idx)))) + +(define frame-upvalue-set + (fn (frame idx value) + (uv-set! (nth (get (get frame "closure") "vm-upvalues") idx) value))) + + +;; -------------------------------------------------------------------------- +;; 8. Global variable access with closure env chain +;; -------------------------------------------------------------------------- + +(define vm-global-get + (fn (vm frame name) + "Look up a global: globals table → closure env chain → primitives." + (let ((globals (get vm "globals"))) + (if (has-key? globals name) + (get globals name) + ;; Walk the closure env chain for inner functions + (let ((closure-env (get (get frame "closure") "vm-closure-env"))) + (if (nil? closure-env) + (get-primitive name) + (let ((found (env-walk closure-env name))) + (if (nil? found) + (get-primitive name) + found)))))))) + +(define vm-global-set + (fn (vm frame name value) + "Set a global: write to closure env if name exists there, else globals." + (let ((closure-env (get (get frame "closure") "vm-closure-env")) + (written false)) + (when (not (nil? closure-env)) + (set! written (env-walk-set! closure-env name value))) + (when (not written) + (dict-set! (get vm "globals") name value))))) + +;; env-walk: walk an environment chain looking for a binding. +;; Returns the value or nil if not found. +(define env-walk + (fn (env name) + (if (nil? env) nil + (if (env-has? env name) + (env-get env name) + (let ((parent (env-parent env))) + (if (nil? parent) nil + (env-walk parent name))))))) + +;; env-walk-set!: walk an environment chain, set value if name found. +;; Returns true if set, false if not found. +(define env-walk-set! + (fn (env name value) + (if (nil? env) false + (if (env-has? env name) + (do (env-set! env name value) true) + (let ((parent (env-parent env))) + (if (nil? parent) false + (env-walk-set! parent name value))))))) + + +;; -------------------------------------------------------------------------- +;; 9. Closure creation — OP_CLOSURE with upvalue capture +;; -------------------------------------------------------------------------- + +(define vm-create-closure + (fn (vm frame code-val) + "Create a closure from a code constant. Reads upvalue descriptors + from the bytecode stream and captures values from the enclosing frame." + (let ((code (code-from-value code-val)) + (uv-count (if (dict? code-val) + (let ((n (get code-val "upvalue-count"))) + (if (nil? n) 0 n)) + 0))) + (let ((upvalues + (let ((result (list)) + (i 0)) + (define capture-loop + (fn () + (when (< i uv-count) + (let ((is-local (frame-read-u8 frame)) + (index (frame-read-u8 frame))) + (let ((cell + (if (= is-local 1) + ;; Capture from enclosing frame's local slot. + ;; Create/reuse a shared cell so both parent + ;; and closure read/write through it. + (let ((cells (get frame "local-cells")) + (key (str index))) + (if (has-key? cells key) + (get cells key) + (let ((c (make-upvalue-cell + (vm-stack-get (get vm "stack") + (+ (get frame "base") index))))) + (dict-set! cells key c) + c))) + ;; Capture from enclosing frame's upvalue + (nth (get (get frame "closure") "vm-upvalues") index)))) + (append! result cell) + (set! i (+ i 1)) + (capture-loop)))))) + (capture-loop) + result))) + (make-vm-closure code upvalues nil + (get vm "globals") nil))))) + + +;; -------------------------------------------------------------------------- +;; 10. Main execution loop — iterative dispatch +;; -------------------------------------------------------------------------- + +(define vm-run + (fn (vm) + "Execute bytecode until all frames are exhausted. + VmClosure calls push new frames; the loop picks them up. + OP_TAIL_CALL + VmClosure = true TCO: drop frame, push new, loop." + (define loop + (fn () + (when (not (empty? (get vm "frames"))) + (let ((frame (first (get vm "frames"))) + (rest-frames (rest (get vm "frames")))) + (let ((bc (get (get (get frame "closure") "vm-code") "vc-bytecode")) + (consts (get (get (get frame "closure") "vm-code") "vc-constants"))) + (if (>= (get frame "ip") (len bc)) + ;; Bytecode exhausted — stop + (dict-set! vm "frames" (list)) + (do + (vm-step vm frame rest-frames bc consts) + (loop)))))))) + (loop))) + + +;; -------------------------------------------------------------------------- +;; 11. Single step — opcode dispatch +;; -------------------------------------------------------------------------- + +(define vm-step + (fn (vm frame rest-frames bc consts) + (let ((op (frame-read-u8 frame))) + (cond + + ;; ---- Constants ---- + (= op 1) ;; OP_CONST + (let ((idx (frame-read-u16 frame))) + (vm-push vm (nth consts idx))) + + (= op 2) ;; OP_NIL + (vm-push vm nil) + + (= op 3) ;; OP_TRUE + (vm-push vm true) + + (= op 4) ;; OP_FALSE + (vm-push vm false) + + (= op 5) ;; OP_POP + (vm-pop vm) + + (= op 6) ;; OP_DUP + (vm-push vm (vm-peek vm)) + + ;; ---- Variable access ---- + (= op 16) ;; OP_LOCAL_GET + (let ((slot (frame-read-u8 frame))) + (vm-push vm (frame-local-get vm frame slot))) + + (= op 17) ;; OP_LOCAL_SET + (let ((slot (frame-read-u8 frame))) + (frame-local-set vm frame slot (vm-peek vm))) + + (= op 18) ;; OP_UPVALUE_GET + (let ((idx (frame-read-u8 frame))) + (vm-push vm (frame-upvalue-get frame idx))) + + (= op 19) ;; OP_UPVALUE_SET + (let ((idx (frame-read-u8 frame))) + (frame-upvalue-set frame idx (vm-peek vm))) + + (= op 20) ;; OP_GLOBAL_GET + (let ((idx (frame-read-u16 frame)) + (name (nth consts idx))) + (vm-push vm (vm-global-get vm frame name))) + + (= op 21) ;; OP_GLOBAL_SET + (let ((idx (frame-read-u16 frame)) + (name (nth consts idx))) + (vm-global-set vm frame name (vm-peek vm))) + + ;; ---- Control flow ---- + (= op 32) ;; OP_JUMP + (let ((offset (frame-read-i16 frame))) + (dict-set! frame "ip" (+ (get frame "ip") offset))) + + (= op 33) ;; OP_JUMP_IF_FALSE + (let ((offset (frame-read-i16 frame)) + (v (vm-pop vm))) + (when (not v) + (dict-set! frame "ip" (+ (get frame "ip") offset)))) + + (= op 34) ;; OP_JUMP_IF_TRUE + (let ((offset (frame-read-i16 frame)) + (v (vm-pop vm))) + (when v + (dict-set! frame "ip" (+ (get frame "ip") offset)))) + + ;; ---- Function calls ---- + (= op 48) ;; OP_CALL + (let ((argc (frame-read-u8 frame)) + (args-rev (list)) + (i 0)) + (define collect-args + (fn () + (when (< i argc) + (set! args-rev (cons (vm-pop vm) args-rev)) + (set! i (+ i 1)) + (collect-args)))) + (collect-args) + (let ((f (vm-pop vm))) + (vm-call vm f args-rev))) + + (= op 49) ;; OP_TAIL_CALL + (let ((argc (frame-read-u8 frame)) + (args-rev (list)) + (i 0)) + (define collect-args + (fn () + (when (< i argc) + (set! args-rev (cons (vm-pop vm) args-rev)) + (set! i (+ i 1)) + (collect-args)))) + (collect-args) + (let ((f (vm-pop vm))) + ;; Drop current frame, reuse stack space — true TCO + (dict-set! vm "frames" rest-frames) + (dict-set! vm "sp" (get frame "base")) + (vm-call vm f args-rev))) + + (= op 50) ;; OP_RETURN + (let ((result (vm-pop vm))) + (dict-set! vm "frames" rest-frames) + (dict-set! vm "sp" (get frame "base")) + (vm-push vm result)) + + (= op 51) ;; OP_CLOSURE + (let ((idx (frame-read-u16 frame)) + (code-val (nth consts idx))) + (let ((cl (vm-create-closure vm frame code-val))) + (vm-push vm cl))) + + (= op 52) ;; OP_CALL_PRIM + (let ((idx (frame-read-u16 frame)) + (argc (frame-read-u8 frame)) + (name (nth consts idx)) + (args-rev (list)) + (i 0)) + (define collect-args + (fn () + (when (< i argc) + (set! args-rev (cons (vm-pop vm) args-rev)) + (set! i (+ i 1)) + (collect-args)))) + (collect-args) + (vm-push vm (call-primitive name args-rev))) + + ;; ---- Collections ---- + (= op 64) ;; OP_LIST + (let ((count (frame-read-u16 frame)) + (items-rev (list)) + (i 0)) + (define collect-items + (fn () + (when (< i count) + (set! items-rev (cons (vm-pop vm) items-rev)) + (set! i (+ i 1)) + (collect-items)))) + (collect-items) + (vm-push vm items-rev)) + + (= op 65) ;; OP_DICT + (let ((count (frame-read-u16 frame)) + (d {}) + (i 0)) + (define collect-pairs + (fn () + (when (< i count) + (let ((v (vm-pop vm)) + (k (vm-pop vm))) + (dict-set! d k v) + (set! i (+ i 1)) + (collect-pairs))))) + (collect-pairs) + (vm-push vm d)) + + ;; ---- String ops ---- + (= op 144) ;; OP_STR_CONCAT + (let ((count (frame-read-u8 frame)) + (parts-rev (list)) + (i 0)) + (define collect-parts + (fn () + (when (< i count) + (set! parts-rev (cons (vm-pop vm) parts-rev)) + (set! i (+ i 1)) + (collect-parts)))) + (collect-parts) + (vm-push vm (apply str parts-rev))) + + ;; ---- Define ---- + (= op 128) ;; OP_DEFINE + (let ((idx (frame-read-u16 frame)) + (name (nth consts idx))) + (dict-set! (get vm "globals") name (vm-peek vm))) + + :else + (error (str "VM: unknown opcode " op)))))) + + +;; -------------------------------------------------------------------------- +;; 12. Entry points +;; -------------------------------------------------------------------------- + +;; Execute a closure with arguments — creates a fresh VM. +(define vm-call-closure + (fn (closure args globals) + (let ((vm (make-vm globals))) + (vm-push-frame vm closure args) + (vm-run vm) + (vm-pop vm)))) + +;; Execute a compiled module (top-level bytecode). +(define vm-execute-module + (fn (code globals) + (let ((closure (make-vm-closure code (list) "module" globals nil)) + (vm (make-vm globals))) + (let ((frame (make-vm-frame closure 0))) + ;; Pad local slots + (let ((i 0) + (total (get code "vc-locals"))) + (define pad-loop + (fn () + (when (< i total) + (vm-push vm nil) + (set! i (+ i 1)) + (pad-loop)))) + (pad-loop)) + (dict-set! vm "frames" (list frame)) + (vm-run vm) + (vm-pop vm))))) + + +;; -------------------------------------------------------------------------- +;; 13. Platform interface +;; -------------------------------------------------------------------------- +;; +;; Each target must provide: +;; +;; make-vm-stack(size) → opaque stack (array-like) +;; vm-stack-get(stack, idx) → value at index +;; vm-stack-set!(stack, idx, value) → mutate index +;; vm-stack-length(stack) → current capacity +;; vm-stack-copy!(src, dst, count) → copy first count elements +;; +;; cek-call(f, args) → evaluate via CEK machine (fallback) +;; get-primitive(name) → look up primitive by name (returns callable) +;; call-primitive(name, args) → call primitive directly with args list +;; +;; env-parent(env) → parent environment or nil +;; env-has?(env, name) → boolean +;; env-get(env, name) → value +;; env-set!(env, name, value) → mutate binding