Guile-hoot/module/wasm/assemble.scm

;;; WebAssembly assembler
;;; Copyright (C) 2023, 2024 Igalia, S.L.
;;; Copyright (C) 2024 David Thompson <dave@spritely.institute>
;;;
;;; Licensed under the Apache License, Version 2.0 (the "License");
;;; you may not use this file except in compliance with the License.
;;; You may obtain a copy of the License at
;;;
;;;    http://www.apache.org/licenses/LICENSE-2.0
;;;
;;; Unless required by applicable law or agreed to in writing, software
;;; distributed under the License is distributed on an "AS IS" BASIS,
;;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;;; See the License for the specific language governing permissions and
;;; limitations under the License.

;;; Commentary:
;;;
;;; Assembler for WebAssembly.
;;;
;;; Code:

(define-module (wasm assemble)
  #:use-module (ice-9 binary-ports)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (wasm types)
  #:export (assemble-wasm))

(define (assemble-wasm wasm)
  (define (put-uleb port val)
    (let lp ((val val))
      (let ((next (ash val -7)))
        (if (zero? next)
            (put-u8 port val)
            (begin
              (put-u8 port (logior #x80 (logand val #x7f)))
              (lp next))))))

  (define (put-sleb port val)
    (let lp ((val val))
      (if (<= 0 (+ val 64) 127)
          (put-u8 port (logand val #x7f))
          (begin
            (put-u8 port (logior #x80 (logand val #x7f)))
            (lp (ash val -7))))))

  (define (put-u32le port val)
    (let ((bv (u32vector 0)))
      (bytevector-u32-set! bv 0 val (endianness little))
      (put-bytevector port bv)))

  (define (->s32 val)
    (if (< val (ash 1 31)) val (- val (ash 1 32))))
  (define (->s64 val)
    (if (< val (ash 1 63)) val (- val (ash 1 64))))

  (define (emit-u8 port val) (put-u8 port val))
  (define (emit-u32 port val) (put-uleb port val))
  (define (emit-s32 port val) (put-sleb port (->s32 val)))
  (define (emit-s64 port val) (put-sleb port (->s64 val)))
  (define (emit-f32 port val) (put-bytevector port (f32vector val)))
  (define (emit-f64 port val) (put-bytevector port (f64vector val)))

  (define (emit-vec port items emit)
    (emit-u32 port (length items))
    (for-each (lambda (item) (emit port item)) items))

  (define (emit-vec/u8 port bv)
    (emit-u32 port (bytevector-length bv))
    (put-bytevector port bv))

  (define (emit-heap-type port ht)
    (match ht
      ((and (? exact-integer?) (not (? negative?))) (put-sleb port ht))
      ('nofunc (emit-u8 port #x73))
      ('noextern (emit-u8 port #x72))
      ('none (emit-u8 port #x71))
      ('func (emit-u8 port #x70))
      ('extern (emit-u8 port #x6F))
      ('any (emit-u8 port #x6E))
      ('eq (emit-u8 port #x6D))
      ('i31 (emit-u8 port #x6C))
      ('struct (emit-u8 port #x6B))
      ('array (emit-u8 port #x6A))
      ('string (emit-u8 port #x67))
      ('stringview_wtf8 (emit-u8 port #x66))
      ('stringview_wtf16 (emit-u8 port #x62))
      ('stringview_iter (emit-u8 port #x61))

      (_ (error "unexpected heap type" ht))))

  (define (emit-val-type port vt)
    (match vt
      ('i32 (emit-u8 port #x7F))
      ('i64 (emit-u8 port #x7E))
      ('f32 (emit-u8 port #x7D))
      ('f64 (emit-u8 port #x7C))
      ('v128 (emit-u8 port #x7B))
      ('nullfuncref (emit-u8 port #x73))
      ('nullexternref (emit-u8 port #x72))
      ('nullref (emit-u8 port #x71))
      ('funcref (emit-u8 port #x70))
      ('externref (emit-u8 port #x6F))
      ('anyref (emit-u8 port #x6E))
      ('eqref (emit-u8 port #x6D))
      ('i31ref (emit-u8 port #x6C))
      ('structref (emit-u8 port #x6B))
      ('arrayref (emit-u8 port #x6A))

      ;; Non-finalized proposals below.
      ('stringref (emit-u8 port #x67))
      ('stringview_wtf8ref (emit-u8 port #x66))
      ('stringview_wtf16ref (emit-u8 port #x62))
      ('stringview_iterref (emit-u8 port #x61))

      (($ <ref-type> nullable? ht)
       (emit-u8 port (if nullable? #x63 #x64))
       (emit-heap-type port ht))

      (_ (error "unexpected valtype" vt))))

  (define (emit-result-type port rt)
    (emit-vec port rt emit-val-type))

  (define (emit-block-type port bt)
    (match bt
      (#f (emit-u8 port #x40))
      ((? exact-integer?) (emit-s32 port bt))
      ((or (? symbol?) ($ <ref-type>)) (emit-val-type port bt))
      (($ <type-use> #f ($ <func-sig> () ())) (emit-u8 port #x40))
      (($ <type-use> #f ($ <func-sig> () (vt))) (emit-val-type port vt))
      (($ <type-use> idx) (emit-s32 port idx))))

  (define (emit-limits port limits)
    (match limits
      (($ <limits> min #f)
       (emit-u8 port #x00)
       (emit-u32 port min))
      (($ <limits> min max)
       (emit-u8 port #x01)
       (emit-u32 port min)
       (emit-u32 port max))))

  (define (emit-ref-type port rt)
    (match rt
      ((or 'i32 'i64 'f32 'f64 'i128)
       (error "unexpected reftype" rt))
      (_ (emit-val-type port rt))))

  (define (emit-elem-type port et)
    (emit-ref-type port et))

  (define (emit-table-type port tt)
    (match tt
      (($ <table-type> limits elem-type)
       (emit-elem-type port elem-type)
       (emit-limits port limits))))

  (define (emit-mem-type port mt)
    (match mt
      (($ <mem-type> limits) (emit-limits port limits))))

  (define (emit-global-type port gt)
    (match gt
      (($ <global-type> mutable? vt)
       (emit-val-type port vt)
       (emit-u8 port (if mutable? 1 0)))))

  (define (emit-tag-type port tt)
    (match tt
      (($ <tag-type> attribute type)
       (match attribute
         ('exception (emit-u8 port #x00))
         (_ (error "bad tag attribute" attribute)))
       (emit-type-use port type))))

  (define (emit-name port str)
    (emit-vec/u8 port (string->utf8 str)))

  (define (emit-end port)
    (emit-u8 port #x0B))

  (define (emit-instruction port inst)
    (define (bad-instruction) (error "bad instruction" inst))

    (define-values (op args)
      (match inst
        ((op args ...) (values op args))
        (op (values op '()))))

    (define (emit code)
      (match args
        (() (emit-u8 port code))
        (_ (bad-instruction))))
    (define (emit-block code)
      (match args
        ((label bt insts)
         (emit-u8 port code)
         (emit-block-type port bt)
         (emit-instructions port insts)
         (emit-end port))
        (_ (bad-instruction))))
    (define (emit-if code)
      (define else-code #x05)
      (match args
        ((label bt consequent alternate)
         (emit-u8 port code)
         (emit-block-type port bt)
         (emit-instructions port consequent)
         (unless (null? alternate)
           (emit-u8 port else-code)
           (emit-instructions port alternate))
         (emit-end port))
        (_ (bad-instruction))))
    (define (emit-try code)
      (define catch-code #x07)
      (define delegate-code #x18)
      (define catch_all-code #x19)
      (match args
        ((label bt body catches catch-all)
         (emit-u8 port code)
         (emit-block-type port bt)
         (emit-instructions port body)
         (for-each (match-lambda
                     ((tag-idx . body)
                      (emit-u8 port catch-code)
                      (emit-u32 port tag-idx)
                      (emit-instructions port body)))
                   catches)
         (unless (null? catch-all)
           (emit-u8 port catch_all-code)
           (emit-instructions port catch-all))
         (emit-end port))))
    (define (emit-try_delegate code)
      (define delegate-code #x18)
      (match args
        ((label bt body delegate)
         (emit-u8 port code)
         (emit-block-type port bt)
         (emit-instructions port body)
         (emit-u8 port delegate-code)
         (emit-u32 port delegate))))
    (define (emit-idx code)
      (match args
        ((idx)
         (emit-u8 port code)
         (emit-u32 port idx))
        (_ (bad-instruction))))
    (define (emit-br_table code)
      (match args
        ((targets default)
         (emit-u8 port code)
         (emit-vec port targets emit-u32)
         (emit-u32 port default))
        (_ (bad-instruction))))
    (define (emit-call_indirect code)
      (match args
        ((table type)
         (emit-u8 port code)
         (emit-u32 port type)
         (emit-u32 port table))
        (_ (bad-instruction))))
    (define (emit-select old-code new-code)
      (match args
        (()
         (emit-u8 port old-code))
        ((types)
         (emit-u8 port new-code)
         (emit-vec port types emit-val-type))
        (_ (bad-instruction))))
    (define (emit-mem code)
      (match args
        ((($ <mem-arg> id offset align))
         (emit-u8 port code)
         (emit-u32 port
                   (if (zero? id)
                       align
                       (logior align (ash 1 6))))
         (unless (zero? id)
           (emit-u32 port id))
         (emit-u32 port offset))
        (_ (bad-instruction))))
    (define (emit-const code emit-val)
      (match args
        ((val)
         (emit-u8 port code)
         (emit-val port val))
        (_ (bad-instruction))))
    (define (emit-ht code)
      (match args
        ((ht)
         (emit-u8 port code)
         (emit-heap-type port ht))
        (_ (bad-instruction))))
    (define (emit-gc-op code)
      (emit-u8 port #xfb)
      (put-uleb port code))
    (define (emit-gc code)
      (match args
        (() (emit-gc-op code))
        (_ (bad-instruction))))
    (define (emit-gc-idx code)
      (match args
        ((idx)
         (emit-gc-op code)
         (emit-u32 port idx))
        (_ (bad-instruction))))
    (define (emit-gc-idx-idx code)
      (match args
        ((idx0 idx1)
         (emit-gc-op code)
         (emit-u32 port idx0)
         (emit-u32 port idx1))
        (_ (bad-instruction))))
    (define (emit-gc-idx-len code)
      (emit-gc-idx-idx code))
    (define (emit-gc-rt code nullable-code)
      (match args
        ((($ <ref-type> nullable? ht))
         (emit-gc-op (if nullable? nullable-code code))
         (emit-heap-type port ht))
        (_ (bad-instruction))))
    (define (emit-gc-idx-rt-rt code)
      (match args
        ((idx ($ <ref-type> nullable1? ht1) ($ <ref-type> nullable2? ht2))
         (emit-gc-op code)
         (emit-u8 port (logior (if nullable1? 1 0) (if nullable2? 2 0)))
         (emit-u32 port idx)
         (emit-heap-type port ht1)
         (emit-heap-type port ht2))
        (_ (bad-instruction))))
    (define (emit-misc-op code)
      (emit-u8 port #xfc)
      (put-uleb port code))
    (define (emit-misc code)
      (match args
        (()
         (emit-misc-op code))
        (_ (bad-instruction))))
    (define (emit-misc-idx code)
      (match args
        ((idx)
         (emit-misc-op code)
         (emit-u32 port idx))
        (_ (bad-instruction))))
    (define (emit-misc-idx-idx code)
      (match args
        ((idx0 idx1)
         (emit-misc-op code)
         (emit-u32 port idx0)
         (emit-u32 port idx1))
        (_ (bad-instruction))))
    (define (emit-simd-splat code)
      (match args
        (()
         (emit-u8 port #xfd)
         (emit-u32 port code))
        (_ (bad-instruction))))

    (match op
      ('unreachable         (emit #x00))
      ('nop                 (emit #x01))
      ('block               (emit-block #x02))
      ('loop                (emit-block #x03))
      ('if                  (emit-if #x04))
      ('try                 (emit-try #x06))
      ('try_delegate        (emit-try_delegate #x06))
      ('throw               (emit-idx #x08))
      ('rethrow             (emit-idx #x09))
      ('br                  (emit-idx #x0C))
      ('br_if               (emit-idx #x0D))
      ('br_table            (emit-br_table #x0E))
      ('return              (emit #x0F))
      ('call                (emit-idx #x10))
      ('call_indirect       (emit-call_indirect #x11))
      ('return_call         (emit-idx #x12))
      ('return_call_indirect (emit-call_indirect #x13))
      ('call_ref            (emit-idx #x14))
      ('return_call_ref     (emit-idx #x15))
      ('drop                (emit #x1A))
      ('select              (emit-select #x1B #x1C))
      ('local.get           (emit-idx #x20))
      ('local.set           (emit-idx #x21))
      ('local.tee           (emit-idx #x22))
      ('global.get          (emit-idx #x23))
      ('global.set          (emit-idx #x24))
      ('table.get           (emit-idx #x25))
      ('table.set           (emit-idx #x26))
      ('i32.load            (emit-mem #x28))
      ('i64.load            (emit-mem #x29))
      ('f32.load            (emit-mem #x2A))
      ('f64.load            (emit-mem #x2B))
      ('i32.load8_s         (emit-mem #x2C))
      ('i32.load8_u         (emit-mem #x2D))
      ('i32.load16_s        (emit-mem #x2E))
      ('i32.load16_u        (emit-mem #x2F))
      ('i64.load8_s         (emit-mem #x30))
      ('i64.load8_u         (emit-mem #x31))
      ('i64.load16_s        (emit-mem #x32))
      ('i64.load16_u        (emit-mem #x33))
      ('i64.load32_s        (emit-mem #x34))
      ('i64.load32_u        (emit-mem #x35))
      ('i32.store           (emit-mem #x36))
      ('i64.store           (emit-mem #x37))
      ('f32.store           (emit-mem #x38))
      ('f64.store           (emit-mem #x39))
      ('i32.store8          (emit-mem #x3A))
      ('i32.store16         (emit-mem #x3B))
      ('i64.store8          (emit-mem #x3C))
      ('i64.store16         (emit-mem #x3D))
      ('i64.store32         (emit-mem #x3E))
      ('memory.size         (emit-idx #x3F))
      ('memory.grow         (emit-idx #x40))
      ('i32.const           (emit-const #x41 emit-s32))
      ('i64.const           (emit-const #x42 emit-s64))
      ('f32.const           (emit-const #x43 emit-f32))
      ('f64.const           (emit-const #x44 emit-f64))
      ('i32.eqz             (emit #x45))
      ('i32.eq              (emit #x46))
      ('i32.ne              (emit #x47))
      ('i32.lt_s            (emit #x48))
      ('i32.lt_u            (emit #x49))
      ('i32.gt_s            (emit #x4A))
      ('i32.gt_u            (emit #x4B))
      ('i32.le_s            (emit #x4C))
      ('i32.le_u            (emit #x4D))
      ('i32.ge_s            (emit #x4E))
      ('i32.ge_u            (emit #x4F))
      ('i64.eqz             (emit #x50))
      ('i64.eq              (emit #x51))
      ('i64.ne              (emit #x52))
      ('i64.lt_s            (emit #x53))
      ('i64.lt_u            (emit #x54))
      ('i64.gt_s            (emit #x55))
      ('i64.gt_u            (emit #x56))
      ('i64.le_s            (emit #x57))
      ('i64.le_u            (emit #x58))
      ('i64.ge_s            (emit #x59))
      ('i64.ge_u            (emit #x5A))
      ('f32.eq              (emit #x5B))
      ('f32.ne              (emit #x5C))
      ('f32.lt              (emit #x5D))
      ('f32.gt              (emit #x5E))
      ('f32.le              (emit #x5F))
      ('f32.ge              (emit #x60))
      ('f64.eq              (emit #x61))
      ('f64.ne              (emit #x62))
      ('f64.lt              (emit #x63))
      ('f64.gt              (emit #x64))
      ('f64.le              (emit #x65))
      ('f64.ge              (emit #x66))
      ('i32.clz             (emit #x67))
      ('i32.ctz             (emit #x68))
      ('i32.popcnt          (emit #x69))
      ('i32.add             (emit #x6A))
      ('i32.sub             (emit #x6B))
      ('i32.mul             (emit #x6C))
      ('i32.div_s           (emit #x6D))
      ('i32.div_u           (emit #x6E))
      ('i32.rem_s           (emit #x6F))
      ('i32.rem_u           (emit #x70))
      ('i32.and             (emit #x71))
      ('i32.or              (emit #x72))
      ('i32.xor             (emit #x73))
      ('i32.shl             (emit #x74))
      ('i32.shr_s           (emit #x75))
      ('i32.shr_u           (emit #x76))
      ('i32.rotl            (emit #x77))
      ('i32.rotr            (emit #x78))
      ('i64.clz             (emit #x79))
      ('i64.ctz             (emit #x7A))
      ('i64.popcnt          (emit #x7B))
      ('i64.add             (emit #x7C))
      ('i64.sub             (emit #x7D))
      ('i64.mul             (emit #x7E))
      ('i64.div_s           (emit #x7F))
      ('i64.div_u           (emit #x80))
      ('i64.rem_s           (emit #x81))
      ('i64.rem_u           (emit #x82))
      ('i64.and             (emit #x83))
      ('i64.or              (emit #x84))
      ('i64.xor             (emit #x85))
      ('i64.shl             (emit #x86))
      ('i64.shr_s           (emit #x87))
      ('i64.shr_u           (emit #x88))
      ('i64.rotl            (emit #x89))
      ('i64.rotr            (emit #x8A))
      ('f32.abs             (emit #x8B))
      ('f32.neg             (emit #x8C))
      ('f32.ceil            (emit #x8D))
      ('f32.floor           (emit #x8E))
      ('f32.trunc           (emit #x8F))
      ('f32.nearest         (emit #x90))
      ('f32.sqrt            (emit #x91))
      ('f32.add             (emit #x92))
      ('f32.sub             (emit #x93))
      ('f32.mul             (emit #x94))
      ('f32.div             (emit #x95))
      ('f32.min             (emit #x96))
      ('f32.max             (emit #x97))
      ('f32.copysign        (emit #x98))
      ('f64.abs             (emit #x99))
      ('f64.neg             (emit #x9A))
      ('f64.ceil            (emit #x9B))
      ('f64.floor           (emit #x9C))
      ('f64.trunc           (emit #x9D))
      ('f64.nearest         (emit #x9E))
      ('f64.sqrt            (emit #x9F))
      ('f64.add             (emit #xA0))
      ('f64.sub             (emit #xA1))
      ('f64.mul             (emit #xA2))
      ('f64.div             (emit #xA3))
      ('f64.min             (emit #xA4))
      ('f64.max             (emit #xA5))
      ('f64.copysign        (emit #xA6))
      ('i32.wrap_i64        (emit #xA7))
      ('i32.trunc_f32_s     (emit #xA8))
      ('i32.trunc_f32_u     (emit #xA9))
      ('i32.trunc_f64_s     (emit #xAA))
      ('i32.trunc_f64_u     (emit #xAB))
      ('i64.extend_i32_s    (emit #xAC))
      ('i64.extend_i32_u    (emit #xAD))
      ('i64.trunc_f32_s     (emit #xAE))
      ('i64.trunc_f32_u     (emit #xAF))
      ('i64.trunc_f64_s     (emit #xB0))
      ('i64.trunc_f64_u     (emit #xB1))
      ('f32.convert_i32_s   (emit #xB2))
      ('f32.convert_i32_u   (emit #xB3))
      ('f32.convert_i64_s   (emit #xB4))
      ('f32.convert_i64_u   (emit #xB5))
      ('f32.demote_f64      (emit #xB6))
      ('f64.convert_i32_s   (emit #xB7))
      ('f64.convert_i32_u   (emit #xB8))
      ('f64.convert_i64_s   (emit #xB9))
      ('f64.convert_i64_u   (emit #xBA))
      ('f64.promote_f32     (emit #xBB))
      ('i32.reinterpret_f32 (emit #xBC))
      ('i64.reinterpret_f64 (emit #xBD))
      ('f32.reinterpret_i32 (emit #xBE))
      ('f64.reinterpret_i64 (emit #xBF))
      ('i32.extend8_s       (emit #xc0))
      ('i32.extend16_s      (emit #xc1))
      ('i64.extend8_s       (emit #xc2))
      ('i64.extend16_s      (emit #xc3))
      ('i64.extend32_s      (emit #xc4))

      ;; GC.
      ('ref.null            (emit-ht #xd0))
      ('ref.is_null         (emit #xd1))
      ('ref.func            (emit-idx #xd2))
      ('ref.eq              (emit #xd3))
      ('ref.as_non_null     (emit #xd4))
      ('struct.new          (emit-gc-idx 0))
      ('struct.new_default  (emit-gc-idx 1))
      ('struct.get          (emit-gc-idx-idx 2))
      ('struct.get_s        (emit-gc-idx-idx 3))
      ('struct.get_u        (emit-gc-idx-idx 4))
      ('struct.set          (emit-gc-idx-idx 5))
      ('array.new           (emit-gc-idx 6))
      ('array.new_default   (emit-gc-idx 7))
      ('array.new_fixed     (emit-gc-idx-len 8))
      ('array.new_data      (emit-gc-idx-idx 9))
      ('array.new_elem      (emit-gc-idx-idx 10))
      ('array.get           (emit-gc-idx 11))
      ('array.get_s         (emit-gc-idx 12))
      ('array.get_u         (emit-gc-idx 13))
      ('array.set           (emit-gc-idx 14))
      ('array.len           (emit-gc 15))
      ('array.fill          (emit-gc-idx 16))
      ('array.copy          (emit-gc-idx-idx 17))
      ('array.init_data     (emit-gc-idx-idx 18))
      ('array.init_elem     (emit-gc-idx-idx 19))
      ('ref.test            (emit-gc-rt 20 21))
      ('ref.cast            (emit-gc-rt 22 23))
      ('br_on_cast          (emit-gc-idx-rt-rt 24))
      ('br_on_cast_fail     (emit-gc-idx-rt-rt 25))
      ('extern.internalize  (emit-gc 26))
      ('extern.externalize  (emit-gc 27))
      ('ref.i31             (emit-gc 28))
      ('i31.get_s           (emit-gc 29))
      ('i31.get_u           (emit-gc 30))

      ;; Stringref.
      ('string.new_utf8                    (emit-gc-idx #x80))
      ('string.new_wtf16                   (emit-gc-idx #x81))
      ('string.const                       (emit-gc-idx #x82))
      ('string.measure_utf8                (emit-gc #x83))
      ('string.measure_wtf8                (emit-gc #x84))
      ('string.measure_wtf16               (emit-gc #x85))
      ('string.encode_utf8                 (emit-gc-idx #x86))
      ('string.encode_wtf16                (emit-gc-idx #x87))
      ('string.concat                      (emit-gc #x88))
      ('string.eq                          (emit-gc #x89))
      ('string.is_usv_sequence             (emit-gc #x8a))
      ('string.new_lossy_utf8              (emit-gc-idx #x8b))
      ('string.new_wtf8                    (emit-gc-idx #x8c))
      ('string.encode_lossy_utf8           (emit-gc-idx #x8d))
      ('string.encode_wtf8                 (emit-gc-idx #x8e))
      ('string.as_wtf8                     (emit-gc #x90))
      ('stringview_wtf8.advance            (emit-gc #x91))
      ('stringview_wtf8.encode_utf8        (emit-gc-idx #x92))
      ('stringview_wtf8.slice              (emit-gc #x93))
      ('stringview_wtf8.encode_lossy_utf8  (emit-gc-idx #x94))
      ('stringview_wtf8.encode_wtf8        (emit-gc-idx #x95))
      ('string.as_wtf16                    (emit-gc #x98))
      ('stringview_wtf16.length            (emit-gc #x99))
      ('stringview_wtf16.get_codeunit      (emit-gc #x9a))
      ('stringview_wtf16.encode            (emit-gc-idx #x9b))
      ('stringview_wtf16.slice             (emit-gc #x9c))
      ('string.as_iter                     (emit-gc #xa0))
      ('stringview_iter.next               (emit-gc #xa1))
      ('stringview_iter.advance            (emit-gc #xa2))
      ('stringview_iter.rewind             (emit-gc #xa3))
      ('stringview_iter.slice              (emit-gc #xa4))
      ('string.compare                     (emit-gc #xa8))
      ('string.from_code_point             (emit-gc #xa9))
      ('string.new_utf8_array              (emit-gc #xb0))
      ('string.new_wtf16_array             (emit-gc #xb1))
      ('string.encode_utf8_array           (emit-gc #xb2))
      ('string.encode_wtf16_array          (emit-gc #xb3))
      ('string.new_lossy_utf8_array        (emit-gc #xb4))
      ('string.new_wtf8_array              (emit-gc #xb5))
      ('string.encode_lossy_utf8_array     (emit-gc #xb6))
      ('string.encode_wtf8_array           (emit-gc #xb7))

      ;; Vector opcodes.
      ('i8x16.splat                        (emit-simd-splat #x0f))
      ('i16x8.splat                        (emit-simd-splat #x10))
      ('i32x4.splat                        (emit-simd-splat #x11))
      ('i64x2.splat                        (emit-simd-splat #x12))
      ('f32x4.splat                        (emit-simd-splat #x13))
      ('f64x2.splat                        (emit-simd-splat #x14))

      ;; Misc opcodes.
      ('i32.trunc_sat_f32_s                (emit-misc #x00))
      ('i32.trunc_sat_f32_u                (emit-misc #x01))
      ('i32.trunc_sat_f64_s                (emit-misc #x02))
      ('i32.trunc_sat_f64_u                (emit-misc #x03))
      ('i64.trunc_sat_f32_s                (emit-misc #x04))
      ('i64.trunc_sat_f32_u                (emit-misc #x05))
      ('i64.trunc_sat_f64_s                (emit-misc #x06))
      ('i64.trunc_sat_f64_u                (emit-misc #x07))
      ('memory.init                        (emit-misc-idx-idx #x08))
      ('data.drop                          (emit-misc-idx #x09))
      ('memory.copy                        (emit-misc-idx-idx #x0a))
      ('memory.fill                        (emit-misc-idx #x0b))
      ('table.init                         (emit-misc-idx-idx #x0c))
      ('elem.drop                          (emit-misc-idx #x0d))
      ('table.copy                         (emit-misc-idx-idx #x0e))
      ('table.grow                         (emit-misc-idx #x0f))
      ('table.size                         (emit-misc-idx #x10))
      ('table.fill                         (emit-misc-idx #x11))

      (_ (bad-instruction))))

  (define (emit-instructions port insts)
    (for-each (lambda (inst) (emit-instruction port inst)) insts))

  (define (emit-expr port expr)
    (emit-instructions port expr)
    (emit-end port))

  (define (emit-type-def port def)
    (define (emit-field-type port mutable? st)
      (match st
        ('i8 (emit-u8 port #x78))
        ('i16 (emit-u8 port #x77))
        (_ (emit-val-type port st)))
      (emit-u8 port (if mutable? 1 0)))
    (define (emit-field port field)
      (match field
        (($ <field> id mutable? type)
         (emit-field-type port mutable? type))))
    (define (emit-base-type-def port def)
      (match def
        (($ <func-sig> (($ <param> _ param-type) ...) (result-type ...))
         (emit-u8 port #x60)
         (emit-result-type port param-type)
         (emit-result-type port result-type))
        (($ <struct-type> fields)
         (emit-u8 port #x5f)
         (emit-vec port fields emit-field))
        (($ <array-type> mutable? type)
         (emit-u8 port #x5e)
         (emit-field-type port mutable? type))))
    (define (emit-sub-type-def port def)
      (match def
        (($ <sub-type> final? supers def)
         (emit-u8 port (if final? #x4f #x50))
         (emit-vec port supers emit-u32)
         (emit-base-type-def port def))
        (_ (emit-base-type-def port def))))
    (match def
      (($ <rec-group> (($ <type> _ def) ...))
       (emit-u8 port #x4e)
       (emit-vec port def emit-sub-type-def))
      (($ <type> id def)
       (emit-sub-type-def port def))))

  (define (emit-type-use port type)
    (match type
      (($ <type-use> idx)
       (emit-u32 port idx))))

  (define (emit-import port import)
    (match import
      (($ <import> mod name kind id type)
       (emit-name port mod)
       (emit-name port name)
       (match kind
         ('func
          (emit-u8 port #x00)
          (emit-type-use port type))
         ('table
          (emit-u8 port #x01)
          (emit-table-type port type))
         ('memory
          (emit-u8 port #x02)
          (emit-mem-type port type))
         ('global
          (emit-u8 port #x03)
          (emit-global-type port type))
         ('tag
          (emit-u8 port #x04)
          (emit-tag-type port type))))))

  (define (emit-func-decl port func)
    (match func
      (($ <func> id type locals body)
       (emit-type-use port type))))

  (define (emit-table port table)
    (match table
      (($ <table> id type #f)
       (emit-table-type port type))
      (($ <table> id type init)
       (emit-u8 port #x40)
       (emit-u8 port #x00)
       (emit-table-type port type)
       (emit-expr port init))))

  (define (emit-memory port memory)
    (match memory
      (($ <memory> id type)
       (emit-mem-type port type))))

  (define (emit-global port global)
    (match global
      (($ <global> id type init)
       (emit-global-type port type)
       (emit-expr port init))))

  (define (emit-export port export)
    (match export
      (($ <export> name kind id)
       (emit-name port name)
       (match kind
         ('func (emit-u8 port #x00))
         ('table (emit-u8 port #x01))
         ('memory (emit-u8 port #x02))
         ('global (emit-u8 port #x03))
         ('tag (emit-u8 port #x04)))
       (emit-u32 port id))))

  (define (emit-element port elem)
    (match elem
      (($ <elem> id 'active 0 'funcref offset ((('ref.func idx)) ...))
       (emit-u8 port #x00)
       (emit-expr port offset)
       (emit-vec port idx emit-u32))
      (($ <elem> id 'passive #f 'funcref #f ((('ref.func idx)) ...))
       (emit-u8 port #x01)
       (emit-u8 port #x00) ;; elemkind: funcref
       (emit-vec port idx emit-u32))
      (($ <elem> id 'active table 'funcref offset ((('ref.func idx)) ...))
       (emit-u8 port #x02)
       (emit-u32 port table)
       (emit-expr port offset)
       (emit-u8 port #x00) ;; elemkind: funcref
       (emit-vec port idx emit-u32))
      (($ <elem> id 'declarative #f 'funcref #f ((('ref.func idx)) ...))
       (emit-u8 port #x03)
       (emit-u8 port #x00) ;; elemkind: funcref
       (emit-vec port idx emit-u32))
      (($ <elem> id 'active 0 'funcref offset (expr ...))
       (emit-u8 port #x04)
       (emit-expr port offset)
       (emit-vec port expr emit-expr))
      (($ <elem> id 'passive #f type #f (expr ...))
       (emit-u8 port #x05)
       (emit-ref-type port type)
       (emit-vec port expr emit-expr))
      (($ <elem> id 'active table type offset (expr ...))
       (emit-u8 port #x06)
       (emit-u32 port table)
       (emit-expr port offset)
       (emit-ref-type port type)
       (emit-vec port expr emit-expr))
      (($ <elem> id 'declarative #f type #f (expr ...))
       (emit-u8 port #x07)
       (emit-ref-type port type)
       (emit-vec port expr emit-expr))))

  (define (emit-func-def port func)
    (define (emit-compressed-locals port locals)
      (define compressed
        (let compress ((locals locals))
          (match locals
            (() '())
            ((($ <local> id type) . locals)
             (match (compress locals)
               (((count . (? (lambda (vt) (equal? vt type)))) . compressed)
                (acons (1+ count) type compressed))
               (compressed (acons 1 type compressed)))))))
      (emit-vec port compressed
                (lambda (port pair)
                  (match pair
                    ((count . vt)
                     (emit-u32 port count)
                     (emit-val-type port vt))))))
    (match func
      (($ <func> id type locals body)
       (emit-vec/u8 port
                    (call-with-output-bytevector
                     (lambda (port)
                       (emit-compressed-locals port locals)
                       (emit-expr port body)))))))

  (define (emit-data port data)
    (match data
      (($ <data> id 'active 0 offset init)
       (emit-u8 port #x00)
       (emit-expr port offset)
       (emit-vec/u8 port init))
      (($ <data> id 'passive #f offset init)
       (emit-u8 port #x01)
       (emit-vec/u8 port init))
      (($ <data> id 'active mem offset init)
       (emit-u8 port #x02)
       (emit-u32 port mem)
       (emit-expr port offset)
       (emit-vec/u8 port init))))

  (define (emit-custom port custom)
    (match custom
      (($ <custom> name bytes)
       (emit-name port name)
       (put-bytevector port bytes))
      (($ <names> module function local label type table memory global elem
                  data field tag)
       (define (id->string id)
         (substring (symbol->string id) 1))
       (define (emit-name-map port name-map)
         (emit-vec port name-map
                   (lambda (port pair)
                     (match pair
                       ((id . name)
                        (emit-u32 port id)
                        (emit-name port (id->string name)))))))
       (define (emit-indirect-name-map port iname-map)
         (emit-vec port iname-map
                   (lambda (port pair)
                     (match pair
                       ((id . name-map)
                        (emit-u32 port id)
                        (emit-name-map port name-map))))))
       (define (emit-subsection port id subsection)
         (emit-u8 port id)
         (emit-vec/u8 port subsection))
       (define (emit-names port id name-map)
         (unless (null? name-map)
           (emit-subsection port id
                            (call-with-output-bytevector
                             (lambda (port)
                               (emit-name-map port name-map))))))
       (define (emit-indirect-names port id iname-map)
         (unless (null? iname-map)
           (emit-subsection port id
                            (call-with-output-bytevector
                             (lambda (port)
                               (emit-indirect-name-map port iname-map))))))
       (let ((bytes
              (call-with-output-bytevector
               (lambda (port)
                 (when module
                   (emit-subsection port 0
                                    (call-with-output-bytevector
                                     (lambda (port)
                                       (emit-name port (id->string module))))))
                 (emit-names port 1 function)
                 (emit-indirect-names port 2 local)
                 (emit-indirect-names port 3 label)
                 (emit-names port 4 type)
                 (emit-names port 5 table)
                 (emit-names port 6 memory)
                 (emit-names port 7 global)
                 (emit-names port 8 elem)
                 (emit-names port 9 data)
                 (emit-indirect-names port 10 field)
                 (emit-names port 11 tag)))))
         (emit-custom port (make-custom "name" bytes))))))

  (define (emit-tag port tag)
    (match tag
      (($ <tag> id type)
       (emit-tag-type port type))))

  (define (emit-section port code bytes)
    (emit-u8 port code)
    (emit-vec/u8 port bytes))

  (define (emit-vec-section port code items emit-item)
    (unless (null? items)
      (emit-section port code
                    (call-with-output-bytevector
                     (lambda (port)
                       (emit-vec port items emit-item))))))

  (match wasm
    (($ <wasm> id types imports funcs tables memories globals exports start
        elems datas tags strings custom)
     (call-with-output-bytevector
      (lambda (port)
        (put-bytevector port #vu8(#x00 #x61 #x73 #x6d)) ;; "\0asm"
        (put-bytevector port #vu8(1 0 0 0))             ;; version
        (emit-vec-section port 1 types emit-type-def)
        (emit-vec-section port 2 imports emit-import)
        (emit-vec-section port 3 funcs emit-func-decl)
        (emit-vec-section port 4 tables emit-table)
        (emit-vec-section port 5 memories emit-memory)
        (emit-vec-section port 13 tags emit-tag)
        (unless (null? strings)
          (emit-section port 14 (call-with-output-bytevector
                                 (lambda (port)
                                   (emit-u8 port #x00)
                                   (emit-vec port strings emit-name)))))
        (emit-vec-section port 6 globals emit-global)
        (emit-vec-section port 7 exports emit-export)
        (when start
          (emit-section port 8 (call-with-output-bytevector
                                (lambda (port)
                                  (emit-u32 port start)))))
        (emit-vec-section port 9 elems emit-element)
        (unless (null? datas)
          (emit-section port 12 (call-with-output-bytevector
                                 (lambda (port)
                                   (emit-u32 port (length datas))))))
        (emit-vec-section port 10 funcs emit-func-def)
        (emit-vec-section port 11 datas emit-data)
        (unless (null? custom)
          (for-each (lambda (custom)
                      (emit-section port 0
                                    (call-with-output-bytevector
                                     (lambda (port)
                                       (emit-custom port custom)))))
                    custom)))))))