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

Rebuild WASM: bytecode with pending_cek snapshot fix

Browse Source 
All .sxbc recompiled with fixed sx_vm.ml. 32/32 WASM tests, 4/4
bytecode regression tests. hs-repeat-times correctly does 6 io-sleep
suspensions in bytecode mode.

Co-Authored-By: Claude Opus 4.6 (1M context) <noreply@anthropic.com>
This commit is contained in:
giles
2026-04-08 21:44:58 +00:00
parent ddc48c6d48
commit 5e708e1b20
24 changed files with 379 additions and 110 deletions
Download Patch File Download Diff File Expand all files Collapse all files

123
shared/static/wasm/sx/compiler.sx
View File

@@ -599,11 +599,12 @@
(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)))
(value (nth binding 1)))
(compile-expr em value let-scope false)
(emit-op em 17)
(emit-byte em slot)))
(let
((slot (scope-define-local let-scope name)))
(emit-op em 17)
(emit-byte em slot))))
bindings)
(compile-begin em body let-scope tail?)))))
(define
@@ -640,29 +641,38 @@
(fn-scope (make-scope scope))
(fn-em (make-emitter)))
(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))))
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)
(emit-u16 em code-idx)
((rest-pos -1) (rest-name nil))
(for-each
(fn
(uv)
(emit-byte em (if (get uv "is-local") 1 0))
(emit-byte em (get uv "index")))
upvals)))))
(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)))
(cond
(= name "&rest")
(set! rest-pos (len (get fn-scope "locals")))
(= name "&key")
nil
:else (do
(when
(and (> rest-pos -1) (nil? rest-name))
(set! rest-name name))
(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 (if (> rest-pos -1) {:upvalue-count (len upvals) :arity (len (get fn-scope "locals")) :constants (get (get fn-em "pool") "entries") :rest-arity rest-pos :bytecode (get fn-em "bytecode")} {: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)
(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
@@ -681,7 +691,7 @@
(and
(not (empty? rest-args))
(= (type-of (first rest-args)) "keyword"))
(let
(letrec
((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)))))
@@ -724,38 +734,41 @@
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))
(compile-expr em body scope tail?)
(do
(compile-expr em test scope false)
(emit-op em 33)
(let
((skip (current-offset em)))
(emit-i16 em 0)
(compile-expr em body scope tail?)
(emit-op em 32)
"Compile (cond test1 body1 test2 body2 ... :else fallback).\n Also handles clause syntax: (cond (test1 body1) (test2 body2) ...)."
(let
((flat-args (if (and (not (empty? args)) (list? (first args)) (> (len (first args)) 1) (list? (first (first args)))) (reduce (fn (acc clause) (if (list? clause) (append acc clause) (append acc (list clause)))) (list) args) args)))
(if
(< (len flat-args) 2)
(emit-op em 2)
(let
((test (nth flat-args 0))
(body (nth flat-args 1))
(rest-clauses
(if (> (len flat-args) 2) (slice flat-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)
(let
((end-jump (current-offset em)))
((skip (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)))))))))))
(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)))
(compile-cond em rest-clauses scope tail?)
(patch-i16
em
end-jump
(- (current-offset em) (+ end-jump 2))))))))))))
(define
compile-case
(fn