coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

SX bytecode: format definition, compiler, OCaml VM (Phase 1)

Browse Source 
Three new files forming the bytecode compilation pipeline:

spec/bytecode.sx — opcode definitions (~65 ops):
  - Stack/constant ops (CONST, NIL, TRUE, POP, DUP)
  - Lexical variable access (LOCAL_GET/SET, UPVALUE_GET/SET, GLOBAL_GET/SET)
  - Jump-based control flow (JUMP, JUMP_IF_FALSE/TRUE)
  - Function ops (CALL, TAIL_CALL, RETURN, CLOSURE, CALL_PRIM)
  - HO form ops (ITER_INIT/NEXT, MAP_OPEN/APPEND/CLOSE)
  - Scope/continuation ops (SCOPE_PUSH/POP, RESET, SHIFT)
  - Aser specialization (ASER_TAG, ASER_FRAG)

spec/compiler.sx — SX-to-bytecode compiler (SX code, portable):
  - Scope analysis: resolve variables to local/upvalue/global at compile time
  - Tail position detection for TCO
  - Code generation for: if, when, and, or, let, begin, lambda,
    define, set!, quote, function calls, primitive calls
  - Constant pool with deduplication
  - Jump patching for forward references

hosts/ocaml/lib/sx_vm.ml — bytecode interpreter (OCaml):
  - Stack-based VM with array-backed operand stack
  - Call frames with base pointer for locals
  - Direct opcode dispatch via pattern match
  - Zero allocation per step (unlike CEK machine's dict-per-step)
  - Handles: constants, variables, jumps, calls, primitives,
    collections, string concat, define

Architecture: compiler.sx is spec (SX, portable). VM is platform
(OCaml-native). Same bytecode runs on JS/WASM VMs.

Also includes: CekFrame record optimization in transpiler.sx
(29 frame types as records instead of Hashtbl).

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-03-19 18:25:41 +00:00
parent d9e80d8544
commit 40d0f1a438
3 changed files with 865 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

235
hosts/ocaml/lib/sx_vm.ml Normal file
View File

@@ -0,0 +1,235 @@
(** SX bytecode VM — stack-based interpreter.
Executes bytecode produced by compiler.sx.
Designed for speed: array-based stack, direct dispatch,
no allocation per step (unlike the CEK machine).
This is the platform-native execution engine. The same bytecode
runs on all platforms (OCaml, JS, WASM). *)
open Sx_types
(** Bytecode instruction stream. *)
type bytecode = int array
(** Code object — compiled function body. *)
type code = {
arity : int;
locals : int;
bytecode : bytecode;
constants : value array;
}
(** Upvalue — reference to a captured variable. *)
type upvalue_ref =
| Open of int (* index into enclosing frame's locals *)
| Closed of value ref (* heap-allocated after frame returns *)
(** Closure — code + captured upvalues. *)
type closure = {
code : code;
upvalues : upvalue_ref array;
name : string option;
}
(** Call frame — one per function invocation. *)
type frame = {
closure : closure;
mutable ip : int;
base : int; (* base index in value stack *)
}
(** VM state. *)
type vm = {
mutable stack : value array;
mutable sp : int; (* stack pointer — next free slot *)
mutable frames : frame list;
globals : (string, value) Hashtbl.t;
}
(** Create a new VM. *)
let create () = {
stack = Array.make 1024 Nil;
sp = 0;
frames = [];
globals = Hashtbl.create 256;
}
(** Stack operations. *)
let push vm v =
if vm.sp >= Array.length vm.stack then begin
let new_stack = Array.make (vm.sp * 2) Nil in
Array.blit vm.stack 0 new_stack 0 vm.sp;
vm.stack <- new_stack
end;
vm.stack.(vm.sp) <- v;
vm.sp <- vm.sp + 1
let pop vm =
vm.sp <- vm.sp - 1;
vm.stack.(vm.sp)
let peek vm =
vm.stack.(vm.sp - 1)
(** Read operands from bytecode. *)
let read_u8 frame =
let v = frame.closure.code.bytecode.(frame.ip) in
frame.ip <- frame.ip + 1; v
let read_u16 frame =
let lo = frame.closure.code.bytecode.(frame.ip) in
let hi = frame.closure.code.bytecode.(frame.ip + 1) in
frame.ip <- frame.ip + 2;
lo lor (hi lsl 8)
let read_i16 frame =
let v = read_u16 frame in
if v >= 32768 then v - 65536 else v
(** Execute bytecode until OP_RETURN. *)
let rec run vm =
match vm.frames with
| [] -> failwith "VM: no frame"
| frame :: _ ->
let code = frame.closure.code in
let bc = code.bytecode in
let op = bc.(frame.ip) in
frame.ip <- frame.ip + 1;
match op with
(* ---- Stack / Constants ---- *)
| 0x01 -> (* OP_CONST *)
let idx = read_u16 frame in
push vm code.constants.(idx);
run vm
| 0x02 -> push vm Nil; run vm (* OP_NIL *)
| 0x03 -> push vm (Bool true); run vm (* OP_TRUE *)
| 0x04 -> push vm (Bool false); run vm (* OP_FALSE *)
| 0x05 -> ignore (pop vm); run vm (* OP_POP *)
| 0x06 -> push vm (peek vm); run vm (* OP_DUP *)
(* ---- Variable access ---- *)
| 0x10 -> (* OP_LOCAL_GET *)
let slot = read_u8 frame in
push vm vm.stack.(frame.base + slot);
run vm
| 0x11 -> (* OP_LOCAL_SET *)
let slot = read_u8 frame in
vm.stack.(frame.base + slot) <- peek vm;
run vm
| 0x14 -> (* OP_GLOBAL_GET *)
let idx = read_u16 frame in
let name = match code.constants.(idx) with String s -> s | _ -> "" in
let v = try Hashtbl.find vm.globals name with Not_found ->
(* Fall back to primitives *)
try Sx_primitives.get name
with _ -> raise (Eval_error ("Undefined: " ^ name))
in
push vm v; run vm
| 0x15 -> (* OP_GLOBAL_SET *)
let idx = read_u16 frame in
let name = match code.constants.(idx) with String s -> s | _ -> "" in
Hashtbl.replace vm.globals name (peek vm);
run vm
(* ---- Control flow ---- *)
| 0x20 -> (* OP_JUMP *)
let offset = read_i16 frame in
frame.ip <- frame.ip + offset;
run vm
| 0x21 -> (* OP_JUMP_IF_FALSE *)
let offset = read_i16 frame in
let v = pop vm in
if not (sx_truthy v) then frame.ip <- frame.ip + offset;
run vm
| 0x22 -> (* OP_JUMP_IF_TRUE *)
let offset = read_i16 frame in
let v = pop vm in
if sx_truthy v then frame.ip <- frame.ip + offset;
run vm
(* ---- Function calls ---- *)
| 0x30 -> (* OP_CALL *)
let argc = read_u8 frame in
let args = Array.init argc (fun _ -> pop vm) in
let f = pop vm in
call vm f (Array.to_list (Array.of_list (List.rev (Array.to_list args))));
run vm
| 0x31 -> (* OP_TAIL_CALL *)
let argc = read_u8 frame in
let args = Array.init argc (fun _ -> pop vm) in
let _f = pop vm in
(* TODO: tail call optimization — reuse frame *)
let args_list = List.rev (Array.to_list args) in
call vm _f args_list;
run vm
| 0x32 -> (* OP_RETURN *)
let result = pop vm in
vm.frames <- List.tl vm.frames;
vm.sp <- frame.base;
push vm result
(* Don't recurse — return to caller *)
| 0x34 -> (* OP_CALL_PRIM *)
let idx = read_u16 frame in
let argc = read_u8 frame in
let name = match code.constants.(idx) with String s -> s | _ -> "" in
let args = List.init argc (fun _ -> pop vm) |> List.rev in
let result = Sx_primitives.call name args in
push vm result;
run vm
(* ---- Collections ---- *)
| 0x40 -> (* OP_LIST *)
let count = read_u16 frame in
let items = List.init count (fun _ -> pop vm) |> List.rev in
push vm (List items);
run vm
| 0x41 -> (* OP_DICT *)
let count = read_u16 frame in
let d = Hashtbl.create count in
for _ = 1 to count do
let v = pop vm in
let k = pop vm in
let key = match k with String s -> s | Keyword s -> s | _ -> "" in
Hashtbl.replace d key v
done;
push vm (Dict d);
run vm
(* ---- String ops ---- *)
| 0x90 -> (* OP_STR_CONCAT *)
let count = read_u8 frame in
let parts = List.init count (fun _ -> pop vm) |> List.rev in
let s = String.concat "" (List.map value_to_str parts) in
push vm (String s);
run vm
(* ---- Define ---- *)
| 0x80 -> (* OP_DEFINE *)
let idx = read_u16 frame in
let name = match code.constants.(idx) with String s -> s | _ -> "" in
let v = peek vm in
Hashtbl.replace vm.globals name v;
run vm
| opcode ->
raise (Eval_error (Printf.sprintf "VM: unknown opcode 0x%02x at ip=%d" opcode (frame.ip - 1)))
and call vm f args =
match f with
| NativeFn (_, fn) ->
let result = fn args in
push vm result
| _ ->
raise (Eval_error ("VM: not callable: " ^ value_to_str f))
(** Execute a code object in a fresh VM. *)
let execute code globals =
let vm = create () in
(* Copy globals *)
Hashtbl.iter (fun k v -> Hashtbl.replace vm.globals k v) globals;
let closure = { code; upvalues = [||]; name = None } in
let frame = { closure; ip = 0; base = 0 } in
vm.frames <- [frame];
run vm;
pop vm

146
spec/bytecode.sx Normal file
View File

@@ -0,0 +1,146 @@
;; ==========================================================================
;; bytecode.sx — SX bytecode format definition
;;
;; Universal bytecode for SX evaluation. Produced by compiler.sx,
;; executed by platform-native VMs (OCaml, JS, WASM).
;;
;; Design principles:
;; - One byte per opcode (~65 ops, fits in u8)
;; - Variable-length encoding (1-5 bytes per instruction)
;; - Lexical scope resolved at compile time (no hash lookups)
;; - Tail calls detected statically (no thunks/trampoline)
;; - Control flow via jumps (no continuation frames for if/when/etc.)
;; - Content-addressable (deterministic binary for CID)
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Opcode constants
;; --------------------------------------------------------------------------
;; Stack / Constants
(define OP_CONST 0x01) ;; u16 pool_idx — push constant
(define OP_NIL 0x02) ;; push nil
(define OP_TRUE 0x03) ;; push true
(define OP_FALSE 0x04) ;; push false
(define OP_POP 0x05) ;; discard TOS
(define OP_DUP 0x06) ;; duplicate TOS
;; Variable access (resolved at compile time)
(define OP_LOCAL_GET 0x10) ;; u8 slot
(define OP_LOCAL_SET 0x11) ;; u8 slot
(define OP_UPVALUE_GET 0x12) ;; u8 idx
(define OP_UPVALUE_SET 0x13) ;; u8 idx
(define OP_GLOBAL_GET 0x14) ;; u16 name_idx
(define OP_GLOBAL_SET 0x15) ;; u16 name_idx
;; Control flow (replaces if/when/cond/and/or frames)
(define OP_JUMP 0x20) ;; i16 offset
(define OP_JUMP_IF_FALSE 0x21) ;; i16 offset
(define OP_JUMP_IF_TRUE 0x22) ;; i16 offset
;; Function operations
(define OP_CALL 0x30) ;; u8 argc
(define OP_TAIL_CALL 0x31) ;; u8 argc — reuse frame (TCO)
(define OP_RETURN 0x32) ;; return TOS
(define OP_CLOSURE 0x33) ;; u16 code_idx — create closure
(define OP_CALL_PRIM 0x34) ;; u16 name_idx, u8 argc — direct primitive
(define OP_APPLY 0x35) ;; (apply f args-list)
;; Collection construction
(define OP_LIST 0x40) ;; u16 count — build list from stack
(define OP_DICT 0x41) ;; u16 count — build dict from stack pairs
(define OP_APPEND_BANG 0x42) ;; (append! TOS-1 TOS)
;; Higher-order forms (inlined loop)
(define OP_ITER_INIT 0x50) ;; init iterator on TOS list
(define OP_ITER_NEXT 0x51) ;; i16 end_offset — push next or jump
(define OP_MAP_OPEN 0x52) ;; push empty accumulator
(define OP_MAP_APPEND 0x53) ;; append TOS to accumulator
(define OP_MAP_CLOSE 0x54) ;; pop accumulator as list
(define OP_FILTER_TEST 0x55) ;; i16 skip — if falsy jump (skip append)
;; HO fallback (dynamic callback)
(define OP_HO_MAP 0x58) ;; (map fn coll)
(define OP_HO_FILTER 0x59) ;; (filter fn coll)
(define OP_HO_REDUCE 0x5A) ;; (reduce fn init coll)
(define OP_HO_FOR_EACH 0x5B) ;; (for-each fn coll)
(define OP_HO_SOME 0x5C) ;; (some fn coll)
(define OP_HO_EVERY 0x5D) ;; (every? fn coll)
;; Scope / dynamic binding
(define OP_SCOPE_PUSH 0x60) ;; TOS = name
(define OP_SCOPE_POP 0x61)
(define OP_PROVIDE_PUSH 0x62) ;; TOS-1 = name, TOS = value
(define OP_PROVIDE_POP 0x63)
(define OP_CONTEXT 0x64) ;; TOS = name → push value
(define OP_EMIT 0x65) ;; TOS-1 = name, TOS = value
(define OP_EMITTED 0x66) ;; TOS = name → push collected
;; Continuations
(define OP_RESET 0x70) ;; i16 body_len — push delimiter
(define OP_SHIFT 0x71) ;; u8 k_slot, i16 body_len — capture k
;; Define / component
(define OP_DEFINE 0x80) ;; u16 name_idx — bind TOS to name
(define OP_DEFCOMP 0x81) ;; u16 template_idx
(define OP_DEFISLAND 0x82) ;; u16 template_idx
(define OP_DEFMACRO 0x83) ;; u16 template_idx
(define OP_EXPAND_MACRO 0x84) ;; u8 argc — runtime macro expansion
;; String / serialize (hot path)
(define OP_STR_CONCAT 0x90) ;; u8 count — concat N values as strings
(define OP_STR_JOIN 0x91) ;; (join sep list)
(define OP_SERIALIZE 0x92) ;; serialize TOS to SX string
;; Aser specialization (optional, 0xE0-0xEF reserved)
(define OP_ASER_TAG 0xE0) ;; u16 tag_name_idx — serialize HTML tag
(define OP_ASER_FRAG 0xE1) ;; u8 child_count — serialize fragment
;; --------------------------------------------------------------------------
;; Bytecode module structure
;; --------------------------------------------------------------------------
;; A module contains:
;; magic: "SXBC" (4 bytes)
;; version: u16
;; pool_count: u32
;; pool: constant pool entries (self-describing tagged values)
;; code_count: u32
;; codes: code objects
;; entry: u32 (index of entry-point code object)
(define BYTECODE_MAGIC "SXBC")
(define BYTECODE_VERSION 1)
;; Constant pool tags
(define CONST_NUMBER 0x01)
(define CONST_STRING 0x02)
(define CONST_BOOL 0x03)
(define CONST_NIL 0x04)
(define CONST_SYMBOL 0x05)
(define CONST_KEYWORD 0x06)
(define CONST_LIST 0x07)
(define CONST_DICT 0x08)
(define CONST_CODE 0x09)
;; --------------------------------------------------------------------------
;; Disassembler
;; --------------------------------------------------------------------------
(define opcode-names
{:0x01 "CONST" :0x02 "NIL" :0x03 "TRUE" :0x04 "FALSE"
:0x05 "POP" :0x06 "DUP"
:0x10 "LOCAL_GET" :0x11 "LOCAL_SET"
:0x12 "UPVALUE_GET" :0x13 "UPVALUE_SET"
:0x14 "GLOBAL_GET" :0x15 "GLOBAL_SET"
:0x20 "JUMP" :0x21 "JUMP_IF_FALSE" :0x22 "JUMP_IF_TRUE"
:0x30 "CALL" :0x31 "TAIL_CALL" :0x32 "RETURN"
:0x33 "CLOSURE" :0x34 "CALL_PRIM" :0x35 "APPLY"
:0x40 "LIST" :0x41 "DICT" :0x42 "APPEND!"
:0x50 "ITER_INIT" :0x51 "ITER_NEXT"
:0x52 "MAP_OPEN" :0x53 "MAP_APPEND" :0x54 "MAP_CLOSE"
:0x80 "DEFINE" :0x90 "STR_CONCAT" :0x92 "SERIALIZE"
:0xE0 "ASER_TAG" :0xE1 "ASER_FRAG"})

484
spec/compiler.sx Normal file
View File

@@ -0,0 +1,484 @@
;; ==========================================================================
;; 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.
;; ==========================================================================
;; --------------------------------------------------------------------------
;; Constant pool builder
;; --------------------------------------------------------------------------
(define make-pool
(fn ()
{:entries (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)
(get idx-map key)
(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)))))
;; --------------------------------------------------------------------------
;; Scope analysis
;; --------------------------------------------------------------------------
(define make-scope
(fn (parent)
{:locals (list) ;; list of {name, slot, mutable?}
:upvalues (list) ;; list of {name, is-local, index}
:parent parent
:next-slot 0}))
(define scope-define-local
(fn (scope name)
"Add a local variable, return its slot index."
(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}."
(if (nil? scope)
{:type "global" :index name}
;; Check locals
(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)
(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 "index")})
;; Try parent scope — if found, capture as upvalue
(let ((parent-result (scope-resolve (get scope "parent") name)))
(if (= (get parent-result "type") "global")
parent-result
;; Capture from parent as upvalue
(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")})
{:type "upvalue" :index uv-idx}))))))))))
;; --------------------------------------------------------------------------
;; Code emitter
;; --------------------------------------------------------------------------
(define make-emitter
(fn ()
{:bytecode (list) ;; list of bytes
: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-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 0x01) ;; OP_CONST
(emit-u16 em idx))))
(define current-offset
(fn (em)
(len (get em "bytecode"))))
(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
(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?)
"Compile an expression. tail? indicates tail position for TCO."
(cond
;; Nil
(nil? expr)
(emit-op em 0x02) ;; OP_NIL
;; 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 0x03 0x04)) ;; 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 0x40) (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 0x10) ;; OP_LOCAL_GET
(emit-byte em (get resolved "index")))
(= (get resolved "type") "upvalue")
(do (emit-op em 0x12) ;; OP_UPVALUE_GET
(emit-byte em (get resolved "index")))
:else
;; Global or primitive
(let ((idx (pool-add (get em "pool") name)))
(emit-op em 0x14) ;; 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))
ks)
(emit-op em 0x41) ;; OP_DICT
(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
(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 "if") (compile-if 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)
;; Jump if false to else
(emit-op em 0x21) ;; 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?)
;; Jump over else
(emit-op em 0x20) ;; 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))
;; Compile else
(if (nil? else-expr)
(emit-op em 0x02) ;; 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)))
(compile-expr em test scope false)
(emit-op em 0x21) ;; OP_JUMP_IF_FALSE
(let ((skip-jump (current-offset em)))
(emit-i16 em 0)
(compile-begin em body scope tail?)
(emit-op em 0x20) ;; 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 0x02) ;; 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 0x03) ;; OP_TRUE
(if (= (len args) 1)
(compile-expr em (first args) scope tail?)
(do
(compile-expr em (first args) scope false)
(emit-op em 0x06) ;; OP_DUP
(emit-op em 0x21) ;; OP_JUMP_IF_FALSE
(let ((skip (current-offset em)))
(emit-i16 em 0)
(emit-op em 0x05) ;; 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 0x04) ;; OP_FALSE
(if (= (len args) 1)
(compile-expr em (first args) scope tail?)
(do
(compile-expr em (first args) scope false)
(emit-op em 0x06) ;; OP_DUP
(emit-op em 0x22) ;; OP_JUMP_IF_TRUE
(let ((skip (current-offset em)))
(emit-i16 em 0)
(emit-op em 0x05) ;; 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?)
(if (empty? exprs)
(emit-op em 0x02) ;; OP_NIL
(if (= (len exprs) 1)
(compile-expr em (first exprs) scope tail?)
(do
(compile-expr em (first exprs) scope false)
(emit-op em 0x05) ;; OP_POP
(compile-begin em (rest exprs) scope tail?))))))
(define compile-let
(fn (em args scope tail?)
(let ((bindings (first args))
(body (rest args))
(let-scope (make-scope scope)))
;; 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 0x11) ;; OP_LOCAL_SET
(emit-byte em slot)))
bindings)
;; Compile body in let scope
(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 params as locals in fn scope
(for-each (fn (p)
(let ((name (if (= (type-of p) "symbol") (symbol-name p) 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 0x32) ;; OP_RETURN
;; Add code object to parent constant pool
(let ((code {:arity (len (get fn-scope "locals"))
:bytecode (get fn-em "bytecode")
:pool (get fn-em "pool")
:upvalues (get fn-scope "upvalues")})
(code-idx (pool-add (get em "pool") code)))
(emit-op em 0x33) ;; OP_CLOSURE
(emit-u16 em code-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))
(value (nth args 1))
(name-idx (pool-add (get em "pool") name)))
(compile-expr em value scope false)
(emit-op em 0x80) ;; 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 0x11) ;; OP_LOCAL_SET
(emit-byte em (get resolved "index")))
(= (get resolved "type") "upvalue")
(do (emit-op em 0x13) ;; OP_UPVALUE_SET
(emit-byte em (get resolved "index")))
:else
(let ((idx (pool-add (get em "pool") name)))
(emit-op em 0x15) ;; OP_GLOBAL_SET
(emit-u16 em idx))))))
(define compile-quote
(fn (em args)
(if (empty? args)
(emit-op em 0x02) ;; OP_NIL
(emit-const em (first args)))))
;; --------------------------------------------------------------------------
;; 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 — no closure overhead
(let ((name (symbol-name head))
(name-idx (pool-add (get em "pool") name)))
(for-each (fn (a) (compile-expr em a scope false)) args)
(emit-op em 0x34) ;; OP_CALL_PRIM
(emit-u16 em name-idx)
(emit-byte em (len args)))
;; 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 0x31) ;; OP_TAIL_CALL
(emit-byte em (len args)))
(do (emit-op em 0x30) ;; OP_CALL
(emit-byte em (len args)))))))))
;; --------------------------------------------------------------------------
;; Top-level API
;; --------------------------------------------------------------------------
(define compile
(fn (expr)
"Compile a single SX expression to a bytecode module."
(let ((em (make-emitter))
(scope (make-scope nil)))
(compile-expr em expr scope false)
(emit-op em 0x32) ;; OP_RETURN
{:bytecode (get em "bytecode")
:pool (get em "pool")})))
(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 0x05)) ;; 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 0x32) ;; OP_RETURN
{:bytecode (get em "bytecode")
:pool (get em "pool")})))