Post-MVP WASM: saturating conversions, bulk memory, ref types, tables, tail calls, exceptions, GC
ober
4c2b7783a70b094b5b6fd2bcad4455fa03207034
--- a/lib/jerboa/wasm/codegen.sls +++ b/lib/jerboa/wasm/codegen.sls @@ -49,6 +49,39 @@ ;;; (drop expr) -> evaluate and discard ;;; (call name args...) -> direct call by name ;;; (call-indirect ti args) -> indirect call via table +;;; +;;; Post-MVP: +;;; (i32.trunc_sat_f32_s v) -> saturating float-to-int (8 variants) +;;; (memory.fill d v n) -> fill memory range +;;; (memory.copy d s n) -> copy memory range +;;; (memory.init seg d s n) -> init from data segment +;;; (data.drop seg) -> drop data segment +;;; (table.get ti idx) -> get table element +;;; (table.set ti idx val) -> set table element +;;; (table.size ti) -> table size +;;; (table.grow ti init n) -> grow table +;;; (table.fill ti i v n) -> fill table range +;;; (ref.null type) -> push null reference +;;; (ref.is_null expr) -> test for null +;;; (ref.func idx) -> push function reference +;;; (return-call f args...) -> tail call +;;; (throw tag args...) -> throw exception +;;; (struct.new ti flds...) -> create GC struct +;;; (struct.get ti fi ref) -> read struct field +;;; (struct.set ti fi r v) -> write struct field +;;; (array.new ti init n) -> create GC array +;;; (array.new_fixed ti ..) -> fixed-size array +;;; (array.get ti arr idx) -> read array element +;;; (array.set ti a i v) -> write array element +;;; (array.len arr) -> array length +;;; (ref.i31 v) -> wrap to i31ref +;;; (i31.get_s v) -> unwrap i31 signed +;;; (i31.get_u v) -> unwrap i31 unsigned +;;; (ref.test ti expr) -> type test +;;; (ref.cast ti expr) -> type cast +;;; +;;; Module declarations: +;;; (define-tag type-idx) -> exception tag (library (jerboa wasm codegen) (export @@ -63,6 +96,7 @@ wasm-module-add-memory! wasm-module-add-global! wasm-module-add-table! wasm-module-add-data! wasm-module-add-element! wasm-module-set-start! + wasm-module-add-tag! wasm-module-tags ;; WASM function make-wasm-func wasm-func? wasm-func-locals wasm-func-body ;; WASM type (function signature) @@ -129,9 +163,10 @@ (mutable tables) ; list of (type min . max-or-#f) (mutable data-segments) ; list of (mem-idx offset-expr bytes) (mutable elements) ; list of (table-idx offset-expr func-indices) - (mutable start)) ; #f or function index + (mutable start) ; #f or function index + (mutable tags)) ; list of type-idx (exception tag types) (protocol (lambda (new) - (lambda () (new '() '() '() '() '() '() '() '() '() #f))))) + (lambda () (new '() '() '() '() '() '() '() '() '() #f '()))))) (define (wasm-module-add-type! mod type) (wasm-module-types-set! mod (append (wasm-module-types mod) (list type)))) @@ -170,6 +205,9 @@ (define (wasm-module-set-start! mod func-idx) (wasm-module-start-set! mod func-idx)) + (define (wasm-module-add-tag! mod type-idx) + (wasm-module-tags-set! mod (append (wasm-module-tags mod) (list type-idx)))) + ;;; ========== Binary encoding helpers ========== (define (bv-concat . bvs) @@ -341,6 +379,22 @@ ;;; ========== Module encoding ========== + ;; Encode tag section (section 13) for exception handling + (define (encode-tag-section tags) + (if (null? tags) + (bytevector) + (let ([content + (bv-concat + (encode-u32-leb128 (length tags)) + (bv-concat-list + (map (lambda (tidx) + (bv-concat (bytevector #x00) ; attribute: exception + (encode-u32-leb128 tidx))) + tags)))]) + (bv-concat (bytevector wasm-section-tag) + (encode-u32-leb128 (bytevector-length content)) + content)))) + (define (wasm-module-encode mod) (bv-concat wasm-magic @@ -355,7 +409,8 @@ (encode-start-section (wasm-module-start mod)) (encode-element-section (wasm-module-elements mod)) (encode-code-section (wasm-module-functions mod)) - (encode-data-section (wasm-module-data-segments mod)))) + (encode-data-section (wasm-module-data-segments mod)) + (encode-tag-section (wasm-module-tags mod)))) ;;; ========== Type conversion ========== @@ -442,14 +497,21 @@ (and (pair? expr) (or (memq (car expr) '(set! while when unless i32.store i64.store f32.store f64.store - i32.store8 i32.store16 global.set drop)) + i32.store8 i32.store16 global.set drop + memory.fill memory.copy memory.init data.drop + table.set table.fill struct.set array.set throw)) ;; let/let*/begin whose last body expr is void (and (memq (car expr) '(let let* begin)) (let ([body (case (car expr) [(begin) (cdr expr)] [(let let*) (cddr expr)])]) (and (pair? body) - (void-expr? (car (last-pair body))))))))) + (void-expr? (car (last-pair body)))))) + ;; if/else where both branches are void + (and (eq? (car expr) 'if) + (>= (length (cdr expr)) 3) + (void-expr? (caddr expr)) + (void-expr? (cadddr expr)))))) ;; Compile a body (list of expressions, result is last) (define (compile-body exprs ctx) @@ -551,13 +613,17 @@ [then (cadr args)] [else-part (if (null? (cddr args)) #f (caddr args))]) (if else-part - (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)) + ;; if/else: void when both branches are void, i32 otherwise + (let ([block-type (if (and (void-expr? then) (void-expr? else-part)) + wasm-type-void + wasm-type-i32)]) + (bv-concat + (compile-expr test ctx) + (bytevector wasm-opcode-if block-type) + (compile-expr then ctx) + (bytevector wasm-opcode-else) + (compile-expr else-part ctx) + (bytevector wasm-opcode-end))) ;; No else: void block type (bv-concat (compile-expr test ctx) @@ -906,6 +972,205 @@ (bv-concat (compile-expr (car args) ctx) (bytevector wasm-opcode-drop))] + ;; =============== POST-MVP EXPRESSION FORMS =============== + + ;; -- Saturating float-to-int conversions -- + ;; (i32.trunc_sat_f32_s expr) etc. + [(i32.trunc_sat_f32_s) + (bv-concat (compile-expr (car args) ctx) (bytevector wasm-prefix-fc) (encode-u32-leb128 0))] + [(i32.trunc_sat_f32_u) + (bv-concat (compile-expr (car args) ctx) (bytevector wasm-prefix-fc) (encode-u32-leb128 1))] + [(i32.trunc_sat_f64_s) + (bv-concat (compile-expr (car args) ctx) (bytevector wasm-prefix-fc) (encode-u32-leb128 2))] + [(i32.trunc_sat_f64_u) + (bv-concat (compile-expr (car args) ctx) (bytevector wasm-prefix-fc) (encode-u32-leb128 3))] + [(i64.trunc_sat_f32_s) + (bv-concat (compile-expr (car args) ctx) (bytevector wasm-prefix-fc) (encode-u32-leb128 4))] + [(i64.trunc_sat_f32_u) + (bv-concat (compile-expr (car args) ctx) (bytevector wasm-prefix-fc) (encode-u32-leb128 5))] + [(i64.trunc_sat_f64_s) + (bv-concat (compile-expr (car args) ctx) (bytevector wasm-prefix-fc) (encode-u32-leb128 6))] + [(i64.trunc_sat_f64_u) + (bv-concat (compile-expr (car args) ctx) (bytevector wasm-prefix-fc) (encode-u32-leb128 7))] + + ;; -- Bulk memory operations -- + ;; (memory.fill dest val count) + [(memory.fill) + (bv-concat (compile-expr (car args) ctx) + (compile-expr (cadr args) ctx) + (compile-expr (caddr args) ctx) + (bytevector wasm-prefix-fc) (encode-u32-leb128 11) + (bytevector #x00))] ; reserved byte + ;; (memory.copy dest src count) + [(memory.copy) + (bv-concat (compile-expr (car args) ctx) + (compile-expr (cadr args) ctx) + (compile-expr (caddr args) ctx) + (bytevector wasm-prefix-fc) (encode-u32-leb128 10) + (bytevector #x00 #x00))] ; 2 reserved bytes + ;; (memory.init seg-idx dest src count) + [(memory.init) + (bv-concat (compile-expr (cadr args) ctx) ; dest + (compile-expr (caddr args) ctx) ; src + (compile-expr (cadddr args) ctx) ; count + (bytevector wasm-prefix-fc) (encode-u32-leb128 8) + (encode-u32-leb128 (car args)) ; seg-idx + (bytevector #x00))] ; reserved + ;; (data.drop seg-idx) + [(data.drop) + (bv-concat (bytevector wasm-prefix-fc) (encode-u32-leb128 9) + (encode-u32-leb128 (car args)))] + + ;; -- Table operations -- + ;; (table.get table-idx idx-expr) + [(table.get) + (bv-concat (compile-expr (cadr args) ctx) + (bytevector wasm-opcode-table-get) (encode-u32-leb128 (car args)))] + ;; (table.set table-idx idx-expr val-expr) + [(table.set) + (bv-concat (compile-expr (cadr args) ctx) + (compile-expr (caddr args) ctx) + (bytevector wasm-opcode-table-set) (encode-u32-leb128 (car args)))] + ;; (table.size table-idx) + [(table.size) + (bv-concat (bytevector wasm-prefix-fc) (encode-u32-leb128 16) + (encode-u32-leb128 (car args)))] + ;; (table.grow table-idx init-expr count-expr) + [(table.grow) + (bv-concat (compile-expr (cadr args) ctx) + (compile-expr (caddr args) ctx) + (bytevector wasm-prefix-fc) (encode-u32-leb128 15) + (encode-u32-leb128 (car args)))] + ;; (table.fill table-idx start-expr val-expr count-expr) + [(table.fill) + (bv-concat (compile-expr (cadr args) ctx) + (compile-expr (caddr args) ctx) + (compile-expr (cadddr args) ctx) + (bytevector wasm-prefix-fc) (encode-u32-leb128 17) + (encode-u32-leb128 (car args)))] + + ;; -- Reference types -- + ;; (ref.null type) -- type is a numeric type code + [(ref.null) + (bv-concat (bytevector wasm-opcode-ref-null) (encode-u32-leb128 (car args)))] + ;; (ref.is_null expr) + [(ref.is_null) + (bv-concat (compile-expr (car args) ctx) (bytevector wasm-opcode-ref-is-null))] + ;; (ref.func func-idx) + [(ref.func) + (bv-concat (bytevector wasm-opcode-ref-func) (encode-u32-leb128 (car args)))] + + ;; -- Tail calls -- + ;; (return-call name args...) + [(return-call) + (let ([fidx (context-func-index ctx (car args))]) + (bv-concat + (bv-concat-list (map (lambda (a) (compile-expr a ctx)) (cdr args))) + (bytevector wasm-opcode-return-call) + (encode-u32-leb128 fidx)))] + ;; (return-call-indirect type-idx args... table-idx-expr) + [(return-call-indirect) + (let ([type-idx (car args)] + [call-args (cdr args)]) + (bv-concat + (bv-concat-list (map (lambda (a) (compile-expr a ctx)) call-args)) + (bytevector wasm-opcode-return-call-indirect) + (encode-u32-leb128 type-idx) + (encode-u32-leb128 0)))] ; table 0 + + ;; -- Exception handling -- + ;; (throw tag-idx args...) + [(throw) + (bv-concat + (bv-concat-list (map (lambda (a) (compile-expr a ctx)) (cdr args))) + (bytevector wasm-opcode-throw) (encode-u32-leb128 (car args)))] + + ;; -- GC: struct operations -- + ;; (struct.new type-idx field-exprs...) + [(struct.new) + (bv-concat + (bv-concat-list (map (lambda (a) (compile-expr a ctx)) (cdr args))) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-struct-new) + (encode-u32-leb128 (car args)))] + ;; (struct.new_default type-idx) + [(struct.new_default) + (bv-concat (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-struct-new-default) + (encode-u32-leb128 (car args)))] + ;; (struct.get type-idx field-idx ref-expr) + [(struct.get) + (bv-concat (compile-expr (caddr args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-struct-get) + (encode-u32-leb128 (car args)) (encode-u32-leb128 (cadr args)))] + ;; (struct.set type-idx field-idx ref-expr val-expr) + [(struct.set) + (bv-concat (compile-expr (caddr args) ctx) + (compile-expr (cadddr args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-struct-set) + (encode-u32-leb128 (car args)) (encode-u32-leb128 (cadr args)))] + + ;; -- GC: array operations -- + ;; (array.new type-idx init-expr count-expr) + [(array.new) + (bv-concat (compile-expr (cadr args) ctx) + (compile-expr (caddr args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-array-new) + (encode-u32-leb128 (car args)))] + ;; (array.new_default type-idx count-expr) + [(array.new_default) + (bv-concat (compile-expr (cadr args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-array-new-default) + (encode-u32-leb128 (car args)))] + ;; (array.new_fixed type-idx elem-exprs...) + [(array.new_fixed) + (let ([elems (cdr args)]) + (bv-concat + (bv-concat-list (map (lambda (a) (compile-expr a ctx)) elems)) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-array-new-fixed) + (encode-u32-leb128 (car args)) (encode-u32-leb128 (length elems))))] + ;; (array.get type-idx arr-expr idx-expr) + [(array.get) + (bv-concat (compile-expr (cadr args) ctx) + (compile-expr (caddr args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-array-get) + (encode-u32-leb128 (car args)))] + ;; (array.set type-idx arr-expr idx-expr val-expr) + [(array.set) + (bv-concat (compile-expr (cadr args) ctx) + (compile-expr (caddr args) ctx) + (compile-expr (cadddr args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-array-set) + (encode-u32-leb128 (car args)))] + ;; (array.len arr-expr) + [(array.len) + (bv-concat (compile-expr (car args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-array-len))] + + ;; -- GC: i31 operations -- + ;; (ref.i31 expr) + [(ref.i31) + (bv-concat (compile-expr (car args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-ref-i31))] + ;; (i31.get_s expr) + [(i31.get_s) + (bv-concat (compile-expr (car args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-i31-get-s))] + ;; (i31.get_u expr) + [(i31.get_u) + (bv-concat (compile-expr (car args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-i31-get-u))] + + ;; -- GC: ref.test / ref.cast -- + ;; (ref.test type-idx expr) + [(ref.test) + (bv-concat (compile-expr (cadr args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-ref-test) + (encode-u32-leb128 (car args)))] + ;; (ref.cast type-idx expr) + [(ref.cast) + (bv-concat (compile-expr (cadr args) ctx) + (bytevector wasm-prefix-fb) (encode-u32-leb128 wasm-fb-ref-cast) + (encode-u32-leb128 (car args)))] + ;; -- Indirect call -- [(call-indirect) ;; (call-indirect type-idx arg1 ... argn table-idx-expr) @@ -1015,6 +1280,9 @@ (encode-f64 (exact->inexact init-val)))] [else (error 'compile-program "unsupported global type" gtype)])]) (wasm-module-add-global! mod gtype mut? init-bv))] + [(define-tag) + ;; (define-tag type-idx) + (wasm-module-add-tag! mod (cadr form))] [else (void)]))) forms) @@ -1026,14 +1294,20 @@ (when (pair? sig) (let* ([name (car sig)] [raw-params (cdr sig)] - ;; Filter out -> return type annotation + [body-forms (cddr form)] + ;; Filter out -> return type annotation from params [params (let loop ([ps raw-params]) (cond [(null? ps) '()] [(eq? (car ps) '->) '()] [else (cons (parse-param (car ps)) (loop (cdr ps)))]))] + ;; Check both param list and body forms for -> rtype [rtype (let loop ([ps raw-params]) - (cond [(null? ps) wasm-type-i32] + (cond [(null? ps) + ;; Not in params — check body forms + (if (and (pair? body-forms) (eq? (car body-forms) '->)) + (scheme->wasm-type (cadr body-forms)) + wasm-type-i32)] [(eq? (car ps) '->) (scheme->wasm-type (cadr ps))] [else (loop (cdr ps))]))]) (context-add-func! global-ctx name) @@ -1048,7 +1322,11 @@ (lambda (form) (when (and (pair? form) (eq? (car form) 'define)) (let* ([sig (cadr form)] - [body-forms (cddr form)]) + [raw-body (cddr form)] + ;; Strip -> return type annotation from body forms + [body-forms (if (and (pair? raw-body) (eq? (car raw-body) '->)) + (cddr raw-body) ; skip -> and type + raw-body)]) (when (pair? sig) (let* ([name (car sig)] [sig-entry (let loop ([ns func-names] [ss func-sigs]) --- a/lib/jerboa/wasm/format.sls +++ b/lib/jerboa/wasm/format.sls @@ -142,6 +142,64 @@ wasm-opcode-i32-extend8-s wasm-opcode-i32-extend16-s wasm-opcode-i64-extend8-s wasm-opcode-i64-extend16-s wasm-opcode-i64-extend32-s + ;; ---- Post-MVP: GC value types ---- + wasm-type-anyref wasm-type-eqref wasm-type-i31ref + wasm-type-structref wasm-type-arrayref + wasm-type-nullref wasm-type-nullfuncref wasm-type-nullexternref + wasm-type-noneref + + ;; ---- Post-MVP: Composite type tags ---- + wasm-composite-func wasm-composite-struct wasm-composite-array + wasm-type-rec wasm-type-sub wasm-type-sub-final + + ;; ---- Post-MVP: Tag section ---- + wasm-section-tag + + ;; ---- Post-MVP: Prefix bytes ---- + wasm-prefix-fc wasm-prefix-fb + + ;; ---- Post-MVP: Tail call opcodes ---- + wasm-opcode-return-call wasm-opcode-return-call-indirect + + ;; ---- Post-MVP: Exception handling opcodes ---- + wasm-opcode-try wasm-opcode-catch wasm-opcode-throw + wasm-opcode-rethrow wasm-opcode-delegate wasm-opcode-catch-all + + ;; ---- Post-MVP: Typed select ---- + wasm-opcode-select-t + + ;; ---- Post-MVP: Reference opcodes ---- + wasm-opcode-ref-null wasm-opcode-ref-is-null wasm-opcode-ref-func + + ;; ---- Post-MVP: Table opcodes ---- + wasm-opcode-table-get wasm-opcode-table-set + + ;; ---- Post-MVP: 0xFC sub-opcodes ---- + wasm-fc-i32-trunc-sat-f32-s wasm-fc-i32-trunc-sat-f32-u + wasm-fc-i32-trunc-sat-f64-s wasm-fc-i32-trunc-sat-f64-u + wasm-fc-i64-trunc-sat-f32-s wasm-fc-i64-trunc-sat-f32-u + wasm-fc-i64-trunc-sat-f64-s wasm-fc-i64-trunc-sat-f64-u + wasm-fc-memory-init wasm-fc-data-drop + wasm-fc-memory-copy wasm-fc-memory-fill + wasm-fc-table-init wasm-fc-elem-drop wasm-fc-table-copy + wasm-fc-table-grow wasm-fc-table-size wasm-fc-table-fill + + ;; ---- Post-MVP: 0xFB sub-opcodes (GC proposal) ---- + wasm-fb-struct-new wasm-fb-struct-new-default + wasm-fb-struct-get wasm-fb-struct-get-s wasm-fb-struct-get-u + wasm-fb-struct-set + wasm-fb-array-new wasm-fb-array-new-default + wasm-fb-array-new-fixed wasm-fb-array-new-data wasm-fb-array-new-elem + wasm-fb-array-get wasm-fb-array-get-s wasm-fb-array-get-u + wasm-fb-array-set wasm-fb-array-len + wasm-fb-array-fill wasm-fb-array-copy + wasm-fb-array-init-data wasm-fb-array-init-elem + wasm-fb-ref-test wasm-fb-ref-test-null + wasm-fb-ref-cast wasm-fb-ref-cast-null + wasm-fb-br-on-cast wasm-fb-br-on-cast-fail + wasm-fb-extern-internalize wasm-fb-extern-externalize + wasm-fb-ref-i31 wasm-fb-i31-get-s wasm-fb-i31-get-u + ;; Bytevector builder make-bytevector-builder bytevector-builder-append-u8! @@ -404,6 +462,120 @@ (define wasm-opcode-i64-extend16-s #xC3) (define wasm-opcode-i64-extend32-s #xC4) + ;;; ========== Post-MVP: GC value types ========== + + (define wasm-type-anyref #x6E) + (define wasm-type-eqref #x6D) + (define wasm-type-i31ref #x6C) + (define wasm-type-structref #x6B) + (define wasm-type-arrayref #x6A) + (define wasm-type-nullref #x69) + (define wasm-type-nullfuncref #x68) + (define wasm-type-nullexternref #x67) + (define wasm-type-noneref #x65) + + ;;; ========== Post-MVP: Composite type tags ========== + + (define wasm-composite-func #x60) + (define wasm-composite-struct #x5F) + (define wasm-composite-array #x5E) + (define wasm-type-rec #x4E) + (define wasm-type-sub #x50) + (define wasm-type-sub-final #x4F) + + ;;; ========== Post-MVP: Tag section ========== + + (define wasm-section-tag 13) + + ;;; ========== Post-MVP: Prefix bytes ========== + + (define wasm-prefix-fc #xFC) + (define wasm-prefix-fb #xFB) + + ;;; ========== Post-MVP: Tail call opcodes ========== + + (define wasm-opcode-return-call #x12) + (define wasm-opcode-return-call-indirect #x13) + + ;;; ========== Post-MVP: Exception handling opcodes ========== + + (define wasm-opcode-try #x06) + (define wasm-opcode-catch #x07) + (define wasm-opcode-throw #x08) + (define wasm-opcode-rethrow #x09) + (define wasm-opcode-delegate #x18) + (define wasm-opcode-catch-all #x19) + + ;;; ========== Post-MVP: Typed select ========== + + (define wasm-opcode-select-t #x1C) + + ;;; ========== Post-MVP: Reference opcodes ========== + + (define wasm-opcode-ref-null #xD0) + (define wasm-opcode-ref-is-null #xD1) + (define wasm-opcode-ref-func #xD2) + + ;;; ========== Post-MVP: Table opcodes ========== + + (define wasm-opcode-table-get #x25) + (define wasm-opcode-table-set #x26) + + ;;; ========== Post-MVP: 0xFC sub-opcodes ========== + + (define wasm-fc-i32-trunc-sat-f32-s 0) + (define wasm-fc-i32-trunc-sat-f32-u 1) + (define wasm-fc-i32-trunc-sat-f64-s 2) + (define wasm-fc-i32-trunc-sat-f64-u 3) + (define wasm-fc-i64-trunc-sat-f32-s 4) + (define wasm-fc-i64-trunc-sat-f32-u 5) + (define wasm-fc-i64-trunc-sat-f64-s 6) + (define wasm-fc-i64-trunc-sat-f64-u 7) + (define wasm-fc-memory-init 8) + (define wasm-fc-data-drop 9) + (define wasm-fc-memory-copy 10) + (define wasm-fc-memory-fill 11) + (define wasm-fc-table-init 12) + (define wasm-fc-elem-drop 13) + (define wasm-fc-table-copy 14) + (define wasm-fc-table-grow 15) + (define wasm-fc-table-size 16) + (define wasm-fc-table-fill 17) + + ;;; ========== Post-MVP: 0xFB sub-opcodes (GC proposal) ========== + + (define wasm-fb-struct-new #x00) + (define wasm-fb-struct-new-default #x01) + (define wasm-fb-struct-get #x02) + (define wasm-fb-struct-get-s #x03) + (define wasm-fb-struct-get-u #x04) + (define wasm-fb-struct-set #x05) + (define wasm-fb-array-new #x06) + (define wasm-fb-array-new-default #x07) + (define wasm-fb-array-new-fixed #x08) + (define wasm-fb-array-new-data #x09) + (define wasm-fb-array-new-elem #x0A) + (define wasm-fb-array-get #x0B) + (define wasm-fb-array-get-s #x0C) + (define wasm-fb-array-get-u #x0D) + (define wasm-fb-array-set #x0E) + (define wasm-fb-array-len #x0F) + (define wasm-fb-array-fill #x10) + (define wasm-fb-array-copy #x11) + (define wasm-fb-array-init-data #x12) + (define wasm-fb-array-init-elem #x13) + (define wasm-fb-ref-test #x14) + (define wasm-fb-ref-test-null #x15) + (define wasm-fb-ref-cast #x16) + (define wasm-fb-ref-cast-null #x17) + (define wasm-fb-br-on-cast #x18) + (define wasm-fb-br-on-cast-fail #x19) + (define wasm-fb-extern-internalize #x1A) + (define wasm-fb-extern-externalize #x1B) + (define wasm-fb-ref-i31 #x1C) + (define wasm-fb-i31-get-s #x1D) + (define wasm-fb-i31-get-u #x1E) + ;;; ========== Bytevector builder ========== (define-record-type bytevector-builder --- a/lib/jerboa/wasm/runtime.sls +++ b/lib/jerboa/wasm/runtime.sls @@ -20,7 +20,13 @@ wasm-instance? wasm-instance-exports wasm-decode-module wasm-module-sections wasm-run-start wasm-validate-module - make-wasm-store wasm-store? wasm-store-instantiate) + make-wasm-store wasm-store? wasm-store-instantiate + ;; Post-MVP: GC types + make-wasm-struct wasm-struct? wasm-struct-type-idx wasm-struct-fields + make-wasm-array wasm-array? wasm-array-type-idx wasm-array-data + make-wasm-i31 wasm-i31? wasm-i31-value + ;; Post-MVP: Exception handling + make-wasm-tag wasm-tag? wasm-tag-type-idx) (import (chezscheme) (jerboa wasm format)) @@ -37,6 +43,34 @@ (depth wasm-branch-depth) (val wasm-branch-val)) + ;;; ========== Post-MVP: GC record types ========== + + (define-record-type wasm-struct + (fields type-idx (mutable fields))) ; fields = vector + + (define-record-type wasm-array + (fields type-idx (mutable data))) ; data = vector + + (define-record-type wasm-i31 + (fields value)) ; 31-bit signed integer + + ;;; ========== Post-MVP: Exception handling types ========== + + (define-record-type wasm-tag + (fields type-idx)) + + (define-condition-type &wasm-exception &condition + make-wasm-exception wasm-exception? + (tag-idx wasm-exception-tag-idx) + (values wasm-exception-values)) + + ;;; ========== Post-MVP: Tail call condition ========== + + (define-condition-type &wasm-tail-call &condition + make-wasm-tail-call wasm-tail-call? + (func-idx wasm-tail-call-func-idx) + (args wasm-tail-call-args)) + ;;; ========== Decoded module ========== (define-record-type decoded-module @@ -55,7 +89,10 @@ globals ; vector tables ; vector of vectors (funcref tables) imports ; vector of import entries (param-count result-count proc type-idx) - types)) ; list of type signatures for call_indirect checking + types ; list of type signatures for call_indirect checking + (mutable data-segments) ; vector of bytevectors (for memory.init/data.drop) + (mutable elem-segments) ; vector of vectors (for table.init/elem.drop) + tags)) ; vector of wasm-tag records (for throw/catch) ;; Public accessor: returns the raw bytevector (define (wasm-instance-memory inst) @@ -351,13 +388,20 @@ ;; No immediates [(or (= op #x00) (= op #x01) (= op #x0F) (= op #x1A) (= op #x1B) (and (>= op #x45) (<= op #xC4)) - (= op #x0B) (= op #x05)) + (= op #x0B) (= op #x05) + (= op #xD1)) ; ref.is_null (+ pos 1)] ;; One LEB128 immediate [(or (= op #x0C) (= op #x0D) ; br, br_if (= op #x10) ; call + (= op #x12) ; return_call (= op #x20) (= op #x21) (= op #x22) ; local ops - (= op #x23) (= op #x24)) ; global ops + (= op #x23) (= op #x24) ; global ops + (= op #x25) (= op #x26) ; table.get, table.set + (= op #x08) ; throw (tag index) + (= op #x09) ; rethrow (depth) + (= op #xD0) ; ref.null (type) + (= op #xD2)) ; ref.func (func index) (let* ([r (decode-u32-leb128 bv (+ pos 1))]) (+ pos 1 (cdr r)))] ;; i32.const / i64.const (signed LEB128) @@ -371,14 +415,29 @@ [(= op #x43) (+ pos 5)] ;; f64.const: 8 bytes [(= op #x44) (+ pos 9)] - ;; block/loop: 1 byte block type - [(or (= op #x02) (= op #x03)) (+ pos 2)] + ;; block/loop/try: 1 byte block type + [(or (= op #x02) (= op #x03) (= op #x06)) (+ pos 2)] ;; if: 1 byte block type [(= op #x04) (+ pos 2)] + ;; catch: 1 LEB128 (tag index) + [(= op #x07) + (let* ([r (decode-u32-leb128 bv (+ pos 1))]) + (+ pos 1 (cdr r)))] + ;; delegate: 1 LEB128 (depth) + [(= op #x18) + (let* ([r (decode-u32-leb128 bv (+ pos 1))]) + (+ pos 1 (cdr r)))] + ;; catch_all: no immediates + [(= op #x19) (+ pos 1)] + ;; select_t: 1 LEB128 count + count type bytes + [(= op #x1C) + (let* ([r (decode-u32-leb128 bv (+ pos 1))] + [count (car r)]) + (+ pos 1 (cdr r) count))] ;; memory.size, memory.grow: 1 byte (reserved) [(or (= op #x3F) (= op #x40)) (+ pos 2)] - ;; call_indirect: 2 LEB128 - [(= op #x11) + ;; call_indirect / return_call_indirect: 2 LEB128 + [(or (= op #x11) (= op #x13)) (let* ([r1 (decode-u32-leb128 bv (+ pos 1))] [r2 (decode-u32-leb128 bv (+ pos 1 (cdr r1)))]) (+ pos 1 (cdr r1) (cdr r2)))] @@ -395,6 +454,100 @@ (let* ([r1 (decode-u32-leb128 bv (+ pos 1))] [r2 (decode-u32-leb128 bv (+ pos 1 (cdr r1)))]) (+ pos 1 (cdr r1) (cdr r2)))] + ;; 0xFC prefix: sub-opcode LEB128 + varying immediates + [(= op #xFC) + (let* ([r (decode-u32-leb128 bv (+ pos 1))] + [sub (car r)] + [p (+ pos 1 (cdr r))]) + (cond + [(<= sub 7) p] ; sat truncations: no extra immediates + [(= sub 8) ; memory.init: data-idx + 0x00 + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2) 1))] + [(= sub 9) ; data.drop: data-idx + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2)))] + [(= sub 10) ; memory.copy: 0x00 0x00 + (+ p 2)] + [(= sub 11) ; memory.fill: 0x00 + (+ p 1)] + [(= sub 12) ; table.init: elem-idx + table-idx + (let* ([r2 (decode-u32-leb128 bv p)] + [r3 (decode-u32-leb128 bv (+ p (cdr r2)))]) + (+ p (cdr r2) (cdr r3)))] + [(= sub 13) ; elem.drop: elem-idx + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2)))] + [(= sub 14) ; table.copy: dst-table + src-table + (let* ([r2 (decode-u32-leb128 bv p)] + [r3 (decode-u32-leb128 bv (+ p (cdr r2)))]) + (+ p (cdr r2) (cdr r3)))] + [(= sub 15) ; table.grow: table-idx + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2)))] + [(= sub 16) ; table.size: table-idx + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2)))] + [(= sub 17) ; table.fill: table-idx + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2)))] + [else p]))] + ;; 0xFB prefix: sub-opcode LEB128 + varying immediates + [(= op #xFB) + (let* ([r (decode-u32-leb128 bv (+ pos 1))] + [sub (car r)] + [p (+ pos 1 (cdr r))]) + (cond + ;; struct.new, struct.new_default: type-idx + [(or (= sub #x00) (= sub #x01)) + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2)))] + ;; struct.get/get_s/get_u/set: type-idx + field-idx + [(and (>= sub #x02) (<= sub #x05)) + (let* ([r2 (decode-u32-leb128 bv p)] + [r3 (decode-u32-leb128 bv (+ p (cdr r2)))]) + (+ p (cdr r2) (cdr r3)))] + ;; array.new, array.new_default: type-idx + [(or (= sub #x06) (= sub #x07)) + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2)))] + ;; array.new_fixed: type-idx + count + [(= sub #x08) + (let* ([r2 (decode-u32-leb128 bv p)] + [r3 (decode-u32-leb128 bv (+ p (cdr r2)))]) + (+ p (cdr r2) (cdr r3)))] + ;; array.new_data/new_elem: type-idx + data/elem-idx + [(or (= sub #x09) (= sub #x0A)) + (let* ([r2 (decode-u32-leb128 bv p)] + [r3 (decode-u32-leb128 bv (+ p (cdr r2)))]) + (+ p (cdr r2) (cdr r3)))] + ;; array.get/get_s/get_u/set: type-idx + [(and (>= sub #x0B) (<= sub #x0E)) + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2)))] + ;; array.len: no immediates + [(= sub #x0F) p] + ;; array.fill: type-idx + [(= sub #x10) + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2)))] + ;; array.copy: dst-type + src-type + [(= sub #x11) + (let* ([r2 (decode-u32-leb128 bv p)] + [r3 (decode-u32-leb128 bv (+ p (cdr r2)))]) + (+ p (cdr r2) (cdr r3)))] + ;; array.init_data/init_elem: type-idx + seg-idx + [(or (= sub #x12) (= sub #x13)) + (let* ([r2 (decode-u32-leb128 bv p)] + [r3 (decode-u32-leb128 bv (+ p (cdr r2)))]) + (+ p (cdr r2) (cdr r3)))] + ;; ref.test/cast/test_null/cast_null: type-idx + [(and (>= sub #x14) (<= sub #x17)) + (let* ([r2 (decode-u32-leb128 bv p)]) (+ p (cdr r2)))] + ;; br_on_cast/br_on_cast_fail: flags + label + type1 + type2 + [(or (= sub #x18) (= sub #x19)) + (let* ([flags (+ p 1)] ; 1 byte flags + [r2 (decode-u32-leb128 bv flags)] + [r3 (decode-u32-leb128 bv (+ flags (cdr r2)))] + [r4 (decode-u32-leb128 bv (+ flags (cdr r2) (cdr r3)))]) + (+ flags (cdr r2) (cdr r3) (cdr r4)))] + ;; extern.internalize/externalize: no immediates + [(or (= sub #x1A) (= sub #x1B)) p] + ;; ref.i31: no immediates + [(= sub #x1C) p] + ;; i31.get_s/get_u: no immediates + [(or (= sub #x1D) (= sub #x1E)) p] + [else p]))] [else (+ pos 1)])))) (define (skip-to-else-or-end bv pos len) @@ -665,7 +818,7 @@ ;; limits = (vector fuel max-call-depth max-stack-depth max-memory-pages) ;; memory-box = (vector bytevector) -- shared mutable reference - (define (execute-func code-bv locals-vec all-funcs memory-box globals tables imports limits depth types) + (define (execute-func code-bv locals-vec all-funcs memory-box globals tables imports limits depth types data-segs elem-segs tags) ;; Check call depth (let ([max-depth (vector-ref limits 1)]) (when (> depth max-depth) @@ -787,6 +940,8 @@ (guard (exn [(wasm-trap? exn) (raise exn)] [(wasm-branch? exn) (raise exn)] + [(wasm-tail-call? exn) (raise exn)] + [(wasm-exception? exn) (raise exn)] [(condition? exn) (raise (make-wasm-trap (string-append "type error at opcode 0x" @@ -916,7 +1071,7 @@ (unless (null? args) (vector-set! new-lv i (car args)) (lp (+ i 1) (cdr args)))) - (push! (execute-func code new-lv all-funcs memory-box globals tables imports limits (+ depth 1) types))))) + (push! (execute-func code new-lv all-funcs memory-box globals tables imports limits (+ depth 1) types data-segs elem-segs tags))))) (step))] ;; ---- call_indirect ---- @@ -982,7 +1137,7 @@ (unless (null? args) (vector-set! new-lv i (car args)) (lp (+ i 1) (cdr args)))) - (push! (execute-func code new-lv all-funcs memory-box globals tables imports limits (+ depth 1) types))))))) + (push! (execute-func code new-lv all-funcs memory-box globals tables imports limits (+ depth 1) types data-segs elem-segs tags))))))) (step)] ;; ---- drop ---- @@ -1317,13 +1472,715 @@ (let ([v (bitwise-and (pop!) #xFFFFFFFF)]) (push! (if (>= v #x80000000) (- v #x100000000) v)) (step))] + ;; =============== POST-MVP OPCODES =============== + + ;; ---- return_call (tail call) ---- + [(= op #x12) + (let* ([r (decode-u32-leb128 code-bv pos)]) + (set! pos (+ pos (cdr r))) + (let ([fidx (car r)]) + (if (< fidx (vector-length imports)) + ;; Tail call to import: just call normally (no trampoline needed) + (let* ([imp-entry (vector-ref imports fidx)] + [param-count (car imp-entry)] + [args (let lp ([n param-count] [a '()]) + (if (= n 0) a (lp (- n 1) (cons (pop!) a))))]) + (safe-import-call! imp-entry args)) + ;; Tail call to local: raise tail-call condition + (let* ([local-fidx (- fidx (vector-length imports))] + [fi (vector-ref all-funcs local-fidx)] + [param-count (car fi)] + [args (let lp ([n param-count] [a '()]) + (if (= n 0) a (lp (- n 1) (cons (pop!) a))))]) + (raise (make-wasm-tail-call fidx args))))))] + + ;; ---- return_call_indirect (tail call) ---- + [(= op #x13) + (let* ([r1 (decode-u32-leb128 code-bv pos)] + [type-idx (car r1)] + [r2 (decode-u32-leb128 code-bv (+ pos (cdr r1)))] + [table-idx (car r2)]) + (set! pos (+ pos (cdr r1) (cdr r2))) + (when (>= table-idx (vector-length tables)) + (raise (make-wasm-trap "return_call_indirect: table index OOB"))) + (let* ([elem-idx (pop!)] + [table (vector-ref tables table-idx)]) + (when (or (< elem-idx 0) (>= elem-idx (vector-length table))) + (raise (make-wasm-trap "return_call_indirect: element index OOB"))) + (let ([fidx (vector-ref table elem-idx)]) + (when (not fidx) + (raise (make-wasm-trap "return_call_indirect: null table entry"))) + (let* ([local-fidx (- fidx (vector-length imports))] + [fi (vector-ref all-funcs local-fidx)] + [param-count (car fi)] + [args (let lp ([n param-count] [a '()]) + (if (= n 0) a (lp (- n 1) (cons (pop!) a))))]) + (raise (make-wasm-tail-call fidx args))))))] + + ;; ---- try (exception handling) ---- + [(= op #x06) + (let ([bt (bytevector-u8-ref code-bv pos)]) + (set! pos (+ pos 1)) + ;; Execute try body; on wasm-exception, scan for catch/catch_all + (guard (exn + [(wasm-exception? exn) + (let ([tag (wasm-exception-tag-idx exn)] + [vals (wasm-exception-values exn)]) + ;; Skip to matching catch or catch_all + (let scan ([p pos] [d 0]) + (if (>= p len) + (raise exn) ; no handler found, propagate + (let ([o (bytevector-u8-ref code-bv p)]) + (cond + [(and (= o #x07) (= d 0)) ; catch + (let* ([r (decode-u32-leb128 code-bv (+ p 1))] + [catch-tag (car r)]) + (if (= catch-tag tag) + (begin + (set! pos (+ p 1 (cdr r))) + (for-each (lambda (v) (push! v)) (reverse vals)) + (execute-block bt 'block)) + (scan (+ p 1 (cdr r)) d)))] + [(and (= o #x19) (= d 0)) ; catch_all + (set! pos (+ p 1)) + (execute-block bt 'block)] + [(or (= o #x02) (= o #x03) (= o #x04) (= o #x06)) + (scan (skip-instr code-bv p len) (+ d 1))] + [(= o #x0B) + (if (= d 0) + (raise exn) ; end of try without matching catch + (scan (+ p 1) (- d 1)))] + [else (scan (skip-instr code-bv p len) d)])))))]) + (execute-block bt 'block)) + (step))] + + ;; ---- throw ---- + [(= op #x08) + (let* ([r (decode-u32-leb128 code-bv pos)] + [tag-idx (car r)]) + (set! pos (+ pos (cdr r))) + (when (>= tag-idx (vector-length tags)) + (raise (make-wasm-trap + (string-append "throw: tag index OOB: " (number->string tag-idx))))) + (let* ([tag (vector-ref tags tag-idx)] + [tidx (wasm-tag-type-idx tag)] + [type (list-ref types tidx)] + [param-count (length (car type))] + [vals (let lp ([n param-count] [a '()]) + (if (= n 0) a (lp (- n 1) (cons (pop!) a))))]) + (raise (make-wasm-exception tag-idx vals))))] + + ;; ---- rethrow ---- + [(= op #x09) + (let* ([r (decode-u32-leb128 code-bv pos)]) + (set! pos (+ pos (cdr r))) + ;; Rethrow is only valid inside catch; for now trap + (raise (make-wasm-trap "rethrow: not inside catch handler")))] + + ;; ---- select_t (typed select) ---- + [(= op #x1C) + (let* ([r (decode-u32-leb128 code-bv pos)] + [count (car r)] + [skip (+ (cdr r) count)]) + (set! pos (+ pos skip)) + ;; Same semantics as select, just with type annotation + (let* ([c (pop!)] [v2 (pop!)] [v1 (pop!)]) + (push! (if (not (= c 0)) v1 v2)) + (step)))] + + ;; ---- table.get ---- + [(= op #x25) + (let* ([r (decode-u32-leb128 code-bv pos)] + [tidx (car r)]) + (set! pos (+ pos (cdr r))) + (when (>= tidx (vector-length tables)) + (raise (make-wasm-trap "table.get: table index OOB"))) + (let* ([idx (pop!)] + [table (vector-ref tables tidx)]) + (when (or (< idx 0) (>= idx (vector-length table))) + (raise (make-wasm-trap "table.get: element index OOB"))) + (let ([val (vector-ref table idx)]) + (push! (or val 0))) + (step)))] + + ;; ---- table.set ---- + [(= op #x26) + (let* ([r (decode-u32-leb128 code-bv pos)] + [tidx (car r)]) + (set! pos (+ pos (cdr r))) + (when (>= tidx (vector-length tables)) + (raise (make-wasm-trap "table.set: table index OOB"))) + (let* ([val (pop!)] + [idx (pop!)] + [table (vector-ref tables tidx)]) + (when (or (< idx 0) (>= idx (vector-length table))) + (raise (make-wasm-trap "table.set: element index OOB"))) + (vector-set! table idx val) + (step)))]