giles
b6f304e91a
Adds opcode 112 (OP_PERFORM / IO suspension) to lib/vm.sx's vm-step dispatch. The native sx_vm.ml already has this opcode — this brings the SX spec into alignment. Full VM transpilation deferred to Step 6 (define-record-type): the dict-based state in vm.sx maps to get_val/sx_dict_set_b calls which are ~5x slower than native record/array access in the hot loop. define-record-type will let vm.sx use typed records that the transpiler maps to OCaml records natively. 2598/2598 tests passing. Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
559 lines
16 KiB
Plaintext
559 lines
16 KiB
Plaintext
(define make-upvalue-cell (fn (value) {:uv-value value}))
|
|
|
|
(define uv-get (fn (cell) (get cell "uv-value")))
|
|
|
|
(define uv-set! (fn (cell value) (dict-set! cell "uv-value" value)))
|
|
|
|
(define make-vm-code (fn (arity locals bytecode constants) {:vc-bytecode bytecode :vc-locals locals :vc-arity arity :vc-constants constants}))
|
|
|
|
(define
|
|
make-vm-closure
|
|
(fn (code upvalues name globals closure-env) {:vm-globals globals :vm-upvalues upvalues :vm-name name :vm-code code :vm-closure-env closure-env}))
|
|
|
|
(define make-vm-frame (fn (closure base) {:ip 0 :closure closure :base base :local-cells {}}))
|
|
|
|
(define make-vm (fn (globals) {:sp 0 :frames (list) :stack (make-vm-stack 4096) :globals globals}))
|
|
|
|
(define
|
|
vm-push
|
|
(fn
|
|
(vm value)
|
|
(let
|
|
((sp (get vm "sp")) (stack (get vm "stack")))
|
|
(when
|
|
(>= sp (vm-stack-length stack))
|
|
(let
|
|
((new-stack (make-vm-stack (* sp 2))))
|
|
(vm-stack-copy! stack new-stack sp)
|
|
(dict-set! vm "stack" new-stack)
|
|
(set! stack new-stack)))
|
|
(vm-stack-set! stack sp value)
|
|
(dict-set! vm "sp" (+ sp 1)))))
|
|
|
|
(define
|
|
vm-pop
|
|
(fn
|
|
(vm)
|
|
(let
|
|
((sp (- (get vm "sp") 1)))
|
|
(dict-set! vm "sp" sp)
|
|
(vm-stack-get (get vm "stack") sp))))
|
|
|
|
(define
|
|
vm-peek
|
|
(fn (vm) (vm-stack-get (get vm "stack") (- (get vm "sp") 1))))
|
|
|
|
(define
|
|
frame-read-u8
|
|
(fn
|
|
(frame)
|
|
(let
|
|
((ip (get frame "ip"))
|
|
(bc (get (get (get frame "closure") "vm-code") "vc-bytecode")))
|
|
(let ((v (nth bc ip))) (dict-set! frame "ip" (+ ip 1)) v))))
|
|
|
|
(define
|
|
frame-read-u16
|
|
(fn
|
|
(frame)
|
|
(let
|
|
((lo (frame-read-u8 frame)) (hi (frame-read-u8 frame)))
|
|
(+ lo (* hi 256)))))
|
|
|
|
(define
|
|
frame-read-i16
|
|
(fn
|
|
(frame)
|
|
(let ((v (frame-read-u16 frame))) (if (>= v 32768) (- v 65536) v))))
|
|
|
|
(define
|
|
vm-push-frame
|
|
(fn
|
|
(vm closure args)
|
|
(let
|
|
((frame (make-vm-frame closure (get vm "sp"))))
|
|
(for-each (fn (a) (vm-push vm a)) args)
|
|
(let
|
|
((arity (len args))
|
|
(total-locals (get (get closure "vm-code") "vc-locals")))
|
|
(let
|
|
((pad-count (- total-locals arity)))
|
|
(when
|
|
(> pad-count 0)
|
|
(let
|
|
((i 0))
|
|
(define
|
|
pad-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(< i pad-count)
|
|
(vm-push vm nil)
|
|
(set! i (+ i 1))
|
|
(pad-loop))))
|
|
(pad-loop)))))
|
|
(dict-set! vm "frames" (cons frame (get vm "frames"))))))
|
|
|
|
(define
|
|
code-from-value
|
|
(fn
|
|
(v)
|
|
"Convert a compiler output dict to a vm-code object."
|
|
(if
|
|
(not (dict? v))
|
|
(make-vm-code 0 16 (list) (list))
|
|
(let
|
|
((bc-raw (get v "bytecode"))
|
|
(bc (if (nil? bc-raw) (list) bc-raw))
|
|
(consts-raw (get v "constants"))
|
|
(consts (if (nil? consts-raw) (list) consts-raw))
|
|
(arity-raw (get v "arity"))
|
|
(arity (if (nil? arity-raw) 0 arity-raw)))
|
|
(make-vm-code arity (+ arity 16) bc consts)))))
|
|
|
|
(define vm-closure? (fn (v) (and (dict? v) (has-key? v "vm-code"))))
|
|
|
|
(define
|
|
vm-call
|
|
(fn
|
|
(vm f args)
|
|
(cond
|
|
(vm-closure? f)
|
|
(vm-push-frame vm f args)
|
|
(or
|
|
(= (type-of f) "lambda")
|
|
(= (type-of f) "component")
|
|
(= (type-of f) "island"))
|
|
(vm-push vm (cek-call f args))
|
|
(callable? f)
|
|
(vm-push vm (apply f args))
|
|
:else (error (str "VM: not callable: " (type-of f))))))
|
|
|
|
(define
|
|
frame-local-get
|
|
(fn
|
|
(vm frame slot)
|
|
"Read a local variable — check shared cells first, then stack."
|
|
(let
|
|
((cells (get frame "local-cells")) (key (str slot)))
|
|
(if
|
|
(has-key? cells key)
|
|
(uv-get (get cells key))
|
|
(vm-stack-get (get vm "stack") (+ (get frame "base") slot))))))
|
|
|
|
(define
|
|
frame-local-set
|
|
(fn
|
|
(vm frame slot value)
|
|
"Write a local variable — to shared cell if captured, else to stack."
|
|
(let
|
|
((cells (get frame "local-cells")) (key (str slot)))
|
|
(if
|
|
(has-key? cells key)
|
|
(uv-set! (get cells key) value)
|
|
(vm-stack-set! (get vm "stack") (+ (get frame "base") slot) value)))))
|
|
|
|
(define
|
|
frame-upvalue-get
|
|
(fn
|
|
(frame idx)
|
|
(uv-get (nth (get (get frame "closure") "vm-upvalues") idx))))
|
|
|
|
(define
|
|
frame-upvalue-set
|
|
(fn
|
|
(frame idx value)
|
|
(uv-set! (nth (get (get frame "closure") "vm-upvalues") idx) value)))
|
|
|
|
(define
|
|
vm-global-get
|
|
(fn
|
|
(vm frame name)
|
|
"Look up a global: globals table → closure env → primitives → HO wrappers"
|
|
(let
|
|
((globals (get vm "globals")))
|
|
(if
|
|
(has-key? globals name)
|
|
(get globals name)
|
|
(let
|
|
((closure-env (get (get frame "closure") "closure-env")))
|
|
(if
|
|
(nil? closure-env)
|
|
(cek-try
|
|
(fn () (get-primitive name))
|
|
(fn (e) (vm-resolve-ho-form vm name)))
|
|
(let
|
|
((found (env-walk closure-env name)))
|
|
(if
|
|
(nil? found)
|
|
(cek-try
|
|
(fn () (get-primitive name))
|
|
(fn (e) (vm-resolve-ho-form vm name)))
|
|
found))))))))
|
|
|
|
(define
|
|
vm-resolve-ho-form
|
|
(fn
|
|
(vm name)
|
|
(cond
|
|
(= name "for-each")
|
|
(fn
|
|
(f coll)
|
|
(for-each (fn (x) (vm-call-external vm f (list x))) coll))
|
|
(= name "map")
|
|
(fn (f coll) (map (fn (x) (vm-call-external vm f (list x))) coll))
|
|
(= name "map-indexed")
|
|
(fn
|
|
(f coll)
|
|
(map-indexed (fn (i x) (vm-call-external vm f (list i x))) coll))
|
|
(= name "filter")
|
|
(fn
|
|
(f coll)
|
|
(filter (fn (x) (vm-call-external vm f (list x))) coll))
|
|
(= name "reduce")
|
|
(fn
|
|
(f init coll)
|
|
(reduce
|
|
(fn (acc x) (vm-call-external vm f (list acc x)))
|
|
init
|
|
coll))
|
|
(= name "some")
|
|
(fn (f coll) (some (fn (x) (vm-call-external vm f (list x))) coll))
|
|
(= name "every?")
|
|
(fn
|
|
(f coll)
|
|
(every? (fn (x) (vm-call-external vm f (list x))) coll))
|
|
:else (error (str "VM undefined: " name)))))
|
|
|
|
(define
|
|
vm-call-external
|
|
(fn
|
|
(vm f args)
|
|
(if
|
|
(vm-closure? f)
|
|
(vm-call-closure f args (get vm "globals"))
|
|
(cek-call f args))))
|
|
|
|
(define
|
|
vm-global-set
|
|
(fn
|
|
(vm frame name value)
|
|
"Set a global: write to closure env if name exists there, else globals."
|
|
(let
|
|
((closure-env (get (get frame "closure") "vm-closure-env"))
|
|
(written false))
|
|
(when
|
|
(not (nil? closure-env))
|
|
(set! written (env-walk-set! closure-env name value)))
|
|
(when (not written) (dict-set! (get vm "globals") name value)))))
|
|
|
|
(define
|
|
env-walk
|
|
(fn
|
|
(env name)
|
|
(if
|
|
(nil? env)
|
|
nil
|
|
(if
|
|
(env-has? env name)
|
|
(env-get env name)
|
|
(let
|
|
((parent (env-parent env)))
|
|
(if (nil? parent) nil (env-walk parent name)))))))
|
|
|
|
(define
|
|
env-walk-set!
|
|
(fn
|
|
(env name value)
|
|
(if
|
|
(nil? env)
|
|
false
|
|
(if
|
|
(env-has? env name)
|
|
(do (env-set! env name value) true)
|
|
(let
|
|
((parent (env-parent env)))
|
|
(if (nil? parent) false (env-walk-set! parent name value)))))))
|
|
|
|
(define
|
|
vm-create-closure
|
|
(fn
|
|
(vm frame code-val)
|
|
"Create a closure from a code constant. Reads upvalue descriptors\n from the bytecode stream and captures values from the enclosing frame."
|
|
(let
|
|
((code (code-from-value code-val))
|
|
(uv-count
|
|
(if
|
|
(dict? code-val)
|
|
(let ((n (get code-val "upvalue-count"))) (if (nil? n) 0 n))
|
|
0)))
|
|
(let
|
|
((upvalues (let ((result (list)) (i 0)) (define capture-loop (fn () (when (< i uv-count) (let ((is-local (frame-read-u8 frame)) (index (frame-read-u8 frame))) (let ((cell (if (= is-local 1) (let ((cells (get frame "local-cells")) (key (str index))) (if (has-key? cells key) (get cells key) (let ((c (make-upvalue-cell (vm-stack-get (get vm "stack") (+ (get frame "base") index))))) (dict-set! cells key c) c))) (nth (get (get frame "closure") "vm-upvalues") index)))) (append! result cell) (set! i (+ i 1)) (capture-loop)))))) (capture-loop) result)))
|
|
(make-vm-closure code upvalues nil (get vm "globals") nil)))))
|
|
|
|
(define
|
|
vm-run
|
|
(fn
|
|
(vm)
|
|
"Execute bytecode until all frames are exhausted.\n VmClosure calls push new frames; the loop picks them up.\n OP_TAIL_CALL + VmClosure = true TCO: drop frame, push new, loop."
|
|
(define
|
|
loop
|
|
(fn
|
|
()
|
|
(when
|
|
(not (empty? (get vm "frames")))
|
|
(let
|
|
((frame (first (get vm "frames")))
|
|
(rest-frames (rest (get vm "frames"))))
|
|
(let
|
|
((bc (get (get (get frame "closure") "vm-code") "vc-bytecode"))
|
|
(consts
|
|
(get (get (get frame "closure") "vm-code") "vc-constants")))
|
|
(if
|
|
(>= (get frame "ip") (len bc))
|
|
(dict-set! vm "frames" (list))
|
|
(do (vm-step vm frame rest-frames bc consts) (loop))))))))
|
|
(loop)))
|
|
|
|
(define
|
|
vm-step
|
|
(fn
|
|
(vm frame rest-frames bc consts)
|
|
(let
|
|
((op (frame-read-u8 frame)))
|
|
(cond
|
|
(= op 1)
|
|
(let ((idx (frame-read-u16 frame))) (vm-push vm (nth consts idx)))
|
|
(= op 2)
|
|
(vm-push vm nil)
|
|
(= op 3)
|
|
(vm-push vm true)
|
|
(= op 4)
|
|
(vm-push vm false)
|
|
(= op 5)
|
|
(vm-pop vm)
|
|
(= op 6)
|
|
(vm-push vm (vm-peek vm))
|
|
(= op 16)
|
|
(let
|
|
((slot (frame-read-u8 frame)))
|
|
(vm-push vm (frame-local-get vm frame slot)))
|
|
(= op 17)
|
|
(let
|
|
((slot (frame-read-u8 frame)))
|
|
(frame-local-set vm frame slot (vm-peek vm)))
|
|
(= op 18)
|
|
(let
|
|
((idx (frame-read-u8 frame)))
|
|
(vm-push vm (frame-upvalue-get frame idx)))
|
|
(= op 19)
|
|
(let
|
|
((idx (frame-read-u8 frame)))
|
|
(frame-upvalue-set frame idx (vm-peek vm)))
|
|
(= op 20)
|
|
(let
|
|
((idx (frame-read-u16 frame)) (name (nth consts idx)))
|
|
(vm-push vm (vm-global-get vm frame name)))
|
|
(= op 21)
|
|
(let
|
|
((idx (frame-read-u16 frame)) (name (nth consts idx)))
|
|
(vm-global-set vm frame name (vm-peek vm)))
|
|
(= op 32)
|
|
(let
|
|
((offset (frame-read-i16 frame)))
|
|
(dict-set! frame "ip" (+ (get frame "ip") offset)))
|
|
(= op 33)
|
|
(let
|
|
((offset (frame-read-i16 frame)) (v (vm-pop vm)))
|
|
(when (not v) (dict-set! frame "ip" (+ (get frame "ip") offset))))
|
|
(= op 34)
|
|
(let
|
|
((offset (frame-read-i16 frame)) (v (vm-pop vm)))
|
|
(when v (dict-set! frame "ip" (+ (get frame "ip") offset))))
|
|
(= op 48)
|
|
(let
|
|
((argc (frame-read-u8 frame)) (args-rev (list)) (i 0))
|
|
(define
|
|
collect-args
|
|
(fn
|
|
()
|
|
(when
|
|
(< i argc)
|
|
(set! args-rev (cons (vm-pop vm) args-rev))
|
|
(set! i (+ i 1))
|
|
(collect-args))))
|
|
(collect-args)
|
|
(let ((f (vm-pop vm))) (vm-call vm f args-rev)))
|
|
(= op 49)
|
|
(let
|
|
((argc (frame-read-u8 frame)) (args-rev (list)) (i 0))
|
|
(define
|
|
collect-args
|
|
(fn
|
|
()
|
|
(when
|
|
(< i argc)
|
|
(set! args-rev (cons (vm-pop vm) args-rev))
|
|
(set! i (+ i 1))
|
|
(collect-args))))
|
|
(collect-args)
|
|
(let
|
|
((f (vm-pop vm)))
|
|
(dict-set! vm "frames" rest-frames)
|
|
(dict-set! vm "sp" (get frame "base"))
|
|
(vm-call vm f args-rev)))
|
|
(= op 50)
|
|
(let
|
|
((result (vm-pop vm)))
|
|
(dict-set! vm "frames" rest-frames)
|
|
(dict-set! vm "sp" (get frame "base"))
|
|
(vm-push vm result))
|
|
(= op 51)
|
|
(let
|
|
((idx (frame-read-u16 frame)) (code-val (nth consts idx)))
|
|
(let
|
|
((cl (vm-create-closure vm frame code-val)))
|
|
(vm-push vm cl)))
|
|
(= op 52)
|
|
(let
|
|
((idx (frame-read-u16 frame))
|
|
(argc (frame-read-u8 frame))
|
|
(name (nth consts idx))
|
|
(args-rev (list))
|
|
(i 0))
|
|
(define
|
|
collect-args
|
|
(fn
|
|
()
|
|
(when
|
|
(< i argc)
|
|
(set! args-rev (cons (vm-pop vm) args-rev))
|
|
(set! i (+ i 1))
|
|
(collect-args))))
|
|
(collect-args)
|
|
(vm-push vm (call-primitive name args-rev)))
|
|
(= op 64)
|
|
(let
|
|
((count (frame-read-u16 frame)) (items-rev (list)) (i 0))
|
|
(define
|
|
collect-items
|
|
(fn
|
|
()
|
|
(when
|
|
(< i count)
|
|
(set! items-rev (cons (vm-pop vm) items-rev))
|
|
(set! i (+ i 1))
|
|
(collect-items))))
|
|
(collect-items)
|
|
(vm-push vm items-rev))
|
|
(= op 65)
|
|
(let
|
|
((count (frame-read-u16 frame)) (d {}) (i 0))
|
|
(define
|
|
collect-pairs
|
|
(fn
|
|
()
|
|
(when
|
|
(< i count)
|
|
(let
|
|
((v (vm-pop vm)) (k (vm-pop vm)))
|
|
(dict-set! d k v)
|
|
(set! i (+ i 1))
|
|
(collect-pairs)))))
|
|
(collect-pairs)
|
|
(vm-push vm d))
|
|
(= op 144)
|
|
(let
|
|
((count (frame-read-u8 frame)) (parts-rev (list)) (i 0))
|
|
(define
|
|
collect-parts
|
|
(fn
|
|
()
|
|
(when
|
|
(< i count)
|
|
(set! parts-rev (cons (vm-pop vm) parts-rev))
|
|
(set! i (+ i 1))
|
|
(collect-parts))))
|
|
(collect-parts)
|
|
(vm-push vm (apply str parts-rev)))
|
|
(= op 128)
|
|
(let
|
|
((idx (frame-read-u16 frame)) (name (nth consts idx)))
|
|
(dict-set! (get vm "globals") name (vm-peek vm)))
|
|
(= op 160)
|
|
(let ((b (vm-pop vm)) (a (vm-pop vm))) (vm-push vm (+ a b)))
|
|
(= op 161)
|
|
(let ((b (vm-pop vm)) (a (vm-pop vm))) (vm-push vm (- a b)))
|
|
(= op 162)
|
|
(let ((b (vm-pop vm)) (a (vm-pop vm))) (vm-push vm (* a b)))
|
|
(= op 163)
|
|
(let ((b (vm-pop vm)) (a (vm-pop vm))) (vm-push vm (/ a b)))
|
|
(= op 164)
|
|
(let ((b (vm-pop vm)) (a (vm-pop vm))) (vm-push vm (= a b)))
|
|
(= op 165)
|
|
(let ((b (vm-pop vm)) (a (vm-pop vm))) (vm-push vm (< a b)))
|
|
(= op 166)
|
|
(let ((b (vm-pop vm)) (a (vm-pop vm))) (vm-push vm (> a b)))
|
|
(= op 167)
|
|
(vm-push vm (not (vm-pop vm)))
|
|
(= op 168)
|
|
(vm-push vm (len (vm-pop vm)))
|
|
(= op 169)
|
|
(vm-push vm (first (vm-pop vm)))
|
|
(= op 170)
|
|
(vm-push vm (rest (vm-pop vm)))
|
|
(= op 171)
|
|
(let
|
|
((n (vm-pop vm)) (coll (vm-pop vm)))
|
|
(vm-push vm (nth coll n)))
|
|
(= op 172)
|
|
(let
|
|
((coll (vm-pop vm)) (x (vm-pop vm)))
|
|
(vm-push vm (cons x coll)))
|
|
(= op 173)
|
|
(vm-push vm (- 0 (vm-pop vm)))
|
|
(= op 174)
|
|
(vm-push vm (inc (vm-pop vm)))
|
|
(= op 175)
|
|
(vm-push vm (dec (vm-pop vm)))
|
|
(= op 112)
|
|
(let
|
|
((request (vm-pop vm)))
|
|
(error (str "VM: IO suspension (OP_PERFORM) — request: " request)))
|
|
:else (error (str "VM: unknown opcode " op))))))
|
|
|
|
(define
|
|
vm-call-closure
|
|
(fn
|
|
(closure args globals)
|
|
(let
|
|
((vm (make-vm globals)))
|
|
(vm-push-frame vm closure args)
|
|
(vm-run vm)
|
|
(vm-pop vm))))
|
|
|
|
(define
|
|
vm-execute-module
|
|
(fn
|
|
(code globals)
|
|
(let
|
|
((closure (make-vm-closure code (list) "module" globals nil))
|
|
(vm (make-vm globals)))
|
|
(let
|
|
((frame (make-vm-frame closure 0)))
|
|
(let
|
|
((i 0) (total (get code "vc-locals")))
|
|
(define
|
|
pad-loop
|
|
(fn
|
|
()
|
|
(when
|
|
(< i total)
|
|
(vm-push vm nil)
|
|
(set! i (+ i 1))
|
|
(pad-loop))))
|
|
(pad-loop))
|
|
(dict-set! vm "frames" (list frame))
|
|
(vm-run vm)
|
|
(vm-pop vm)))))
|