;;; WebAssembly virtual machine
;;; Copyright (C) 2023, 2026 David Thompson <dave@spritely.institute>
;;; Copyright (C) 2023 Igalia, S.L.
;;;
;;; 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:
;;;
;;; Interpreter for WebAssembly.
;;;
;;; Code:

(define-module (wasm vm)
  #:use-module (ice-9 exceptions)
  #:use-module (ice-9 match)
  #:use-module (rnrs bytevectors)
  #:use-module (rnrs bytevectors gnu)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-4)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (wasm canonical-types)
  #:use-module (wasm subtyping)
  #:use-module ((wasm stack) #:select (wasm-info-type-mapping
                                       wasm-info-types
                                       wasm-info-canonicalization))
  #:use-module (wasm types)
  #:use-module (wasm validate)
  #:export (make-wasm-global
            wasm-global?
            wasm-global-ref
            wasm-global-set!
            wasm-global-mutable?

            make-wasm-memory
            wasm-memory?
            wasm-memory-bytes
            wasm-memory-size
            wasm-memory-limits
            wasm-memory-grow!

            make-wasm-table
            wasm-table?
            wasm-table-size
            wasm-table-ref
            wasm-table-set!
            wasm-table-fill!
            wasm-table-copy!
            wasm-table-init!
            wasm-table-grow!

            wasm-stack?
            wasm-stack-items

            wasm-func?
            wasm-null?
            wasm-struct?

            make-wasm-array
            bytevector->wasm-array
            wasm-array->bytevector
            wasm-array?
            wasm-array-element-type
            wasm-array-length
            wasm-array-ref
            wasm-array-ref-unsigned
            wasm-array-ref-signed
            wasm-array-set!

            instantiate-wasm
            wasm-instance?
            wasm-instance-module
            wasm-instance-export-ref
            wasm-instance-export-names

            current-instruction-listener

            &wasm-instance-error
            wasm-instance-error?

            &wasm-runtime-error
            wasm-runtime-error?
            wasm-runtime-error-position
            wasm-runtime-error-instruction
            wasm-runtime-error-instance
            wasm-runtime-error-stack
            wasm-runtime-error-blocks
            wasm-runtime-error-locals))


;;;
;;; Types
;;;

(define (s32? x)
  (and (exact-integer? x) (< (- (ash -1 31) 1) x (ash 1 31))))

(define (s31? x)
  (and (exact-integer? x) (< (- (ash -1 30) 1) x (ash 1 30))))

(define (u32? x)
  (and (exact-integer? x) (< -1 x (- (ash 1 32) 1))))

(define (s8->u8 x)
  (logand x #xff))

(define (s8-overflow x)
  (centered-remainder x (ash 1 8)))

(define (s16->u16 x)
  (logand x #xffff))

(define (s16-overflow x)
  (centered-remainder x (ash 1 16)))

(define (s32->u32 x)
  (logand x #xffffFFFF))

(define (s31->u31 x)
  (logand x #x7fffFFFF))

(define (s32-overflow x)
  (centered-remainder x (ash 1 32)))

(define (s64? x)
  (and (exact-integer? x) (< (- (ash -1 63) 1) x (ash 1 63))))

(define (u64? x)
  (and (exact-integer? x) (< -1 x (- (ash 1 64) 1))))

(define (s64->u64 x)
  (logand x #xffffFFFFffffFFFF))

(define (s64-overflow x)
  (centered-remainder x (ash 1 64)))

(define (f32? x)
  (and (number? x) (or (inexact? x) (exact-integer? x))))

(define (f64? x)
  (and (number? x) (or (inexact? x) (exact-integer? x))))

(define (resolve-type type)
  (match type
    (($ <sub-type> _ _ type) type)
    (_ type)))


;;;
;;; Instances
;;;

(define-exception-type &wasm-runtime-error &wasm-error
  make-wasm-runtime-error
  wasm-runtime-error?
  (instruction wasm-runtime-error-instruction)
  (position wasm-runtime-error-position)
  (instance wasm-runtime-error-instance)
  (stack wasm-runtime-error-stack)
  (blocks wasm-runtime-error-blocks)
  (locals wasm-runtime-error-locals))

;; TODO: Use a vector instead of a list to avoid allocation for each
;; push.  Maximum stack depth for each function can be determined at
;; validation time.
(define-record-type <wasm-stack>
  (%make-wasm-stack items)
  wasm-stack?
  (items wasm-stack-items set-wasm-stack-items!))

(define (make-wasm-stack)
  (%make-wasm-stack '()))

(define (stack-push! stack x)
  (set-wasm-stack-items! stack (cons x (wasm-stack-items stack))))

(define (stack-push-all! stack vals)
  (for-each (lambda (val)
              (stack-push! stack val))
            vals))

(define (stack-peek stack)
  (match (wasm-stack-items stack)
    (() #f)
    ((head . _)
     head)))

(define (stack-pop! stack)
  (match (wasm-stack-items stack)
    (() #f)
    ((head . rest)
     (set-wasm-stack-items! stack rest)
     head)))

(define (stack-pop-n! stack n)
  (let loop ((n n)
             (result '()))
    (if (= n 0)
        result
        (loop (- n 1) (cons (stack-pop! stack) result)))))

;; This is similar to what's in (wasm dump), but is for canonical type
;; objects: no names, and heap type reference indices are canonical, not
;; local.
(define* (heap-type-repr type #:optional
                         ;; Defaulting to the current canonicalization
                         ;; is usually the right thing to do but if you
                         ;; do actually have multiple canonicalizations,
                         ;; this is a footgun: you might not resolve
                         ;; references against the right
                         ;; canonicalization.  Oh well.
                         (canonicalization (current-canonicalization))
                         (seen '()))
  (define (sub-type-repr type seen)
    (define (%heap-type-repr type)
      (heap-type-repr type canonicalization seen))

    (define (value-type-repr type)
      (match type
        (($ <ref-type> #t ht)
         `(ref null ,(%heap-type-repr ht)))
        (($ <ref-type> #f ht)
         `(ref ,(%heap-type-repr ht)))
        (_ type)))

    (define (params-repr params)
      (match params
        (() '())
        ((($ <param> #f type) ...)
         `((param ,@(map value-type-repr type))))))

    (define (results-repr results)
      `((result ,@(map value-type-repr results))))

    (define (field-repr field)
      (define (wrap mutable? repr)
        (if mutable? `(mut ,repr) repr))
      (match field
        (($ <field> #f mutable? type)
         (wrap mutable? (value-type-repr type)))))

    (define (base-type-repr type)
      (match type
        (($ <func-sig> params results)
         `(func ,@(params-repr params) ,@(results-repr results)))
        (($ <struct-type> fields)
         `(struct ,@(map field-repr fields)))
        (($ <array-type> mutable? type)
         `(array ,(field-repr (make-field #f mutable? type))))))

    (match type
      (($ <sub-type> final? supers type)
       `(sub ,@(if final? '(final) '())
             ,@(map %heap-type-repr supers)
             ,(base-type-repr type)))
      (type (base-type-repr type))))

  (match type
    ((? symbol?) type)                  ; e.g. 'extern
    ((? exact-integer?)
     (if (memv type seen)
         '_
         (sub-type-repr (canonical-type-ref canonicalization type)
                        (cons type seen))))))

;; TODO: Replace with global weak hash table that maps procedures to
;; signatures.
(define-record-type <wasm-func>
  (make-wasm-func proc type)
  wasm-func?
  (proc wasm-func-proc)
  (type wasm-func-type)) ; Canonical type index.

(set-record-type-printer! <wasm-func>
                          (lambda (f port)
                            (format port "#<wasm-func ~a ~a>"
                                    (heap-type-repr (wasm-func-type f))
                                    (object-address f))))

(define-record-type <wasm-global>
  (make-wasm-global value mutable?)
  wasm-global?
  (value wasm-global-ref %wasm-global-set!)
  (mutable? wasm-global-mutable?))

(define (wasm-global-set! global val)
  (if (wasm-global-mutable? global)
      (%wasm-global-set! global val)
      (error "WASM global is immutable" global)))

(define %page-size (* 64 1024))
(define %max-pages (/ (ash 1 32) %page-size))

(define (clamp-to-limits x limits default-max)
  (match limits
    (($ <limits> min max)
     (let ((max* (or max default-max)))
       (cond
        ((< x min) min)
        ((> x max*) max*)
        (else x))))))

(define-record-type <wasm-memory>
  (%make-wasm-memory bytes size limits)
  wasm-memory?
  (bytes wasm-memory-bytes set-wasm-memory-bytes!)
  (size wasm-memory-size set-wasm-memory-size!)
  (limits wasm-memory-limits))

(define (make-bytevector/pages n)
  (make-bytevector (* n %page-size) 0))

(define* (make-wasm-memory size #:optional (limits (make-limits 1 #f)))
  (let ((size* (clamp-to-limits size limits %max-pages)))
    (%make-wasm-memory (make-bytevector/pages size*) size* limits)))

(define (wasm-memory-grow! memory n)
  (match memory
    (($ <wasm-memory> old-bytes old-size limits)
     (if (= n 0)
         old-size
         (let ((new-size (clamp-to-limits (+ (wasm-memory-size memory) n)
                                          limits %max-pages)))
           (if (= new-size old-size)
               -1
               (let ((new-bytes (make-bytevector/pages new-size)))
                 (bytevector-copy! old-bytes 0 new-bytes 0
                                   (* old-size %page-size))
                 (set-wasm-memory-bytes! memory new-bytes)
                 (set-wasm-memory-size! memory new-size)
                 old-size)))))))

(define-record-type <wasm-table>
  (%make-wasm-table elements limits)
  wasm-table?
  (elements wasm-table-elements set-wasm-table-elements!)
  (limits wasm-table-limits))

(define %max-table-size (- (ash 1 32) 1))

(define* (make-wasm-table size #:optional (limits (make-limits 1 #f)))
  (let ((size* (clamp-to-limits size limits %max-table-size)))
    (%make-wasm-table (make-vector size*) limits)))

(define (wasm-table-size table)
  (vector-length (wasm-table-elements table)))

(define (wasm-table-ref table i)
  (vector-ref (wasm-table-elements table) i))

(define (wasm-table-set! table i x)
  (vector-set! (wasm-table-elements table) i x))

(define (wasm-table-fill! table start fill length)
  (vector-fill! (wasm-table-elements table) fill start (+ start length)))

(define (wasm-table-copy! table at src start length)
  (vector-copy! (wasm-table-elements table) at (wasm-table-elements src)
                start (+ start length)))

(define (wasm-table-init! table at elems start length)
  (vector-copy! (wasm-table-elements table) at elems start (+ start length)))

(define (wasm-table-grow! table n init)
  (match table
    (($ <wasm-table> elems limits)
     (let ((old-size (vector-length elems)))
       (if (= n 0)
           old-size
           (let ((new-size (clamp-to-limits (+ old-size n) limits %max-table-size)))
             (if (= new-size old-size)
                 -1
                 (let ((new-elems (make-vector new-size)))
                   (vector-copy! new-elems 0 elems)
                   (do ((i old-size (+ i 1)))
                       ((= i new-size))
                     (vector-set! new-elems i init))
                   (set-wasm-table-elements! table new-elems)
                   old-size))))))))

(define-record-type <wasm-null>
  (make-wasm-null type)
  wasm-null?
  (type wasm-null-type))

(set-record-type-printer! <wasm-null>
                          (lambda (struct port)
                            (format port "#<wasm-null ~a>"
                                    (heap-type-repr
                                     (wasm-null-type struct)))))

;; TODO: Packed fields.
(define-record-type <wasm-struct>
  (make-wasm-struct type fields)
  wasm-struct?
  (type wasm-struct-type) ; Canonical type index.
  (fields wasm-struct-fields))

(set-record-type-printer! <wasm-struct>
                          (lambda (struct port)
                            (format port "#<wasm-struct ~a ~a>"
                                    (heap-type-repr
                                     (wasm-struct-type struct))
                                    (object-address struct))))

(define-record-type <wasm-array>
  (%make-wasm-array type vector)
  wasm-array?
  (type wasm-array-type) ; Canonical type index.
  (vector wasm-array-vector)) ; Scheme vector, or typed array (s8vector, etc).

(define (wasm-array->bytevector array)
  (let ((v (wasm-array-vector array)))
    (bytevector-slice v 0 (bytevector-length v))))

(define (packed-data-width tag)
  (match tag
    ('s8 1)
    ('s16 2)
    ((or 's32 'f32) 4)
    ((or 's64 'f64) 8)))

(define (packed-data-copy! tag dst at src start length)
  (let ((unit-size (packed-data-width tag)))
    (bytevector-copy! src (* start unit-size)
                      dst (* at unit-size) (* length unit-size))))

(define (packed-data-copy tag src start length)
  (let* ((dst (make-typed-array tag 0 length)))
    (packed-data-copy! tag dst 0 src start length)
    dst))

(define* (bytevector->wasm-array bv #:optional
                                 (canonicalization (current-canonicalization)))
  (%make-wasm-array (canonical-mutable-i8-array-heap-type canonicalization)
                    (packed-data-copy 's8 bv 0 (bytevector-length bv))))

(set-record-type-printer! <wasm-array>
                          (lambda (array port)
                            (format port "#<wasm-array ~a ~a>"
                                    (heap-type-repr
                                     (wasm-array-type array))
                                    (object-address array))))

(define (default-for-type type)
  (match type
    ((or 'i8 'i16 'i32 'i64) 0)
    ((or 'f32 'f64) 0.0)
    (($ <ref-type> nullable? ht)
     ;; This function is used in validated contexts, which prevents null
     ;; from actually flowing to wasm if nullable? is false.
     (make-wasm-null ht))))

(define* (make-wasm-array type field-type k #:optional
                          (fill (default-for-type field-type)))
  (%make-wasm-array type
                    (match field-type
                      ('i8 (make-s8vector k (s8-overflow fill)))
                      ('i16 (make-s16vector k (s16-overflow fill)))
                      ('i32 (make-s32vector k fill))
                      ('i64 (make-s64vector k fill))
                      ('f32 (make-f32vector k fill))
                      ('f64 (make-f64vector k fill))
                      (_ (make-vector k fill)))))

(define (wasm-array-length array)
  (let ((v (wasm-array-vector array)))
    (if (vector? v)
        (vector-length v)
        (match (array-type v)
          ('s8 (s8vector-length v))
          ('s16 (s16vector-length v))
          ('s32 (s32vector-length v))
          ('s64 (s64vector-length v))
          ('f32 (f32vector-length v))
          ('f64 (f64vector-length v))))))

(define (wasm-array-ref array i)
  (let ((v (wasm-array-vector array)))
    (if (vector? v)
        (vector-ref v i)
        (match (array-type v)
          ('s8 (s8vector-ref v i))
          ('s16 (s16vector-ref v i))
          ('s32 (s32vector-ref v i))
          ('s64 (s64vector-ref v i))
          ('f32 (f32vector-ref v i))
          ('f64 (f64vector-ref v i))))))

(define (wasm-array-ref-unsigned array i)
  (let ((v (wasm-array-vector array)))
    (match (array-type v)
      ('s8 (u8vector-ref v i))
      ('s16 (u16vector-ref v i)))))

(define (wasm-array-ref-signed array i)
  (let ((v (wasm-array-vector array)))
    (match (array-type v)
      ('s8 (s8vector-ref v i))
      ('s16 (s16vector-ref v i)))))

(define (wasm-array-set! array i value)
  (let ((v (wasm-array-vector array)))
    (if (vector? v)
        (vector-set! v i value)
        (match (array-type v)
          ('s8 (s8vector-set! v i (s8-overflow value)))
          ('s16 (s16vector-set! v i (s16-overflow value)))
          ('s32 (s32vector-set! v i value))
          ('s64 (s64vector-set! v i value))
          ('f32 (f32vector-set! v i value))
          ('f64 (f64vector-set! v i value))))))

(define (wasm-array-init-data! array at data offset length)
  (let ((v (wasm-array-vector array)))
    (packed-data-copy! (array-type v) v at data offset length)))

(define (wasm-array-init-elem! array at elem offset length)
  (vector-copy! (wasm-array-vector array) at elem offset (+ offset length)))

(define (wasm-array-fill! array start fill length)
  (let ((v (wasm-array-vector array)))
    (define (fill! set! fill)
      (let lp ((i 0))
        (when (< i length)
          (set! v (+ start i) fill)
          (lp (1+ i)))))
    (if (vector? v)
        (vector-fill! v fill start (+ start length))
        (match (array-type v)
          ('s8 (fill! s8vector-set! (s8-overflow fill)))
          ('s16 (fill! s16vector-set! (s16-overflow fill)))
          ('s32 (fill! s32vector-set! fill))
          ('s64 (fill! s64vector-set! fill))
          ('f32 (fill! f32vector-set! fill))
          ('f64 (fill! f64vector-set! fill))
          (_ vector-fill!)))))

(define (wasm-array-copy! dst at src start length)
  (let ((dstv (wasm-array-vector dst))
        (srcv (wasm-array-vector src)))
    (if (vector? dstv)
        (vector-copy! dstv at srcv start (+ start length))
        (packed-data-copy! (array-type dstv) dstv at srcv start length))))

(define (wasm-array->string array start end)
  (utf8->string
   (bytevector-slice (wasm-array-vector array) start (- end start))))

(define (wasm-array-encode-string! array str start)
  (let ((utf8 (string->utf8 str)))
    ;; Note that unlike vector-copy!, s32vector-copy! etc,
    ;; bytevector-copy!'s arguments have a different order.  Incredible
    ;; stuff.
    (bytevector-copy! utf8 0 (wasm-array-vector array) start
                      (bytevector-length utf8))))

(define-record-type <wasm-string-iterator>
  (make-wasm-string-iterator string index)
  wasm-string-iterator?
  (string wasm-string-iterator-string)
  (index wasm-string-iterator-index set-wasm-string-iterator-index!))

(define (wasm-string-iterator-next! iter)
  (match iter
    (($ <wasm-string-iterator> str i)
     (let ((len (string-length str)))
       (set-wasm-string-iterator-index! iter (+ i 1))
       (if (>= i len)
           -1
           (char->integer (string-ref str i)))))))

(define (wasm-string-iterator-advance! iter k)
  (match iter
    (($ <wasm-string-iterator> str i)
     (let ((len (string-length str)))
       (set-wasm-string-iterator-index! iter (+ i k))
       (max (- (min (+ i k) len) i) 0)))))

;; Exceptions raised from Wasm via 'throw' and friends.
(define-exception-type &wasm-exception &wasm-error
  make-wasm-exception
  wasm-exception?
  (tag wasm-exception-tag)
  (args wasm-exception-args))

(define-record-type <wasm-tag>
  (make-wasm-tag type)
  wasm-tag?
  (type wasm-tag-type))

(define (scheme-value-is-a? x type canonicalization)
  "Given a Scheme value, return true if that value is compatible with the
given WebAssembly value type."
  (match type
    ('i32 (s32? x))
    ('i64 (s64? x))
    ('f32 (f32? x))
    ('f64 (f64? x))
    (($ <ref-type> nullable? ht)
     (cond
      ((wasm-null? x)
       (and nullable?
            (let ((obj-type (wasm-null-type x)))
              (heap-type<=? obj-type ht canonicalization))))
      (else
       (match ht
         ('i31 (s31? x))
         ('extern #t)
         ('exn (wasm-exception? x))
         ((or 'eq 'any) (or (s31? x) (wasm-struct? x) (wasm-array? x)))
         ('func (wasm-func? x))
         ('struct (wasm-struct? x))
         ('array (wasm-array? x))
         ('string (string? x))
         ((? exact-integer?)
          (let ((obj-type
                 (cond
                  ((wasm-func? x) (wasm-func-type x))
                  ((wasm-struct? x) (wasm-struct-type x))
                  ((wasm-array? x) (wasm-array-type x))
                  (else #f))))
            (and obj-type
                 (heap-type<=? obj-type ht canonicalization))))))))))

;; Some more global state that keeps a record of all exported WASM
;; functions so that we can avoid runtime type checking when making
;; calls directly from one instance to another.
(define *exported-functions* (make-weak-key-hash-table))

(define (register-exported-function! wrap func)
  (hashq-set! *exported-functions* wrap func))

(define (lookup-exported-function wrap)
  (hashq-ref *exported-functions* wrap))

(define-record-type <wasm-instance>
  (make-wasm-instance module type-mapping type-info
                      globals funcs memories tables datas elems
                      tags strings exports canonicalization)
  wasm-instance?
  (module wasm-instance-module)
  (type-mapping wasm-instance-type-mapping)
  (type-info wasm-instance-type-info)
  (globals wasm-instance-globals)
  (funcs wasm-instance-funcs)
  (memories wasm-instance-memories)
  (tables wasm-instance-tables)
  (datas wasm-instance-datas)
  (elems wasm-instance-elems)
  (tags wasm-instance-tags)
  (strings wasm-instance-strings)
  (exports wasm-instance-exports)
  (canonicalization wasm-instance-canonicalization))

(set-record-type-printer! <wasm-instance>
                          (lambda (instance port)
                            (format port "#<wasm-instance ~a>"
                                    (object-address instance))))

(define-exception-type &wasm-instance-error &wasm-error
  make-wasm-instance-error
  wasm-instance-error?)

(define (instance-error msg . irritants)
  (raise-exception
   (make-exception
    (make-wasm-instance-error)
    (make-exception-with-message
     (format #f "WASM instantiation error: ~a" msg))
    (make-exception-with-irritants irritants))))

(define (vector-map f src)
  (let* ((len (vector-length src))
         (dst (make-vector len)))
    (let lp ((i 0))
      (when (< i len)
        (vector-set! dst i (f (vector-ref src i)))
        (lp (1+ i))))
    dst))

(define* (instantiate-wasm module #:key (imports '()))
  (define (lookup-import mod name)
    (assoc-ref (or (assoc-ref imports mod) '()) name))
  (define wasm-info (validated-wasm-info module))
  (match (validated-wasm-ref module)
    (($ <wasm> id types wasm-imports funcs tables memories globals exports
        start elems datas tags strings custom)
     (define (count-imports kind)
       (fold (lambda (i sum)
               (match i
                 (($ <import> _ _ k)
                  (if (eq? kind k) (+ sum 1) sum))))
             0 wasm-imports))
     (let* ((n-global-imports (count-imports 'global))
            (n-func-imports (count-imports 'func))
            (n-memory-imports (count-imports 'memory))
            (n-table-imports (count-imports 'table))
            (n-tag-imports (count-imports 'tag))
            (type-mapping (wasm-info-type-mapping wasm-info))
            (type-info (vector-map (match-lambda
                                     ((id . type)
                                      (match (resolve-type type)
                                        (($ <struct-type> fields)
                                         (list->vector fields))
                                        (($ <array-type> mutable? field-type)
                                         field-type)
                                        ((and ($ <func-sig>) ft) ft))))
                                   (wasm-info-types wasm-info)))
            (global-vec (make-vector (+ n-global-imports (length globals))))
            (func-vec (make-vector (+ n-func-imports (length funcs))))
            (memory-vec (make-vector (+ n-memory-imports (length memories))))
            (table-vec (make-vector (+ n-table-imports (length tables))))
            (tag-vec (make-vector (+ n-tag-imports (length tags))))
            (data-vec (make-vector (length datas)))
            (elem-vec (make-vector (length elems)))
            (string-vec (list->vector strings))
            (export-table (make-hash-table))
            (canonicalization (wasm-info-canonicalization wasm-info))
            (instance (make-wasm-instance module type-mapping type-info
                                          global-vec func-vec
                                          memory-vec table-vec data-vec elem-vec
                                          tag-vec string-vec export-table
                                          canonicalization)))
       (define (%canonical-type-ref idx)
         (canonical-type-ref canonicalization idx))
       (define (type-check vals types)
         (unless (let loop ((vals vals)
                            (types types))
                   (match vals
                     (()
                      (match types
                        (() #t)
                        (_ #f)))
                     ((val . rest-vals)
                      (match types
                        (() #f)
                        ((type . rest-types)
                         (and (scheme-value-is-a? val type canonicalization)
                              (loop rest-vals rest-types)))))))
           (error (format #f "type mismatch; expected ~a" types)
                  vals)))
       (define (convert-results vals types)
         (map (lambda (val type)
                (match type
                  ('i32
                   (match val
                     ((? s32?) val)
                     (#t 1)
                     (#f 0)
                     (_ (error "invalid i32" val))))
                  ;; For (ref null extern), #f is converted to a null
                  ;; WASM value.
                  (($ <ref-type> #t 'extern)
                   (match val
                     (#f (make-wasm-null 'extern))
                     (_ val)))
                  (_ val)))
              vals types))
       (define (make-import-closure mod name proc sig)
         (let ((result-types (func-sig-results sig)))
           (define (wrap . args)
             (call-with-values (lambda () (apply proc args))
               (lambda vals
                 (let ((vals* (convert-results vals result-types)))
                   (type-check vals* result-types)
                   (apply values vals*)))))
           (set-procedure-property! wrap 'name (format #f "~a:~a" mod name))
           wrap))
       (define (make-export-closure name func)
         (match func
           (($ <wasm-func> proc (= %canonical-type-ref
                                   ($ <func-sig>
                                      (($ <param> _ param-types) ...) results)))
            (define (wrap . args)
              (type-check args param-types)
              (apply proc args))
            (set-procedure-property! wrap 'name (string->symbol name))
            wrap)))
       (define (instantiate-func idx func)
         (match func
           (($ <func> _ ($ <type-use> type-idx) locals body)
            (let* ((local-types (map local-type locals))
                   (ht (vector-ref type-mapping type-idx))
                   (sig (vector-ref type-info type-idx))
                   (n-params (length (func-sig-params sig)))
                   (n-results (length (func-sig-results sig)))
                   (n-locals (length local-types))
                   (base-path `(,idx func)))
              (define (wasm-proc . args)
                (let ((stack (make-wasm-stack))
                      (locals (make-vector (+ n-params n-locals))))
                  ;; Initialize first n locals with args.
                  (let loop ((args args)
                             (i 0))
                    (match args
                      (() #t)
                      ((arg . rest)
                       (vector-set! locals i arg)
                       (loop rest (+ i 1)))))
                  ;; Initialize rest of locals with defaults.
                  (let loop ((types local-types)
                             (i n-params))
                    (match types
                      (() #t)
                      ((type . rest)
                       (vector-set! locals i (default-for-type type))
                       (loop rest (+ i 1)))))
                  ;; Execute the function body, handling early
                  ;; returns.  There are two classes of returns:
                  ;; return and return-call.  A regular return simply
                  ;; returns the top n values on the stack.  A
                  ;; return-call passes along a thunk to be tail
                  ;; called which will continue the computation.
                  (let ((tail-cont #f))
                    (call-with-block
                     (lambda (tag)
                       (execute* body base-path instance stack (list tag) locals))
                     (lambda (k)
                       (set! tail-cont k)))
                    (if tail-cont
                        (tail-cont)
                        (apply values (stack-pop-n! stack n-results))))))
              (make-wasm-func wasm-proc ht)))))
       (define (exec-init base-path init)
         (let ((stack (make-wasm-stack)))
           (execute* init (reverse base-path) instance stack '() #())
           (stack-pop! stack)))
       ;; Process imports.
       (let loop ((wasm-imports wasm-imports)
                  (global-idx 0)
                  (func-idx 0)
                  (memory-idx 0)
                  (table-idx 0)
                  (tag-idx 0))
         (match wasm-imports
           (() #t)
           ((($ <import> mod name 'func _ ($ <type-use> idx)) . rest)
            (let ((ht (vector-ref type-mapping idx))
                  (sig (vector-ref type-info idx)))
              (match (lookup-import mod name)
                ((? procedure? proc)
                 ;; If proc is a wrapper around a WASM function from
                 ;; another instance, then we'll just use the internal
                 ;; procedure instead and skip unnecessary runtime type
                 ;; checking.
                 (match (lookup-exported-function proc)
                   ((and func ($ <wasm-func> _ other-ht))
                    (if (eq? ht other-ht)
                        (vector-set! func-vec func-idx func)
                        (instance-error "imported function signature mismatch"
                                        mod name ht other-ht)))
                   (#f
                    (let ((wrap (make-import-closure mod name proc sig)))
                      (vector-set! func-vec func-idx (make-wasm-func wrap ht)))))
                 (loop rest global-idx (+ func-idx 1) memory-idx table-idx tag-idx))
                (x (instance-error "invalid function import" mod name x)))))
           ((($ <import> mod name 'global _ _) . rest)
            (match (lookup-import mod name)
              ((? wasm-global? global)
               (vector-set! global-vec global-idx global)
               (loop rest (+ global-idx 1) func-idx memory-idx table-idx tag-idx))
              (x (instance-error "invalid global import" mod name x))))
           ((($ <import> mod name 'memory _ _) . rest)
            (match (lookup-import mod name)
              ((? wasm-memory? memory)
               (vector-set! memory-vec memory-idx memory)
               (loop rest global-idx func-idx (+ memory-idx 1) table-idx tag-idx))
              (x (instance-error "invalid memory import" mod name x))))
           ((($ <import> mod name 'table _ _) . rest)
            (match (lookup-import mod name)
              ((? wasm-table? table)
               (vector-set! table-vec table-idx table)
               (loop rest global-idx func-idx memory-idx (+ table-idx 1) tag-idx))
              (x (instance-error "invalid table import" mod name x))))
           ((($ <import> mod name 'tag _ type) . rest)
            (match (lookup-import mod name)
              ((? wasm-tag? tag)
               (match type
                 (($ <tag-type> 'exception ($ <type-use> idx))
                  (let ((declared-type (vector-ref type-info idx))
                        (imported-type (wasm-tag-type tag)))
                    (unless (eq? declared-type imported-type)
                      (instance-error "imported tag signature mismatch"
                                      mod name declared-type imported-type))
                    (vector-set! tag-vec tag-idx tag)
                    (loop rest global-idx func-idx memory-idx table-idx (+ tag-idx 1))))
                 (instance-error "invalid tag type" mod name type)))
              (x (instance-error "invalid tag import" mod name x))))))
       ;; Initialize tags.
       (let loop ((tags tags)
                  (idx n-tag-imports))
         (match tags
           (() #t)
           ((($ <tag> _ ($ <tag-type> _ ($ <type-use> type-idx))) . rest)
            (let ((tag (make-wasm-tag (vector-ref type-info type-idx))))
              (vector-set! tag-vec idx tag))
            (loop rest (+ idx 1)))))
       ;; Initialize functions.
       (let loop ((funcs funcs)
                  (idx n-func-imports))
         (match funcs
           (() #t)
           ((func . rest)
            (vector-set! func-vec idx (instantiate-func idx func))
            (loop rest (+ idx 1)))))
       ;; Initialize globals.
       (let loop ((globals globals)
                  (idx n-global-imports))
         (match globals
           (() #t)
           (((and ($ <global> _ ($ <global-type> mutable? type) init) global) . rest)
            (let ((global (make-wasm-global (exec-init `(global ,idx) init) mutable?)))
              (vector-set! global-vec idx global))
            (loop rest (+ idx 1)))))
       ;; Initialize memories.
       (let loop ((memories memories)
                  (idx n-memory-imports))
         (match memories
           (() #t)
           ((($ <memory> _ ($ <mem-type> (and ($ <limits> min) limits))) . rest)
            (vector-set! memory-vec idx (make-wasm-memory min limits))
            (loop rest (+ idx 1)))))
       ;; Initialize data segments and copy active ones into memory.
       (let loop ((datas datas) (idx 0))
         (match datas
           (() #t)
           (((and ($ <data> _ mode mem-id instrs init) data) . rest)
            (vector-set! data-vec idx init)
            (when (eq? mode 'active)
              ;; Invoke the VM to process the constant
              ;; expressions that produce the offset value.
              (let ((offset (exec-init `(data ,idx) instrs))
                    (memory (vector-ref memory-vec mem-id)))
                (bytevector-copy! init 0 (wasm-memory-bytes memory)
                                  offset (bytevector-length init))))
            (loop rest (+ idx 1)))))
       ;; Initialize tables.
       (let loop ((tables tables)
                  (idx n-table-imports))
         (match tables
           (() #t)
           ((($ <table> _ ($ <table-type> (and ($ <limits> min) limits)) init) . rest)
            (vector-set! table-vec idx (make-wasm-table min limits))
            (loop rest (+ idx 1)))))
       ;; Initialize elements and copy active elements into tables.
       (let loop ((elems elems)
                  (idx 0))
         (match elems
           (() #t)
           (((and elem ($ <elem> _ mode table-idx type offset inits)) . rest)
            (let ((table (and table-idx (vector-ref table-vec table-idx)))
                  (offset (and (eq? mode 'active)
                               (exec-init `(elem ,idx 0) offset)))
                  (init-vec (list->vector
                             (let init-loop ((inits inits) (j 1))
                               (match inits
                                 (() '())
                                 ((instrs . rest)
                                  (cons (exec-init `(elem ,idx ,j) instrs)
                                        (init-loop rest (+ j 1)))))))))
              (vector-set! elem-vec idx init-vec)
              (when table
                (do ((i 0 (+ i 1)))
                    ((= i (vector-length init-vec)))
                  (wasm-table-set! table (+ offset i) (vector-ref init-vec i))))
              (loop rest (+ idx 1))))))
       ;; Call start function, if present.
       (when start ((wasm-func-proc (vector-ref func-vec start))))
       ;; Populate export table.
       (for-each (match-lambda
                   (($ <export> name 'func idx)
                    (let* ((func (vector-ref func-vec idx))
                           (wrap (make-export-closure name func)))
                      (register-exported-function! wrap func)
                      (hash-set! export-table name wrap)))
                   (($ <export> name 'global idx)
                    (hash-set! export-table name (vector-ref global-vec idx)))
                   (($ <export> name 'memory idx)
                    (hash-set! export-table name (vector-ref memory-vec idx)))
                   (($ <export> name 'table idx)
                    (hash-set! export-table name (vector-ref table-vec idx)))
                   (($ <export> name 'tag idx)
                    (hash-set! export-table name (vector-ref tag-vec idx))))
                 exports)
       instance))))

(define (wasm-instance-export-ref instance name)
  (hash-ref (wasm-instance-exports instance) name))

(define (wasm-instance-export-names instance)
  (hash-fold (lambda (k v memo) (cons k memo))
             '() (wasm-instance-exports instance)))

(define (wasm-instance-global-ref instance idx)
  (vector-ref (wasm-instance-globals instance) idx))

(define (wasm-instance-drop-elem! instance idx)
  (vector-set! (wasm-instance-elems instance) idx #f))

;; Blocks are delimited by a prompt so that 'br', 'return',
;; 'return_call' and friends can abort to that prompt.
(define (call-with-block proc handler)
  (let ((tag (make-prompt-tag 'wasm-block)))
    (call-with-prompt tag
      (lambda ()
        (proc tag))
      ;; The 'return_call' family of instructions need to pass along a
      ;; continuation that can be tail called after aborting to the
      ;; prompt.
      (lambda (_k thunk)
        (handler thunk)))))

;; Debugging/instrumentation hook, called before each instruction.
(define current-instruction-listener
  (make-parameter (lambda (instr path instance stack blocks locals) #t)))

(define (execute instr path instance stack blocks locals)
  (define (runtime-error msg . irritants)
    (let ((path* (reverse path)))
      (raise-exception
       (make-exception
        (make-wasm-runtime-error instr path* instance stack blocks locals)
        (make-exception-with-message
         (format #f "WASM runtime error: ~a" msg))
        (make-exception-with-irritants irritants))
       #:continuable? #t)))
  ;; Stack shorthands.
  (define (push x) (stack-push! stack x))
  (define (push-all lst) (stack-push-all! stack lst))
  (define (pop) (or (stack-pop! stack) (runtime-error "empty stack")))
  (define (pop-n n) (stack-pop-n! stack n))
  (define (peek) (or (stack-peek stack) (runtime-error "empty stack")))
  ;; Macro for let-binding values popped off the stack.
  (define-syntax lets
    (lambda (x)
      (syntax-case x ()
        ((_ (var ...) body ...)
         ;; Popping the stack gets the last arg, so reverse binding
         ;; order.
         (with-syntax (((var ...) (reverse #'(var ...))))
           #'(let* ((var (pop)) ...) body ...))))))
  (define (%canonical-type-ref idx)
    (canonical-type-ref (wasm-instance-canonicalization instance) idx))
  ;; Control flow helpers.
  (define (call* func)
    (match func
      (($ <wasm-func> proc (= %canonical-type-ref ($ <func-sig> params)))
       (apply proc (pop-n (length params))))
      (x (runtime-error "not a function" x))))
  (define (call func)
    (call-with-values (lambda () (call* func))
      (lambda vals (push-all vals))))
  (define (return* thunk)
    ;; The current function's tag is at the bottom.
    (match blocks
      ((_ ... tag)
       (abort-to-prompt tag thunk))))
  (define (return) (return* #f))
  (define (return-call f) (return* (lambda () (call* f))))
  (define (branch l) (abort-to-prompt (list-ref blocks l) #f))
  (define* (block path body branch)
    (call-with-block
     (lambda (block)
       (execute* body path instance stack (cons block blocks) locals))
     (lambda (thunk)
       (when (procedure? thunk)
         (thunk))
       (branch))))
  (define (end) 'end)
  ;; Convenience macros.
  (define-syntax-rule (unop proc)
    (push (proc (pop))))
  (define-syntax-rule (u32-unop proc)
    (unop (lambda (a) (proc (s32->u32 a)))))
  (define-syntax-rule (u64-unop proc)
    (unop (lambda (a) (proc (s64->u64 a)))))
  (define-syntax-rule (binop proc)
    (lets (a b) (push (proc a b))))
  (define-syntax-rule (compare pred)
    (binop (lambda (a b) (if (pred a b) 1 0))))
  (define-syntax-rule (compare1 pred)
    (unop (lambda (a) (if (pred a) 1 0))))
  (define-syntax-rule (s32-binop proc)
    (binop (lambda (a b) (s32-overflow (proc a b)))))
  (define-syntax-rule (s64-binop proc)
    (binop (lambda (a b) (s64-overflow (proc a b)))))
  (define-syntax-rule (u32-binop proc)
    (s32-binop (lambda (a b) (s32-overflow (proc (s32->u32 a) (s32->u32 b))))))
  (define-syntax-rule (u64-binop proc)
    (s64-binop (lambda (a b) (s64-overflow (proc (s64->u64 a) (s64->u64 b))))))
  (define-syntax-rule (u32-compare pred)
    (compare (lambda (a b) (pred (s32->u32 a) (s32->u32 b)))))
  (define-syntax-rule (u64-compare pred)
    (compare (lambda (a b) (pred (s64->u64 a) (s64->u64 b)))))
  ;; Math/bitwise op helpers.
  (define (!= a b) (not (= a b)))
  (define (shl n m k) (modulo (ash n (modulo m k)) (ash 1 k)))
  (define (shl32 n m) (shl n m 32))
  (define (shl64 n m) (shl n m 64))
  (define (shr n m k) (ash n (- (modulo m k))))
  (define (shr32 n m) (shr n m 32))
  (define (shr64 n m) (shr n m 64))
  (define (rotl n m k) (logior (ash n m) (ash n (- (- k m)))))
  (define (rotl32 n m) (rotl n m 32))
  (define (rotl64 n m) (rotl n m 64))
  (define (rotr n m k) (logior (ash n (- m)) (ash n (- k m))))
  (define (rotr32 n m) (rotr n m 32))
  (define (rotr64 n m) (rotr n m 64))
  (define (clz n k)
    (let loop ((i (- k 1))
               (result 0))
      (if (or (= i -1) (logbit? i n))
          result
          (loop (- i 1) (+ result 1)))))
  (define (clz32 n) (clz n 32))
  (define (clz64 n) (clz n 64))
  (define (ctz n k)
    (let loop ((i 0)
               (result 0))
      (if (or (= i k) (logbit? i n))
          result
          (loop (+ i 1) (+ result 1)))))
  (define (ctz32 n) (ctz n 32))
  (define (ctz64 n) (ctz n 64))
  (define (wrap n k)
    (remainder n (ash 1 k)))
  (define (wrap8 n) (wrap n 8))
  (define (wrap16 n) (wrap n 16))
  (define (wrap32 n) (wrap n 32))
  (define (wrap64 n) (wrap n 64))
  (define (s32->s64 x) x)
  (define (u32->s64 x) (s32->u32 x))
  (define (copy-sign a b)
    (define (sign-bit x)
      (if (or (> x 0.0) (eqv? x 0.0) (nan? x)) 0 1))
    (if (zero? (- (sign-bit a) (sign-bit b))) a (- a)))
  (define (float->int x pred)
    (let ((y (inexact->exact (truncate x))))
      (if (pred y) y (runtime-error "integer overflow"))))
  (define (float->s32 x) (float->int x s32?))
  (define (float->u32 x) (float->int x u32?))
  (define (float->s64 x) (float->int x s64?))
  (define (float->u64 x) (float->int x u64?))
  (define (reinterpret x make-bv ref)
    (ref (make-bv x) 0))
  (define (reinterpret/s32->f32 x)
    (reinterpret x s32vector f32vector-ref))
  (define (reinterpret/s64->f64 x)
    (reinterpret x s64vector f64vector-ref))
  (define (reinterpret/f32->s32 x)
    (reinterpret x f32vector s32vector-ref))
  (define (reinterpret/f64->s64 x)
    (reinterpret x f64vector s64vector-ref))
  ;; Memory helpers
  (define (memory-ref id)
    (vector-ref (wasm-instance-memories instance) id))
  (define (memory-bytes id)
    (wasm-memory-bytes (memory-ref id)))
  (define (load* id offset ref)
    (let* ((i (+ (s32->u32 (pop)) offset))
           (bv (memory-bytes id)))
      (push (ref bv i))))
  (define (load id offset ref)
    (load* id offset (lambda (bv i) (ref bv i (endianness little)))))
  (define (load-s64 id offset) (load id offset bytevector-s64-ref))
  (define (load-s32 id offset) (load id offset bytevector-s32-ref))
  (define (load-u32 id offset) (load id offset bytevector-u32-ref))
  (define (load-s16 id offset) (load id offset bytevector-s16-ref))
  (define (load-u16 id offset) (load id offset bytevector-u16-ref))
  (define (load-s8 id offset) (load* id offset bytevector-s8-ref))
  (define (load-u8 id offset) (load* id offset bytevector-u8-ref))
  (define (load-f32 id offset) (load id offset bytevector-ieee-single-ref))
  (define (load-f64 id offset) (load id offset bytevector-ieee-double-ref))
  (define (storei* id offset set wrap s->u)
    (let* ((c (wrap (s->u (pop))))
           (i (+ (s32->u32 (pop)) offset))
           (bv (memory-bytes id)))
      (set bv i c)))
  (define (storei id offset set wrap s->u)
    (storei* id offset
             (lambda (bv i c) (set bv i c (endianness little)))
             wrap s->u))
  (define (store-u64 id offset s->u)
    (storei id offset bytevector-u64-set! wrap64 s->u))
  (define (store-u32 id offset s->u)
    (storei id offset bytevector-u32-set! wrap32 s->u))
  (define (store-u16 id offset s->u)
    (storei id offset bytevector-u16-set! wrap16 s->u))
  (define (store-u8 id offset s->u)
    (storei* id offset bytevector-u8-set! wrap8 s->u))
  (define (storef id offset set)
    (let* ((c (pop))
           (i (+ (s32->u32 (pop)) offset))
           (bv (memory-bytes id)))
      (set bv i c (endianness little))))
  (define (store-f32 id offset) (storef id offset bytevector-ieee-single-set!))
  (define (store-f64 id offset) (storef id offset bytevector-ieee-double-set!))
  ;; Reference helpers:
  (define (canonical-heap-type ht)
    (match ht
      ((? integer? idx)
       (vector-ref (wasm-instance-type-mapping instance) idx))
      ((? symbol? sym) sym)))
  (define (type-info idx)
    (vector-ref (wasm-instance-type-info instance) idx))
  (define (table-ref idx)
    (vector-ref (wasm-instance-tables instance) idx))
  (define (elem-ref idx)
    (vector-ref (wasm-instance-elems instance) idx))
  (define (data-ref idx)
    (vector-ref (wasm-instance-datas instance) idx))
  (define (func-ref idx)
    (vector-ref (wasm-instance-funcs instance) idx))
  (define (tag-ref idx)
    (vector-ref (wasm-instance-tags instance) idx))
  (define (string-ref idx)
    (vector-ref (wasm-instance-strings instance) idx))
  (define (can-downcast? x nullable? ht)
    (and (or nullable? (not (wasm-null? x)))
         (heap-type<=? (match x
                         (($ <wasm-array> type) type)
                         (($ <wasm-func> _ type) type)
                         (($ <wasm-struct> type) type)
                         ((? s31?) 'i31)
                         (($ <wasm-null> type) type))
                       ht
                       (wasm-instance-canonicalization instance))))
  ;; Call instrumentation hook then execute the instruction.
  ((current-instruction-listener) path instr instance stack blocks locals)
  (match instr
    ;; Control:
    (('$source _) instr)
    (('$attr _ _) instr)
    (('nop) 'nop)
    (('unreachable)
     (runtime-error "unreachable"))
    (('block _ _ body)
     ;; Branching to a 'block' label exits the block.
     (block path body end))
    (('if _ _ consequent alternate)
     ;; Same behavior as branching to 'block', which is to exit.
     (let ((test (= (pop) 0)))
       (block (if test (cons 0 path) (cons 1 path))
              (if test alternate consequent)
              end)))
    (('loop _ _ body)
     (define (iterate)
       ;; Branching to a 'loop' label re-enters the loop.
       (block path body iterate))
     (iterate))
    (('call idx) (call (func-ref idx)))
    (('call_indirect idx _)
     (call (wasm-table-ref (table-ref idx) (pop))))
    (('call_ref _)
     (lets (f)
           (if (wasm-null? f)
               (runtime-error "null function reference" f)
               (call f))))
    (('return) (return))
    (('return_call idx)
     (return-call (func-ref idx)))
    (('return_call_indirect idx _)
     (return-call (wasm-table-ref (table-ref idx) (pop))))
    (('return_call_ref _)
     (lets (f)
           (if (wasm-null? f)
               (runtime-error "null function reference" f)
               (return-call f))))
    (('br l) (branch l))
    (('br_if l) (unless (= (pop) 0) (branch l)))
    (('br_table l* l)
     (let ((i (s32->u32 (pop))))
       (branch (if (< i (length l*)) (list-ref l* i) l))))
    ;; Exceptions:
    (('try_table _ _ catches body)
     (define (handler exn)
       (let ((tag (wasm-exception-tag exn)))
         (define (push-args-and-branch push-ref? label)
           (push-all (wasm-exception-args exn))
           (when push-ref?
             (push exn))
           (branch label))
         ;; Look for a matching catch block.
         (let loop ((catches catches))
           (match catches
             (() (raise-exception exn))
             ((('catch (= tag-ref tag) label) . catches)
              (if (eq? tag (wasm-exception-tag exn))
                  (push-args-and-branch #f label)
                  (loop catches)))
             ((('catch_ref (= tag-ref tag) label) . catches)
              (if (eq? tag (wasm-exception-tag exn))
                  (push-args-and-branch #t label)
                  (loop catches)))
             ((('catch_all label) . catches)
              (push-args-and-branch #f label))
             ((('catch_all_ref label) . catches)
              (push-args-and-branch #t label))))))
     (with-exception-handler handler
       (lambda ()
         (block path body end))
       #:unwind? #t
       #:unwind-for-type &wasm-exception))
    (('throw tag-idx)
     (let* ((tag (tag-ref tag-idx))
            (nargs (length (func-sig-params (wasm-tag-type tag)))))
       (raise-exception
        (make-wasm-exception tag (pop-n nargs)))))
    (('throw_ref)
     (raise-exception (pop)))
    ;; Parametric:
    (('drop) (pop))
    (('select)
     (if (= (pop) 0)
         (let ((x (pop)))
           (pop)
           (push x))
         (pop)))
    ;; Locals:
    (('local.get idx) (push (vector-ref locals idx)))
    (('local.set idx) (vector-set! locals idx (pop)))
    (('local.tee idx) (vector-set! locals idx (peek)))
    ;; Globals:
    (('global.get idx)
     (push (wasm-global-ref (wasm-instance-global-ref instance idx))))
    (('global.set idx)
     (wasm-global-set! (wasm-instance-global-ref instance idx) (pop)))
    ;; Numeric:
    (('i32.const x) (push x))
    (('i32.eqz) (compare1 zero?))
    (('i32.eq) (compare =))
    (('i32.ne) (compare !=))
    (('i32.lt_s) (compare <))
    (('i32.lt_u) (u32-compare <))
    (('i32.le_s) (compare <=))
    (('i32.le_u) (u32-compare <=))
    (('i32.gt_s) (compare >))
    (('i32.gt_u) (u32-compare >))
    (('i32.ge_s) (compare >=))
    (('i32.ge_u) (u32-compare >=))
    (('i32.add) (s32-binop +))
    (('i32.sub) (s32-binop -))
    (('i32.mul) (s32-binop *))
    (('i32.div_s) (s32-binop quotient))
    (('i32.div_u) (u32-binop quotient))
    (('i32.rem_s) (s32-binop remainder))
    (('i32.rem_u) (u32-binop remainder))
    (('i32.and) (binop logand))
    (('i32.or) (binop logior))
    (('i32.xor) (binop logxor))
    (('i32.shl) (s32-binop shl32))
    (('i32.shr_s) (s32-binop shr32))
    (('i32.shr_u) (u32-binop shr32))
    (('i32.rotl) (u32-binop rotl32))
    (('i32.rotr) (u32-binop rotr32))
    (('i32.clz) (u32-unop clz32))
    (('i32.ctz) (u32-unop ctz32))
    (('i32.popcnt) (u32-unop logcount))
    (('i32.wrap_i64) (unop wrap32))
    (('i32.trunc_f32_s) (unop float->s32))
    (('i32.trunc_f32_u) (unop float->u32))
    (('i32.trunc_f64_s) (unop float->s32))
    (('i32.trunc_f64_u) (unop float->u32))
    (('i32.reinterpret_f32) (unop reinterpret/f32->s32))
    (('i64.const x) (push x))
    (('i64.eqz) (compare1 zero?))
    (('i64.eq) (compare =))
    (('i64.ne) (compare !=))
    (('i64.lt_s) (compare <))
    (('i64.lt_u) (u64-compare <))
    (('i64.le_s) (compare <=))
    (('i64.le_u) (u64-compare <=))
    (('i64.gt_s) (compare >))
    (('i64.gt_u) (u64-compare >))
    (('i64.ge_s) (compare >=))
    (('i64.ge_u) (u64-compare >=))
    (('i64.add) (s64-binop +))
    (('i64.sub) (s64-binop -))
    (('i64.mul) (s64-binop *))
    (('i64.div_s) (s64-binop quotient))
    (('i64.div_u) (u64-binop quotient))
    (('i64.rem_s) (s64-binop remainder))
    (('i64.rem_u) (u64-binop remainder))
    (('i64.and) (binop logand))
    (('i64.or) (binop logior))
    (('i64.xor) (binop logxor))
    (('i64.shl) (s64-binop shl64))
    (('i64.shr_s) (s64-binop shr64))
    (('i64.shr_u) (u64-binop shr64))
    (('i64.rotl) (u64-binop rotl64))
    (('i64.rotr) (u64-binop rotr64))
    (('i64.clz) (u64-unop clz64))
    (('i64.ctz) (u64-unop ctz64))
    (('i64.popcnt) (u64-unop logcount))
    (('i64.extend_i32_s) (unop s32->s64))
    (('i64.extend_i32_u) (unop u32->s64))
    (('i64.trunc_f32_s) (unop float->s64))
    (('i64.trunc_f32_u) (unop float->u64))
    (('i64.trunc_f64_s) (unop float->s64))
    (('i64.trunc_f64_u) (unop float->u64))
    (('i64.reinterpret_f64) (unop reinterpret/f64->s64))
    (('f32.const x) (push x))
    (('f32.eq) (compare =))
    (('f32.ne) (compare !=))
    (('f32.lt) (compare <))
    (('f32.le) (compare <=))
    (('f32.gt) (compare >))
    (('f32.ge) (compare >=))
    (('f32.add) (binop +))
    (('f32.sub) (binop -))
    (('f32.mul) (binop *))
    (('f32.div) (binop /))
    (('f32.abs) (unop abs))
    (('f32.neg) (unop -))
    (('f32.ceil) (unop ceiling))
    (('f32.floor) (unop floor))
    (('f32.trunc) (unop truncate))
    (('f32.nearest) (unop round))
    (('f32.sqrt) (unop sqrt))
    (('f32.min) (binop min))
    (('f32.max) (binop max))
    (('f32.copysign) (binop copy-sign))
    (('f32.convert_i32_s) (unop exact->inexact))
    (('f32.convert_i32_u) (u32-unop exact->inexact))
    (('f32.convert_i64_s) (unop exact->inexact))
    (('f32.convert_i64_u) (u64-unop exact->inexact))
    (('f32.demote_f64) #t)
    (('f32.reinterpret_i32) (unop reinterpret/s32->f32))
    (('f64.const x) (push x))
    (('f64.eq) (compare =))
    (('f64.ne) (compare !=))
    (('f64.lt) (compare <))
    (('f64.le) (compare <=))
    (('f64.gt) (compare >))
    (('f64.ge) (compare >=))
    (('f64.add) (binop +))
    (('f64.sub) (binop -))
    (('f64.mul) (binop *))
    (('f64.div) (binop /))
    (('f64.abs) (unop abs))
    (('f64.neg) (unop -))
    (('f64.ceil) (unop ceiling))
    (('f64.floor) (unop floor))
    (('f64.trunc) (unop truncate))
    (('f64.nearest) (unop round))
    (('f64.sqrt) (unop sqrt))
    (('f64.min) (binop min))
    (('f64.max) (binop max))
    (('f64.copysign) (binop copy-sign))
    (('f64.convert_i32_s) (unop exact->inexact))
    (('f64.convert_i32_u) (u32-unop exact->inexact))
    (('f64.convert_i64_s) (unop exact->inexact))
    (('f64.convert_i64_u) (u64-unop exact->inexact))
    (('f64.promote_f32) #t)
    (('f64.reinterpret_i64) (unop reinterpret/s64->f64))
    ;; Linear memory:
    (('i32.load ($ <mem-arg> id offset _)) (load-s32 id offset))
    (('i32.load16_s ($ <mem-arg> id offset _)) (load-s16 id offset))
    (('i32.load16_u ($ <mem-arg> id offset _)) (load-u16 id offset))
    (('i32.load8_s ($ <mem-arg> id offset _)) (load-s8 id offset))
    (('i32.load8_u ($ <mem-arg> id offset _)) (load-u8 id offset))
    (('i32.store ($ <mem-arg> id offset _)) (store-u32 id offset s32->u32))
    (('i32.store16 ($ <mem-arg> id offset _)) (store-u16 id offset s32->u32))
    (('i32.store8 ($ <mem-arg> id offset _)) (store-u8 id offset s32->u32))
    (('i64.load ($ <mem-arg> id offset _)) (load-s64 id offset))
    (('i64.load32_s ($ <mem-arg> id offset _)) (load-s32 id offset))
    (('i64.load32_u ($ <mem-arg> id offset _)) (load-u32 id offset))
    (('i64.load16_s ($ <mem-arg> id offset _)) (load-s16 id offset))
    (('i64.load16_u ($ <mem-arg> id offset _)) (load-u16 id offset))
    (('i64.load8_s ($ <mem-arg> id offset _)) (load-s8 id offset))
    (('i64.load8_u ($ <mem-arg> id offset _)) (load-u8 id offset))
    (('f32.load ($ <mem-arg> id offset _)) (load-f32 id offset))
    (('f64.load ($ <mem-arg> id offset _)) (load-f64 id offset))
    (('i64.store ($ <mem-arg> id offset _)) (store-u64 id offset s64->u64))
    (('i64.store32 ($ <mem-arg> id offset _)) (store-u32 id offset s64->u64))
    (('i64.store16 ($ <mem-arg> id offset _)) (store-u16 id offset s64->u64))
    (('i64.store8 ($ <mem-arg> id offset _)) (store-u8 id offset s64->u64))
    (('f32.store ($ <mem-arg> id offset _)) (store-f32 id offset))
    (('f64.store ($ <mem-arg> id offset _)) (store-f64 id offset))
    (('memory.size id) (push (wasm-memory-size (memory-ref id))))
    (('memory.grow id) (push (wasm-memory-grow! (memory-ref id) (pop))))
    ;; Reference types:
    (('table.get idx) (push (wasm-table-ref (table-ref idx) (pop))))
    (('table.set idx)
     (lets (i val) (wasm-table-set! (table-ref idx) i val)))
    (('table.size idx) (push (wasm-table-size (table-ref idx))))
    (('table.grow idx)
     (lets (x n) (push (wasm-table-grow! (table-ref idx) n x))))
    (('table.init dst src)
     (lets (d s n) (wasm-table-init! (table-ref dst) d (elem-ref src) s n)))
    (('table.fill idx)
     (lets (i val n) (wasm-table-fill! (table-ref idx) i val n)))
    (('table.copy dst src)
     (lets (d s n) (wasm-table-copy! (table-ref dst) d (table-ref src) s n)))
    (('elem.drop idx) (wasm-instance-drop-elem! instance idx))
    (('ref.eq) (compare eq?))
    (('ref.null (= canonical-heap-type ht)) (push (make-wasm-null ht)))
    (('ref.as_non_null)
     (let ((x (peek)))
       (when (wasm-null? x)
         (runtime-error "null value" x))))
    (('ref.is_null) (compare1 wasm-null?))
    (('ref.func idx) (push (func-ref idx)))
    (('ref.test ($ <ref-type> nullable? (= canonical-heap-type ht)))
     (push (if (can-downcast? (pop) nullable? ht) 1 0)))
    (('ref.cast ($ <ref-type> nullable? (= canonical-heap-type ht)))
     (let ((x (peek)))
       (unless (can-downcast? x nullable? ht)
         (runtime-error "invalid cast" x))))
    (('br_on_cast l rt1
                  ($ <ref-type> nullable? (= canonical-heap-type ht)))
     (when (can-downcast? (peek) nullable? ht)
       (branch l)))
    (('br_on_cast_fail l rt1
                       ($ <ref-type> nullable? (= canonical-heap-type ht)))
     (unless (can-downcast? (peek) nullable? ht)
       (branch l)))
    (('ref.i31)
     (let ((x (peek)))
       (unless (s31? (peek))
         (runtime-error "invalid i31" x))))
    (('i31.get_s) #t)
    (('i31.get_u) (unop s31->u31))
    (('struct.new (and (= canonical-heap-type ht)
                       (= type-info fields)))
     (push
      (let ((v (make-vector (vector-length fields))))
        (let lp ((i (vector-length v)))
          (unless (zero? i)
            (let ((i (1- i))
                  (val (pop)))
              (vector-set! v i (match (field-type (vector-ref fields i))
                                 ('i8 (s8-overflow val))
                                 ('i16 (s16-overflow val))
                                 (_ val)))
              (lp i))))
        (make-wasm-struct ht v))))
    (('struct.new_default (and (= canonical-heap-type ht)
                               (= type-info fields)))
     (push
      (make-wasm-struct ht (vector-map
                            (lambda (field)
                              (default-for-type (field-type field)))
                            fields))))
    (('struct.get _ field)
     (push (vector-ref (wasm-struct-fields (pop)) field)))
    (('struct.get_s _ field)
     (push (vector-ref (wasm-struct-fields (pop)) field)))
    (('struct.get_u (= type-info fields) field)
     (let ((val (vector-ref (wasm-struct-fields (pop)) field)))
       (push
        (match (field-type (vector-ref fields field))
          ('i8 (s8->u8 val))
          ('i16 (s16->u16 val))))))
    (('struct.set (= type-info fields) field)
     (lets (s x)
       (vector-set! (wasm-struct-fields s) field
                    (match (field-type (vector-ref fields field))
                      ('i8 (s8-overflow x))
                      ('i16 (s16-overflow x))
                      (_ x)))))
    (('array.new (and (= canonical-heap-type ht)
                      (= type-info field-type)))
     (lets (fill k)
       (push (make-wasm-array ht field-type (s32->u32 k) fill))))
    (('array.new_fixed (and (= canonical-heap-type ht)
                            (= type-info field-type))
                       k)
     (let ((array (make-wasm-array ht field-type k)))
       (do ((i (- k 1) (- i 1)))
           ((< i 0))
         (wasm-array-set! array i (pop)))
       (push array)))
    (('array.new_default (and (= canonical-heap-type ht)
                              (= type-info field-type)))
     (lets (k)
       (push (make-wasm-array ht field-type k))))
    (('array.new_data (and (= canonical-heap-type ht)
                           (= type-info field-type))
                      d)
     (lets (offset k)
       (let ((array (make-wasm-array ht field-type k)))
         (wasm-array-init-data! array 0 (data-ref d) offset k)
         (push array))))
    (('array.new_elem (and (= canonical-heap-type ht)
                           (= type-info field-type))
                      d)
     (lets (offset k)
       (let ((array (make-wasm-array ht field-type k)))
         (wasm-array-init-elem! array 0 (elem-ref d) offset k)
         (push array))))
    ;; FIXME: More s32->u32 needed here for offsets and lengths.
    (('array.init_data _ d)
     (lets (a at offset length)
       (wasm-array-init-data! a at (data-ref d) offset length)))
    (('array.init_elem _ d)
     (lets (a at offset length)
       (wasm-array-init-elem! a at (elem-ref d) offset length)))
    (('array.len) (lets (a) (push (wasm-array-length a))))
    (('array.get _) (lets (a i) (push (wasm-array-ref a (s32->u32 i)))))
    (('array.get_s _) (lets (a i) (push (wasm-array-ref-signed a (s32->u32 i)))))
    (('array.get_u _) (lets (a i) (push (wasm-array-ref-unsigned a (s32->u32 i)))))
    (('array.set _) (lets (a i x) (wasm-array-set! a (s32->u32 i) x)))
    (('array.fill _) (lets (a d x n) (wasm-array-fill! a d x n)))
    (('array.copy _ _) (lets (dst d src s n) (wasm-array-copy! dst d src s n)))
    (('any.convert_extern) #t)
    (('extern.convert_any) #t)
    ;; Strings:
    (('string.const idx) (push (string-ref idx)))
    (('string.new_lossy_utf8_array)
     (lets (array start end) (push (wasm-array->string array start end))))
    (('string.encode_wtf8_array)
     (lets (str array start)
           (wasm-array-encode-string! array str start)
           (push (string-utf8-length str))))
    (((or 'string.measure_utf8 'string.measure_wtf8))
     (lets (str) (push (string-utf8-length str))))
    (('string.as_iter)
     (lets (str)
           (push (make-wasm-string-iterator str 0))))
    (('stringview_iter.next)
     (lets (iter) (push (wasm-string-iterator-next! iter))))
    (('stringview_iter.advance)
     (lets (iter k) (push (wasm-string-iterator-advance! iter k))))
    (_ (runtime-error "unimplemented" instr))))

(define (execute* instrs path instance stack blocks locals)
  (let loop ((instrs instrs) (i 0))
    (match instrs
      (() 'end)
      ((instr . rest)
       (execute instr (cons i path) instance stack blocks locals)
       (loop rest (+ i 1))))))
