Phase 3e complete: WASM Target (3 libraries, 100 tests passing)
ober
c2fb6954d4bc1c639cbf94be55237953092e9244
new file mode 100644 --- /dev/null +++ b/lib/jerboa/wasm/codegen.sls @@ -0,0 +1,481 @@ +#!chezscheme +;;; (jerboa wasm codegen) -- WebAssembly code generation +;;; +;;; Compiles a restricted subset of Scheme to WASM binary format. +;;; Supported subset: i32-only, no closures, no heap allocation. +;;; +;;; (define (name args...) body) -> WASM function +;;; (let ([x e] ...) body) -> locals +;;; (if test then else) -> WASM if/else +;;; (+ a b), (- a b), etc. -> i32 arithmetic +;;; (= a b), (< a b), (> a b) -> i32 comparisons +;;; integer literals -> i32.const +;;; variable references -> local.get +;;; (begin e1 ... en) -> sequential, result is last + +(library (jerboa wasm codegen) + (export + ;; WASM module structure + make-wasm-module wasm-module? wasm-module-encode + wasm-module-types wasm-module-imports wasm-module-functions + wasm-module-exports wasm-module-memories wasm-module-globals + wasm-module-add-type! wasm-module-add-import! + wasm-module-add-function! wasm-module-add-export! + wasm-module-add-memory! wasm-module-add-global! + ;; WASM function + make-wasm-func wasm-func? wasm-func-locals wasm-func-body + ;; WASM type (function signature) + make-wasm-type wasm-type-params wasm-type-results + ;; WASM import descriptor + make-wasm-import wasm-import-module wasm-import-name wasm-import-desc + ;; WASM export descriptor + make-wasm-export wasm-export-name wasm-export-kind wasm-export-index + wasm-export-func wasm-export-memory + ;; Compilation + compile-expr compile-program scheme->wasm-type + ;; Compile context + make-compile-context context-add-local! context-local-index + context-add-func! context-func-index) + + (import (except (chezscheme) compile-program) + (jerboa wasm format)) + + ;;; ========== WASM type (function signature) ========== + + (define-record-type wasm-type + (fields params results) + (protocol (lambda (new) + (lambda (params results) (new params results))))) + + ;;; ========== WASM import ========== + + (define-record-type wasm-import + (fields module name desc)) + + ;;; ========== WASM export ========== + + (define-record-type wasm-export + (fields name kind index)) + + (define (wasm-export-func name index) + (make-wasm-export name 0 index)) ; kind 0 = function + + (define (wasm-export-memory name index) + (make-wasm-export name 2 index)) ; kind 2 = memory + + ;;; ========== WASM function ========== + + (define-record-type wasm-func + (fields locals body)) + + ;;; ========== WASM module ========== + + (define-record-type wasm-module + (fields + (mutable types) ; list of wasm-type + (mutable imports) ; list of wasm-import + (mutable functions) ; list of (type-index . wasm-func) + (mutable exports) ; list of wasm-export + (mutable memories) ; list of (min . max-or-#f) + (mutable globals)) ; list of (type mut? init-expr) + (protocol (lambda (new) + (lambda () (new '() '() '() '() '() '()))))) + + (define (wasm-module-add-type! mod type) + (wasm-module-types-set! mod (append (wasm-module-types mod) (list type)))) + + (define (wasm-module-add-import! mod imp) + (wasm-module-imports-set! mod (append (wasm-module-imports mod) (list imp)))) + + (define (wasm-module-add-function! mod type-idx func) + (wasm-module-functions-set! mod + (append (wasm-module-functions mod) (list (cons type-idx func))))) + + (define (wasm-module-add-export! mod exp) + (wasm-module-exports-set! mod (append (wasm-module-exports mod) (list exp)))) + + (define (wasm-module-add-memory! mod min-pages max-pages) + (wasm-module-memories-set! mod + (append (wasm-module-memories mod) (list (cons min-pages max-pages))))) + + (define (wasm-module-add-global! mod type mut? init-bv) + (wasm-module-globals-set! mod + (append (wasm-module-globals mod) (list (list type mut? init-bv))))) + + ;;; ========== Binary encoding helpers ========== + + ;; Concatenate list of bytevectors + (define (bv-concat . bvs) + (let ([total (apply + (map bytevector-length bvs))]) + (let ([result (make-bytevector total)]) + (let loop ([bvs bvs] [offset 0]) + (if (null? bvs) + result + (let* ([bv (car bvs)] + [len (bytevector-length bv)]) + (bytevector-copy! bv 0 result offset len) + (loop (cdr bvs) (+ offset len)))))))) + + (define (bv-concat-list lst) + (apply bv-concat lst)) + + ;; Encode a vector (list of items) with count prefix + (define (encode-vec items encode-item) + (let ([encoded (map encode-item items)]) + (bv-concat + (encode-u32-leb128 (length items)) + (bv-concat-list encoded)))) + + ;; Encode a WASM section: section-id + length + content + (define (encode-section id content) + (let ([len-bv (encode-u32-leb128 (bytevector-length content))]) + (bv-concat + (bytevector id) + len-bv + content))) + + ;;; ========== Type section encoding ========== + + (define (encode-wasm-type type) + ;; func type: 0x60 params results + (bv-concat + (bytevector #x60) + (encode-vec (wasm-type-params type) (lambda (t) (bytevector t))) + (encode-vec (wasm-type-results type) (lambda (t) (bytevector t))))) + + (define (encode-type-section types) + (if (null? types) + (bytevector) + (encode-section wasm-section-type + (encode-vec types encode-wasm-type)))) + + ;;; ========== Import section encoding ========== + + (define (encode-wasm-import imp) + (let ([desc (wasm-import-desc imp)]) + (bv-concat + (encode-string (wasm-import-module imp)) + (encode-string (wasm-import-name imp)) + (cond + [(and (pair? desc) (= (car desc) 0)) + (bv-concat (bytevector #x00) (encode-u32-leb128 (cdr desc)))] + [else + (error 'encode-wasm-import "unsupported import descriptor" desc)])))) + + (define (encode-import-section imports) + (if (null? imports) + (bytevector) + (encode-section wasm-section-import + (encode-vec imports encode-wasm-import)))) + + ;;; ========== Function section encoding ========== + + (define (encode-function-section functions) + (if (null? functions) + (bytevector) + (encode-section wasm-section-function + (encode-vec functions + (lambda (f) (encode-u32-leb128 (car f))))))) + + ;;; ========== Memory section encoding ========== + + (define (encode-memory-section memories) + (if (null? memories) + (bytevector) + (encode-section wasm-section-memory + (encode-vec memories + (lambda (m) + (let ([min (car m)] [max (cdr m)]) + (if max + (bv-concat (bytevector #x01) + (encode-u32-leb128 min) + (encode-u32-leb128 max)) + (bv-concat (bytevector #x00) + (encode-u32-leb128 min))))))))) + + ;;; ========== Global section encoding ========== + + (define (encode-global-section globals) + (if (null? globals) + (bytevector) + (encode-section wasm-section-global + (encode-vec globals + (lambda (g) + (let ([type (car g)] [mut? (cadr g)] [init (caddr g)]) + (bv-concat + (bytevector type (if mut? 1 0)) + init + (bytevector wasm-opcode-end)))))))) + + ;;; ========== Export section encoding ========== + + (define (encode-wasm-export exp) + (bv-concat + (encode-string (wasm-export-name exp)) + (bytevector (wasm-export-kind exp)) + (encode-u32-leb128 (wasm-export-index exp)))) + + (define (encode-export-section exports) + (if (null? exports) + (bytevector) + (encode-section wasm-section-export + (encode-vec exports encode-wasm-export)))) + + ;;; ========== Code section encoding ========== + + (define (encode-locals locals) + (if (null? locals) + (encode-u32-leb128 0) + (let loop ([locals locals] [groups '()] [cur-type (car locals)] [count 0]) + (cond + [(null? locals) + (let ([final-groups (reverse (cons (cons count cur-type) groups))]) + (encode-vec final-groups + (lambda (g) + (bv-concat (encode-u32-leb128 (car g)) + (bytevector (cdr g))))))] + [(= (car locals) cur-type) + (loop (cdr locals) groups cur-type (+ count 1))] + [else + (loop (cdr locals) + (cons (cons count cur-type) groups) + (car locals) + 1)])))) + + (define (encode-func-body func) + (let* ([locals-bv (encode-locals (wasm-func-locals func))] + [body-bv (wasm-func-body func)] + [content (bv-concat locals-bv body-bv)] + [size-bv (encode-u32-leb128 (bytevector-length content))]) + (bv-concat size-bv content))) + + (define (encode-code-section functions) + (if (null? functions) + (bytevector) + (encode-section wasm-section-code + (encode-vec functions + (lambda (f) (encode-func-body (cdr f))))))) + + ;;; ========== Module encoding ========== + + (define (wasm-module-encode mod) + (bv-concat + wasm-magic + wasm-version + (encode-type-section (wasm-module-types mod)) + (encode-import-section (wasm-module-imports mod)) + (encode-function-section (wasm-module-functions mod)) + (encode-memory-section (wasm-module-memories mod)) + (encode-global-section (wasm-module-globals mod)) + (encode-export-section (wasm-module-exports mod)) + (encode-code-section (wasm-module-functions mod)))) + + ;;; ========== Type conversion ========== + + (define (scheme->wasm-type sym) + (case sym + [(i32 integer fixnum) wasm-type-i32] + [(i64) wasm-type-i64] + [(f32 float single) wasm-type-f32] + [(f64 double) wasm-type-f64] + [else wasm-type-i32])) + + ;;; ========== Compile context ========== + + (define-record-type compile-context + (fields + (mutable locals) + (mutable local-count) + (mutable funcs)) + (protocol (lambda (new) + (lambda () (new '() 0 '()))))) + + (define (context-add-local! ctx name) + (let ([idx (compile-context-local-count ctx)]) + (compile-context-locals-set! ctx + (cons (cons name idx) (compile-context-locals ctx))) + (compile-context-local-count-set! ctx (+ idx 1)) + idx)) + + (define (context-local-index ctx name) + (let ([entry (assq name (compile-context-locals ctx))]) + (if entry + (cdr entry) + (error 'context-local-index "unbound variable" name)))) + + (define (context-add-func! ctx name) + (let ([idx (length (compile-context-funcs ctx))]) + (compile-context-funcs-set! ctx + (cons (cons name idx) (compile-context-funcs ctx))) + idx)) + + (define (context-func-index ctx name) + (let ([entry (assq name (compile-context-funcs ctx))]) + (if entry + (cdr entry) + (error 'context-func-index "unbound function" name)))) + + ;;; ========== Expression compiler ========== + + ;; Compile a let binding sequence into the given context + (define (compile-let bindings body ctx) + (let* ([names (map car bindings)] + [exprs (map cadr bindings)]) + ;; Evaluate each expr then store in new local + (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 + (bv-concat-list (map (lambda (e) (compile-expr e ctx)) body)))))) + + ;; Binary operation: compile both operands and emit opcode + (define (compile-binop args ctx opcode) + (bv-concat + (compile-expr (car args) ctx) + (compile-expr (cadr args) ctx) + (bytevector opcode))) + + ;; compile-expr: Scheme expression -> bytevector of WASM instructions + (define (compile-expr expr ctx) + (cond + ;; Integer literal -> i32.const + [(integer? expr) + (bv-concat + (bytevector wasm-opcode-i32-const) + (encode-i32-leb128 expr))] + + ;; Symbol -> local.get + [(symbol? expr) + (bv-concat + (bytevector wasm-opcode-local-get) + (encode-u32-leb128 (context-local-index ctx expr)))] + + ;; Compound forms + [(pair? expr) + (let ([head (car expr)] [args (cdr expr)]) + (case head + ;; (begin e1 ... en) + [(begin) + (if (null? args) + (bytevector wasm-opcode-nop) + (bv-concat-list (map (lambda (e) (compile-expr e ctx)) args)))] + + ;; (if test then else) + [(if) + (let ([test (car args)] + [then (cadr args)] + [else-part (if (null? (cddr args)) 0 (caddr args))]) + (bv-concat + (compile-expr test ctx) + (bytevector wasm-opcode-if wasm-type-i32) + (compile-expr then ctx) + (bytevector wasm-opcode-else) + (compile-expr else-part ctx) + (bytevector wasm-opcode-end)))] + + ;; (let ([x e] ...) body) + [(let) + (compile-let (car args) (cdr args) ctx)] + + ;; Arithmetic + [(+) (compile-binop args ctx wasm-opcode-i32-add)] + [(-) (compile-binop args ctx wasm-opcode-i32-sub)] + [(*) (compile-binop args ctx wasm-opcode-i32-mul)] + [(quotient) (compile-binop args ctx wasm-opcode-i32-div-s)] + [(remainder)(compile-binop args ctx wasm-opcode-i32-rem-s)] + + ;; Comparisons + [(=) (compile-binop args ctx wasm-opcode-i32-eq)] + [(<) (compile-binop args ctx wasm-opcode-i32-lt-s)] + [(>) (compile-binop args ctx wasm-opcode-i32-gt-s)] + [(<=) (compile-binop args ctx wasm-opcode-i32-le-s)] + [(>=) (compile-binop args ctx wasm-opcode-i32-ge-s)] + + ;; Function call (symbol in head position) + [else + (if (symbol? head) + (let ([fidx (context-func-index ctx head)]) + (bv-concat + (bv-concat-list (map (lambda (a) (compile-expr a ctx)) args)) + (bytevector wasm-opcode-call) + (encode-u32-leb128 fidx))) + (error 'compile-expr "unknown form" expr))]))] + + [else (error 'compile-expr "unsupported expression" expr)])) + + ;;; ========== Program compiler ========== + + ;; compile-program: list of top-level (define ...) forms -> binary WASM bytevector + ;; All values are i32 (integer-only subset). + (define (compile-program forms) + (let ([mod (make-wasm-module)] + [global-ctx (make-compile-context)]) + + ;; First pass: register all function names (so mutual calls work) + (for-each + (lambda (form) + (when (and (pair? form) (eq? (car form) 'define)) + (let ([sig (cadr form)]) + (when (pair? sig) + (context-add-func! global-ctx (car sig)))))) + forms) + + ;; Second pass: compile each define into a WASM function + (for-each + (lambda (form) + (when (and (pair? form) (eq? (car form) 'define)) + (let* ([sig (cadr form)] + [body-forms (cddr form)]) + (when (pair? sig) + (let* ([name (car sig)] + [params (cdr sig)] + ;; Create per-function context with all function names + [ctx (make-compile-context)] + [_ (compile-context-funcs-set! ctx + (compile-context-funcs global-ctx))] + ;; Add params as locals (indices 0..n-1) + [_ (for-each (lambda (p) (context-add-local! ctx p)) params)] + ;; Compile body (multiple forms -> begin) + [body-bv (if (= (length body-forms) 1) + (compile-expr (car body-forms) ctx) + (bv-concat-list + (map (lambda (e) (compile-expr e ctx)) body-forms)))] + ;; Append end opcode + [full-body (bv-concat body-bv (bytevector wasm-opcode-end))] + ;; Collect let-bound locals (index >= param count) + [all-locals (compile-context-locals ctx)] + [let-locals + (filter (lambda (pair) (>= (cdr pair) (length params))) + all-locals)] + [local-types (map (lambda (_) wasm-type-i32) let-locals)] + [func (make-wasm-func local-types full-body)] + ;; Type signature: all i32 params, i32 result + [param-types (map (lambda (_) wasm-type-i32) params)] + [type-idx (length (wasm-module-types mod))] + [type (make-wasm-type param-types (list wasm-type-i32))]) + + (wasm-module-add-type! mod type) + (wasm-module-add-function! mod type-idx func)))))) + forms) + + ;; Add exports for all registered functions + ;; The global-ctx funcs list is in reverse order of registration + ;; (context-add-func! prepends, so first func is at end of list) + (let ([funcs (reverse (compile-context-funcs global-ctx))]) + (for-each + (lambda (pair) + (wasm-module-add-export! mod + (wasm-export-func (symbol->string (car pair)) (cdr pair)))) + funcs)) + + (wasm-module-encode mod))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/wasm/format.sls @@ -0,0 +1,335 @@ +#!chezscheme +;;; (jerboa wasm format) -- WebAssembly binary format encoding/decoding +;;; +;;; Implements the WebAssembly binary format per the WASM spec: +;;; - LEB128 integer encoding (unsigned and signed) +;;; - IEEE 754 float encoding +;;; - String encoding (LEB128 length + UTF-8) +;;; - Section IDs, type constants, opcode constants +;;; - Bytevector builder for accumulating bytes + +(library (jerboa wasm format) + (export + ;; Module header constants + wasm-magic wasm-version + ;; LEB128 encoding + encode-u32-leb128 decode-u32-leb128 + encode-i32-leb128 encode-i64-leb128 + decode-i32-leb128 + ;; Float encoding + encode-f32 encode-f64 decode-f32 decode-f64 + ;; String encoding + encode-string decode-string + ;; Value types + wasm-type-i32 wasm-type-i64 wasm-type-f32 wasm-type-f64 + wasm-type-funcref wasm-type-externref + ;; Section IDs + wasm-section-custom wasm-section-type wasm-section-import + wasm-section-function wasm-section-table wasm-section-memory + wasm-section-global wasm-section-export wasm-section-start + wasm-section-element wasm-section-code wasm-section-data + ;; Control flow opcodes + wasm-opcode-unreachable wasm-opcode-nop + wasm-opcode-block wasm-opcode-loop wasm-opcode-if wasm-opcode-else wasm-opcode-end + wasm-opcode-br wasm-opcode-br-if + wasm-opcode-return wasm-opcode-call wasm-opcode-call-indirect + wasm-opcode-drop wasm-opcode-select + ;; Variable opcodes + wasm-opcode-local-get wasm-opcode-local-set wasm-opcode-local-tee + wasm-opcode-global-get wasm-opcode-global-set + ;; Memory opcodes + wasm-opcode-i32-load wasm-opcode-i64-load wasm-opcode-f32-load wasm-opcode-f64-load + wasm-opcode-i32-store wasm-opcode-i64-store + wasm-opcode-memory-size wasm-opcode-memory-grow + ;; Numeric const opcodes + wasm-opcode-i32-const wasm-opcode-i64-const + wasm-opcode-f32-const wasm-opcode-f64-const + ;; i32 comparison opcodes + wasm-opcode-i32-eqz wasm-opcode-i32-eq wasm-opcode-i32-ne + wasm-opcode-i32-lt-s wasm-opcode-i32-lt-u + wasm-opcode-i32-gt-s wasm-opcode-i32-gt-u + wasm-opcode-i32-le-s wasm-opcode-i32-ge-s + ;; i32 arithmetic opcodes + wasm-opcode-i32-add wasm-opcode-i32-sub wasm-opcode-i32-mul + wasm-opcode-i32-div-s wasm-opcode-i32-rem-s + wasm-opcode-i32-and wasm-opcode-i32-or wasm-opcode-i32-xor + wasm-opcode-i32-shl wasm-opcode-i32-shr-s + ;; i64 arithmetic opcodes + wasm-opcode-i64-add wasm-opcode-i64-sub wasm-opcode-i64-mul wasm-opcode-i64-div-s + ;; f32 arithmetic opcodes + wasm-opcode-f32-add wasm-opcode-f32-sub wasm-opcode-f32-mul wasm-opcode-f32-div + ;; f64 arithmetic opcodes + wasm-opcode-f64-add wasm-opcode-f64-sub wasm-opcode-f64-mul wasm-opcode-f64-div + ;; Bytevector builder + make-bytevector-builder + bytevector-builder-append-u8! + bytevector-builder-append-bv! + bytevector-builder-build + bytevector-builder-length) + + (import (chezscheme)) + + ;;; ========== Module header constants ========== + + ;; WASM magic: "\0asm" as bytes + (define wasm-magic (bytevector #x00 #x61 #x73 #x6D)) + ;; WASM version 1 + (define wasm-version (bytevector #x01 #x00 #x00 #x00)) + + ;;; ========== Value types ========== + + (define wasm-type-i32 #x7F) + (define wasm-type-i64 #x7E) + (define wasm-type-f32 #x7D) + (define wasm-type-f64 #x7C) + (define wasm-type-funcref #x70) + (define wasm-type-externref #x6F) + + ;;; ========== Section IDs ========== + + (define wasm-section-custom 0) + (define wasm-section-type 1) + (define wasm-section-import 2) + (define wasm-section-function 3) + (define wasm-section-table 4) + (define wasm-section-memory 5) + (define wasm-section-global 6) + (define wasm-section-export 7) + (define wasm-section-start 8) + (define wasm-section-element 9) + (define wasm-section-code 10) + (define wasm-section-data 11) + + ;;; ========== Opcodes ========== + + ;; Control flow + (define wasm-opcode-unreachable #x00) + (define wasm-opcode-nop #x01) + (define wasm-opcode-block #x02) + (define wasm-opcode-loop #x03) + (define wasm-opcode-if #x04) + (define wasm-opcode-else #x05) + (define wasm-opcode-end #x0B) + (define wasm-opcode-br #x0C) + (define wasm-opcode-br-if #x0D) + (define wasm-opcode-return #x0F) + (define wasm-opcode-call #x10) + (define wasm-opcode-call-indirect #x11) + (define wasm-opcode-drop #x1A) + (define wasm-opcode-select #x1B) + + ;; Variable access + (define wasm-opcode-local-get #x20) + (define wasm-opcode-local-set #x21) + (define wasm-opcode-local-tee #x22) + (define wasm-opcode-global-get #x23) + (define wasm-opcode-global-set #x24) + + ;; Memory + (define wasm-opcode-i32-load #x28) + (define wasm-opcode-i64-load #x29) + (define wasm-opcode-f32-load #x2A) + (define wasm-opcode-f64-load #x2B) + (define wasm-opcode-i32-store #x36) + (define wasm-opcode-i64-store #x37) + (define wasm-opcode-memory-size #x3F) + (define wasm-opcode-memory-grow #x40) + + ;; Constants + (define wasm-opcode-i32-const #x41) + (define wasm-opcode-i64-const #x42) + (define wasm-opcode-f32-const #x43) + (define wasm-opcode-f64-const #x44) + + ;; i32 comparisons + (define wasm-opcode-i32-eqz #x45) + (define wasm-opcode-i32-eq #x46) + (define wasm-opcode-i32-ne #x47) + (define wasm-opcode-i32-lt-s #x48) + (define wasm-opcode-i32-lt-u #x49) + (define wasm-opcode-i32-gt-s #x4A) + (define wasm-opcode-i32-gt-u #x4B) + (define wasm-opcode-i32-le-s #x4C) + (define wasm-opcode-i32-ge-s #x4E) + + ;; i32 arithmetic + (define wasm-opcode-i32-add #x6A) + (define wasm-opcode-i32-sub #x6B) + (define wasm-opcode-i32-mul #x6C) + (define wasm-opcode-i32-div-s #x6D) + (define wasm-opcode-i32-rem-s #x6F) + (define wasm-opcode-i32-and #x71) + (define wasm-opcode-i32-or #x72) + (define wasm-opcode-i32-xor #x73) + (define wasm-opcode-i32-shl #x74) + (define wasm-opcode-i32-shr-s #x75) + + ;; i64 arithmetic + (define wasm-opcode-i64-add #x7C) + (define wasm-opcode-i64-sub #x7D) + (define wasm-opcode-i64-mul #x7E) + (define wasm-opcode-i64-div-s #x7F) + + ;; f32 arithmetic + (define wasm-opcode-f32-add #x92) + (define wasm-opcode-f32-sub #x93) + (define wasm-opcode-f32-mul #x94) + (define wasm-opcode-f32-div #x95) + + ;; f64 arithmetic + (define wasm-opcode-f64-add #xA0) + (define wasm-opcode-f64-sub #xA1) + (define wasm-opcode-f64-mul #xA2) + (define wasm-opcode-f64-div #xA3) + + ;;; ========== Bytevector builder ========== + + ;; A simple accumulator: list of bytevectors in reverse order + total length + (define-record-type bytevector-builder + (fields (mutable chunks) (mutable total-length)) + (protocol (lambda (new) (lambda () (new '() 0))))) + + (define (bytevector-builder-append-u8! builder byte) + (let ([bv (make-bytevector 1 byte)]) + (bytevector-builder-chunks-set! builder + (cons bv (bytevector-builder-chunks builder))) + (bytevector-builder-total-length-set! builder + (+ (bytevector-builder-total-length builder) 1)))) + + (define (bytevector-builder-append-bv! builder bv) + (let ([len (bytevector-length bv)]) + (when (> len 0) + (bytevector-builder-chunks-set! builder + (cons bv (bytevector-builder-chunks builder))) + (bytevector-builder-total-length-set! builder + (+ (bytevector-builder-total-length builder) len))))) + + (define (bytevector-builder-length builder) + (bytevector-builder-total-length builder)) + + (define (bytevector-builder-build builder) + (let* ([total (bytevector-builder-total-length builder)] + [result (make-bytevector total)] + [chunks (reverse (bytevector-builder-chunks builder))]) + (let loop ([chunks chunks] [offset 0]) + (if (null? chunks) + result + (let* ([chunk (car chunks)] + [len (bytevector-length chunk)]) + ;; bytevector-copy! in Chez: src src-start dst dst-start count + (bytevector-copy! chunk 0 result offset len) + (loop (cdr chunks) (+ offset len))))))) + + ;;; ========== LEB128 encoding ========== + + ;; Unsigned LEB128: encode non-negative integer + (define (encode-u32-leb128 n) + (let ([builder (make-bytevector-builder)]) + (let loop ([n n]) + (let ([byte (bitwise-and n #x7F)] + [rest (bitwise-arithmetic-shift-right n 7)]) + (if (= rest 0) + (begin + (bytevector-builder-append-u8! builder byte) + (bytevector-builder-build builder)) + (begin + (bytevector-builder-append-u8! builder (bitwise-ior byte #x80)) + (loop rest))))))) + + ;; Decode unsigned LEB128 from bytevector at offset + ;; Returns (value . bytes-consumed) + (define (decode-u32-leb128 bv offset) + (let loop ([result 0] [shift 0] [pos offset]) + (let ([byte (bytevector-u8-ref bv pos)]) + (let ([val (bitwise-ior result + (bitwise-arithmetic-shift-left + (bitwise-and byte #x7F) + shift))]) + (if (= (bitwise-and byte #x80) 0) + (cons val (- (+ pos 1) offset)) + (loop val (+ shift 7) (+ pos 1))))))) + + ;; Signed LEB128 for i32 + (define (encode-i32-leb128 n) + (let ([builder (make-bytevector-builder)]) + (let loop ([n n] [more #t]) + (when more + (let* ([byte (bitwise-and n #x7F)] + [n-shifted (bitwise-arithmetic-shift n -7)] + [done? (or (and (= n-shifted 0) (= (bitwise-and byte #x40) 0)) + (and (= n-shifted -1) (not (= (bitwise-and byte #x40) 0))))]) + (bytevector-builder-append-u8! builder + (if done? byte (bitwise-ior byte #x80))) + (loop n-shifted (not done?))))) + (bytevector-builder-build builder))) + + ;; Signed LEB128 for i64 (same algorithm) + (define (encode-i64-leb128 n) + (encode-i32-leb128 n)) + + ;; Decode signed LEB128 from bytevector at offset + ;; Returns (value . bytes-consumed) + (define (decode-i32-leb128 bv offset) + (let loop ([result 0] [shift 0] [pos offset]) + (let ([byte (bytevector-u8-ref bv pos)]) + (let ([val (bitwise-ior result + (bitwise-arithmetic-shift-left + (bitwise-and byte #x7F) + shift))]) + (if (= (bitwise-and byte #x80) 0) + ;; Sign extend if high bit of last group is set + (let ([final-val + (if (and (< shift 32) + (not (= (bitwise-and byte #x40) 0))) + (bitwise-ior val + (bitwise-arithmetic-shift-left -1 (+ shift 7))) + val)]) + (cons final-val (- (+ pos 1) offset))) + (loop val (+ shift 7) (+ pos 1))))))) + + ;;; ========== Float encoding ========== + + ;; Encode f32 as 4 bytes little-endian IEEE 754 + (define (encode-f32 val) + (let ([bv (make-bytevector 4)]) + (bytevector-ieee-single-set! bv 0 val 'little) + bv)) + + ;; Decode f32 from 4 bytes little-endian IEEE 754 + (define (decode-f32 bv offset) + (bytevector-ieee-single-ref bv offset 'little)) + + ;; Encode f64 as 8 bytes little-endian IEEE 754 + (define (encode-f64 val) + (let ([bv (make-bytevector 8)]) + (bytevector-ieee-double-set! bv 0 val 'little) + bv)) + + ;; Decode f64 from 8 bytes little-endian IEEE 754 + (define (decode-f64 bv offset) + (bytevector-ieee-double-ref bv offset 'little)) + + ;;; ========== String encoding ========== + + ;; Encode string: LEB128 length (in bytes) + UTF-8 bytes + (define (encode-string s) + (let* ([utf8 (string->utf8 s)] + [len (bytevector-length utf8)] + [len-bv (encode-u32-leb128 len)] + [result (make-bytevector (+ (bytevector-length len-bv) len))]) + (bytevector-copy! len-bv 0 result 0 (bytevector-length len-bv)) + (bytevector-copy! utf8 0 result (bytevector-length len-bv) len) + result)) + + ;; Decode string from bytevector at offset + ;; Returns (string . bytes-consumed) + (define (decode-string bv offset) + (let* ([len-result (decode-u32-leb128 bv offset)] + [str-len (car len-result)] + [len-bytes (cdr len-result)] + [str-start (+ offset len-bytes)] + [utf8 (make-bytevector str-len)]) + (bytevector-copy! bv str-start utf8 0 str-len) + (cons (utf8->string utf8) (+ len-bytes str-len)))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/wasm/runtime.sls @@ -0,0 +1,560 @@ +#!chezscheme +;;; (jerboa wasm runtime) -- WebAssembly interpreter/runtime +;;; +;;; A stack-based interpreter that executes WASM bytecode. +;;; Supports i32 arithmetic, comparisons, locals, if/else, function calls. +;;; Not a JIT -- pure interpreter for testing codegen correctness. + +(library (jerboa wasm runtime) + (export + make-wasm-runtime wasm-runtime? wasm-runtime-load wasm-runtime-call + wasm-runtime-memory-ref wasm-runtime-memory-set! + wasm-runtime-global-ref wasm-runtime-global-set! + make-wasm-trap wasm-trap? wasm-trap-message + wasm-instance? wasm-instance-exports + wasm-decode-module wasm-module-sections wasm-run-start + make-wasm-store wasm-store? wasm-store-instantiate) + + (import (chezscheme) + (jerboa wasm format)) + + ;;; ========== Trap ========== + + (define-record-type wasm-trap + (fields message)) + + ;;; ========== Decoded module ========== + + (define-record-type decoded-module + (fields sections)) + + (define (wasm-module-sections mod) + (decoded-module-sections mod)) + + ;;; ========== WASM instance ========== + + (define-record-type wasm-instance + (fields + exports + funcs + memory + globals)) + + ;;; ========== WASM store ========== + + (define-record-type wasm-store + (fields (mutable instances)) + (protocol (lambda (new) (lambda () (new '()))))) + + ;;; ========== WASM runtime ========== + + (define-record-type wasm-runtime + (fields (mutable instance)) + (protocol (lambda (new) (lambda () (new #f))))) + + ;;; ========== Binary section parsing helpers ========== + + (define (read-u32 bv pos) + (let* ([r (decode-u32-leb128 bv pos)]) + (cons (car r) (+ pos (cdr r))))) + + (define (read-i32 bv pos) + (let* ([r (decode-i32-leb128 bv pos)]) + (cons (car r) (+ pos (cdr r))))) + + (define (read-string bv pos) + (let* ([r (decode-string bv pos)]) + (cons (car r) (+ pos (cdr r))))) + + ;;; ========== Binary WASM decoder ========== + + (define (wasm-decode-module bv) + (let ([len (bytevector-length bv)]) + (unless (and (>= len 8) + (= (bytevector-u8-ref bv 0) #x00) + (= (bytevector-u8-ref bv 1) #x61) + (= (bytevector-u8-ref bv 2) #x73) + (= (bytevector-u8-ref bv 3) #x6D)) + (error 'wasm-decode-module "invalid WASM magic")) + (let loop ([pos 8] [sections '()]) + (if (>= pos len) + (make-decoded-module (reverse sections)) + (let* ([sid (bytevector-u8-ref bv pos)] + [pos1 (+ pos 1)] + [sz-result (read-u32 bv pos1)] + [sz (car sz-result)] + [cstart (cdr sz-result)] + [cend (+ cstart sz)] + [content (make-bytevector sz)]) + (bytevector-copy! bv cstart content 0 sz) + (loop cend (cons (cons sid content) sections))))))) + + ;;; ========== Section parsers ========== + + (define (parse-type-section bv) + (let* ([cr (read-u32 bv 0)] + [count (car cr)] + [pos (cdr cr)]) + (let loop ([i 0] [pos pos] [acc '()]) + (if (= i count) + (reverse acc) + (let* ([pos1 (+ pos 1)] ; skip 0x60 + [pcr (read-u32 bv pos1)] + [pcount (car pcr)] + [pos2 (cdr pcr)] + [params+pos + (let lp ([j 0] [p pos2] [a '()]) + (if (= j pcount) + (cons (reverse a) p) + (lp (+ j 1) (+ p 1) (cons (bytevector-u8-ref bv p) a))))] + [params (car params+pos)] + [pos3 (cdr params+pos)] + [rcr (read-u32 bv pos3)] + [rcount (car rcr)] + [pos4 (cdr rcr)] + [results+pos + (let lp ([j 0] [p pos4] [a '()]) + (if (= j rcount) + (cons (reverse a) p) + (lp (+ j 1) (+ p 1) (cons (bytevector-u8-ref bv p) a))))] + [results (car results+pos)] + [pos5 (cdr results+pos)]) + (loop (+ i 1) pos5 (cons (cons params results) acc))))))) + + (define (parse-function-section bv) + (let* ([cr (read-u32 bv 0)] + [count (car cr)] + [pos (cdr cr)]) + (let loop ([i 0] [pos pos] [acc '()]) + (if (= i count) + (reverse acc) + (let* ([r (read-u32 bv pos)]) + (loop (+ i 1) (cdr r) (cons (car r) acc))))))) + + (define (parse-export-section bv) + (let* ([cr (read-u32 bv 0)] + [count (car cr)] + [pos (cdr cr)]) + (let loop ([i 0] [pos pos] [acc '()]) + (if (= i count) + (reverse acc) + (let* ([nr (read-string bv pos)] + [name (car nr)] + [pos1 (cdr nr)] + [kind (bytevector-u8-ref bv pos1)] + [pos2 (+ pos1 1)] + [ir (read-u32 bv pos2)] + [idx (car ir)] + [pos3 (cdr ir)]) + (loop (+ i 1) pos3 (cons (list name kind idx) acc))))))) + + (define (parse-code-section bv) + (let* ([cr (read-u32 bv 0)] + [count (car cr)] + [pos (cdr cr)]) + (let loop ([i 0] [pos pos] [acc '()]) + (if (= i count) + (reverse acc) + (let* ([sr (read-u32 bv pos)] + [sz (car sr)] + [body-start (cdr sr)] + [body-end (+ body-start sz)] + [lcr (read-u32 bv body-start)] + [lcount (car lcr)] + [lpos (cdr lcr)] + [locals+pos + (let lp ([j 0] [p lpos] [a '()]) + (if (= j lcount) + (cons (reverse a) p) + (let* ([nr (read-u32 bv p)] + [n (car nr)] + [p1 (cdr nr)] + [t (bytevector-u8-ref bv p1)] + [p2 (+ p1 1)]) + (lp (+ j 1) p2 + (append a (make-list n t))))))] + [local-types (car locals+pos)] + [code-start (cdr locals+pos)]