From 98f74149b285dc163a5481fa7a0d5a3c2e9f4297 Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 29 Mar 2026 19:20:30 +0000 Subject: [PATCH] Add compile-match to bytecode compiler, use match in compile-list The JIT compiler now handles the match special form, emitting the same DUP/compare/JUMP_IF_FALSE bytecode pattern as case. Supports literal patterns (string, number, boolean, nil), _ wildcard, symbol binding, and quoted symbol patterns. This fixes the infinite JIT retry loop where compile-list (which used match for dispatch) couldn't be JIT-compiled, causing parse-loop to endlessly fall back to CEK evaluation. 1166 passed, 0 failed. Co-Authored-By: Claude Opus 4.6 (1M context) --- lib/compiler.sx | 1268 +++++++++++++++++++++++------------------------ 1 file changed, 618 insertions(+), 650 deletions(-) diff --git a/lib/compiler.sx b/lib/compiler.sx index c1aa987b..85f36e43 100644 --- a/lib/compiler.sx +++ b/lib/compiler.sx @@ -1,826 +1,794 @@ -;; ========================================================================== -;; compiler.sx — SX bytecode compiler -;; -;; Compiles SX AST to bytecode for the platform-native VM. -;; Written in SX — runs on any platform with an SX evaluator. -;; -;; Architecture: -;; Pass 1: Scope analysis — resolve variables, detect tail positions -;; Pass 2: Code generation — emit bytecode -;; -;; The compiler produces Code objects (bytecode + constant pool). -;; The VM executes them with a stack machine model. -;; ========================================================================== +(define make-pool (fn () {:entries (if (primitive? "mutable-list") (mutable-list) (list)) :index {:_count 0}})) - -;; -------------------------------------------------------------------------- -;; Constant pool builder -;; -------------------------------------------------------------------------- - -(define make-pool - (fn () - {:entries (if (primitive? "mutable-list") (mutable-list) (list)) - :index {:_count 0}})) - -(define pool-add - (fn (pool value) +(define + pool-add + (fn + (pool value) "Add a value to the constant pool, return its index. Deduplicates." - (let ((key (serialize value)) - (idx-map (get pool "index"))) - (if (has-key? idx-map key) + (let + ((key (serialize value)) (idx-map (get pool "index"))) + (if + (has-key? idx-map key) (get idx-map key) - (let ((idx (get idx-map "_count"))) + (let + ((idx (get idx-map "_count"))) (dict-set! idx-map key idx) (dict-set! idx-map "_count" (+ idx 1)) (append! (get pool "entries") value) idx))))) +(define make-scope (fn (parent) {:next-slot 0 :upvalues (list) :locals (list) :parent parent :is-function false})) -;; -------------------------------------------------------------------------- -;; Scope analysis -;; -------------------------------------------------------------------------- - -(define make-scope - (fn (parent) - {:locals (list) ;; list of {name, slot, mutable?} - :upvalues (list) ;; list of {name, is-local, index} - :parent parent - :is-function false ;; true for fn/lambda scopes (create frames) - :next-slot 0})) - -(define scope-define-local - (fn (scope name) - "Add a local variable, return its slot index. - Idempotent: if name already has a slot, return it." - (let ((existing (first (filter (fn (l) (= (get l "name") name)) - (get scope "locals"))))) - (if existing +(define + scope-define-local + (fn + (scope name) + "Add a local variable, return its slot index.\n Idempotent: if name already has a slot, return it." + (let + ((existing (first (filter (fn (l) (= (get l "name") name)) (get scope "locals"))))) + (if + existing (get existing "slot") - (let ((slot (get scope "next-slot"))) - (append! (get scope "locals") - {:name name :slot slot :mutable false}) + (let + ((slot (get scope "next-slot"))) + (append! (get scope "locals") {:mutable false :slot slot :name name}) (dict-set! scope "next-slot" (+ slot 1)) slot))))) -(define scope-resolve - (fn (scope name) - "Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}. - Upvalue captures only happen at function boundaries (is-function=true). - Let scopes share the enclosing function's frame — their locals are - accessed directly without upvalue indirection." - (if (nil? scope) - {:type "global" :index name} - ;; Check locals in this scope - (let ((locals (get scope "locals")) - (found (some (fn (l) (= (get l "name") name)) locals))) - (if found - (let ((local (first (filter (fn (l) (= (get l "name") name)) locals)))) - {:type "local" :index (get local "slot")}) - ;; Check upvalues already captured at this scope - (let ((upvals (get scope "upvalues")) - (uv-found (some (fn (u) (= (get u "name") name)) upvals))) - (if uv-found - (let ((uv (first (filter (fn (u) (= (get u "name") name)) upvals)))) - {:type "upvalue" :index (get uv "uv-index")}) - ;; Look in parent - (let ((parent (get scope "parent"))) - (if (nil? parent) - {:type "global" :index name} - (let ((parent-result (scope-resolve parent name))) - (if (= (get parent-result "type") "global") +(define + scope-resolve + (fn + (scope name) + "Resolve a variable name. Returns {:type \"local\"|\"upvalue\"|\"global\", :index N}.\n Upvalue captures only happen at function boundaries (is-function=true).\n Let scopes share the enclosing function's frame — their locals are\n accessed directly without upvalue indirection." + (if + (nil? scope) + {:index name :type "global"} + (let + ((locals (get scope "locals")) + (found (some (fn (l) (= (get l "name") name)) locals))) + (if + found + (let + ((local (first (filter (fn (l) (= (get l "name") name)) locals)))) + {:index (get local "slot") :type "local"}) + (let + ((upvals (get scope "upvalues")) + (uv-found (some (fn (u) (= (get u "name") name)) upvals))) + (if + uv-found + (let + ((uv (first (filter (fn (u) (= (get u "name") name)) upvals)))) + {:index (get uv "uv-index") :type "upvalue"}) + (let + ((parent (get scope "parent"))) + (if + (nil? parent) + {:index name :type "global"} + (let + ((parent-result (scope-resolve parent name))) + (if + (= (get parent-result "type") "global") parent-result - ;; Found in parent. Capture as upvalue only at function boundaries. - (if (get scope "is-function") - ;; Function boundary — create upvalue capture - (let ((uv-idx (len (get scope "upvalues")))) - (append! (get scope "upvalues") - {:name name - :is-local (= (get parent-result "type") "local") - :index (get parent-result "index") - :uv-index uv-idx}) - {:type "upvalue" :index uv-idx}) - ;; Let scope — pass through (same frame) + (if + (get scope "is-function") + (let + ((uv-idx (len (get scope "upvalues")))) + (append! (get scope "upvalues") {:index (get parent-result "index") :is-local (= (get parent-result "type") "local") :uv-index uv-idx :name name}) + {:index uv-idx :type "upvalue"}) parent-result)))))))))))) +(define make-emitter (fn () {:pool (make-pool) :bytecode (if (primitive? "mutable-list") (mutable-list) (list))})) -;; -------------------------------------------------------------------------- -;; Code emitter -;; -------------------------------------------------------------------------- +(define emit-byte (fn (em byte) (append! (get em "bytecode") byte))) -(define make-emitter - (fn () - {:bytecode (if (primitive? "mutable-list") (mutable-list) (list)) - :pool (make-pool)})) - -(define emit-byte - (fn (em byte) - (append! (get em "bytecode") byte))) - -(define emit-u16 - (fn (em value) +(define + emit-u16 + (fn + (em value) (emit-byte em (mod value 256)) (emit-byte em (mod (floor (/ value 256)) 256)))) -(define emit-i16 - (fn (em value) - (let ((v (if (< value 0) (+ value 65536) value))) - (emit-u16 em v)))) +(define + emit-i16 + (fn + (em value) + (let ((v (if (< value 0) (+ value 65536) value))) (emit-u16 em v)))) -(define emit-op - (fn (em opcode) - (emit-byte em opcode))) +(define emit-op (fn (em opcode) (emit-byte em opcode))) -(define emit-const - (fn (em value) - (let ((idx (pool-add (get em "pool") value))) - (emit-op em 1) ;; OP_CONST +(define + emit-const + (fn + (em value) + (let + ((idx (pool-add (get em "pool") value))) + (emit-op em 1) (emit-u16 em idx)))) -(define current-offset - (fn (em) - (len (get em "bytecode")))) +(define current-offset (fn (em) (len (get em "bytecode")))) -(define patch-i16 - (fn (em offset value) +(define + patch-i16 + (fn + (em offset value) "Patch a previously emitted i16 at the given bytecode offset." - (let ((v (if (< value 0) (+ value 65536) value)) - (bc (get em "bytecode"))) - ;; Direct mutation of bytecode list at offset + (let + ((v (if (< value 0) (+ value 65536) value)) + (bc (get em "bytecode"))) (set-nth! bc offset (mod v 256)) (set-nth! bc (+ offset 1) (mod (floor (/ v 256)) 256))))) - -;; -------------------------------------------------------------------------- -;; Compilation — expression dispatch -;; -------------------------------------------------------------------------- - -(define compile-expr - (fn (em expr scope tail?) +(define + compile-expr + (fn + (em expr scope tail?) "Compile an expression. tail? indicates tail position for TCO." (cond - ;; Nil (nil? expr) - (emit-op em 2) ;; OP_NIL - - ;; Number + (emit-op em 2) (= (type-of expr) "number") - (emit-const em expr) - - ;; String + (emit-const em expr) (= (type-of expr) "string") - (emit-const em expr) - - ;; Boolean + (emit-const em expr) (= (type-of expr) "boolean") - (emit-op em (if expr 3 4)) ;; OP_TRUE / OP_FALSE - - ;; Keyword + (emit-op em (if expr 3 4)) (= (type-of expr) "keyword") - (emit-const em (keyword-name expr)) - - ;; Symbol — resolve to local/upvalue/global + (emit-const em (keyword-name expr)) (= (type-of expr) "symbol") - (compile-symbol em (symbol-name expr) scope) - - ;; List — dispatch on head + (compile-symbol em (symbol-name expr) scope) (= (type-of expr) "list") - (if (empty? expr) - (do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0 - (compile-list em expr scope tail?)) - - ;; Dict literal + (if + (empty? expr) + (do (emit-op em 64) (emit-u16 em 0)) + (compile-list em expr scope tail?)) (= (type-of expr) "dict") - (compile-dict em expr scope) + (compile-dict em expr scope) + :else (emit-const em expr)))) - ;; Fallback - :else - (emit-const em expr)))) - - -(define compile-symbol - (fn (em name scope) - (let ((resolved (scope-resolve scope name))) +(define + compile-symbol + (fn + (em name scope) + (let + ((resolved (scope-resolve scope name))) (cond (= (get resolved "type") "local") - (do (emit-op em 16) ;; OP_LOCAL_GET - (emit-byte em (get resolved "index"))) + (do (emit-op em 16) (emit-byte em (get resolved "index"))) (= (get resolved "type") "upvalue") - (do (emit-op em 18) ;; OP_UPVALUE_GET - (emit-byte em (get resolved "index"))) - :else - ;; Global or primitive - (let ((idx (pool-add (get em "pool") name))) - (emit-op em 20) ;; OP_GLOBAL_GET - (emit-u16 em idx)))))) + (do (emit-op em 18) (emit-byte em (get resolved "index"))) + :else (let + ((idx (pool-add (get em "pool") name))) + (emit-op em 20) + (emit-u16 em idx)))))) - -(define compile-dict - (fn (em expr scope) - (let ((ks (keys expr)) - (count (len ks))) - (for-each (fn (k) - (emit-const em k) - (compile-expr em (get expr k) scope false)) +(define + compile-dict + (fn + (em expr scope) + (let + ((ks (keys expr)) (count (len ks))) + (for-each + (fn + (k) + (emit-const em k) + (compile-expr em (get expr k) scope false)) ks) - (emit-op em 65) ;; OP_DICT + (emit-op em 65) (emit-u16 em count)))) - -;; -------------------------------------------------------------------------- -;; List compilation — special forms, calls -;; -------------------------------------------------------------------------- - -(define compile-list - (fn (em expr scope tail?) - (let ((head (first expr)) - (args (rest expr))) - (if (not (= (type-of head) "symbol")) - ;; Non-symbol head — compile as call +(define + compile-list + (fn + (em expr scope tail?) + (let + ((head (first expr)) (args (rest expr))) + (if + (not (= (type-of head) "symbol")) (compile-call em head args scope tail?) - ;; Symbol head — check for special forms - (let ((name (symbol-name head))) - (cond - (= name "if") (compile-if em args scope tail?) - (= name "when") (compile-when em args scope tail?) - (= name "and") (compile-and em args scope tail?) - (= name "or") (compile-or em args scope tail?) - (= name "let") (compile-let em args scope tail?) - (= name "let*") (compile-let em args scope tail?) - (= name "begin") (compile-begin em args scope tail?) - (= name "do") (compile-begin em args scope tail?) - (= name "lambda") (compile-lambda em args scope) - (= name "fn") (compile-lambda em args scope) - (= name "define") (compile-define em args scope) - (= name "set!") (compile-set em args scope) - (= name "quote") (compile-quote em args) - (= name "cond") (compile-cond em args scope tail?) - (= name "case") (compile-case em args scope tail?) - (= name "->") (compile-thread em args scope tail?) - (= name "defcomp") (compile-defcomp em args scope) - (= name "defisland") (compile-defcomp em args scope) - (= name "defmacro") (compile-defmacro em args scope) - (= name "defstyle") (emit-op em 2) ;; defstyle → nil (no-op at runtime) - (= name "defhandler") (emit-op em 2) ;; no-op - (= name "defpage") (emit-op em 2) ;; handled by page loader - (= name "defquery") (emit-op em 2) - (= name "defaction") (emit-op em 2) - (= name "defrelation") (emit-op em 2) - (= name "deftype") (emit-op em 2) - (= name "defeffect") (emit-op em 2) - (= name "defisland") (compile-defcomp em args scope) - (= name "quasiquote") (compile-quasiquote em (first args) scope) - (= name "letrec") (compile-letrec em args scope tail?) - ;; Default — function call - :else - (compile-call em head args scope tail?))))))) + (let + ((name (symbol-name head))) + (match + name + ("if" (compile-if em args scope tail?)) + ("when" (compile-when em args scope tail?)) + ("and" (compile-and em args scope tail?)) + ("or" (compile-or em args scope tail?)) + ("let" (compile-let em args scope tail?)) + ("let*" (compile-let em args scope tail?)) + ("begin" (compile-begin em args scope tail?)) + ("do" (compile-begin em args scope tail?)) + ("lambda" (compile-lambda em args scope)) + ("fn" (compile-lambda em args scope)) + ("define" (compile-define em args scope)) + ("set!" (compile-set em args scope)) + ("quote" (compile-quote em args)) + ("cond" (compile-cond em args scope tail?)) + ("case" (compile-case em args scope tail?)) + ("match" (compile-match em args scope tail?)) + ("->" (compile-thread em args scope tail?)) + ("defcomp" (compile-defcomp em args scope)) + ("defisland" (compile-defcomp em args scope)) + ("defmacro" (compile-defmacro em args scope)) + ("defstyle" (emit-op em 2)) + ("defhandler" (emit-op em 2)) + ("defpage" (emit-op em 2)) + ("defquery" (emit-op em 2)) + ("defaction" (emit-op em 2)) + ("defrelation" (emit-op em 2)) + ("deftype" (emit-op em 2)) + ("defeffect" (emit-op em 2)) + ("quasiquote" (compile-quasiquote em (first args) scope)) + ("letrec" (compile-letrec em args scope tail?)) + (_ (compile-call em head args scope tail?)))))))) - -;; -------------------------------------------------------------------------- -;; Special form compilation -;; -------------------------------------------------------------------------- - -(define compile-if - (fn (em args scope tail?) - (let ((test (first args)) - (then-expr (nth args 1)) - (else-expr (if (> (len args) 2) (nth args 2) nil))) - ;; Compile test +(define + compile-if + (fn + (em args scope tail?) + (let + ((test (first args)) + (then-expr (nth args 1)) + (else-expr (if (> (len args) 2) (nth args 2) nil))) (compile-expr em test scope false) - ;; Jump if false to else - (emit-op em 33) ;; OP_JUMP_IF_FALSE - (let ((else-jump (current-offset em))) - (emit-i16 em 0) ;; placeholder - ;; Compile then (in tail position if if is) + (emit-op em 33) + (let + ((else-jump (current-offset em))) + (emit-i16 em 0) (compile-expr em then-expr scope tail?) - ;; Jump over else - (emit-op em 32) ;; OP_JUMP - (let ((end-jump (current-offset em))) - (emit-i16 em 0) ;; placeholder - ;; Patch else jump + (emit-op em 32) + (let + ((end-jump (current-offset em))) + (emit-i16 em 0) (patch-i16 em else-jump (- (current-offset em) (+ else-jump 2))) - ;; Compile else - (if (nil? else-expr) - (emit-op em 2) ;; OP_NIL + (if + (nil? else-expr) + (emit-op em 2) (compile-expr em else-expr scope tail?)) - ;; Patch end jump (patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))) - -(define compile-when - (fn (em args scope tail?) - (let ((test (first args)) - (body (rest args))) +(define + compile-when + (fn + (em args scope tail?) + (let + ((test (first args)) (body (rest args))) (compile-expr em test scope false) - (emit-op em 33) ;; OP_JUMP_IF_FALSE - (let ((skip-jump (current-offset em))) + (emit-op em 33) + (let + ((skip-jump (current-offset em))) (emit-i16 em 0) (compile-begin em body scope tail?) - (emit-op em 32) ;; OP_JUMP - (let ((end-jump (current-offset em))) + (emit-op em 32) + (let + ((end-jump (current-offset em))) (emit-i16 em 0) (patch-i16 em skip-jump (- (current-offset em) (+ skip-jump 2))) - (emit-op em 2) ;; OP_NIL + (emit-op em 2) (patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))) - -(define compile-and - (fn (em args scope tail?) - (if (empty? args) - (emit-op em 3) ;; OP_TRUE - (if (= (len args) 1) +(define + compile-and + (fn + (em args scope tail?) + (if + (empty? args) + (emit-op em 3) + (if + (= (len args) 1) (compile-expr em (first args) scope tail?) (do (compile-expr em (first args) scope false) - (emit-op em 6) ;; OP_DUP - (emit-op em 33) ;; OP_JUMP_IF_FALSE - (let ((skip (current-offset em))) + (emit-op em 6) + (emit-op em 33) + (let + ((skip (current-offset em))) (emit-i16 em 0) - (emit-op em 5) ;; OP_POP (discard duplicated truthy) + (emit-op em 5) (compile-and em (rest args) scope tail?) (patch-i16 em skip (- (current-offset em) (+ skip 2))))))))) - -(define compile-or - (fn (em args scope tail?) - (if (empty? args) - (emit-op em 4) ;; OP_FALSE - (if (= (len args) 1) +(define + compile-or + (fn + (em args scope tail?) + (if + (empty? args) + (emit-op em 4) + (if + (= (len args) 1) (compile-expr em (first args) scope tail?) (do (compile-expr em (first args) scope false) - (emit-op em 6) ;; OP_DUP - (emit-op em 34) ;; OP_JUMP_IF_TRUE - (let ((skip (current-offset em))) + (emit-op em 6) + (emit-op em 34) + (let + ((skip (current-offset em))) (emit-i16 em 0) - (emit-op em 5) ;; OP_POP + (emit-op em 5) (compile-or em (rest args) scope tail?) (patch-i16 em skip (- (current-offset em) (+ skip 2))))))))) - -(define compile-begin - (fn (em exprs scope tail?) - ;; Hoist: pre-allocate local slots for all define forms in this block. - ;; Enables forward references between inner functions (e.g. sx-parse). - ;; Only inside function bodies (scope has parent), not at top level. - (when (and (not (empty? exprs)) (not (nil? (get scope "parent")))) - (for-each (fn (expr) - (when (and (= (type-of expr) "list") - (>= (len expr) 2) - (= (type-of (first expr)) "symbol") - (= (symbol-name (first expr)) "define")) - (let ((name-expr (nth expr 1)) - (name (if (= (type-of name-expr) "symbol") - (symbol-name name-expr) - name-expr))) - (scope-define-local scope name)))) +(define + compile-begin + (fn + (em exprs scope tail?) + (when + (and (not (empty? exprs)) (not (nil? (get scope "parent")))) + (for-each + (fn + (expr) + (when + (and + (= (type-of expr) "list") + (>= (len expr) 2) + (= (type-of (first expr)) "symbol") + (= (symbol-name (first expr)) "define")) + (let + ((name-expr (nth expr 1)) + (name + (if + (= (type-of name-expr) "symbol") + (symbol-name name-expr) + name-expr))) + (scope-define-local scope name)))) exprs)) - ;; Compile expressions - (if (empty? exprs) - (emit-op em 2) ;; OP_NIL - (if (= (len exprs) 1) + (if + (empty? exprs) + (emit-op em 2) + (if + (= (len exprs) 1) (compile-expr em (first exprs) scope tail?) (do (compile-expr em (first exprs) scope false) - (emit-op em 5) ;; OP_POP + (emit-op em 5) (compile-begin em (rest exprs) scope tail?)))))) - -(define compile-let - (fn (em args scope tail?) - ;; Detect named let: (let loop ((x init) ...) body) - (if (= (type-of (first args)) "symbol") - ;; Named let → desugar to letrec: - ;; (letrec ((loop (fn (x ...) body))) (loop init ...)) - (let ((loop-name (symbol-name (first args))) - (bindings (nth args 1)) - (body (slice args 2)) - (params (list)) - (inits (list))) - (for-each (fn (binding) - (append! params (if (= (type-of (first binding)) "symbol") - (first binding) - (make-symbol (first binding)))) - (append! inits (nth binding 1))) +(define + compile-let + (fn + (em args scope tail?) + (if + (= (type-of (first args)) "symbol") + (let + ((loop-name (symbol-name (first args))) + (bindings (nth args 1)) + (body (slice args 2)) + (params (list)) + (inits (list))) + (for-each + (fn + (binding) + (append! + params + (if + (= (type-of (first binding)) "symbol") + (first binding) + (make-symbol (first binding)))) + (append! inits (nth binding 1))) bindings) - ;; Compile as: (letrec ((loop (fn (params...) body...))) (loop inits...)) - (let ((lambda-expr (concat (list (make-symbol "fn") params) body)) - (letrec-bindings (list (list (make-symbol loop-name) lambda-expr))) - (call-expr (cons (make-symbol loop-name) inits))) + (let + ((lambda-expr (concat (list (make-symbol "fn") params) body)) + (letrec-bindings + (list (list (make-symbol loop-name) lambda-expr))) + (call-expr (cons (make-symbol loop-name) inits))) (compile-letrec em (list letrec-bindings call-expr) scope tail?))) - ;; Normal let - (let ((bindings (first args)) - (body (rest args)) - (let-scope (make-scope scope))) - ;; Let scopes share the enclosing function's frame. - ;; Continue slot numbering from parent. - (dict-set! let-scope "next-slot" (get scope "next-slot")) - ;; Compile each binding - (for-each (fn (binding) - (let ((name (if (= (type-of (first binding)) "symbol") - (symbol-name (first binding)) - (first binding))) - (value (nth binding 1)) - (slot (scope-define-local let-scope name))) - (compile-expr em value let-scope false) - (emit-op em 17) ;; OP_LOCAL_SET - (emit-byte em slot))) - bindings) - ;; Compile body in let scope - (compile-begin em body let-scope tail?))))) - - -(define compile-letrec - (fn (em args scope tail?) - "Compile letrec: all names visible during value compilation. - 1. Define all local slots (initialized to nil). - 2. Compile each value and assign — names are already in scope - so mutually recursive functions can reference each other." - (let ((bindings (first args)) + (let + ((bindings (first args)) (body (rest args)) (let-scope (make-scope scope))) + (dict-set! let-scope "next-slot" (get scope "next-slot")) + (for-each + (fn + (binding) + (let + ((name (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (first binding))) + (value (nth binding 1)) + (slot (scope-define-local let-scope name))) + (compile-expr em value let-scope false) + (emit-op em 17) + (emit-byte em slot))) + bindings) + (compile-begin em body let-scope tail?))))) + +(define + compile-letrec + (fn + (em args scope tail?) + "Compile letrec: all names visible during value compilation.\n 1. Define all local slots (initialized to nil).\n 2. Compile each value and assign — names are already in scope\n so mutually recursive functions can reference each other." + (let + ((bindings (first args)) + (body (rest args)) + (let-scope (make-scope scope))) (dict-set! let-scope "next-slot" (get scope "next-slot")) - ;; Phase 1: define all slots (push nil for each) - (let ((slots (map (fn (binding) - (let ((name (if (= (type-of (first binding)) "symbol") - (symbol-name (first binding)) - (first binding)))) - (let ((slot (scope-define-local let-scope name))) - (emit-op em 2) ;; OP_NIL - (emit-op em 17) ;; OP_LOCAL_SET - (emit-byte em slot) - slot))) - bindings))) - ;; Phase 2: compile values and assign (all names in scope) - (for-each (fn (pair) - (let ((binding (first pair)) - (slot (nth pair 1))) - (compile-expr em (nth binding 1) let-scope false) - (emit-op em 17) ;; OP_LOCAL_SET - (emit-byte em slot))) - (map (fn (i) (list (nth bindings i) (nth slots i))) - (range 0 (len bindings))))) - ;; Compile body + (let + ((slots (map (fn (binding) (let ((name (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (first binding)))) (let ((slot (scope-define-local let-scope name))) (emit-op em 2) (emit-op em 17) (emit-byte em slot) slot))) bindings))) + (for-each + (fn + (pair) + (let + ((binding (first pair)) (slot (nth pair 1))) + (compile-expr em (nth binding 1) let-scope false) + (emit-op em 17) + (emit-byte em slot))) + (map + (fn (i) (list (nth bindings i) (nth slots i))) + (range 0 (len bindings))))) (compile-begin em body let-scope tail?)))) -(define compile-lambda - (fn (em args scope) - (let ((params (first args)) - (body (rest args)) - (fn-scope (make-scope scope)) - (fn-em (make-emitter))) - ;; Mark as function boundary — upvalue captures happen here +(define + compile-lambda + (fn + (em args scope) + (let + ((params (first args)) + (body (rest args)) + (fn-scope (make-scope scope)) + (fn-em (make-emitter))) (dict-set! fn-scope "is-function" true) - ;; Define params as locals in fn scope. - ;; Handle type annotations: (name :as type) → extract name - (for-each (fn (p) - (let ((name (cond - (= (type-of p) "symbol") (symbol-name p) - ;; Type-annotated param: (name :as type) - (and (list? p) (not (empty? p)) - (= (type-of (first p)) "symbol")) - (symbol-name (first p)) - :else p))) - (when (and (not (= name "&key")) - (not (= name "&rest"))) - (scope-define-local fn-scope name)))) + (for-each + (fn + (p) + (let + ((name (cond (= (type-of p) "symbol") (symbol-name p) (and (list? p) (not (empty? p)) (= (type-of (first p)) "symbol")) (symbol-name (first p)) :else p))) + (when + (and (not (= name "&key")) (not (= name "&rest"))) + (scope-define-local fn-scope name)))) params) - ;; Compile body - (compile-begin fn-em body fn-scope true) ;; tail position - (emit-op fn-em 50) ;; OP_RETURN - ;; Add code object to parent constant pool - (let ((upvals (get fn-scope "upvalues")) - (code {:arity (len (get fn-scope "locals")) - :bytecode (get fn-em "bytecode") - :constants (get (get fn-em "pool") "entries") - :upvalue-count (len upvals)}) - (code-idx (pool-add (get em "pool") code))) - (emit-op em 51) ;; OP_CLOSURE + (compile-begin fn-em body fn-scope true) + (emit-op fn-em 50) + (let + ((upvals (get fn-scope "upvalues")) + (code {:upvalue-count (len upvals) :arity (len (get fn-scope "locals")) :constants (get (get fn-em "pool") "entries") :bytecode (get fn-em "bytecode")}) + (code-idx (pool-add (get em "pool") code))) + (emit-op em 51) (emit-u16 em code-idx) - ;; Emit upvalue descriptors: for each captured variable, - ;; (is_local, index) — tells the VM where to find the value. - ;; is_local=1: capture from enclosing frame's local slot - ;; is_local=0: capture from enclosing frame's upvalue - (for-each (fn (uv) - (emit-byte em (if (get uv "is-local") 1 0)) - (emit-byte em (get uv "index"))) + (for-each + (fn + (uv) + (emit-byte em (if (get uv "is-local") 1 0)) + (emit-byte em (get uv "index"))) upvals))))) +(define + compile-define + (fn + (em args scope) + (let + ((name-expr (first args)) + (name + (if + (= (type-of name-expr) "symbol") + (symbol-name name-expr) + name-expr)) + (value + (let + ((rest-args (rest args))) + (if + (and + (not (empty? rest-args)) + (= (type-of (first rest-args)) "keyword")) + (let + ((skip-annotations (fn (items) (if (empty? items) nil (if (= (type-of (first items)) "keyword") (skip-annotations (rest (rest items))) (first items)))))) + (skip-annotations rest-args)) + (first rest-args))))) + (if + (not (nil? (get scope "parent"))) + (let + ((slot (scope-define-local scope name))) + (compile-expr em value scope false) + (emit-op em 17) + (emit-byte em slot)) + (let + ((name-idx (pool-add (get em "pool") name))) + (compile-expr em value scope false) + (emit-op em 128) + (emit-u16 em name-idx)))))) -(define compile-define - (fn (em args scope) - (let ((name-expr (first args)) - (name (if (= (type-of name-expr) "symbol") - (symbol-name name-expr) - name-expr)) - ;; Handle :effects annotation: (define name :effects [...] value) - ;; Skip keyword-value pairs between name and body - (value (let ((rest-args (rest args))) - (if (and (not (empty? rest-args)) - (= (type-of (first rest-args)) "keyword")) - ;; Skip :keyword value pairs until we hit the body - (let ((skip-annotations - (fn (items) - (if (empty? items) nil - (if (= (type-of (first items)) "keyword") - (skip-annotations (rest (rest items))) - (first items)))))) - (skip-annotations rest-args)) - (first rest-args))))) - ;; Inside a function body, define creates a LOCAL binding. - ;; At top level (no enclosing function scope), define creates a global. - ;; Local binding prevents recursive calls from overwriting - ;; each other's defines in the flat globals hashtable. - (if (not (nil? (get scope "parent"))) - ;; Local define — allocate slot, compile value, set local - (let ((slot (scope-define-local scope name))) - (compile-expr em value scope false) - (emit-op em 17) ;; OP_LOCAL_SET - (emit-byte em slot)) - ;; Top-level define — global - (let ((name-idx (pool-add (get em "pool") name))) - (compile-expr em value scope false) - (emit-op em 128) ;; OP_DEFINE - (emit-u16 em name-idx)))))) - - -(define compile-set - (fn (em args scope) - (let ((name (if (= (type-of (first args)) "symbol") - (symbol-name (first args)) - (first args))) - (value (nth args 1)) - (resolved (scope-resolve scope name))) +(define + compile-set + (fn + (em args scope) + (let + ((name (if (= (type-of (first args)) "symbol") (symbol-name (first args)) (first args))) + (value (nth args 1)) + (resolved (scope-resolve scope name))) (compile-expr em value scope false) (cond (= (get resolved "type") "local") - (do (emit-op em 17) ;; OP_LOCAL_SET - (emit-byte em (get resolved "index"))) + (do (emit-op em 17) (emit-byte em (get resolved "index"))) (= (get resolved "type") "upvalue") - (do (emit-op em 19) ;; OP_UPVALUE_SET - (emit-byte em (get resolved "index"))) - :else - (let ((idx (pool-add (get em "pool") name))) - (emit-op em 21) ;; OP_GLOBAL_SET - (emit-u16 em idx)))))) + (do (emit-op em 19) (emit-byte em (get resolved "index"))) + :else (let + ((idx (pool-add (get em "pool") name))) + (emit-op em 21) + (emit-u16 em idx)))))) +(define + compile-quote + (fn + (em args) + (if (empty? args) (emit-op em 2) (emit-const em (first args))))) -(define compile-quote - (fn (em args) - (if (empty? args) - (emit-op em 2) ;; OP_NIL - (emit-const em (first args))))) - - -(define compile-cond - (fn (em args scope tail?) +(define + compile-cond + (fn + (em args scope tail?) "Compile (cond test1 body1 test2 body2 ... :else fallback)." - (if (< (len args) 2) - (emit-op em 2) ;; OP_NIL - (let ((test (first args)) - (body (nth args 1)) - (rest-clauses (if (> (len args) 2) (slice args 2) (list)))) - (if (or (and (= (type-of test) "keyword") (= (keyword-name test) "else")) - (= test true)) - ;; else clause — just compile the body + (if + (< (len args) 2) + (emit-op em 2) + (let + ((test (first args)) + (body (nth args 1)) + (rest-clauses (if (> (len args) 2) (slice args 2) (list)))) + (if + (or + (and + (= (type-of test) "keyword") + (= (keyword-name test) "else")) + (= test true)) (compile-expr em body scope tail?) (do (compile-expr em test scope false) - (emit-op em 33) ;; OP_JUMP_IF_FALSE - (let ((skip (current-offset em))) + (emit-op em 33) + (let + ((skip (current-offset em))) (emit-i16 em 0) (compile-expr em body scope tail?) - (emit-op em 32) ;; OP_JUMP - (let ((end-jump (current-offset em))) + (emit-op em 32) + (let + ((end-jump (current-offset em))) (emit-i16 em 0) (patch-i16 em skip (- (current-offset em) (+ skip 2))) (compile-cond em rest-clauses scope tail?) - (patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))))) + (patch-i16 + em + end-jump + (- (current-offset em) (+ end-jump 2))))))))))) - -(define compile-case - (fn (em args scope tail?) +(define + compile-case + (fn + (em args scope tail?) "Compile (case expr val1 body1 val2 body2 ... :else fallback)." - ;; Desugar to nested if: evaluate expr once, then compare (compile-expr em (first args) scope false) - (let ((clauses (rest args))) + (let + ((clauses (rest args))) (compile-case-clauses em clauses scope tail?)))) -(define compile-case-clauses - (fn (em clauses scope tail?) - (if (< (len clauses) 2) - (do (emit-op em 5) (emit-op em 2)) ;; POP match-val, push NIL - (let ((test (first clauses)) - (body (nth clauses 1)) - (rest-clauses (if (> (len clauses) 2) (slice clauses 2) (list)))) - (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?)) +(define + compile-match + (fn + (em args scope tail?) + (compile-expr em (first args) scope false) + (compile-match-clauses em (rest args) scope tail?))) + +(define + compile-case-clauses + (fn + (em clauses scope tail?) + (if + (< (len clauses) 2) + (do (emit-op em 5) (emit-op em 2)) + (let + ((test (first clauses)) + (body (nth clauses 1)) + (rest-clauses (if (> (len clauses) 2) (slice clauses 2) (list)))) + (if + (or + (and + (= (type-of test) "keyword") + (= (keyword-name test) "else")) + (= test true)) + (do (emit-op em 5) (compile-expr em body scope tail?)) (do - (emit-op em 6) ;; DUP match-val + (emit-op em 6) (compile-expr em test scope false) - (let ((name-idx (pool-add (get em "pool") "="))) - (emit-op em 52) (emit-u16 em name-idx) (emit-byte em 2)) ;; CALL_PRIM "=" 2 - (emit-op em 33) ;; JUMP_IF_FALSE - (let ((skip (current-offset em))) + (let + ((name-idx (pool-add (get em "pool") "="))) + (emit-op em 52) + (emit-u16 em name-idx) + (emit-byte em 2)) + (emit-op em 33) + (let + ((skip (current-offset em))) (emit-i16 em 0) - (emit-op em 5) ;; POP match-val + (emit-op em 5) (compile-expr em body scope tail?) - (emit-op em 32) ;; JUMP - (let ((end-jump (current-offset em))) + (emit-op em 32) + (let + ((end-jump (current-offset em))) (emit-i16 em 0) (patch-i16 em skip (- (current-offset em) (+ skip 2))) (compile-case-clauses em rest-clauses scope tail?) - (patch-i16 em end-jump (- (current-offset em) (+ end-jump 2))))))))))) + (patch-i16 + em + end-jump + (- (current-offset em) (+ end-jump 2))))))))))) - -(define compile-thread - (fn (em args scope tail?) +(define + compile-thread + (fn + (em args scope tail?) "Compile (-> val (f1 a) (f2 b)) by desugaring to nested calls." - (if (empty? args) + (if + (empty? args) (emit-op em 2) - (if (= (len args) 1) + (if + (= (len args) 1) (compile-expr em (first args) scope tail?) - ;; Desugar: (-> x (f a)) → (f x a) - (let ((val-expr (first args)) - (forms (rest args))) + (let + ((val-expr (first args)) (forms (rest args))) (compile-thread-step em val-expr forms scope tail?)))))) -(define compile-thread-step - (fn (em val-expr forms scope tail?) - (if (empty? forms) +(define + compile-thread-step + (fn + (em val-expr forms scope tail?) + (if + (empty? forms) (compile-expr em val-expr scope tail?) - (let ((form (first forms)) - (rest-forms (rest forms)) - (is-tail (and tail? (empty? rest-forms)))) - ;; Build desugared call: (f val args...) - (let ((call-expr - (if (list? form) - ;; (-> x (f a b)) → (f x a b) - (concat (list (first form) val-expr) (rest form)) - ;; (-> x f) → (f x) - (list form val-expr)))) - (if (empty? rest-forms) + (let + ((form (first forms)) + (rest-forms (rest forms)) + (is-tail (and tail? (empty? rest-forms)))) + (let + ((call-expr (if (list? form) (concat (list (first form) val-expr) (rest form)) (list form val-expr)))) + (if + (empty? rest-forms) (compile-expr em call-expr scope is-tail) (do (compile-expr em call-expr scope false) - ;; Thread result through remaining forms - ;; Store in temp, compile next step - ;; Actually, just compile sequentially — each step returns a value (compile-thread-step em call-expr rest-forms scope tail?)))))))) - -(define compile-defcomp - (fn (em args scope) +(define + compile-defcomp + (fn + (em args scope) "Compile defcomp/defisland — delegates to runtime via GLOBAL_GET + CALL." - (let ((name-idx (pool-add (get em "pool") "eval-defcomp"))) - (emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn + (let + ((name-idx (pool-add (get em "pool") "eval-defcomp"))) + (emit-op em 20) + (emit-u16 em name-idx)) (emit-const em (concat (list (make-symbol "defcomp")) args)) - (emit-op em 48) (emit-byte em 1))) ;; CALL 1 + (emit-op em 48) + (emit-byte em 1))) -(define compile-defmacro - (fn (em args scope) +(define + compile-defmacro + (fn + (em args scope) "Compile defmacro — delegates to runtime via GLOBAL_GET + CALL." - (let ((name-idx (pool-add (get em "pool") "eval-defmacro"))) - (emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn + (let + ((name-idx (pool-add (get em "pool") "eval-defmacro"))) + (emit-op em 20) + (emit-u16 em name-idx)) (emit-const em (concat (list (make-symbol "defmacro")) args)) - (emit-op em 48) (emit-byte em 1))) + (emit-op em 48) + (emit-byte em 1))) - -(define compile-quasiquote - (fn (em expr scope) - "Compile quasiquote inline — walks the template at compile time, - emitting code that builds the structure at runtime. Unquoted - expressions are compiled normally (resolving locals/upvalues), - avoiding the qq-expand-runtime env-lookup limitation." +(define + compile-quasiquote + (fn + (em expr scope) + "Compile quasiquote inline — walks the template at compile time,\n emitting code that builds the structure at runtime. Unquoted\n expressions are compiled normally (resolving locals/upvalues),\n avoiding the qq-expand-runtime env-lookup limitation." (compile-qq-expr em expr scope))) -(define compile-qq-expr - (fn (em expr scope) +(define + compile-qq-expr + (fn + (em expr scope) "Compile a quasiquote sub-expression." - (if (not (= (type-of expr) "list")) - ;; Atom — emit as constant + (if + (not (= (type-of expr) "list")) (emit-const em expr) - (if (empty? expr) - ;; Empty list - (do (emit-op em 64) (emit-u16 em 0)) ;; OP_LIST 0 - (let ((head (first expr))) - (if (and (= (type-of head) "symbol") - (= (symbol-name head) "unquote")) - ;; (unquote expr) — compile the expression + (if + (empty? expr) + (do (emit-op em 64) (emit-u16 em 0)) + (let + ((head (first expr))) + (if + (and + (= (type-of head) "symbol") + (= (symbol-name head) "unquote")) (compile-expr em (nth expr 1) scope false) - ;; List — compile elements, handling splice-unquote (compile-qq-list em expr scope))))))) -(define compile-qq-list - (fn (em items scope) - "Compile a quasiquote list. Handles splice-unquote by building - segments and concatenating them." - (let ((has-splice (some (fn (item) - (and (= (type-of item) "list") - (>= (len item) 2) - (= (type-of (first item)) "symbol") - (= (symbol-name (first item)) "splice-unquote"))) - items))) - (if (not has-splice) - ;; No splicing — compile each element, then OP_LIST +(define + compile-qq-list + (fn + (em items scope) + "Compile a quasiquote list. Handles splice-unquote by building\n segments and concatenating them." + (let + ((has-splice (some (fn (item) (and (= (type-of item) "list") (>= (len item) 2) (= (type-of (first item)) "symbol") (= (symbol-name (first item)) "splice-unquote"))) items))) + (if + (not has-splice) (do (for-each (fn (item) (compile-qq-expr em item scope)) items) - (emit-op em 64) (emit-u16 em (len items))) ;; OP_LIST N - ;; Has splicing — build segments and concat - ;; Strategy: accumulate non-spliced items into a pending list, - ;; flush as OP_LIST when hitting a splice, concat all segments. - (let ((segment-count 0) - (pending 0)) + (emit-op em 64) + (emit-u16 em (len items))) + (let + ((segment-count 0) (pending 0)) (for-each - (fn (item) - (if (and (= (type-of item) "list") - (>= (len item) 2) - (= (type-of (first item)) "symbol") - (= (symbol-name (first item)) "splice-unquote")) - ;; Splice-unquote: flush pending, compile spliced expr + (fn + (item) + (if + (and + (= (type-of item) "list") + (>= (len item) 2) + (= (type-of (first item)) "symbol") + (= (symbol-name (first item)) "splice-unquote")) (do - (when (> pending 0) - (emit-op em 64) (emit-u16 em pending) ;; OP_LIST for pending + (when + (> pending 0) + (emit-op em 64) + (emit-u16 em pending) (set! segment-count (+ segment-count 1)) (set! pending 0)) - ;; Compile the spliced expression (compile-expr em (nth item 1) scope false) (set! segment-count (+ segment-count 1))) - ;; Normal element — compile and count as pending (do (compile-qq-expr em item scope) (set! pending (+ pending 1))))) items) - ;; Flush remaining pending items - (when (> pending 0) - (emit-op em 64) (emit-u16 em pending) + (when + (> pending 0) + (emit-op em 64) + (emit-u16 em pending) (set! segment-count (+ segment-count 1))) - ;; Concat all segments - (when (> segment-count 1) - (let ((concat-idx (pool-add (get em "pool") "concat"))) - ;; concat takes N args — call with all segments - (emit-op em 52) (emit-u16 em concat-idx) + (when + (> segment-count 1) + (let + ((concat-idx (pool-add (get em "pool") "concat"))) + (emit-op em 52) + (emit-u16 em concat-idx) (emit-byte em segment-count)))))))) - -;; -------------------------------------------------------------------------- -;; Function call compilation -;; -------------------------------------------------------------------------- - -(define compile-call - (fn (em head args scope tail?) - ;; Check for known primitives - (let ((is-prim (and (= (type-of head) "symbol") - (let ((name (symbol-name head))) - (and (not (= (get (scope-resolve scope name) "type") "local")) - (not (= (get (scope-resolve scope name) "type") "upvalue")) - (primitive? name)))))) - (if is-prim - ;; Direct primitive call via CALL_PRIM - (let ((name (symbol-name head)) - (argc (len args)) - (name-idx (pool-add (get em "pool") name))) +(define + compile-call + (fn + (em head args scope tail?) + (let + ((is-prim (and (= (type-of head) "symbol") (let ((name (symbol-name head))) (and (not (= (get (scope-resolve scope name) "type") "local")) (not (= (get (scope-resolve scope name) "type") "upvalue")) (primitive? name)))))) + (if + is-prim + (let + ((name (symbol-name head)) + (argc (len args)) + (name-idx (pool-add (get em "pool") name))) (for-each (fn (a) (compile-expr em a scope false)) args) - (emit-op em 52) ;; OP_CALL_PRIM + (emit-op em 52) (emit-u16 em name-idx) (emit-byte em argc)) - ;; General call (do (compile-expr em head scope false) (for-each (fn (a) (compile-expr em a scope false)) args) - (if tail? - (do (emit-op em 49) ;; OP_TAIL_CALL - (emit-byte em (len args))) - (do (emit-op em 48) ;; OP_CALL - (emit-byte em (len args))))))))) + (if + tail? + (do (emit-op em 49) (emit-byte em (len args))) + (do (emit-op em 48) (emit-byte em (len args))))))))) - -;; -------------------------------------------------------------------------- -;; Top-level API -;; -------------------------------------------------------------------------- - -(define compile - (fn (expr) +(define + compile + (fn + (expr) "Compile a single SX expression to a bytecode module." - (let ((em (make-emitter)) - (scope (make-scope nil))) + (let + ((em (make-emitter)) (scope (make-scope nil))) (compile-expr em expr scope false) - (emit-op em 50) ;; OP_RETURN - {:bytecode (get em "bytecode") - :constants (get (get em "pool") "entries")}))) + (emit-op em 50) + {:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))) -(define compile-module - (fn (exprs) +(define + compile-module + (fn + (exprs) "Compile a list of top-level expressions to a bytecode module." - (let ((em (make-emitter)) - (scope (make-scope nil))) - (for-each (fn (expr) - (compile-expr em expr scope false) - (emit-op em 5)) ;; OP_POP between top-level exprs + (let + ((em (make-emitter)) (scope (make-scope nil))) + (for-each + (fn (expr) (compile-expr em expr scope false) (emit-op em 5)) (init exprs)) - ;; Last expression's value is the module result (compile-expr em (last exprs) scope false) - (emit-op em 50) ;; OP_RETURN - {:bytecode (get em "bytecode") - :constants (get (get em "pool") "entries")}))) + (emit-op em 50) + {:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")})))