Add Slang-to-WASM compilation infrastructure
ober
a3ccb389bf0dd5d460c277c0abd9cf53cb7c7657
new file mode 100644 --- /dev/null +++ b/lib/jerboa/wasm/closure.sls @@ -0,0 +1,563 @@ +#!chezscheme +;;; (jerboa wasm closure) -- Lambda lifting for Slang-to-WASM compilation +;;; +;;; Transforms Slang source code by hoisting all lambda expressions to +;;; top-level `define` forms with explicit environment parameters. +;;; +;;; Slang's restrictions make this simpler than general Scheme: +;;; - No call/cc: no upward continuations +;;; - No set! on captured variables: environments are immutable (copy-on-capture) +;;; - No eval: all lambdas are visible at compile time +;;; +;;; Transformation: +;;; (define (f x) +;;; (let ([g (lambda (y) (+ x y))]) +;;; (g 10))) +;;; → +;;; (define (__lifted_f_g env y) +;;; (+ (closure-env-ref env 0) y)) +;;; (define (f x) +;;; (let ([g (alloc-closure <idx-of-__lifted_f_g> 1)]) +;;; (closure-env-set! g 0 x) +;;; (call-closure g 10))) +;;; +;;; Higher-order calls (map, filter, etc.) go through call_indirect +;;; using the closure's func-idx field and the function table. + +(library (jerboa wasm closure) + (export + lambda-lift ;; (list of forms) -> (list of forms) + free-variables ;; (expr bound-set) -> (list of symbols) + ) + + (import (chezscheme)) + + ;; ================================================================ + ;; Free variable analysis + ;; ================================================================ + + ;; Return a list of free variables in `expr` that are not in `bound`. + ;; `bound` is a list of symbols currently in scope. + (define (free-variables expr bound) + (unique (fv expr bound))) + + (define (unique lst) + (let loop ([l lst] [seen '()] [out '()]) + (if (null? l) + (reverse out) + (if (memq (car l) seen) + (loop (cdr l) seen out) + (loop (cdr l) (cons (car l) seen) (cons (car l) out)))))) + + (define (fv expr bound) + (cond + ;; Literal: no free variables + [(or (number? expr) (boolean? expr) (string? expr) (char? expr)) + '()] + + ;; Symbol: free if not bound + [(symbol? expr) + (if (memq expr bound) '() (list expr))] + + ;; Compound form + [(pair? expr) + (let ([head (car expr)] [args (cdr expr)]) + (case head + ;; Quote: no free variables + [(quote) '()] + + ;; Lambda: parameters become bound + [(lambda) + (let* ([params (lambda-params (car args))] + [body (cdr args)] + [new-bound (append params bound)]) + (fv-body body new-bound))] + + ;; Let: binding names are sequential + [(let) + (let* ([bindings (car args)] + [body (cdr args)] + [bind-names (map car bindings)] + [bind-exprs (map cadr bindings)] + ;; Binding RHS sees outer scope + [bind-fvs (apply append (map (lambda (e) (fv e bound)) bind-exprs))] + ;; Body sees bindings + [body-fvs (fv-body body (append bind-names bound))]) + (append bind-fvs body-fvs))] + + ;; Let*: sequential binding + [(let*) + (if (null? (car args)) + (fv-body (cdr args) bound) + (let* ([bindings (car args)] + [body (cdr args)] + [first-name (caar bindings)] + [first-expr (cadar bindings)] + [first-fvs (fv first-expr bound)] + [rest-fvs (fv `(let* ,(cdr bindings) ,@body) + (cons first-name bound))]) + (append first-fvs rest-fvs)))] + + ;; Define (in body context): name is bound for body + [(define) + (if (pair? (cadr expr)) + ;; (define (name params...) body...) + (let* ([sig (cadr expr)] + [name (car sig)] + [params (lambda-params (cdr sig))] + [body (cddr expr)] + [new-bound (append params (cons name bound))]) + (fv-body body new-bound)) + ;; (define name expr) + (fv (caddr expr) bound))] + + ;; If/when/unless/and/or/begin: recurse into subexpressions + [(if) + (append (fv (car args) bound) + (fv (cadr args) bound) + (if (null? (cddr args)) '() + (fv (caddr args) bound)))] + + [(when unless) + (append (fv (car args) bound) + (fv-body (cdr args) bound))] + + [(and or begin) + (fv-body args bound)] + + [(cond) + (apply append + (map (lambda (clause) + (if (eq? (car clause) 'else) + (fv-body (cdr clause) bound) + (append (fv (car clause) bound) + (fv-body (cdr clause) bound)))) + args))] + + ;; While/set! + [(while) + (append (fv (car args) bound) + (fv-body (cdr args) bound))] + + [(set!) + (append (if (memq (car args) bound) '() (list (car args))) + (fv (cadr args) bound))] + + ;; Match: simplified — treat patterns as binding + [(match) + (let ([scrutinee-fvs (fv (car args) bound)]) + (apply append scrutinee-fvs + (map (lambda (clause) + (let* ([pat (car clause)] + [pat-binds (pattern-bindings pat)] + [body (cdr clause)]) + (fv-body body (append pat-binds bound)))) + (cdr args))))] + + ;; For/collect, for/fold: iterator bindings + [(for/collect for for/fold) + ;; Simplified: treat all binding forms as introducing vars + (let* ([binding-clauses (car args)] + [bind-names (map car binding-clauses)] + [iter-fvs (apply append + (map (lambda (bc) (fv (cadr bc) bound)) + binding-clauses))] + [body-fvs (fv-body (cdr args) (append bind-names bound))]) + (append iter-fvs body-fvs))] + + ;; Default: function call — recurse into all subexpressions + [else + (apply append (map (lambda (e) (fv e bound)) expr))]))] + + [else '()])) + + ;; Free variables in a body (list of expressions) + (define (fv-body exprs bound) + (apply append (map (lambda (e) (fv e bound)) exprs))) + + ;; Extract parameter names from a lambda formals list + (define (lambda-params formals) + (cond + [(null? formals) '()] + [(symbol? formals) (list formals)] ;; rest arg + [(pair? formals) + (let ([p (car formals)]) + (cons (if (pair? p) (car p) p) ;; handle (name type) params + (lambda-params (cdr formals))))] + [else '()])) + + ;; Extract binding names from a match pattern (approximate) + (define (pattern-bindings pat) + (cond + [(symbol? pat) + (if (eq? pat '_) '() (list pat))] + [(pair? pat) + (case (car pat) + [(quote) '()] + [(list cons vector) + (apply append (map pattern-bindings (cdr pat)))] + [(? =>) + (if (>= (length pat) 3) + (pattern-bindings (caddr pat)) + '())] + [else (apply append (map pattern-bindings (cdr pat)))])] + [else '()])) + + ;; ================================================================ + ;; Lambda lifting transformation + ;; ================================================================ + + ;; Global counter for generating unique lifted function names + (define lift-counter 0) + + (define (fresh-lifted-name parent-name) + (set! lift-counter (+ lift-counter 1)) + (string->symbol + (string-append "__lifted_" + (symbol->string parent-name) "_" + (number->string lift-counter)))) + + ;; Main entry point: transform a list of top-level forms. + ;; Returns a new list of forms with all lambdas hoisted to top-level. + (define (lambda-lift forms) + (set! lift-counter 0) + (let ([lifted '()] ;; accumulated lifted function definitions + [result '()]) ;; transformed top-level forms + ;; Process each top-level form + (for-each + (lambda (form) + (if (and (pair? form) (eq? (car form) 'define) (pair? (cadr form))) + ;; (define (name params...) body...) + (let* ([sig (cadr form)] + [name (car sig)] + [params (cdr sig)] + [body (cddr form)] + [param-names (map (lambda (p) (if (pair? p) (car p) p)) params)] + [toplevel-names (collect-toplevel-names forms)] + [ctx (make-lift-context name param-names toplevel-names)]) + (let-values ([(new-body new-lifted) (lift-body body ctx)]) + (set! lifted (append lifted new-lifted)) + (set! result (cons `(define ,sig ,@new-body) result)))) + ;; Non-define forms pass through unchanged + (set! result (cons form result)))) + forms) + ;; Return: lifted functions first, then original (transformed) forms + (append (reverse lifted) (reverse result)))) + + ;; Collect all top-level define names (for excluding from free variables) + (define (collect-toplevel-names forms) + (let loop ([fs forms] [names '()]) + (if (null? fs) + names + (let ([f (car fs)]) + (if (and (pair? f) (eq? (car f) 'define)) + (let ([sig (cadr f)]) + (loop (cdr fs) + (cons (if (pair? sig) (car sig) sig) names))) + (loop (cdr fs) names)))))) + + ;; Lift context: tracks scope for lambda lifting + (define-record-type lift-context + (fields + parent-name ;; symbol: enclosing function name + bound-vars ;; list of symbols: locally bound variables + toplevel-names) ;; list of symbols: top-level function names + (protocol (lambda (new) + (lambda (parent bound toplevel) + (new parent bound toplevel))))) + + ;; Extend context with additional bound variables + (define (ctx-extend ctx new-vars) + (make-lift-context + (lift-context-parent-name ctx) + (append new-vars (lift-context-bound-vars ctx)) + (lift-context-toplevel-names ctx))) + + ;; Lift lambdas in a body (list of expressions) + ;; Returns (values new-body lifted-defines) + (define (lift-body body ctx) + (let loop ([exprs body] [new-body '()] [lifted '()]) + (if (null? exprs) + (values (reverse new-body) lifted) + (let-values ([(new-expr new-lifted) (lift-expr (car exprs) ctx)]) + (loop (cdr exprs) + (cons new-expr new-body) + (append lifted new-lifted)))))) + + ;; Lift lambdas in a single expression. + ;; Returns (values new-expr lifted-defines) + (define (lift-expr expr ctx) + (cond + ;; Atoms pass through + [(or (number? expr) (boolean? expr) (string? expr) + (char? expr) (symbol? expr)) + (values expr '())] + + [(pair? expr) + (let ([head (car expr)] [args (cdr expr)]) + (case head + ;; Lambda: the core transformation + [(lambda) + (lift-lambda expr ctx)] + + ;; Let: process bindings and body + [(let) + (let* ([bindings (car args)] + [body (cdr args)] + [bind-names (map car bindings)]) + (let loop ([bs bindings] [new-bs '()] [lifted '()]) + (if (null? bs) + (let ([inner-ctx (ctx-extend ctx bind-names)]) + (let-values ([(new-body body-lifted) (lift-body body inner-ctx)]) + (values `(let ,(reverse new-bs) ,@new-body) + (append lifted body-lifted)))) + (let-values ([(new-val val-lifted) (lift-expr (cadar bs) ctx)]) + (loop (cdr bs) + (cons (list (caar bs) new-val) new-bs) + (append lifted val-lifted))))))] + + ;; Let*: similar to let but sequential + [(let*) + (let* ([bindings (car args)] + [body (cdr args)]) + (let loop ([bs bindings] [new-bs '()] [cur-ctx ctx] [lifted '()]) + (if (null? bs) + (let-values ([(new-body body-lifted) (lift-body body cur-ctx)]) + (values `(let* ,(reverse new-bs) ,@new-body) + (append lifted body-lifted))) + (let-values ([(new-val val-lifted) (lift-expr (cadar bs) cur-ctx)]) + (loop (cdr bs) + (cons (list (caar bs) new-val) new-bs) + (ctx-extend cur-ctx (list (caar bs))) + (append lifted val-lifted))))))] + + ;; If + [(if) + (let-values ([(new-test test-l) (lift-expr (car args) ctx)] + [(new-then then-l) (lift-expr (cadr args) ctx)]) + (if (null? (cddr args)) + (values `(if ,new-test ,new-then) + (append test-l then-l)) + (let-values ([(new-else else-l) (lift-expr (caddr args) ctx)]) + (values `(if ,new-test ,new-then ,new-else) + (append test-l then-l else-l)))))] + + ;; When/unless + [(when unless) + (let-values ([(new-test test-l) (lift-expr (car args) ctx)]) + (let-values ([(new-body body-l) (lift-body (cdr args) ctx)]) + (values `(,head ,new-test ,@new-body) + (append test-l body-l))))] + + ;; Begin + [(begin) + (let-values ([(new-body body-l) (lift-body args ctx)]) + (values `(begin ,@new-body) body-l))] + + ;; While + [(while) + (let-values ([(new-test test-l) (lift-expr (car args) ctx)] + [(new-body body-l) (lift-body (cdr args) ctx)]) + (values `(while ,new-test ,@new-body) + (append test-l body-l)))] + + ;; Set! + [(set!) + (let-values ([(new-val val-l) (lift-expr (cadr args) ctx)]) + (values `(set! ,(car args) ,new-val) val-l))] + + ;; And/or + [(and or) + (let-values ([(new-args args-l) (lift-args args ctx)]) + (values `(,head ,@new-args) args-l))] + + ;; Cond + [(cond) + (let loop ([clauses args] [new-clauses '()] [lifted '()]) + (if (null? clauses) + (values `(cond ,@(reverse new-clauses)) lifted) + (let* ([clause (car clauses)] + [test (car clause)] + [body (cdr clause)]) + (if (eq? test 'else) + (let-values ([(new-body body-l) (lift-body body ctx)]) + (loop (cdr clauses) + (cons `(else ,@new-body) new-clauses) + (append lifted body-l))) + (let-values ([(new-test test-l) (lift-expr test ctx)] + [(new-body body-l) (lift-body body ctx)]) + (loop (cdr clauses) + (cons `(,new-test ,@new-body) new-clauses) + (append lifted test-l body-l)))))))] + + ;; Quote + [(quote) (values expr '())] + + ;; Default: function call or other form + [else + (let-values ([(new-args args-l) (lift-args args ctx)]) + ;; Also lift the head if it could be an expression + (if (symbol? head) + (values `(,head ,@new-args) args-l) + (let-values ([(new-head head-l) (lift-expr head ctx)]) + (values `(,new-head ,@new-args) + (append head-l args-l)))))]))] + + [else (values expr '())])) + + ;; Lift lambdas in a list of argument expressions + (define (lift-args args ctx) + (let loop ([as args] [new-as '()] [lifted '()]) + (if (null? as) + (values (reverse new-as) lifted) + (let-values ([(new-a a-l) (lift-expr (car as) ctx)]) + (loop (cdr as) (cons new-a new-as) (append lifted a-l)))))) + + ;; ================================================================ + ;; Lambda lifting core: transform a lambda into a closure allocation + ;; ================================================================ + + (define (lift-lambda expr ctx) + (let* ([formals (cadr expr)] + [body (cddr expr)] + [param-names (lambda-params formals)] + ;; Compute free variables (exclude top-level names and built-ins) + [all-bound (append param-names + (lift-context-bound-vars ctx) + (lift-context-toplevel-names ctx))] + ;; Also exclude known runtime functions + [runtime-names '(alloc alloc-closure closure-env-set! closure-env-ref + closure-func-idx call-closure + cons-val pair-car pair-cdr + tag-fixnum untag-fixnum is-fixnum is-heap-ptr + write-header heap-type-tag heap-obj-size + is-pair is-string is-bytevector is-vector + is-symbol is-closure is-nil is-true is-false + scheme-cons scheme-car scheme-cdr + alloc-string alloc-bytevector alloc-vector + alloc-symbol alloc-record alloc-flonum + string-length-bytes string-byte-ref string-byte-set! + bytevector-length-val bytevector-u8-ref-val + bytevector-u8-set-val! vector-length-val + vector-ref-val vector-set-val! + arena-reset arena-mark + root-push root-pop root-peek + grow-memory + fx+ fx- fx* fx/ fx-mod + fx< fx> fx<= fx>= fx= + scheme-eq? scheme-eqv? scheme-equal? + io-read-u16be io-write-u16be + io-read-u32be io-write-u32be + mem-copy mem-zero + scheme-length scheme-append scheme-reverse + scheme-null? scheme-list? + scheme-string=? scheme-string-compare + scheme-make-bytevector scheme-bytevector-length + scheme-bytevector-u8-ref scheme-bytevector-u8-set! + scheme-make-vector scheme-vector-length + scheme-vector-ref scheme-vector-set!)] + [bound-with-runtime (append runtime-names all-bound)] + [free-vars (free-variables `(begin ,@body) bound-with-runtime)] + ;; Generate lifted function name + [lifted-name (fresh-lifted-name (lift-context-parent-name ctx))] + ;; New formals: env parameter + original params + [env-param 'env] + [new-formals (cons env-param formals)]) + + ;; Transform body: replace free variable references with + ;; (closure-env-ref env <index>) + (let* ([env-map (let loop ([vars free-vars] [i 0]) + (if (null? vars) '() + (cons (cons (car vars) i) + (loop (cdr vars) (+ i 1)))))] + ;; Transform body to use env references + [new-body (map (lambda (e) (subst-free-vars e env-map env-param)) + body)] + ;; The lifted function definition + [lifted-def `(define (,lifted-name ,@new-formals) ,@new-body)] + ;; The closure allocation expression + [n-free (length free-vars)] + ;; Build the closure allocation + env filling + [closure-expr + (if (= n-free 0) + ;; No free variables: still create a closure for uniformity + `(alloc-closure 0 0) ;; func-idx filled in later by wasm-target + `(let ([__clos (alloc-closure 0 ,n-free)]) + ,@(map (lambda (var) + (let ([idx (cdr (assq var env-map))]) + `(closure-env-set! __clos ,idx ,var))) + free-vars) + __clos))]) + + ;; Also recursively lift any lambdas inside the lifted body + (let ([inner-ctx (make-lift-context lifted-name + (cons env-param param-names) + (lift-context-toplevel-names ctx))]) + (let-values ([(final-body inner-lifted) (lift-body new-body inner-ctx)]) + (let ([final-def `(define (,lifted-name ,@new-formals) ,@final-body)]) + (values closure-expr + (append inner-lifted (list final-def))))))))) + + ;; Substitute free variable references with closure-env-ref calls + (define (subst-free-vars expr env-map env-param) + (cond + [(symbol? expr) + (let ([entry (assq expr env-map)]) + (if entry + `(closure-env-ref ,env-param ,(cdr entry)) + expr))] + + [(pair? expr) + (let ([head (car expr)]) + (case head + [(quote) expr] + [(lambda) + ;; Don't substitute inside lambda params, only body + (let ([formals (cadr expr)] + [body (cddr expr)] + [param-names (lambda-params (cadr expr))]) + ;; Remove params from env-map (they shadow captures) + (let ([inner-map (filter (lambda (e) + (not (memq (car e) param-names))) + env-map)]) + `(lambda ,formals + ,@(map (lambda (e) (subst-free-vars e inner-map env-param)) + body))))] + [(let) + (let* ([bindings (cadr expr)] + [body (cddr expr)] + [new-bindings + (map (lambda (b) + (list (car b) (subst-free-vars (cadr b) env-map env-param))) + bindings)] + [bind-names (map car bindings)] + [inner-map (filter (lambda (e) + (not (memq (car e) bind-names))) + env-map)]) + `(let ,new-bindings + ,@(map (lambda (e) (subst-free-vars e inner-map env-param)) + body)))] + [(let*) + (let* ([bindings (cadr expr)] + [body (cddr expr)]) + ;; Process bindings sequentially, removing names as we go + (let loop ([bs bindings] [new-bs '()] [cur-map env-map]) + (if (null? bs) + `(let* ,(reverse new-bs) + ,@(map (lambda (e) (subst-free-vars e cur-map env-param)) + body)) + (let ([name (caar bs)] + [val (subst-free-vars (cadar bs) cur-map env-param)]) + (loop (cdr bs) + (cons (list name val) new-bs) + (filter (lambda (e) (not (eq? (car e) name))) + cur-map))))))] + [(set!) + `(set! ,(cadr expr) + ,(subst-free-vars (caddr expr) env-map env-param))] + [else + (map (lambda (e) (subst-free-vars e env-map env-param)) expr)]))] + + [else expr])) + +) ;; end library --- a/lib/jerboa/wasm/codegen.sls +++ b/lib/jerboa/wasm/codegen.sls @@ -477,20 +477,23 @@ ;;; ========== Expression compiler ========== ;; Compile let bindings + ;; NOTE: Must process bindings left-to-right with explicit sequencing. + ;; Chez's map does not guarantee evaluation order, so we use a loop. (define (compile-let bindings body ctx) - (let* ([names (map car bindings)] - [exprs (map cadr bindings)]) - (let ([binding-code - (bv-concat-list - (map (lambda (name expr) - (let ([eval-bv (compile-expr expr ctx)] - [idx (context-add-local! ctx name)]) - (bv-concat eval-bv - (bytevector wasm-opcode-local-set) - (encode-u32-leb128 idx)))) - names exprs))]) - (bv-concat binding-code - (compile-body body ctx))))) + (let ([binding-code + (let loop ([bs bindings] [acc '()]) + (if (null? bs) + (bv-concat-list (reverse acc)) + (let* ([name (caar bs)] + [expr (cadar bs)] + [eval-bv (compile-expr expr ctx)] + [idx (context-add-local! ctx name)] + [code (bv-concat eval-bv + (bytevector wasm-opcode-local-set) + (encode-u32-leb128 idx))]) + (loop (cdr bs) (cons code acc)))))]) + (bv-concat binding-code + (compile-body body ctx)))) ;; Does the expression produce no value on the stack (void)? (define (void-expr? expr) new file mode 100644 --- /dev/null +++ b/lib/jerboa/wasm/gc.sls @@ -0,0 +1,125 @@ +#!chezscheme +;;; (jerboa wasm gc) -- Heap allocator and arena GC for WASM linear memory +;;; +;;; Provides WASM source forms (for compile-program) that implement: +;;; - Bump allocator with 4-byte alignment +;;; - Arena reset (instant "GC" — reset bump pointer to arena base) +;;; - Memory growth via memory.grow when heap is exhausted +;;; - Root stack for preserving values across arena boundaries +;;; +;;; Arena model: +;;; DNS query processing allocates heap objects per-query, then calls +;;; arena-reset to reclaim all memory at once. No tracing GC needed. +;;; For long-lived data (zone config), allocate before setting the +;;; arena base, so arena-reset doesn't reclaim it. +;;; +;;; Memory layout (from values.sls): +;;; 0-255: Reserved null-trap zone +;;; 256-1023: Root stack +;;; 1024-4095: Static data +;;; 4096-8191: I/O buffers +;;; 8192+: Heap (bump-allocated) + +(library (jerboa wasm gc) + (export + gc-allocator-forms ;; core alloc + arena-reset + gc-root-stack-forms ;; root push/pop for cross-arena values + gc-memory-grow-forms ;; memory.grow integration + gc-all-forms ;; all gc forms combined + ) + + (import (chezscheme) + (jerboa wasm values)) + + ;; ================================================================ + ;; Core allocator: bump allocation with arena reset + ;; ================================================================ + + (define gc-allocator-forms + '( + ;; Allocate `size` bytes from the heap. Returns pointer. + ;; Size must be a multiple of 4 (caller ensures alignment). + ;; Calls grow-memory if heap is exhausted. + (define (alloc size) + (let ([ptr (global.get 0)]) ;; heap-ptr + (let ([new-ptr (+ ptr size)]) + (when (> new-ptr (global.get 1)) ;; heap-end + (grow-memory size)) + (global.set 0 (+ (global.get 0) size)) + ptr))) + + ;; Reset the arena: reclaim all heap memory allocated since arena-base. + ;; Call this between DNS queries to instantly free per-query allocations. + (define (arena-reset) + (global.set 0 (global.get 3))) ;; heap-ptr = arena-base + + ;; Set the current heap pointer as the new arena base. + ;; Objects allocated before this call survive arena-reset. + (define (arena-mark) + (global.set 3 (global.get 0))) ;; arena-base = heap-ptr + + ;; Return the number of bytes currently allocated in the arena. + (define (arena-used) + (- (global.get 0) (global.get 3))) + + ;; Return the number of bytes available before growth is needed. + (define (heap-available) + (- (global.get 1) (global.get 0))) + )) + + ;; ================================================================ + ;; Memory growth + ;; ================================================================ + + (define gc-memory-grow-forms + '( + ;; Grow linear memory to accommodate at least `needed` more bytes. + ;; Grows by at least 1 page (64KB) or enough pages for `needed`. + (define (grow-memory needed) + (let ([pages-needed (+ (shr-u needed 16) 1)]) ;; ceil(needed/65536) + (let ([result (memory.grow pages-needed)]) + (when (= result -1) + ;; memory.grow failed — out of memory, trap + (unreachable)) + ;; Update heap-end to reflect new size + (global.set 1 (* (memory.size) 65536))))) + )) + + ;; ================================================================ + ;; Root stack: preserve values that must survive arena reset + ;; ================================================================ + + (define gc-root-stack-forms + '( + ;; Push a value onto the root stack. + ;; Used to protect values that must survive arena-reset. + (define (root-push val) + (let ([sp (global.get 2)]) ;; root-sp + (i32.store sp val) + (global.set 2 (+ sp 4)))) + + ;; Pop and return the top value from the root stack. + (define (root-pop) + (let ([sp (- (global.get 2) 4)]) + (global.set 2 sp) + (i32.load sp))) + + ;; Peek at the top of the root stack without popping. + (define (root-peek) + (i32.load (- (global.get 2) 4))) + + ;; Return current root stack depth (number of entries). + (define (root-depth) + (shr-u (- (global.get 2) 256) 2)) ;; (sp - ROOT_BASE) / 4 + )) + + ;; ================================================================ + ;; Combined: all GC forms + ;; ================================================================ + + (define gc-all-forms + (append gc-allocator-forms + gc-memory-grow-forms + gc-root-stack-forms)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/wasm/scheme-runtime.sls @@ -0,0 +1,522 @@ +#!chezscheme +;;; (jerboa wasm scheme-runtime) -- Scheme runtime library compiled to WASM +;;; +;;; Provides WASM source forms (for compile-program) implementing the +;;; essential Scheme runtime operations. Built on top of the tagged value +;;; representation (values.sls) and allocator (gc.sls). +;;; +;;; Operations provided: +;;; - List operations: cons, car, cdr, length, append, reverse, map, etc. +;;; - Type checks: pair?, string?, number?, etc. (wrapped predicates) +;;; - Bytevector operations: make-bytevector, bv-ref, bv-set!, bv-copy +;;; - String operations: string-length, string-ref, string comparison +;;; - Vector operations: make-vector, vector-ref, vector-set! +;;; - Fixnum arithmetic with overflow to tagged values +;;; - Equality: eq?, equal? +;;; - Comparison: <, >, <=, >= +;;; +;;; All functions operate on tagged values (i32) and return tagged values. +;;; The caller passes tagged fixnums (not raw ints) for numeric arguments. + +(library (jerboa wasm scheme-runtime) + (export + runtime-list-forms + runtime-bytevector-forms + runtime-string-forms + runtime-vector-forms + runtime-arithmetic-forms + runtime-comparison-forms + runtime-equality-forms + runtime-conversion-forms + runtime-io-forms + runtime-all-forms + ) + + (import (chezscheme) + (jerboa wasm values)) + + ;; ================================================================ + ;; List operations (on tagged values) + ;; ================================================================ + + (define runtime-list-forms + '( + ;; Scheme `cons` — allocate pair from tagged values + (define (scheme-cons a d) + (cons-val a d)) + + ;; Scheme `car` — extract car from tagged pair + (define (scheme-car p) + (pair-car p)) + + ;; Scheme `cdr` — extract cdr from tagged pair + (define (scheme-cdr p) + (pair-cdr p)) + + ;; Scheme `null?` — check if value is () + (define (scheme-null? v) + (= v 4)) ;; IMM-NIL = 4 + + ;; Scheme `list?` — proper list ending in () + (define (scheme-list? v) + (if (= v 4) + 1 ;; () is a list + (if (is-pair v) + (scheme-list? (pair-cdr v)) + 0))) + + ;; Scheme `length` — count elements in a proper list + ;; Returns a tagged fixnum + (define (scheme-length lst) + (let ([count 0] + [p lst]) + (while (is-pair p) + (set! count (+ count 1)) + (set! p (pair-cdr p))) + (tag-fixnum count))) + + ;; Scheme `append` — append two lists + ;; Copies the spine of lst1, shares lst2 + (define (scheme-append lst1 lst2) + (if (= lst1 4) + lst2 + (cons-val (pair-car lst1) + (scheme-append (pair-cdr lst1) lst2)))) + + ;; Scheme `reverse` — reverse a list + (define (scheme-reverse lst) + (let ([result 4] ;; NIL + [p lst]) + (while (is-pair p) + (set! result (cons-val (pair-car p) result)) + (set! p (pair-cdr p))) + result)) + + ;; Scheme `list-ref` — get nth element (n is tagged fixnum) + (define (scheme-list-ref lst n) + (let ([idx (untag-fixnum n)] + [p lst]) + (while (> idx 0) + (set! p (pair-cdr p)) + (set! idx (- idx 1))) + (pair-car p))) + + ;; Build a list from values in a vector (helper for apply) + (define (vector->list-range vec start end) + (let ([result 4] ;; NIL + [i (- end 1)]) + (while (>= i start) + (set! result (cons-val (vector-ref-val vec i) result)) + (set! i (- i 1))) + result)) + + ;; Scheme `assq` — find pair by key using eq? + (define (scheme-assq key alist) + (let ([p alist] + [found 0]) ;; #f + (while (and (is-pair p) (= found 0)) + (let ([entry (pair-car p)]) + (if (= (pair-car entry) key) + (set! found entry) + (set! p (pair-cdr p))))) + found)) + + ;; Scheme `memq` — find element by eq? + (define (scheme-memq key lst) + (let ([p lst] + [found 0]) + (while (and (is-pair p) (= found 0)) + (if (= (pair-car p) key) + (set! found p) + (set! p (pair-cdr p)))) + found)) + )) + + ;; ================================================================ + ;; Bytevector operations + ;; ================================================================ + + (define runtime-bytevector-forms + '( + ;; make-bytevector: allocate and zero-fill + ;; len is a tagged fixnum + (define (scheme-make-bytevector len) + (let ([n (untag-fixnum len)]) + (let ([bv (alloc-bytevector n)]) + ;; Zero-fill + (let ([i 0]) + (while (< i n) + (bytevector-u8-set-val! bv i 0) + (set! i (+ i 1)))) + bv))) + + ;; bytevector-length: returns tagged fixnum + (define (scheme-bytevector-length bv) + (tag-fixnum (bytevector-length-val bv))) + + ;; bytevector-u8-ref: returns tagged fixnum + ;; idx is tagged fixnum + (define (scheme-bytevector-u8-ref bv idx) + (tag-fixnum (bytevector-u8-ref-val bv (untag-fixnum idx)))) + + ;; bytevector-u8-set!: val is tagged fixnum + (define (scheme-bytevector-u8-set! bv idx val) + (bytevector-u8-set-val! bv (untag-fixnum idx) (untag-fixnum val))) + + ;; bytevector-copy: copy range from src to dst + ;; All indices are tagged fixnums + (define (scheme-bytevector-copy src src-start dst dst-start count) + (let ([ss (untag-fixnum src-start)] + [ds (untag-fixnum dst-start)] + [n (untag-fixnum count)] + [i 0]) + (while (< i n) + (bytevector-u8-set-val! dst (+ ds i) + (bytevector-u8-ref-val src (+ ss i))) + (set! i (+ i 1))))) + + ;; Copy raw bytes from linear memory offset to a bytevector + ;; mem-offset and len are raw i32 (not tagged) + (define (bytevector-from-memory mem-offset len) + (let ([bv (alloc-bytevector len)] + [i 0]) + (while (< i len) + (bytevector-u8-set-val! bv i (i32.load8_u (+ mem-offset i))) + (set! i (+ i 1))) + bv)) + + ;; Copy bytevector contents to linear memory offset + ;; mem-offset is raw i32 + (define (bytevector-to-memory bv mem-offset) + (let ([n (bytevector-length-val bv)] + [i 0]) + (while (< i n) + (i32.store8 (+ mem-offset i) (bytevector-u8-ref-val bv i)) + (set! i (+ i 1))))) + )) + + ;; ================================================================ + ;; String operations + ;; ================================================================ + + (define runtime-string-forms + '( + ;; string-length: returns tagged fixnum (byte length for now) + ;; TODO: proper UTF-8 codepoint counting + (define (scheme-string-length s) + (tag-fixnum (string-length-bytes s))) + + ;; string-ref: returns tagged fixnum (byte value) + ;; idx is tagged fixnum + (define (scheme-string-ref s idx) + (tag-fixnum (string-byte-ref s (untag-fixnum idx)))) + + ;; String equality: byte-by-byte comparison + (define (scheme-string=? a b) + (let ([alen (string-length-bytes a)] + [blen (string-length-bytes b)]) + (if (!= alen blen) + 0 ;; #f — different lengths + (let ([i 0] + [eq 1]) + (while (and (< i alen) eq) + (when (!= (string-byte-ref a i) (string-byte-ref b i)) + (set! eq 0)) + (set! i (+ i 1))) + (if eq 2 0))))) ;; return #t (2) or #f (0) + + ;; String lexicographic comparison: returns -1, 0, or 1 as tagged fixnum + (define (scheme-string-compare a b) + (let ([alen (string-length-bytes a)] + [blen (string-length-bytes b)] + [minlen (if (< alen blen) alen blen)] + [result 0] + [i 0]) + (while (and (< i minlen) (= result 0)) + (let ([ab (string-byte-ref a i)] + [bb (string-byte-ref b i)]) + (when (< ab bb) (set! result -1)) + (when (> ab bb) (set! result 1))) + (set! i (+ i 1))) + (when (= result 0) + (when (< alen blen) (set! result -1)) + (when (> alen blen) (set! result 1))) + (tag-fixnum result))) + + ;; Allocate a string from I/O buffer contents + ;; offset and len are raw i32 + (define (string-from-memory offset len) + (let ([s (alloc-string len)] + [i 0]) + (while (< i len) + (string-byte-set! s i (i32.load8_u (+ offset i))) + (set! i (+ i 1))) + s)) + )) + + ;; ================================================================ + ;; Vector operations + ;; ================================================================ + + (define runtime-vector-forms + '( + ;; make-vector: len is tagged fixnum, fill is tagged value + (define (scheme-make-vector len fill) + (let ([n (untag-fixnum len)]) + (let ([v (alloc-vector n)] + [i 0])