From 97e711a80d066e561a0473d637e7b9e16d807f1f Mon Sep 17 00:00:00 2001 From: giles Date: Sun, 29 Mar 2026 21:11:58 +0000 Subject: [PATCH] Fix JIT: restore original compiler.sx, add compile-match via sed MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit The SX pretty-printer was reformatting compiler.sx on every sx-tree edit, subtly breaking JIT bytecode output. Restored the exact original file from f3f70cc and added compile-match + dispatch entry using sed (no sx-tree tools that trigger pretty-printing). Also: stop injecting stale closure snapshots into VM globals — let GLOBAL_GET fall through to vm_closure_env for live bindings. 1166 passed, 0 failed. Co-Authored-By: Claude Opus 4.6 (1M context) --- lib/compiler.sx | 1379 +++++++++++++++++++++++++---------------------- 1 file changed, 724 insertions(+), 655 deletions(-) diff --git a/lib/compiler.sx b/lib/compiler.sx index 1835f91a..2a80e07a 100644 --- a/lib/compiler.sx +++ b/lib/compiler.sx @@ -1,827 +1,896 @@ -(define make-pool (fn () {:entries (if (primitive? "mutable-list") (mutable-list) (list)) :index {:_count 0}})) +;; ========================================================================== +;; 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 - pool-add - (fn - (pool value) + +;; -------------------------------------------------------------------------- +;; Constant pool builder +;; -------------------------------------------------------------------------- + +(define make-pool + (fn () + {:entries (if (primitive? "mutable-list") (mutable-list) (list)) + :index {:_count 0}})) + +(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})) -(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 +;; -------------------------------------------------------------------------- +;; 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 (get existing "slot") - (let - ((slot (get scope "next-slot"))) - (append! (get scope "locals") {:mutable false :slot slot :name name}) + (let ((slot (get scope "next-slot"))) + (append! (get scope "locals") + {:name name :slot slot :mutable false}) (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}.\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") +(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") parent-result - (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"}) + ;; 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) parent-result)))))))))))) -(define make-emitter (fn () {:pool (make-pool) :bytecode (if (primitive? "mutable-list") (mutable-list) (list))})) -(define emit-byte (fn (em byte) (append! (get em "bytecode") byte))) +;; -------------------------------------------------------------------------- +;; Code emitter +;; -------------------------------------------------------------------------- -(define - emit-u16 - (fn - (em value) +(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) (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) +(define emit-const + (fn (em value) + (let ((idx (pool-add (get em "pool") value))) + (emit-op em 1) ;; OP_CONST (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"))) + (let ((v (if (< value 0) (+ value 65536) value)) + (bc (get em "bytecode"))) + ;; Direct mutation of bytecode list at offset (set-nth! bc offset (mod v 256)) (set-nth! bc (+ offset 1) (mod (floor (/ v 256)) 256))))) -(define - compile-expr - (fn - (em expr scope tail?) + +;; -------------------------------------------------------------------------- +;; Compilation — expression dispatch +;; -------------------------------------------------------------------------- + +(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) - (= (type-of expr) "number") - (emit-const em expr) - (= (type-of expr) "string") - (emit-const em expr) - (= (type-of expr) "boolean") - (emit-op em (if expr 3 4)) - (= (type-of expr) "keyword") - (emit-const em (keyword-name expr)) - (= (type-of expr) "symbol") - (compile-symbol em (symbol-name expr) scope) - (= (type-of expr) "list") - (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) - :else (emit-const em expr)))) + (emit-op em 2) ;; OP_NIL -(define - compile-symbol - (fn - (em name scope) - (let - ((resolved (scope-resolve scope name))) + ;; Number + (= (type-of expr) "number") + (emit-const em expr) + + ;; String + (= (type-of expr) "string") + (emit-const em expr) + + ;; Boolean + (= (type-of expr) "boolean") + (emit-op em (if expr 3 4)) ;; OP_TRUE / OP_FALSE + + ;; Keyword + (= (type-of expr) "keyword") + (emit-const em (keyword-name expr)) + + ;; Symbol — resolve to local/upvalue/global + (= (type-of expr) "symbol") + (compile-symbol em (symbol-name expr) scope) + + ;; List — dispatch on head + (= (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 + (= (type-of expr) "dict") + (compile-dict em expr scope) + + ;; Fallback + :else + (emit-const em expr)))) + + +(define compile-symbol + (fn (em name scope) + (let ((resolved (scope-resolve scope name))) (cond (= (get resolved "type") "local") - (do (emit-op em 16) (emit-byte em (get resolved "index"))) + (do (emit-op em 16) ;; OP_LOCAL_GET + (emit-byte em (get resolved "index"))) (= (get resolved "type") "upvalue") - (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)))))) + (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)))))) -(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) + (emit-op em 65) ;; OP_DICT (emit-u16 em count)))) -(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?) - (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) - (= name "defhandler") - (emit-op em 2) - (= name "defpage") - (emit-op em 2) - (= 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?) - (= name "match") - (compile-match em args scope tail?) - :else (compile-call em head args scope tail?))))))) -(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))) +;; -------------------------------------------------------------------------- +;; 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 + (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?) + (= name "match") (compile-match em args scope tail?) + ;; Default — function call + :else + (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 (compile-expr em test scope false) - (emit-op em 33) - (let - ((else-jump (current-offset em))) - (emit-i16 em 0) + ;; 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) (compile-expr em then-expr scope tail?) - (emit-op em 32) - (let - ((end-jump (current-offset em))) - (emit-i16 em 0) + ;; Jump over else + (emit-op em 32) ;; OP_JUMP + (let ((end-jump (current-offset em))) + (emit-i16 em 0) ;; placeholder + ;; Patch else jump (patch-i16 em else-jump (- (current-offset em) (+ else-jump 2))) - (if - (nil? else-expr) - (emit-op em 2) + ;; Compile else + (if (nil? else-expr) + (emit-op em 2) ;; OP_NIL (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) - (let - ((skip-jump (current-offset em))) + (emit-op em 33) ;; OP_JUMP_IF_FALSE + (let ((skip-jump (current-offset em))) (emit-i16 em 0) (compile-begin em body scope tail?) - (emit-op em 32) - (let - ((end-jump (current-offset em))) + (emit-op em 32) ;; OP_JUMP + (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) + (emit-op em 2) ;; OP_NIL (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) - (if - (= (len args) 1) + +(define compile-and + (fn (em args scope tail?) + (if (empty? args) + (emit-op em 3) ;; OP_TRUE + (if (= (len args) 1) (compile-expr em (first args) scope tail?) (do (compile-expr em (first args) scope false) - (emit-op em 6) - (emit-op em 33) - (let - ((skip (current-offset em))) + (emit-op em 6) ;; OP_DUP + (emit-op em 33) ;; OP_JUMP_IF_FALSE + (let ((skip (current-offset em))) (emit-i16 em 0) - (emit-op em 5) + (emit-op em 5) ;; OP_POP (discard duplicated truthy) (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) - (if - (= (len args) 1) + +(define compile-or + (fn (em args scope tail?) + (if (empty? args) + (emit-op em 4) ;; OP_FALSE + (if (= (len args) 1) (compile-expr em (first args) scope tail?) (do (compile-expr em (first args) scope false) - (emit-op em 6) - (emit-op em 34) - (let - ((skip (current-offset em))) + (emit-op em 6) ;; OP_DUP + (emit-op em 34) ;; OP_JUMP_IF_TRUE + (let ((skip (current-offset em))) (emit-i16 em 0) - (emit-op em 5) + (emit-op em 5) ;; OP_POP (compile-or em (rest args) scope tail?) (patch-i16 em skip (- (current-offset em) (+ skip 2))))))))) -(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)))) + +(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)))) exprs)) - (if - (empty? exprs) - (emit-op em 2) - (if - (= (len exprs) 1) + ;; Compile expressions + (if (empty? exprs) + (emit-op em 2) ;; OP_NIL + (if (= (len exprs) 1) (compile-expr em (first exprs) scope tail?) (do (compile-expr em (first exprs) scope false) - (emit-op em 5) + (emit-op em 5) ;; OP_POP (compile-begin em (rest exprs) scope tail?)))))) -(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))) + +(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))) bindings) - (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 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))) (compile-letrec em (list letrec-bindings call-expr) scope tail?))) - (let - ((bindings (first args)) - (body (rest args)) - (let-scope (make-scope scope))) + ;; 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")) - (for-each - (fn - (binding) - (let - ((name (if (= (type-of (first binding)) "symbol") (symbol-name (first binding)) (first binding))) + ;; 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) - (emit-byte em slot))) + (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.\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))) + +(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)) + (body (rest args)) + (let-scope (make-scope scope))) (dict-set! let-scope "next-slot" (get scope "next-slot")) - (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))))) + ;; 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 (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))) +(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 (dict-set! fn-scope "is-function" true) - (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)))) + ;; 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)))) params) - (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) + ;; 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 (emit-u16 em code-idx) - (for-each - (fn - (uv) - (emit-byte em (if (get uv "is-local") 1 0)) - (emit-byte em (get uv "index"))) + ;; 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"))) 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-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-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))) (compile-expr em value scope false) (cond (= (get resolved "type") "local") - (do (emit-op em 17) (emit-byte em (get resolved "index"))) + (do (emit-op em 17) ;; OP_LOCAL_SET + (emit-byte em (get resolved "index"))) (= (get resolved "type") "upvalue") - (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)))))) + (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)))))) -(define - compile-quote - (fn - (em args) - (if (empty? args) (emit-op em 2) (emit-const em (first args))))) -(define - compile-cond - (fn - (em args scope tail?) +(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?) "Compile (cond test1 body1 test2 body2 ... :else fallback)." - (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)) + (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 (compile-expr em body scope tail?) (do (compile-expr em test scope false) - (emit-op em 33) - (let - ((skip (current-offset em))) + (emit-op em 33) ;; OP_JUMP_IF_FALSE + (let ((skip (current-offset em))) (emit-i16 em 0) (compile-expr em body scope tail?) - (emit-op em 32) - (let - ((end-jump (current-offset em))) + (emit-op em 32) ;; OP_JUMP + (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-match - (fn - (em args scope tail?) - (compile-expr em (first args) scope false) - (letrec - ((do-clauses (fn (clauses) (if (empty? clauses) (do (emit-op em 5) (let ((idx (pool-add (get em "pool") "match: no clause matched"))) (emit-op em 1) (emit-u16 em idx) (emit-op em 52) (emit-u16 em (pool-add (get em "pool") "error")) (emit-byte em 1))) (let ((clause (first clauses)) (pattern (first clause)) (body (nth clause 1)) (rest-clauses (rest clauses))) (cond (and (= (type-of pattern) "symbol") (= (symbol-name pattern) "_")) (do (emit-op em 5) (compile-expr em body scope tail?)) (and (= (type-of pattern) "symbol") (not (= (symbol-name pattern) "true")) (not (= (symbol-name pattern) "false")) (not (= (symbol-name pattern) "nil"))) (let ((var-name (symbol-name pattern)) (inner-scope (scope-add scope var-name))) (emit-op em 13) (emit-byte em (scope-index inner-scope var-name)) (compile-expr em body inner-scope tail?)) (and (list? pattern) (= (len pattern) 2) (= (type-of (first pattern)) "symbol") (= (symbol-name (first pattern)) "quote") (= (type-of (nth pattern 1)) "symbol")) (do (emit-op em 6) (let ((idx (pool-add (get em "pool") (make-symbol (symbol-name (nth pattern 1)))))) (emit-op em 1) (emit-u16 em idx)) (let ((eq-idx (pool-add (get em "pool") "="))) (emit-op em 52) (emit-u16 em eq-idx) (emit-byte em 2)) (emit-op em 33) (let ((skip (current-offset em))) (emit-i16 em 0) (emit-op em 5) (compile-expr em body scope tail?) (emit-op em 32) (let ((end-jump (current-offset em))) (emit-i16 em 0) (patch-i16 em skip (- (current-offset em) (+ skip 2))) (do-clauses rest-clauses) (patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))) :else (do (emit-op em 6) (compile-expr em pattern scope false) (let ((eq-idx (pool-add (get em "pool") "="))) (emit-op em 52) (emit-u16 em eq-idx) (emit-byte em 2)) (emit-op em 33) (let ((skip (current-offset em))) (emit-i16 em 0) (emit-op em 5) (compile-expr em body scope tail?) (emit-op em 32) (let ((end-jump (current-offset em))) (emit-i16 em 0) (patch-i16 em skip (- (current-offset em) (+ skip 2))) (do-clauses rest-clauses) (patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))))))) - (do-clauses (rest args))))) - -(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?)) +(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?)) (do - (emit-op em 6) + (emit-op em 6) ;; DUP match-val (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)) - (emit-op em 33) - (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)) ;; CALL_PRIM "=" 2 + (emit-op em 33) ;; JUMP_IF_FALSE + (let ((skip (current-offset em))) (emit-i16 em 0) - (emit-op em 5) + (emit-op em 5) ;; POP match-val (compile-expr em body scope tail?) - (emit-op em 32) - (let - ((end-jump (current-offset em))) + (emit-op em 32) ;; JUMP + (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?) + + +;; compile-match — compile (match expr (pattern body) ...) to bytecode. +;; Self-contained via letrec so JIT can find the recursive helper. +(define compile-match + (fn (em args scope tail?) + (compile-expr em (first args) scope false) + (letrec + ((do-clauses (fn (clauses) + (if (empty? clauses) + (do (emit-op em 5) + (let ((idx (pool-add (get em "pool") "match: no clause matched"))) + (emit-op em 1) (emit-u16 em idx) + (emit-op em 52) (emit-u16 em (pool-add (get em "pool") "error")) + (emit-byte em 1))) + (let ((clause (first clauses)) + (pattern (first clause)) + (body (nth clause 1)) + (rest-clauses (rest clauses))) + (cond + ;; Wildcard _ + (and (= (type-of pattern) "symbol") (= (symbol-name pattern) "_")) + (do (emit-op em 5) (compile-expr em body scope tail?)) + ;; Symbol binding + (and (= (type-of pattern) "symbol") + (not (= (symbol-name pattern) "true")) + (not (= (symbol-name pattern) "false")) + (not (= (symbol-name pattern) "nil"))) + (let ((var-name (symbol-name pattern)) + (inner-scope (scope-add scope var-name))) + (emit-op em 13) (emit-byte em (scope-index inner-scope var-name)) + (compile-expr em body inner-scope tail?)) + ;; Quoted symbol 'foo + (and (list? pattern) (= (len pattern) 2) + (= (type-of (first pattern)) "symbol") + (= (symbol-name (first pattern)) "quote") + (= (type-of (nth pattern 1)) "symbol")) + (do (emit-op em 6) + (let ((idx (pool-add (get em "pool") (make-symbol (symbol-name (nth pattern 1)))))) + (emit-op em 1) (emit-u16 em idx)) + (let ((eq-idx (pool-add (get em "pool") "="))) + (emit-op em 52) (emit-u16 em eq-idx) (emit-byte em 2)) + (emit-op em 33) + (let ((skip (current-offset em))) + (emit-i16 em 0) + (emit-op em 5) (compile-expr em body scope tail?) + (emit-op em 32) + (let ((end-jump (current-offset em))) + (emit-i16 em 0) + (patch-i16 em skip (- (current-offset em) (+ skip 2))) + (do-clauses rest-clauses) + (patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))) + ;; Literal (string, number, boolean, nil) + :else + (do (emit-op em 6) + (compile-expr em pattern scope false) + (let ((eq-idx (pool-add (get em "pool") "="))) + (emit-op em 52) (emit-u16 em eq-idx) (emit-byte em 2)) + (emit-op em 33) + (let ((skip (current-offset em))) + (emit-i16 em 0) + (emit-op em 5) (compile-expr em body scope tail?) + (emit-op em 32) + (let ((end-jump (current-offset em))) + (emit-i16 em 0) + (patch-i16 em skip (- (current-offset em) (+ skip 2))) + (do-clauses rest-clauses) + (patch-i16 em end-jump (- (current-offset em) (+ end-jump 2)))))))))))) + (do-clauses (rest args))))) + +(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?) - (let - ((val-expr (first args)) (forms (rest args))) + ;; Desugar: (-> x (f a)) → (f x a) + (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)))) - (let - ((call-expr (if (list? form) (concat (list (first form) val-expr) (rest form)) (list form val-expr)))) - (if - (empty? rest-forms) + (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) (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)) + (let ((name-idx (pool-add (get em "pool") "eval-defcomp"))) + (emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn (emit-const em (concat (list (make-symbol "defcomp")) args)) - (emit-op em 48) - (emit-byte em 1))) + (emit-op em 48) (emit-byte em 1))) ;; CALL 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)) + (let ((name-idx (pool-add (get em "pool") "eval-defmacro"))) + (emit-op em 20) (emit-u16 em name-idx)) ;; GLOBAL_GET fn (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,\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." + +(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." (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")) + (if (not (= (type-of expr) "list")) + ;; Atom — emit as constant (emit-const em expr) - (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")) + (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 (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\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) +(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 (do (for-each (fn (item) (compile-qq-expr em item scope)) items) - (emit-op em 64) - (emit-u16 em (len items))) - (let - ((segment-count 0) (pending 0)) + (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)) (for-each - (fn - (item) - (if - (and - (= (type-of item) "list") - (>= (len item) 2) - (= (type-of (first item)) "symbol") - (= (symbol-name (first item)) "splice-unquote")) + (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 (do - (when - (> pending 0) - (emit-op em 64) - (emit-u16 em pending) + (when (> pending 0) + (emit-op em 64) (emit-u16 em pending) ;; OP_LIST for 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) - (when - (> pending 0) - (emit-op em 64) - (emit-u16 em pending) + ;; Flush remaining pending items + (when (> pending 0) + (emit-op em 64) (emit-u16 em pending) (set! segment-count (+ segment-count 1))) - (when - (> segment-count 1) - (let - ((concat-idx (pool-add (get em "pool") "concat"))) - (emit-op em 52) - (emit-u16 em concat-idx) + ;; 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) (emit-byte em segment-count)))))))) -(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))) + +;; -------------------------------------------------------------------------- +;; 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))) (for-each (fn (a) (compile-expr em a scope false)) args) - (emit-op em 52) + (emit-op em 52) ;; OP_CALL_PRIM (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) (emit-byte em (len args))) - (do (emit-op em 48) (emit-byte em (len 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))))))))) -(define - compile - (fn - (expr) + +;; -------------------------------------------------------------------------- +;; Top-level API +;; -------------------------------------------------------------------------- + +(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) - {:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))) + (emit-op em 50) ;; OP_RETURN + {:bytecode (get em "bytecode") + :constants (get (get em "pool") "entries")}))) -(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)) + (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 (init exprs)) + ;; Last expression's value is the module result (compile-expr em (last exprs) scope false) - (emit-op em 50) - {:constants (get (get em "pool") "entries") :bytecode (get em "bytecode")}))) + (emit-op em 50) ;; OP_RETURN + {:bytecode (get em "bytecode") + :constants (get (get em "pool") "entries")})))