Guile-hoot/module/hoot/backend.scm

;;; WebAssembly compiler
;;; Copyright (C) 2023, 2024 Igalia, S.L.
;;; Copyright (C) 2023 Robin Templeton <robin@spritely.institute>
;;; Copyright (C) 2023 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:
;;;
;;; Scheme to WebAssembly compiler.
;;;
;;; Code:

(define-module (hoot backend)
  #:use-module (ice-9 format)
  #:use-module (ice-9 match)
  #:use-module ((srfi srfi-1) #:select (append-map alist-delete))
  #:use-module (srfi srfi-9)
  #:use-module (system base language)
  #:use-module (language cps)
  #:use-module (language cps intset)
  #:use-module (language cps intmap)
  #:use-module (language cps dump)
  #:use-module (language cps utils)
  #:use-module ((language cps hoot)
                #:select (hoot-primcall-raw-representations
                          target-hash
                          target-symbol-hash
                          target-keyword-hash))
  #:use-module (rnrs bytevectors)
  #:use-module (hoot stdlib)
  #:use-module (wasm dump)
  #:use-module (wasm link)
  #:use-module (wasm lower)
  #:use-module (wasm types)
  #:export (high-level-cps->wasm))

(define (invert-tree parents)
  (intmap-fold
   (lambda (child parent tree)
     (let ((tree (intmap-add tree child empty-intset intset-union)))
       (match parent
         (-1 tree)
         (_ (intmap-add tree parent (intset child) intset-union)))))
   parents empty-intmap))

(define (intset-filter pred set)
  (persistent-intset
   (intset-fold (lambda (i out)
                  (if (pred i) (intset-add! out i) out))
                set empty-intset)))

(define (intset-pop-right set)
  (match (intset-prev set)
    (#f (values set #f))
    (i (values (intset-remove set i) i))))

(define (intmap-map->list f map)
  (intmap-fold-right (lambda (k v out) (cons (f k v) out)) map '()))

(define void-block-type (make-type-use #f (make-func-sig '() '())))
(define i32-block-type (make-type-use #f (make-func-sig '() '(i32))))
(define i64-block-type (make-type-use #f (make-func-sig '() '(i64))))

;; Codegen improvements:
;;
;; 1. Eliminating directly-used locals.  Compute a set of variables that
;;    are used once, right after they are defined, in such a way that
;;    they can just flow to their use sites on the stack.  Avoid
;;    creating locals for these.
;;
;; 2. Instruction selection.  Could be that some instructions could be
;;    combined or rescheduled.  Perhaps this is something on the CPS
;;    level though.
;;
;; 3. Optimised local allocation.  Do graph coloring to map variables to
;;    a smaller set of locals, to avoid emitting one local per variable.

(define scm-type (make-ref-type #f 'eq))
(define scm-block-type (make-type-use #f (make-func-sig '() (list scm-type))))

(define i31-type (make-ref-type #f 'i31))

(define kvarargs-sig
  (make-func-sig (list (make-param '$nargs 'i32)
                       (make-param '$arg0 scm-type)
                       (make-param '$arg1 scm-type)
                       (make-param '$arg2 scm-type))'()))

(define (export-abi wasm)
  (define abi-exports
    (list (make-export "$arg3" 'global '$arg3)
          (make-export "$arg4" 'global '$arg4)
          (make-export "$arg5" 'global '$arg5)
          (make-export "$arg6" 'global '$arg6)
          (make-export "$arg7" 'global '$arg7)
          (make-export "$argv" 'table '$argv)
          (make-export "$raw-sp" 'global '$raw-sp)
          (make-export "$scm-sp" 'global '$scm-sp)
          (make-export "$ret-sp" 'global '$ret-sp)
          (make-export "$dyn-sp" 'global '$dyn-sp)
          (make-export "$current-fluids" 'global '$current-fluids)
          (make-export "$raise-exception" 'global '$raise-exception)
          (make-export "$with-exception-handler" 'global '$with-exception-handler)
          (make-export "$current-input-port" 'global '$current-input-port)
          (make-export "$current-output-port" 'global '$current-output-port)
          (make-export "$current-error-port" 'global '$current-error-port)
          (make-export "$default-prompt-tag" 'global '$default-prompt-tag)
          (make-export "$raw-stack" 'memory '$raw-stack)
          (make-export "$scm-stack" 'table '$scm-stack)
          (make-export "$ret-stack" 'table '$ret-stack)
          (make-export "$dyn-stack" 'table '$dyn-stack)
          (make-export "$intern-symbol!" 'func '$intern-symbol!)
          (make-export "$intern-keyword!" 'func '$intern-keyword!)

          (make-export "$make-size-error" 'global '$make-size-error)
          (make-export "$make-index-error" 'global '$make-index-error)
          (make-export "$make-range-error" 'global '$make-range-error)
          (make-export "$make-start-offset-error" 'global '$make-start-offset-error)
          (make-export "$make-end-offset-error" 'global '$make-end-offset-error)
          (make-export "$make-type-error" 'global '$make-type-error)
          (make-export "$make-unimplemented-error" 'global '$make-unimplemented-error)
          (make-export "$make-assertion-error" 'global '$make-assertion-error)
          (make-export "$make-not-seekable-error" 'global '$make-not-seekable-error)
          (make-export "$make-runtime-error-with-message" 'global '$make-runtime-error-with-message)
          (make-export "$make-runtime-error-with-message+irritants" 'global '$make-runtime-error-with-message+irritants)
          (make-export "$make-match-error" 'global '$make-match-error)
          (make-export "$make-arity-error" 'global '$make-arity-error)))
  (define (add-export export exports)
    (cons export exports))
  (match wasm
    (($ <wasm> id types imports funcs tables memories globals exports
        start elems datas tags strings custom)
     (make-wasm id types imports funcs tables memories globals
                (reverse (fold1 add-export abi-exports (reverse exports)))
                start elems datas tags strings custom))))

(define (target-hashq x)
  (target-hash x))

(define-record-type <static-procedure>
  (make-static-procedure code)
  static-procedure?
  (code static-procedure-code))

(define (compute-used-vars cps)
  (define (adjoin var used)
    (intset-add! used var))
  (define (adjoin* vars used)
    (fold1 adjoin vars used))
  (persistent-intset
   (intmap-fold
    (lambda (k cont used)
      ;; Only a term can use a var.
      (match cont
        (($ $kargs names syms term)
         (match term
           (($ $continue k src exp)
            (match exp
              (($ $call proc args)
               (adjoin* args (adjoin proc used)))
              (($ $callk k proc args)
               (adjoin* args (if proc (adjoin proc used) used)))
              (($ $calli args callee)
               (adjoin* args (adjoin callee used)))
              (($ $primcall name param args)
               (adjoin* args used))
              (($ $values args)
               (adjoin* args used))
              ((or ($ $const) ($ $const-fun) ($ $prim) ($ $code)) used)))
           (($ $branch kf kt src op param args)
            (adjoin* args used))
           (($ $switch kf kt* src arg)
            (adjoin arg used))
           (($ $prompt k kh src escape? tag)
            (adjoin tag used))
           (($ $throw src op param args)
            (adjoin* args used))))
        (_ used)))
    cps empty-intset)))

(define (compute-join-vars cps preds)
  (define (adjoin var joins)
    (intset-add! joins var))
  (define (adjoin* vars joins)
    (fold1 adjoin vars joins))
  (define (join-cont? k)
    (< 1 (fold1 (lambda (pred count)
                  (if (< pred k) (1+ count) count))
                (intmap-ref preds k)
                0)))
  (persistent-intset
   (intmap-fold
    (lambda (k cont joins)
      (match cont
        (($ $kargs names syms)
         (if (and (pair? syms) (join-cont? k))
             (adjoin* syms joins)
             joins))
        (_ joins)))
    cps empty-intset)))

(define* (lower-to-wasm cps #:key import-abi?)
  (define max-args 0)
  ;; interning constants into constant table
  ;; finalizing constant table
  ;; setting init function.
  (define imports '())
  (define datas '())
  (define data-count 0)
  (define (intern-data! bv)
    (let ((name (string->symbol
                 (format #f "$data~a" data-count))))
      (set! data-count (1+ data-count))
      (set! datas (cons (make-data name 'passive #f #f bv) datas))
      name))
  (define heap-constants '())
  (define heap-constant-count 0)
  (define heap-constant-names (make-hash-table))
  (define (intern-heap-constant! x)
    (define* (intern! type init-expr #:optional make-reloc)
      (let ((name (string->symbol
                   (format #f "$constant~a" heap-constant-count))))
        (set! heap-constant-count (1+ heap-constant-count))
        (hash-set! heap-constant-names x name)
        (define entry (vector name type init-expr make-reloc))
        (set! heap-constants (cons entry heap-constants))
        name))
    (match x
      ((car . cdr)
       (intern! (make-ref-type #f '$pair)
                `((i32.const ,(target-hashq x))
                  ,@(compile-constant car)
                  ,@(compile-constant cdr)
                  (struct.new $pair))))
      (#(elt ...)
       (intern! (make-ref-type #f '$vector)
                `((i32.const ,(target-hashq x))
                  ,@(append-map compile-constant elt)
                  (array.new_fixed $raw-scmvector ,(vector-length x))
                  (struct.new $vector))))
      ((? bytevector?)
       (let ((name (intern-data! x)))
         (intern! (make-ref-type #f '$bytevector)
                  `((i32.const ,(target-hashq x))
                    (i32.const 0)
                    (i32.const ,(bytevector-length x))
                    (array.new_data $raw-bytevector ,name)
                    (struct.new $bytevector)))))
      ((? bitvector?)
       ;; FIXME: Probably we should put the initializers in the data
       ;; section instead of using new_fixed.
       (intern! (make-ref-type #f '$bitvector)
                `((i32.const ,(target-hashq x))
                  (i32.const ,(bitvector-length x))
                  ,@(let* ((u32v (uniform-array->bytevector x))
                           (u32len (/ (bytevector-length u32v) 4)))
                      (unless (eq? (native-endianness) (endianness little))
                        (error "unsupported"))
                      (let lp ((i 0))
                        (if (< i u32len)
                            (cons `(i32.const
                                    ,(bytevector-s32-native-ref u32v (* i 4)))
                                  (lp (1+ i)))
                            '())))
                  (array.new_fixed $raw-bitvector
                                   ,(ash (+ 31 (bitvector-length x)) -5))
                  (struct.new $bitvector))))
      ((? string?)
       (intern! (make-ref-type #f '$string)
                `((i32.const ,(target-hashq x))
                  (string.const ,x)
                  (struct.new $string))))
      (($ <static-procedure> code)
       (intern! (make-ref-type #f '$proc)
                `((i32.const 0)
                  (ref.func ,code)
                  (struct.new $proc))))
      ((? symbol?)
       ;; We need to add the symbol to the symbol table.  In the case
       ;; where we're not importing ABI, the actual global is known to
       ;; be constant at compile-time, and we just emit a call to
       ;; $intern-symbol!.  Otherwise we call $intern-symbol! as part of
       ;; the initializer, and rely on lower-globals pass to move this
       ;; non-constant initialization to start.
       (intern! (make-ref-type #f '$symbol)
                `((i32.const ,(target-symbol-hash (symbol->string x)))
                  ,@(compile-constant (symbol->string x))
                  (struct.new $symbol)
                  . ,(if import-abi? `((call $intern-symbol!)) '()))
                (and (not import-abi?)
                     (lambda (name)
                       `((global.get ,name)
                         (call $intern-symbol!)
                         (drop))))))
      ((? keyword?)
       ;; Same run-time interning considerations as symbols.
       (intern! (make-ref-type #f '$keyword)
                `((i32.const ,(target-keyword-hash
                               (symbol->string (keyword->symbol x))))
                  ,@(compile-constant (keyword->symbol x))
                  (struct.new $keyword)
                  . ,(if import-abi? `((call $intern-keyword!)) '()))
                (and (not import-abi?)
                     (lambda (name)
                       `((global.get ,name)
                         (call $intern-keyword!)
                         (drop))))))
      ((? number?)
       (if (exact? x)
           (if (integer? x)
               (intern! (make-ref-type #f '$bignum)
                        `((i32.const 0)
                          (string.const ,(number->string x))
                          (call $string->bignum)
                          (struct.new $bignum)))
               (intern! (make-ref-type #f '$fraction)
                        `((i32.const 0)
                          ,@(compile-constant (numerator x))
                          ,@(compile-constant (denominator x))
                          (struct.new $fraction))))
           (if (real? x)
               (intern! (make-ref-type #f '$flonum)
                        `((i32.const 0)
                          (f64.const ,x)
                          (struct.new $flonum)))
               (intern! (make-ref-type #f '$complex)
                        `((i32.const 0)
                          (f64.const ,(real-part x))
                          (f64.const ,(imag-part x))
                          (struct.new $complex))))))
      (_ (error "unrecognized constant" x))))
  (define (compile-heap-constant val)
    (let ((name (or (hash-ref heap-constant-names val)
                    (intern-heap-constant! val))))
      `((global.get ,name))))
  (define (compile-immediate-constant val)
    (define (fixnum? val)
      (and (exact-integer? val)
           (<= (ash -1 29) val (1- (ash 1 29)))))
    (match val
      ((? fixnum?) `((i32.const ,(ash val 1))
                     (ref.i31)))
      (#f `((i32.const 1) (ref.i31)))
      ((? (lambda (x) (eq? x #nil))) `((i32.const 5) (ref.i31)))
      ((? (lambda (x) (eq? x '()))) `((i32.const 13) (ref.i31)))
      (#t `((i32.const 17) (ref.i31)))
      ((? unspecified?) `((i32.const 33) (ref.i31)))
      ((? eof-object?) `((i32.const 41) (ref.i31)))
      ((? char?) `((i32.const ,(logior (ash (char->integer val) 2)
                                       #b11))
                   (ref.i31)))
      (_ #f)))
  (define (compile-constant val)
    (or (compile-immediate-constant val)
        (compile-heap-constant val)))
  (define closure-types empty-intmap)
  (define (closure-type nfree)
    (if (zero? nfree)
        '$proc
        (or (intmap-ref closure-types nfree (lambda (_) #f))
            (let ((name (string->symbol (format #f "$closure~a" nfree))))
              (set! closure-types (intmap-add closure-types nfree name))
              name))))
  (define (make-closure-type nfree name)
    (define fields (make-list nfree (make-field #f #t scm-type)))
    (define struct-type
      (make-struct-type (cons* (make-field '$hash #t 'i32)
                               (make-field '$proc #f
                                           (make-ref-type #f '$kvarargs))
                               fields)))
    (make-type name (make-sub-type #t '($proc) struct-type)))
  (define max-struct-nfields 0)
  (define (struct-type-name nfields)
    (cond
     ((zero? nfields) '$struct)
     (else
      (when (< max-struct-nfields nfields)
        (set! max-struct-nfields nfields))
      (string->symbol (format #f "$struct/~a" nfields)))))
  (define (make-struct-types)
    ;; The first few struct types are part of the rec block, because
    ;; vtables are structs.  See vtable-fields in stdlib.scm.
    (define vtable-nfields 8)
    (let lp ((n (1+ vtable-nfields)))
      (if (<= n max-struct-nfields)
          (let ((name (struct-type-name n))
                (parent (struct-type-name (1- n))))
            (define fields (make-list n (make-field #f #t scm-type)))
            (define struct-type
              (make-struct-type (cons* (make-field '$hash #t 'i32)
                                       (make-field '$vtable #t
                                                   (make-ref-type #t '$vtable))
                                       fields)))
            (define sub-type
              (make-sub-type #f (list parent) struct-type))
            (cons (make-type name sub-type) (lp (1+ n))))
          '())))
  (define (func-label k) (string->symbol (format #f "$f~a" k)))
  (define (known-arity k)
    (match (intmap-ref cps k)
      (($ $kfun src meta self ktail kentry)
       (match (intmap-ref cps kentry)
         (($ $kclause) #f)
         (($ $kargs names vars) (if self (cons self vars) vars))))))
  (define (lower-func kfun body)
    (let ((cps (intmap-select cps body)))
      (define has-closure?
        (match (intmap-ref cps kfun)
          (($ $kfun src meta self ktail kentry) self)))
      (define elide-arity-check?
        (match (intmap-ref cps kfun)
          (($ $kfun src meta self ktail kentry)
           (assq-ref meta 'elide-arity-check?))))
      (define func-name
        (match (intmap-ref cps kfun)
          (($ $kfun src meta self ktail kentry)
           (assq-ref meta 'name))))
      (define used-vars (compute-used-vars cps))
      (define (var-used? var) (intset-ref used-vars var))
      (define preds (compute-predecessors cps kfun))
      (define join-vars (compute-join-vars cps preds))
      (define idoms (compute-idoms cps kfun))
      (define dom-children (invert-tree idoms))
      (define (merge-cont? label)
        (let lp ((preds (intmap-ref preds label))
                 (has-forward-in-edge? #f))
          (match preds
            (() #f)
            ((pred . preds)
             (if (< pred label)
                 (or has-forward-in-edge?
                     (lp preds #t))
                 (lp preds has-forward-in-edge?))))))
      (define (loop-cont? label)
        (or-map (lambda (pred) (<= label pred))
                (intmap-ref preds label)))
      (define (loop-label label)
        (string->symbol (format #f "$l~a" label)))
      (define (wrap-loop expr label)
        (if (loop-cont? label)
            `(loop ,(loop-label label) ,void-block-type ,expr)
            expr))
      (define (var-label var) (string->symbol (format #f "$v~a" var)))
      (define (local.get var) `(local.get ,(var-label var)))
      (define (local.set var) `(local.set ,(var-label var)))
      (define (local-arg-label idx) (string->symbol (format #f "$arg~a" idx)))
      (define (global-arg-label idx) (string->symbol (format #f "$arg~a" idx)))
      (define (arg-ref idx)
        (cond
         ((< idx 3) `((local.get ,(local-arg-label idx))))
         ((< idx 8) `((global.get ,(global-arg-label idx))))
         (else `((i32.const ,(- idx 8))
                 (table.get $argv)
                 ref.as_non_null))))

      (define (compile-tail exp)
        (define (pass-abi-arguments args)
          (cons
           `(i32.const ,(length args))
           (let lp ((args args) (idx 0))
             (match args
               (()
                (if (< idx 3)
                    (append '((i32.const 0)
                              (ref.i31))
                            (lp args (1+ idx)))
                    '()))
               ((arg . args)
                (append (cond
                         ((< idx 3)
                          `(,(local.get arg)))
                         ((< idx 8)
                          `(,(local.get arg)
                            (global.set ,(global-arg-label idx))))
                         (else
                          `((i32.const ,(- idx 8))
                            ,(local.get arg)
                            (table.set $argv))))
                        (lp args (1+ idx))))))))
        ;; Keep track of the maximum number of arguments passed in a
        ;; single call so that we can size the $argv table
        ;; appropriately in the start function.
        (define (update-max-args args)
          (set! max-args (max max-args (length args))))
        (match exp
          (($ $call proc args)
           (update-max-args args)
           `(,@(pass-abi-arguments (cons proc args))
             ,(local.get proc)
             (ref.cast ,(make-ref-type #f '$proc))
             (struct.get $proc 1)
             (return_call_ref $kvarargs)))
          (($ $calli args callee)
           (update-max-args args)
           ;; This is a return.
           `(,@(pass-abi-arguments args)
             ,(local.get callee)
             (return_call_ref $kvarargs)))
          (($ $callk k proc args)
           (update-max-args args)
           (let ((args (if proc (cons proc args) args)))
             `(,@(if (known-arity k)
                     (map local.get args)
                     (pass-abi-arguments args))
               (return_call ,(func-label k)))))))

      (define-syntax-rule (match-primcall name param args
                                          ((%name %param . %args) . body) ...)
        (match name
          (%name (match (cons param args) ((%param . %args) . body)))
          ...))

      (define (analyze-saved-vars reprs)
        (define (save/raw memory sp maybe-grow-stack idx store-inst alignment)
          (lambda (var sizes)
            (define (prepare-save)
              `((global.get ,sp)
                (local.tee ,sp)
                (i32.const ,(assq-ref sizes sp))
                (i32.add)
                (global.set ,sp)
                (call ,maybe-grow-stack)))
            `(,@(if (zero? idx) (prepare-save) '())
              (local.get ,sp)
              (local.get ,var)
              (,store-inst ,(make-mem-arg memory idx alignment)))))
        (define (save/ref table sp maybe-grow-stack idx)
          (lambda (var sizes)
            (define (prepare-save)
              `((global.get ,sp)
                (local.tee ,sp)
                (i32.const ,(assq-ref sizes sp))
                (i32.add)
                (global.set ,sp)
                (call ,maybe-grow-stack)))
            `(,@(if (zero? idx) (prepare-save) '())
              (local.get ,sp)
              ,@(if (zero? idx) '() `((i32.const ,idx) (i32.add)))
              (local.get ,var)
              (table.set ,table))))
        (define (restore sp idx code)
          (lambda (sizes)
            (define (prepare-restore)
              `((global.get ,sp)
                (i32.const ,(assq-ref sizes sp))
                (i32.sub)
                (local.tee ,sp)
                (global.set ,sp)))
            `(,@(if (zero? idx) (prepare-restore) '())
              (local.get ,sp)
              ,@code)))
        (define (restore/raw memory sp idx load-inst alignment)
          (restore sp idx `((,load-inst ,(make-mem-arg memory idx alignment)))))
        (define (restore/ref table sp idx cast)
          (restore sp idx `(,@(if (zero? idx) '() `((i32.const ,idx) (i32.add)))
                            (table.get ,table)
                            ,@cast)))

        (define (visit/raw idx store-inst load-inst alignment)
          (cons (save/raw '$raw-stack '$raw-sp '$maybe-grow-raw-stack
                          idx store-inst alignment)
                (restore/raw '$raw-stack '$raw-sp idx load-inst alignment)))
        (define (visit/ref table sp grow idx restore-cast)
          (cons (save/ref table sp grow idx)
                (restore/ref table sp idx restore-cast)))

        (define (visit-i64 idx) (visit/raw idx 'i64.store 'i64.load 3))
        (define (visit-f64 idx) (visit/raw idx 'f64.store 'f64.load 3))
        (define (visit-scm idx)
          (visit/ref '$scm-stack '$scm-sp '$maybe-grow-scm-stack idx
                     '((ref.as_non_null))))
        (define (visit-raw-bytevector idx)
          (visit/ref '$scm-stack '$scm-sp '$maybe-grow-scm-stack idx
                     `((ref.cast ,(make-ref-type #f '$raw-bytevector)))))
        (define (visit-ret idx)
          (visit/ref '$ret-stack '$ret-sp '$maybe-grow-ret-stack idx
                     '((ref.as_non_null))))

        (let lp ((reprs reprs) (out '())
                 (raw-size 0) (scm-size 0) (ret-size 0))
          (match reprs
            (()
             (values (reverse out)
                     `(($raw-sp . ,raw-size)
                       ($scm-sp . ,scm-size)
                       ($ret-sp . ,ret-size))))
            ((r . reprs)
             (match r
               ((or 'u64 's64)
                (lp reprs
                    (cons (visit-i64 raw-size) out)
                    (+ raw-size 8) scm-size ret-size))
               ('f64
                (lp reprs
                    (cons (visit-f64 raw-size) out)
                    (+ raw-size 8) scm-size ret-size))
               ('scm
                (lp reprs
                    (cons (visit-scm scm-size) out)
                    raw-size (1+ scm-size) ret-size))
               ('bv-contents
                (lp reprs
                    (cons (visit-raw-bytevector scm-size) out)
                    raw-size (1+ scm-size) ret-size))
               ('code
                (lp reprs
                    (cons (visit-ret ret-size) out)
                    raw-size scm-size (1+ ret-size))))))))

      (define (compile-fixnum-fast-path a block-type
                                        fast-expr slow-expr)
        `((block #f ,block-type
                 ((block #f ,void-block-type
                         (,(local.get a)
                          (ref.test ,i31-type)
                          (i32.eqz)
                          (br_if 0)

                          ,(local.get a)
                          (ref.cast ,i31-type)
                          (i31.get_s)
                          (local.tee $i0)
                          (i32.const 1)
                          (i32.and)
                          (br_if 0)

                          ,@fast-expr
                          (br 1)))
                  ,(local.get a)
                  ,@slow-expr))))

      (define* (compile-fixnum-fixnum-fast-path a b block-type
                                                   fast-expr slow-expr
                                                   #:key (fast-checks '()))
        `((block #f ,block-type
                 ((block #f ,void-block-type
                         (,(local.get a)
                          (ref.test ,i31-type)
                          (i32.eqz)
                          (br_if 0)
                          ,(local.get b)
                          (ref.test ,i31-type)
                          (i32.eqz)
                          (br_if 0)

                          ,(local.get a)
                          (ref.cast ,i31-type)
                          (i31.get_s)
                          (local.tee $i0)
                          ,(local.get b)
                          (ref.cast ,i31-type)
                          (i31.get_s)
                          (local.tee $i1)
                          (i32.or)
                          (i32.const 1)
                          (i32.and)
                          (br_if 0)

                          ,@(append-map (lambda (checks)
                                          `(,@checks (br_if 0)))
                                        fast-checks)

                          ,@fast-expr
                          (br 1)))
                  ,(local.get a)
                  ,(local.get b)
                  ,@slow-expr))))

      (define* (compile-fixnum-u64-fast-path a b block-type
                                             fast-expr slow-expr
                                             #:key (fast-checks '()))
        `((block #f ,block-type
                 ((block #f ,void-block-type
                         (,(local.get a)
                          (ref.test ,i31-type)
                          (i32.eqz)
                          (br_if 0)

                          ,(local.get a)
                          (ref.cast ,i31-type)
                          (i31.get_s)
                          (local.tee $i0)
                          (i32.const 1)
                          (i32.and)
                          (br_if 0)

                          ,@(append-map (lambda (checks)
                                          `(,@checks (br_if 0)))
                                        fast-checks)

                          ,@fast-expr
                          (br 1)))
                  ,(local.get a)
                  ,(local.get b)
                  ,@slow-expr))))

      (define (compile-values exp)
        (match exp
          (($ $const val) (compile-constant val))
          (($ $const-fun k) (compile-constant
                             (make-static-procedure (func-label k))))
          (($ $values vals)
           (map local.get vals))

          (($ $code k)
           `((ref.func ,(func-label k))))

          (($ $prim name)
           (match name
             ('values `((global.get $values-primitive)))
             ('apply `((global.get $apply-primitive)))
             ('append `((global.get $append-primitive)))
             ('abort-to-prompt '((global.get $abort-to-prompt-primitive)))
             ('raise-exception '((global.get $raise-exception)))
             (_ (error "unhandled $prim" name))))

          (($ $primcall name param args)
           (match-primcall
            name param args

            (('inline-wasm
              ($ <func> id
                 ($ <type-use> #f ($ <func-sig> params results))
                 locals body)
              . args)
             (define named-locals
               (map
                (lambda (param arg)
                  (match param
                    (($ <param> id type)
                     (cons id (match type
                                (($ <ref-type> #f 'string)
                                 `(,(local.get arg)
                                   (ref.cast ,(make-ref-type #f '$string))
                                   (struct.get $string $str)))
                                (($ <ref-type> #t 'extern)
                                 `(,(local.get arg)
                                   (ref.cast ,(make-ref-type #f '$extern-ref))
                                   (struct.get $extern-ref $val)))
                                (($ <ref-type> #f 'eq)
                                 `(,(local.get arg)))
                                (($ <ref-type>)
                                 `(,(local.get arg)
                                   (ref.cast ,type)))
                                ('i32 `(,(local.get arg) (i32.wrap_i64)))
                                ('i64 `(,(local.get arg)))
                                ('f32 `(,(local.get arg) (f32.demote_f64)))
                                ('f64 `(,(local.get arg)))
                                (_ (error "unexpected param type" type)))))))
                params args))
             (define temp-locals
               (map (lambda (local)
                      (match local
                        (($ <local> id type)
                         (unless (equal? type (type-for-named-temporary id))
                           (error "unexpected local type for name" id type))
                         id)))
                    locals))
             (define (rename-inst inst)
               (match inst
                 (((and inst (or 'block 'loop)) label type body)
                  `((,inst ,label ,type ,(rename-expr body))))
                 (('if label type consequent alternate)
                  `((if ,label ,type
                        ,(rename-expr consequent) ,(rename-expr alternate))))
                 (('try label type body catches catch-all)
                  `((try ,label ,type ,(rename-expr body)
                         ,(map rename-expr catches)
                         ,(and catch-all (rename-expr catch-all)))))
                 (('try_delegate label type body handler)
                  `((try_delegate ,label ,type ,(rename-expr body) ,handler)))
                 (('local.get id)
                  (or (assq-ref named-locals id)
                      (begin
                        (unless (memq id temp-locals)
                          (error "unexpected local" id))
                        `((local.get ,id)))))
                 (((or 'local.set 'local.tee) id)
                  ;; Only temporary locals are assignable from inline wasm.
                  (unless (memq id temp-locals)
                    (error "unexpected local" id))
                  (list inst))
                 (inst (list inst))))
             (define (rename-expr expr)
               (append-map rename-inst expr))
             (rename-expr body))

            (('wasm-import (? import? import))
             (set! imports (cons import imports))
             '())

            ;; These are the primcalls inserted by tailification to
            ;; handle stack-allocated return continuations.
            (('save reprs . args)
             (call-with-values (lambda () (analyze-saved-vars reprs))
               (lambda (analyzed spill-sizes)
                 (define (save-var analyzed var)
                   (match analyzed
                     ((save . restore)
                      (save (var-label var) spill-sizes))))
                 (append-map save-var analyzed args))))
            (('drop reprs)
             (call-with-values (lambda () (analyze-saved-vars reprs))
               (lambda (analyzed spill-sizes)
                 (define pop-sp
                   (match-lambda
                    ((sp . size)
                     (if (zero? size)
                         '()
                         `((global.get ,sp)
                           (i32.const ,size)
                           (i32.sub)
                           (global.set ,sp))))))
                 (append-map pop-sp spill-sizes))))
            (('restore reprs)
             ;; Precondition: the order of the vars (and associated
             ;; reprs) is the same as for the corresponding save.
             (call-with-values (lambda () (analyze-saved-vars reprs))
               (lambda (analyzed spill-sizes)
                 (define restore-var
                   (match-lambda
                    ((save . restore)
                     (restore spill-sizes))))
                 (append-map restore-var analyzed))))

            ;; Primcalls related to the module system.  Not sure if we
            ;; will need these, at least in this form; the whole-program
            ;; compiler may take a different approach to modules.
            (('current-module #f)
             (error "unimplemented" exp))
            (('current-thread #f)
             (error "unimplemented" exp))
            (('define! #f mod sym)
             (error "unimplemented" exp))
            (('resolve (bound?) (name))
             (error "unimplemented" exp))
            (('cache-ref key)
             (error "unimplemented" exp))
            (('cache-set! key val)
             (error "unimplemented" exp))
            (('resolve-module public? (name))
             (error "unimplemented" exp))
            (('module-variable #f mod name)
             (error "unimplemented" exp))
            (('lookup #f mod name)
             (error "unimplemented" exp))
            (('lookup-bound #f mod name)
             (error "unimplemented" exp))
            (('lookup-bound-public (mod name))
             (error "unimplemented" exp))
            (('lookup-bound-private (mod name))
             (error "unimplemented" exp))

            ;; Object allocation.  Probably most of these need to be
            ;; replaced with `cons` et al; see log.md.
            (('cons #f head tail)
             `((i32.const 0)
               ,(local.get head)
               ,(local.get tail)
               (struct.new $mutable-pair)))
            (('car #f pair)
             `(,(local.get pair)
               (ref.cast ,(make-ref-type #f '$pair))
               (struct.get $pair $car)))
            (('cdr #f pair)
             `(,(local.get pair)
               (ref.cast ,(make-ref-type #f '$pair))
               (struct.get $pair $cdr)))
            (('set-car! #f pair val)
             `(,(local.get pair)
               (ref.cast ,(make-ref-type #f '$pair))
               ,(local.get val)
               (struct.set $pair $car)))
            (('set-cdr! #f pair val)
             `(,(local.get pair)
               (ref.cast ,(make-ref-type #f '$pair))
               ,(local.get val)
               (struct.set $pair $cdr)))

            (('allocate-vector/immediate len)
             `((i32.const 0)
               ,@(compile-constant #f)
               (i32.const ,len)
               (array.new $raw-scmvector)
               (struct.new $mutable-vector)))
            (('allocate-vector #f len)
             `((i32.const 0)
               ,@(compile-constant #f)
               ,(local.get len)
               (i32.wrap_i64)
               (array.new $raw-scmvector)
               (struct.new $mutable-vector)))
            (('vector-length #f v)
             `(,(local.get v)
               (ref.cast ,(make-ref-type #f '$vector))
               (struct.get $vector $vals)
               (array.len)
               (i64.extend_i32_u)))
            (('vector-ref #f v idx)
             `(,(local.get v)
               (ref.cast ,(make-ref-type #f '$vector))
               (struct.get $vector $vals)
               ,(local.get idx)
               (i32.wrap_i64)
               (array.get $raw-scmvector)))
            (('vector-ref/immediate idx v)
             `(,(local.get v)
               (ref.cast ,(make-ref-type #f '$vector))
               (struct.get $vector $vals)
               (i32.const ,idx)
               (array.get $raw-scmvector)))
            (('vector-set! #f v idx val)
             `(,(local.get v)
               (ref.cast ,(make-ref-type #f '$vector))
               (struct.get $vector $vals)
               ,(local.get idx)
               (i32.wrap_i64)
               ,(local.get val)
               (array.set $raw-scmvector)))
            (('vector-set!/immediate idx v val)
             `(,(local.get v)
               (ref.cast ,(make-ref-type #f '$vector))
               (struct.get $vector $vals)
               (i32.const ,idx)
               ,(local.get val)
               (array.set $raw-scmvector)))

            (('box #f val)
             `((i32.const 0)
               ,(local.get val)
               (struct.new $variable)))
            (('box-ref #f v)
             `(,(local.get v)
               (ref.cast ,(make-ref-type #f '$variable))
               (struct.get $variable $val)))
            (('box-set! #f v val)
             `(,(local.get v)
               (ref.cast ,(make-ref-type #f '$variable))
               ,(local.get val)
               (struct.set $variable $val)))

            (('bv-length #f bv)
             `(,(local.get bv)
               (ref.cast ,(make-ref-type #f '$bytevector))
               (struct.get $bytevector $vals)
               (array.len)
               (i64.extend_i32_u)))
            (('bv-contents #f bv)
             `(,(local.get bv)
               (ref.cast ,(make-ref-type #f '$bytevector))
               (struct.get $bytevector $vals)))

            (('make-closure nfree code)
             `((i32.const 0)
               ,(local.get code)
               ,@(append-map (lambda (_) '((i32.const 0) (ref.i31)))
                             (iota nfree))
               (struct.new ,(closure-type nfree))))
            (('closure-ref (idx . nfree) closure)
             (let ((type (closure-type nfree))
                   ;; Two header fields: hash and proc.
                   (pos (+ idx 2)))
               `(,(local.get closure)
                 (ref.cast ,(make-ref-type #f type))
                 (struct.get ,type ,pos))))
            (('closure-set! (idx . nfree) closure val)
             (let ((type (closure-type nfree))
                   ;; Two header fields: hash and proc.
                   (pos (+ idx 2)))
               `(,(local.get closure)
                 (ref.cast ,(make-ref-type #f type))
                 ,(local.get val)
                 (struct.set ,type ,pos))))

            (('struct-vtable #f struct)
             `(,(local.get struct)
               (ref.cast ,(make-ref-type #f '$struct))
               (struct.get $struct $vtable)
               (ref.as_non_null)))
            (('vtable-size #f struct)
             `(,(local.get struct)
               (ref.cast ,(make-ref-type #f '$vtable))
               (struct.get $vtable $nfields)
               (ref.cast ,i31-type)
               (i31.get_s)
               (i32.const 1)
               (i32.shr_s)
               (i64.extend_i32_u)))
            (('allocate-struct nfields vtable)
             `((i32.const 0)
               ,(local.get vtable)
               (ref.cast ,(make-ref-type #f '$vtable))
               ,@(append-map (lambda (_) '((i32.const 0) (ref.i31)))
                             (iota nfields))
               (struct.new ,(struct-type-name nfields))))
            (('struct-ref idx struct)
             (let ((type (struct-type-name (1+ idx)))
                   ;; Two header fields: hash and vtable.
                   (pos (+ idx 2)))
               `(,(local.get struct)
                 (ref.cast ,(make-ref-type #f type))
                 (struct.get ,type ,pos))))
            (('struct-set! idx struct val)
             (let ((type (struct-type-name (1+ idx)))
                   ;; Two header fields: hash and vtable.
                   (pos (+ idx 2)))
               `(,(local.get struct)
                 (ref.cast ,(make-ref-type #f type))
                 ,(local.get val)
                 (struct.set ,type ,pos))))

            (('string-length #f str)
             `(,(local.get str)
               (ref.cast ,(make-ref-type #f '$string))
               (struct.get $string $str)
               (string.as_iter)
               (i32.const #x7fffffff)
               (stringview_iter.advance)
               (i64.extend_i32_u)))
            (('string-ref #f str idx)
             `(,(local.get str)
               (ref.cast ,(make-ref-type #f '$string))
               (struct.get $string $str)
               (string.as_iter)
               (local.tee $str_iter)
               ,(local.get idx)
               (i32.wrap_i64)
               (stringview_iter.advance)
               (drop)
               (local.get $str_iter)
               (stringview_iter.next)
               (i64.extend_i32_u)))
            (('string-set! #f str idx val)
             `(,(local.get str)
               ,(local.get idx)
               (i32.wrap_i64)
               ,(local.get val)
               (i32.wrap_i64)
               (call $string-set!)))

            (('symbol-hash #f sym)
             `(,(local.get sym)
               (ref.cast ,(make-ref-type #f '$symbol))
               (struct.get $symbol $hash)
               (i64.extend_i32_u)))

            ;; For the time being, atomic boxes are basically the same
            ;; as regular boxes.
            (('make-atomic-box #f val)
             `((i32.const 0)
               ,(local.get val)
               (struct.new $atomic-box)))
            (('atomic-box-ref #f box)
             `(,(local.get box)
               (ref.cast ,(make-ref-type #f '$atomic-box))
               (struct.get $atomic-box $val)))
            (('atomic-box-set! #f box val)
             `(,(local.get box)
               (ref.cast ,(make-ref-type #f '$atomic-box))
               ,(local.get val)
               (struct.set $atomic-box $val)))
            (('atomic-box-swap! #f box val)
             `(,(local.get box)
               (ref.cast ,(make-ref-type #f '$atomic-box))
               (struct.get $atomic-box $val)
               ,(local.get box)
               (ref.cast ,(make-ref-type #f '$atomic-box))
               ,(local.get val)
               (struct.set $atomic-box $val)))
            (('atomic-box-compare-and-swap! #f box expected desired)
             `(,(local.get box)
               (ref.cast ,(make-ref-type #f '$atomic-box))
               (struct.get $atomic-box $val)
               (local.tee $s0)
               ,(local.get expected)
               (ref.eq)
               (if #f ,void-block-type
                   (,(local.get box)
                    (ref.cast ,(make-ref-type #f '$atomic-box))
                    ,(local.get desired)
                    (struct.set $atomic-box $val))
                   ())
               (local.get $s0)))

            (('f64->scm #f f64)
             `((i32.const 0)
               ,(local.get f64)
               (struct.new $flonum)))

            ;; Generic arithmetic.  Emit a fixnum fast-path and a
            ;; callout to runtime functions for the slow path.
            (('add #f x y)
             (compile-fixnum-fixnum-fast-path
              x y scm-block-type
              '((local.get $i0) (local.get $i1) (call $fixnum-add))
              '((call $add))))
            (('sub #f x y)
             (compile-fixnum-fixnum-fast-path
              x y scm-block-type
              '((local.get $i0) (local.get $i1) (call $fixnum-sub))
              '((call $sub))))
            ;; FIXME: Reimplement fast paths
            (('add/immediate y x)
             (compile-fixnum-fast-path
              x scm-block-type
              `((local.get $i0) (i32.const ,(ash y 1)) (call $fixnum-add))
              `((i32.const ,(ash y 1))
                (ref.i31)
                (call $add))))
            (('sub/immediate y x)
             (compile-fixnum-fast-path
              x scm-block-type
              `((local.get $i0) (i32.const ,(ash y 1)) (call $fixnum-sub))
              `((i32.const ,(ash y 1))
                (ref.i31)
                (call $sub))))
            (('mul #f x y)
             (compile-fixnum-fixnum-fast-path
              x y scm-block-type
              '((local.get $i0) (local.get $i1) (call $fixnum-mul))
              '((call $mul))))
            (('mul/immediate y x)
             (compile-fixnum-fast-path
              x scm-block-type
              `((local.get $i0) (i32.const ,(ash y 1)) (call $fixnum-mul))
              `((i32.const ,(ash y 1))
                (ref.i31)
                (call $mul))))
            (('div #f x y)
             `(,(local.get x)
               ,(local.get y)
               (call $div)))
            (('quo #f x y)
             (compile-fixnum-fixnum-fast-path
              x y scm-block-type
              '((local.get $i0) (i32.const 1) (i32.shr_s)
                (local.get $i1) (i32.const 1) (i32.shr_s)
                (i32.div_s)
                (i32.const 1) (i32.shl)
                (ref.i31))
              '((call $quo))
              #:fast-checks '(((local.get $i1) (i32.eqz))
                              ((local.get $i1) (i32.const -2) (i32.eq)))))
            (('rem #f x y)
             (compile-fixnum-fixnum-fast-path
              x y scm-block-type
              '((local.get $i0) (i32.const 1) (i32.shr_s)
                (local.get $i1) (i32.const 1) (i32.shr_s)
                (i32.rem_s)
                (i32.const 1) (i32.shl)
                (ref.i31))
              '((call $rem))
              #:fast-checks '(((local.get $i1) (i32.eqz)))))
            (('mod #f x y)
             (compile-fixnum-fixnum-fast-path
              x y scm-block-type
              `((local.get $i0) (i32.const 1) (i32.shr_s)
                (local.get $i1) (i32.const 1) (i32.shr_s)
                (i32.rem_s)
                ;; Tag as fixnum.
                (i32.const 1) (i32.shl)
                ;; Adjust if y and r have opposite signs.
                (local.tee $i0)
                (local.get $i1)
                (i32.const 0)
                (i32.gt_s)
                (if #f ,i32-block-type
                    ((local.get $i0) (i32.const 0) (i32.lt_s))
                    ((local.get $i0) (i32.const 0) (i32.gt_s)))
                (if #f ,i32-block-type
                    ;; Adjust by adding tagged $i1.
                    ((local.get $i0) (local.get $i1) (i32.add))
                    ((local.get $i0)))
                (ref.i31))
              '((call $mod))
              #:fast-checks '(((local.get $i1) (i32.eqz)))))

            ;; Integer bitwise operations.  Fast path for fixnums and
            ;; callout otherwise.
            (('logand #f x y)
             (compile-fixnum-fixnum-fast-path
              x y scm-block-type
              '((local.get $i0) (local.get $i1) (i32.and) (ref.i31))
              '((call $logand))))
            (('logand/immediate y x)
             (compile-fixnum-fast-path
              x scm-block-type
              `((local.get $i0) (i32.const ,(ash y 1)) (i32.and) (ref.i31))
              `((i32.const ,(ash y 1))
                (ref.i31)
                (call $logand))))
            (('logior #f x y)
             (compile-fixnum-fixnum-fast-path
              x y scm-block-type
              '((local.get $i0) (local.get $i1) (i32.or) (ref.i31))
              '((call $logior))))
            (('logxor #f x y)
             (compile-fixnum-fixnum-fast-path
              x y scm-block-type
              '((local.get $i0) (local.get $i1) (i32.xor) (ref.i31))
              '((call $logxor))))
            (('logsub #f x y)
             (compile-fixnum-fixnum-fast-path
              x y scm-block-type
              '((local.get $i0)
                (local.get $i1)
                (i32.const -1)
                (i32.xor)
                (i32.and)
                (ref.i31))
              '((call $logsub))))
            (('rsh #f x y)
             (compile-fixnum-u64-fast-path
              x y scm-block-type
              `((local.get $i0)

                ;; Clamp shift to 31 bits; fixnum is smaller than that.
                (i64.const 31)
                ,(local.get y)
                (i64.lt_u)
                (if #f ,i32-block-type
                    ((i32.const 31))
                    (,(local.get y)
                     (i32.wrap_i64)))

                (i32.shr_s)
                ;; Mask off fixnum bit.
                (i32.const -2)
                (i32.and)
                (ref.i31))
              '((call $rsh))))
            (('lsh #f x y)
             (compile-fixnum-u64-fast-path
              x y scm-block-type
              `((local.get $i0)
                (i32.const 1)
                (i32.shr_s)
                (i64.extend_i32_s)
                ,(local.get y)
                (i64.shl)
                (call $s64->scm))
              '((call $lsh))
              #:fast-checks `((,(local.get y) (i64.const 32) (i64.gt_u)))))
            (('rsh/immediate y x)
             (compile-fixnum-fast-path
              x scm-block-type
              (if (< y 31)
                   `((local.get $i0)
                     (i32.const ,y)
                     (i32.shr_s)
                     (i32.const -2)
                     (i32.and)
                     (ref.i31))
                   `((i32.const 0)
                     (ref.i31)))
              `((i64.const ,y)
                (call $rsh))))
            (('lsh/immediate y x)
             (if (<= y 32)
                 (compile-fixnum-fast-path
                  x scm-block-type
                  `((local.get $i0)
                    (i32.const 1)
                    (i32.shr_s)
                    (i64.extend_i32_s)
                    (i64.const ,y)
                    (i64.shl)
                    (call $s64->scm))
                  `((i64.const ,y)
                    (call $lsh)))
                 `((i64.const ,y)
                   (call $lsh))))

            ;; Arithmetic on real numbers.
            (('inexact #f x)
             `(,(local.get x)
               (call $inexact)))
            (('abs #f x)
             `(,(local.get x)
               (call $abs)))
            (('sqrt #f x)
             `(,(local.get x)
               (call $sqrt)))
            (('floor #f x)
             `(,(local.get x)
               (call $floor)))
            (('ceiling #f x)
             `(,(local.get x)
               (call $ceiling)))

            ;; Trig functions.  Probably just call out for now.
            (('sin #f x)
             `(,(local.get x)
               (call $sin)))
            (('cos #f x)
             `(,(local.get x)
               (call $cos)))
            (('tan #f x)
             `(,(local.get x)
               (call $tan)))
            (('asin #f x)
             `(,(local.get x)
               (call $asin)))
            (('acos #f x)
             `(,(local.get x)
               (call $acos)))
            (('atan #f x)
             `(,(local.get x)
               (call $atan)))
            (('atan2 #f x y)
             `(,(local.get x)
               ,(local.get y)
               (call $atan2)))

            ;; Unboxed integer arithmetic and logical operations.
            (((or 'load-u64 'load-s64) s64)
             `((i64.const ,s64)))
            (((or 's64->u64 'u64->s64) #f arg)
             `(,(local.get arg)))
            (((or 'uadd 'sadd) #f x y)
             `(,(local.get x)
               ,(local.get y)
               (i64.add)))
            (((or 'usub 'ssub) #f x y)
             `(,(local.get x)
               ,(local.get y)
               (i64.sub)))
            (((or 'umul 'smul) #f x y)
             `(,(local.get x)
               ,(local.get y)
               (i64.mul)))
            (((or 'sadd/immediate 'uadd/immediate) y x)
             `(,(local.get x)
               (i64.const ,y)
               (i64.add)))
            (((or 'usub/immediate 'ssub/immediate) y x)
             `(,(local.get x)
               (i64.const ,y)
               (i64.sub)))
            (((or 'umul/immediate 'smul/immediate) y x)
             `(,(local.get x)
               (i64.const ,y)
               (i64.mul)))
            (('ulogand #f x y)
             `(,(local.get x)
               ,(local.get y)
               (i64.and)))
            (('ulogand/immediate y x)
             `(,(local.get x)
               (i64.const ,y)
               (i64.and)))
            (('ulogior #f x y)
             `(,(local.get x)
               ,(local.get y)
               (i64.or)))
            (('ulogsub #f x y)
             `(,(local.get x)
               ,(local.get y)
               (i64.not)
               (i64.or)))
            (('ulogxor #f x y)
             `(,(local.get x)
               ,(local.get y)
               (i64.xor)))
            (('ursh #f x y)
             `(,(local.get x)
               ,(local.get y)
               (i64.shr_u)))
            (('srsh #f x y)
             `(,(local.get x)
               ,(local.get y)
               (i64.shr_s)))
            (('ulsh #f x y)
             `(,(local.get x)
               ,(local.get y)
               (i64.shl)))
            (('ursh/immediate y x)
             `(,(local.get x)
               (i64.const ,y)
               (i64.shr_u)))
            (('srsh/immediate y x)
             `(,(local.get x)
               (i64.const ,y)
               (i64.shr_s)))
            (('ulsh/immediate y x)
             `(,(local.get x)
               (i64.const ,y)
               (i64.shl)))
            (('slsh/immediate y x)
             `(,(local.get x)
               (i64.const ,y)
               (i64.shl)))

            ;; Unboxed floating-point arithmetic and trig.
            (('load-f64 f64)
             `((f64.const ,f64)))
            (('s64->f64 #f arg)
             `(,(local.get arg)
               (f64.reinterpret_i64)))
            (('fadd #f x y)
             `(,(local.get x)
               ,(local.get y)
               (f64.add)))
            (('fadd/immediate y x)
             `(,(local.get x)
               (f64.const ,y)
               (f64.add)))
            (('fsub #f x y)
             `(,(local.get x)
               ,(local.get y)
               (f64.sub)))
            (('fmul #f x y)
             `(,(local.get x)
               ,(local.get y)
               (f64.mul)))
            (('fdiv #f x y)
             `(,(local.get x)
               ,(local.get y)
               (f64.div)))
            (('fabs #f x)
             `(,(local.get x)
               (f64.abs)))
            (('fsqrt #f x)
             `(,(local.get x)
               (f64.sqrt)))
            (('ffloor #f x)
             `(,(local.get x)
               (f64.floor)))
            (('fceiling #f x)
             `(,(local.get x)
               (f64.ceil)))
            (('fsin #f x)
             `(,(local.get x)
               (call $fsin)))
            (('fcos #f x)
             `(,(local.get x)
               (call $fcos)))
            (('ftan #f x)
             `(,(local.get x)
               (call $ftan)))
            (('fasin #f x)
             `(,(local.get x)
               (call $fasin)))
            (('facos #f x)
             `(,(local.get x)
               (call $facos)))
            (('fatan #f x)
             `(,(local.get x)
               (call $fatan)))
            (('fatan2 #f x y)
             `(,(local.get x)
               ,(local.get y)
               (call $fatan2)))

            ;; Misc.
            (('string->bignum #f x)
             `((i32.const 0)
               ,(local.get x)
               (ref.cast ,(make-ref-type #f '$string))
               (struct.get $string $str)
               (call $string->bignum)
               (struct.new $bignum)))

            (('string->symbol #f x)
             `(,(local.get x)
               (ref.cast ,(make-ref-type #f '$string))
               (call $string->symbol)))
            (('symbol->string #f x)
             `(,(local.get x)
               (ref.cast ,(make-ref-type #f '$symbol))
               (struct.get $symbol $name)))

            (('symbol->keyword #f x)
             `(,(local.get x)
               (ref.cast ,(make-ref-type #f '$symbol))
               (call $symbol->keyword)))
            (('keyword->symbol #f x)
             `(,(local.get x)
               (ref.cast ,(make-ref-type #f '$keyword))
               (struct.get $keyword $name)))

            (('string->utf8 #f str)
             `((i32.const 0)
               ,(local.get str)
               (ref.cast ,(make-ref-type #f '$string))
               (struct.get $string $str)
               (call $string->wtf8)
               (struct.new $bytevector)))
            (('string-utf8-length #f str)
             `(,(local.get str)
               (ref.cast ,(make-ref-type #f '$string))
               (struct.get $string $str)
               (string.measure_wtf8)))
            (('utf8->string #f bv)
             `((i32.const 0)
               ,(local.get bv)
               (ref.cast ,(make-ref-type #f '$bytevector))
               (struct.get $bytevector $vals)
               (call $wtf8->string)
               (struct.new $mutable-string)))

            ;; Unboxing and boxing numbers.
            (('scm->f64 #f src)
             `(,(local.get src)
               (call $scm->f64)))
            (('flonum->f64 #f src)
             `(,(local.get src)
               (ref.cast ,(make-ref-type #f '$flonum))
               (struct.get $flonum $val)))
            (('compnum-real #f src)
             `(,(local.get src)
               (ref.cast ,(make-ref-type #f '$complex))
               (struct.get $complex $real)))
            (('compnum-imag #f src)
             `(,(local.get src)
               (ref.cast ,(make-ref-type #f '$complex))
               (struct.get $complex $imag)))
            (('scm->s64 #f src)
             (compile-fixnum-fast-path
              src i64-block-type
              `((local.get $i0)
                (i32.const 1)
                (i32.shr_s)
                (i64.extend_i32_s))
              `((call $scm->s64))))
            (('scm->u64 #f src)
             `(,(local.get src)
               (call $scm->u64)))
            (('scm->u64/truncate #f src)
             (compile-fixnum-fast-path
              src i64-block-type
              `((local.get $i0)
                (i32.const 1)
                (i32.shr_s)
                (i64.extend_i32_s))
              '((call $scm->u64/truncate))))
            (('u64->scm #f src)
             `(,(local.get src)
               (i64.const ,(ash 1 29))
               (i64.lt_u)
               (if #f ,scm-block-type
                   (,(local.get src)
                    (i32.wrap_i64)
                    (i32.const 1)
                    (i32.shl)
                    (ref.i31))
                   (,(local.get src)
                    (call $u64->bignum)))))
            (('s64->scm #f src)
             `(,(local.get src)
               (call $s64->scm)))

            ;; For native Guile, these bytevector accesses take three
            ;; parameters: the object itself, which is unused but keeps
            ;; the pointer alive; a pointer to the actual bytes; and an
            ;; index.  For WebAssembly we pass the $raw-bytevector as
            ;; the ptr and not reference the object.
            (('u8-ref ann obj ptr idx)
             `(,(local.get ptr)
               ,(local.get idx)
               (i32.wrap_i64)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u)))
            (('s8-ref ann obj ptr idx)
             `(,(local.get ptr)
               ,(local.get idx)
               (i32.wrap_i64)
               (array.get_s $raw-bytevector)
               (i64.extend_i32_s)))
            ;; Annoyingly there are no native multi-byte accesses to i8
            ;; arrays.
            (('u16-ref ann obj ptr idx)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               (array.get_u $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               (array.get_u $raw-bytevector)
               (i32.const 8) (i32.shl)
               (i32.or)
               (i64.extend_i32_u)))
            (('s16-ref ann obj ptr idx)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               (array.get_u $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               (array.get_s $raw-bytevector)
               (i32.const 8) (i32.shl)
               (i32.or)
               (i64.extend_i32_s)))
            (('u32-ref ann obj ptr idx)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               (array.get_u $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               (array.get_u $raw-bytevector)
               (i32.const 8) (i32.shl)
               (i32.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 2) (i32.add)
               (array.get_u $raw-bytevector)
               (i32.const 16) (i32.shl)
               (i32.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 3) (i32.add)
               (array.get_u $raw-bytevector)
               (i32.const 24) (i32.shl)
               (i32.or)
               (i64.extend_i32_u)))
            (('s32-ref ann obj ptr idx)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               (array.get_u $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               (array.get_u $raw-bytevector)
               (i32.const 8) (i32.shl)
               (i32.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 2) (i32.add)
               (array.get_u $raw-bytevector)
               (i32.const 16) (i32.shl)
               (i32.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 3) (i32.add)
               (array.get_s $raw-bytevector)
               (i32.const 24) (i32.shl)
               (i32.or)
               (i64.extend_i32_s)))
            (((or 'u64-ref 's64-ref) ann obj ptr idx)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 8) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 2) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 16) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 3) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 24) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 4) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 32) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 5) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 40) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 6) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 48) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 7) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 56) (i64.shl)
               (i64.or)))
            (('f32-ref ann obj ptr idx)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               (array.get_u $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               (array.get_u $raw-bytevector)
               (i32.const 8) (i32.shl)
               (i32.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 2) (i32.add)
               (array.get_u $raw-bytevector)
               (i32.const 16) (i32.shl)
               (i32.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 3) (i32.add)
               (array.get_s $raw-bytevector)
               (i32.const 24) (i32.shl)
               (i32.or)
               (f32.reinterpret_i32)
               (f64.promote_f32)))
            (('f64-ref ann obj ptr idx)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 8) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 2) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 16) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 3) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 24) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 4) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 32) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 5) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 40) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 6) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 48) (i64.shl)
               (i64.or)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 7) (i32.add)
               (array.get_u $raw-bytevector)
               (i64.extend_i32_u) (i64.const 56) (i64.shl)
               (i64.or)
               (f64.reinterpret_i64)))
            (((or 'u8-set! 's8-set!) ann obj ptr idx val)
             `(,(local.get ptr)
               ,(local.get idx)
               (i32.wrap_i64)
               ,(local.get val)
               (i32.wrap_i64)
               (array.set $raw-bytevector)))
            (((or 'u16-set! 's16-set!) ann obj ptr idx val)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               ,(local.get val) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               ,(local.get val) (i64.const 8) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)))
            (((or 'u32-set! 's32-set!) ann obj ptr idx val)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               ,(local.get val) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               ,(local.get val) (i64.const 8) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 2) (i32.add)
               ,(local.get val) (i64.const 16) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 3) (i32.add)
               ,(local.get val) (i64.const 24) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)))
            (((or 'u64-set! 's64-set!) ann obj ptr idx val)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               ,(local.get val) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               ,(local.get val) (i64.const 8) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 2) (i32.add)
               ,(local.get val) (i64.const 16) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 3) (i32.add)
               ,(local.get val) (i64.const 24) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 4) (i32.add)
               ,(local.get val) (i64.const 32) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 5) (i32.add)
               ,(local.get val) (i64.const 40) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 6) (i32.add)
               ,(local.get val) (i64.const 48) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 7) (i32.add)
               ,(local.get val) (i64.const 56) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)))
            (('f32-set! ann obj ptr idx val)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               ,(local.get val) (f32.demote_f64) (i32.reinterpret_f32)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               ,(local.get val) (f32.demote_f64) (i32.reinterpret_f32) (i32.const 8) (i32.shr_u)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 2) (i32.add)
               ,(local.get val) (f32.demote_f64) (i32.reinterpret_f32) (i32.const 16) (i32.shr_u)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 3) (i32.add)
               ,(local.get val) (f32.demote_f64) (i32.reinterpret_f32) (i32.const 24) (i32.shr_u)
               (array.set $raw-bytevector)))
            (('f64-set! ann obj ptr idx val)
             `(,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64)
               ,(local.get val) (i64.reinterpret_f64) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 1) (i32.add)
               ,(local.get val) (i64.reinterpret_f64) (i64.const 8) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 2) (i32.add)
               ,(local.get val) (i64.reinterpret_f64) (i64.const 16) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 3) (i32.add)
               ,(local.get val) (i64.reinterpret_f64) (i64.const 24) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 4) (i32.add)
               ,(local.get val) (i64.reinterpret_f64) (i64.const 32) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 5) (i32.add)
               ,(local.get val) (i64.reinterpret_f64) (i64.const 40) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 6) (i32.add)
               ,(local.get val) (i64.reinterpret_f64) (i64.const 48) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)
               ,(local.get ptr)
               ,(local.get idx) (i32.wrap_i64) (i32.const 7) (i32.add)
               ,(local.get val) (i64.reinterpret_f64) (i64.const 56) (i64.shr_u) (i32.wrap_i64)
               (array.set $raw-bytevector)))

            ;; Infallible unboxing of fixnums and chars.
            (('untag-fixnum #f src)
             `(,(local.get src)
               (ref.cast ,i31-type)
               (i31.get_s)
               (i32.const 1)
               (i32.shr_s)
               (i64.extend_i32_s)))
            (('tag-fixnum #f src)
             `(,(local.get src)
               (i32.wrap_i64)
               (i32.const 1)
               (i32.shl)
               (ref.i31)))
            (('untag-char #f src)
             `(,(local.get src)
               (ref.cast ,i31-type)
               (i31.get_s)
               (i32.const 2)
               (i32.shr_u)
               (i64.extend_i32_u)))
            (('tag-char #f src)
             `(,(local.get src)
               (i32.wrap_i64)
               (i32.const 2)
               (i32.shl)
               (i32.const #b11)
               (i32.or)
               (ref.i31)))

            ;; The dynamic state.  Implement using runtime.
            (('push-prompt escape-only? tag handler)
             `((global.get $raw-sp)
               (global.get $scm-sp)
               (global.get $ret-sp)
               (i32.const ,(if escape-only? 1 0))
               ,(local.get tag)
               ,(local.get handler)
               (struct.new $dynprompt)
               (call $push-dyn)))
            (('push-fluid #f fluid val)
             ;; Going to assume (via the ref.cast) that someone checked
             ;; that fluid is in fact a fluid.  Not the case currently
             ;; in Guile; this should be fixed.
             `(,(local.get fluid)
               (ref.cast ,(make-ref-type #f '$fluid))
               ,(local.get val)
               (call $push-fluid)))
            (('pop-fluid #f)
             `((call $pop-fluid)))
            (('fluid-ref #f fluid)
             `(,(local.get fluid)
               (ref.cast ,(make-ref-type #f '$fluid))
               (call $fluid-ref)))
            (('fluid-set! #f fluid value)
             `(,(local.get fluid)
               (ref.cast ,(make-ref-type #f '$fluid))
               ,(local.get value)
               (call $fluid-set!)))
            (('push-dynamic-state #f state)
             ;; Assuming that it's a $dynamic-state, as with fluids.
             `(,(local.get state)
               (ref.cast ,(make-ref-type #f '$dynamic-state))
               (call $push-dynamic-state)))
            (('pop-dynamic-state #f)
             `((call $pop-dynamic-state)))
            (('wind #f winder unwinder)
             `(,(local.get winder)
               (ref.cast ,(make-ref-type #f '$proc))
               ,(local.get unwinder)
               (ref.cast ,(make-ref-type #f '$proc))
               (struct.new $dynwind)
               (call $push-dyn)))
            (('unwind #f)
             `((global.get $dyn-sp)
               (i32.const 1)
               (i32.sub)
               (global.set $dyn-sp)))

            ((name param . args)
             (error "unexpected primcall" name param args))))

          (_ (error "unexpected expression" exp))))

      (define (compile-test op param args)
        (match (vector op param args)
          ;; Immediate type tag predicates.
          (#('fixnum? #f (a))
           `(,(local.get a)
             (ref.test ,i31-type)
             (if #f ,i32-block-type
                 (,(local.get a)
                  (ref.cast ,i31-type)
                  (i31.get_s)
                  (i32.const #b1)
                  (i32.and)
                  (i32.eqz))
                 ((i32.const 0)))))
          ;; FIXME: elide heap-object? tests if they just guard a more
          ;; specific test.
          (#('heap-object? #f (a))
           `(,(local.get a) (ref.test ,(make-ref-type #f '$heap-object))))
          (#('char? #f (a))
           `(,(local.get a)
             (ref.test ,i31-type)
             (if #f ,i32-block-type
                 (,(local.get a)
                  (ref.cast ,i31-type)
                  (i31.get_u)
                  (i32.const #b11)
                  (i32.and)
                  (i32.const #b11)
                  (i32.eq))
                 ((i32.const 0)))))
          (#('eq-constant? imm (a))
           `(,(local.get a)
             ,@(compile-constant imm)
             (ref.eq)))
          (#('undefined? #f (a))
           `(,(local.get a)
             (i32.const 57)
             (ref.i31)
             (ref.eq)))
          (#('null? #f (a))
           `(,(local.get a)
             (ref.test ,i31-type)
             (if #f ,i32-block-type
                 (,(local.get a)
                  (ref.cast ,i31-type)
                  (i31.get_s)
                  (i32.const #b110111)
                  (i32.and)
                  (i32.const #b000101)
                  (i32.eq))
                 ((i32.const 0)))))
          (#('false? #f (a))
           `(,(local.get a)
             (ref.test ,i31-type)
             (if #f ,i32-block-type
                 (,(local.get a)
                  (ref.cast ,i31-type)
                  (i31.get_s)
                  (i32.const #b111011)
                  (i32.and)
                  (i32.const #b000001)
                  (i32.eq))
                 ((i32.const 0)))))
          (#('nil? #f (a))
           `(,(local.get a)
             (ref.test ,i31-type)
             (if #f ,i32-block-type
                 (,(local.get a)
                  (ref.cast ,i31-type)
                  (i31.get_s)
                  (i32.const #b110011)
                  (i32.and)
                  (i32.const #b000001)
                  (i32.eq))
                 ((i32.const 0)))))
          (#('pair? #f (a))             `(,(local.get a) (ref.test ,(make-ref-type #f '$pair))))
          (#('struct? #f (a))           `(,(local.get a) (ref.test ,(make-ref-type #f '$struct))))
          (#('symbol? #f (a))           `(,(local.get a) (ref.test ,(make-ref-type #f '$symbol))))
          (#('variable? #f (a))         `(,(local.get a) (ref.test ,(make-ref-type #f '$variable))))
          (#('vector? #f (a))           `(,(local.get a) (ref.test ,(make-ref-type #f '$vector))))
          (#('mutable-vector? #f (a))   `(,(local.get a) (ref.test ,(make-ref-type #f '$mutable-vector))))
          (#('immutable-vector? #f (a)) `(,(local.get a) (ref.test ,(make-ref-type #f '$vector))))
          (#('string? #f (a))           `(,(local.get a) (ref.test ,(make-ref-type #f '$string))))
          (#('heap-number? #f (a))      `(,(local.get a) (ref.test ,(make-ref-type #f '$heap-number))))
          (#('hash-table? #f (a))       `(,(local.get a) (ref.test ,(make-ref-type #f '$hash-table))))
          (#('fluid? #f (a))            `(,(local.get a) (ref.test ,(make-ref-type #f '$fluid))))
          (#('dynamic-state? #f (a))    `(,(local.get a) (ref.test ,(make-ref-type #f '$dynamic-state))))
          (#('keyword? #f (a))          `(,(local.get a) (ref.test ,(make-ref-type #f '$keyword))))
          (#('atomic-box? #f (a))       `(,(local.get a) (ref.test ,(make-ref-type #f '$atomic-box))))
          (#('syntax? #f (a))           `(,(local.get a) (ref.test ,(make-ref-type #f '$syntax))))
          (#('procedure? #f (a))        `(,(local.get a) (ref.test ,(make-ref-type #f '$proc))))
          (#('bytevector? #f (a))       `(,(local.get a) (ref.test ,(make-ref-type #f '$bytevector))))
          (#('weak-table? #f (a))       `(,(local.get a) (ref.test ,(make-ref-type #f '$weak-table))))
          (#('bitvector? #f (a))        `(,(local.get a) (ref.test ,(make-ref-type #f '$bitvector))))
          (#('port? #f (a))             `(,(local.get a) (ref.test ,(make-ref-type #f '$port))))
          (#('bignum? #f (a))           `(,(local.get a) (ref.test ,(make-ref-type #f '$bignum))))
          (#('flonum? #f (a))           `(,(local.get a) (ref.test ,(make-ref-type #f '$flonum))))
          (#('compnum? #f (a))          `(,(local.get a) (ref.test ,(make-ref-type #f '$complex))))
          (#('fracnum? #f (a))          `(,(local.get a) (ref.test ,(make-ref-type #f '$fraction))))
          (#('eq? #f (a b))             `(,(local.get a) ,(local.get b) (ref.eq)))

          (#('vtable-vtable? #f (vtable))
           `(,(local.get vtable)
             (ref.cast ,(make-ref-type #f '$vtable))
             (struct.get $vtable $vtable)
             (ref.test ,(make-ref-type #f '$vtable-vtable))))

          (#('heap-numbers-equal? #f (a b))
           `(,(local.get a) ,(local.get b) (call $heap-numbers-equal?)))
          (#('< #f (a b))
           (compile-fixnum-fixnum-fast-path a b i32-block-type
                                            '((local.get $i0)
                                              (local.get $i1)
                                              (i32.lt_s))
                                            '((call $slow-<))))
          (#('<= #f (a b))
           (compile-fixnum-fixnum-fast-path a b i32-block-type
                                            '((local.get $i0)
                                              (local.get $i1)
                                              (i32.le_s))
                                            '((call $slow-<=))))
          (#('= #f (a b))
           (compile-fixnum-fixnum-fast-path a b i32-block-type
                                            '((local.get $i0)
                                              (local.get $i1)
                                              (i32.eq))
                                            '((call $slow-=))))
          (#('u64-< #f (a b))
           `(,(local.get a)
             ,(local.get b)
             (i64.lt_u)))
          (#('u64-imm-< b (a))
           `(,(local.get a)
             (i64.const ,b)
             (i64.lt_u)))
          (#('imm-u64-< b (a))
           `((i64.const ,b)
             ,(local.get a)
             (i64.lt_u)))
          (#((or 'u64-= 's64-=) #f (a b))
           `(,(local.get a)
             ,(local.get b)
             (i64.eq)))
          (#((or 'u64-imm-= 's64-imm-=) b (a))
           `(,(local.get a)
             (i64.const ,b)
             (i64.eq)))
          (#('s64-< #f (a b))
           `(,(local.get a)
             ,(local.get b)
             (i64.lt_s)))
          (#('s64-imm-< b (a))
           `(,(local.get a)
             (i64.const ,b)
             (i64.lt_s)))
          (#('imm-s64-< b (a))
           `((i64.const ,b)
             ,(local.get a)
             (i64.lt_s)))
          (#('f64-< #f (a b))
           `(,(local.get a)
             ,(local.get b)
             (f64.lt)))
          (#('f64-<= #f (a b))
           `(,(local.get a)
             ,(local.get b)
             (f64.le)))
          (#('f64-= #f (a b))
           `(,(local.get a)
             ,(local.get b)
             (f64.eq)))

          (#('f64-finite? #f (a))
           `(,(local.get a)
             ,(local.get a)
             (f64.sub)
             (f64.const 0)
             (f64.eq)))
          (#('f64-int? #f (a))
           `(,(local.get a)
             (f64.trunc)
             ,(local.get a)
             (f64.sub)
             (f64.const 0)
             (f64.eq)))))

      (define (compile-throw src op param args)
        ;; FIXME: Instead of dying, we need to implement exception
        ;; handling, as in Guile.
        (match (vector op param args)
          (#('raise-type-error #(subr pos what) (val))
           `((string.const ,subr)
             (string.const ,what)
             ,(local.get val)
             (return_call $raise-type-error)))
          (#('raise-range-error #(subr pos) (val))
           `((string.const ,subr)
             ,(local.get val)
             (return_call $raise-range-error)))
          (#('raise-arity-error #(subr) (val))
           `(,(if subr
                  `(string.const ,subr)
                  '(ref.null string))
             ,(local.get val)
             (return_call $raise-arity-error)))
          (#('raise-unbound-error #(subr) (val))
           `((string.const ,subr)
             ,(local.get val)
             (return_call $raise-unbound-error)))
          (#('raise-exception #f (exn))
           `(,(local.get exn)
             (return_call $raise-exception)))))

      ;; See "Beyond Relooper: Recursive Translation of Unstructured
      ;; Control Flow to Structured Control Flow", Norman Ramsey, ICFP
      ;; 2022.
      (define (make-ctx next-label stack) (cons next-label stack))
      (define (push-loop label ctx)
        (match ctx
          ((next-label . stack)
           (make-ctx next-label
                     (acons 'loop-headed-by label stack)))))
      (define (push-block label ctx)
        (match ctx
          ((next-label . stack)
           (make-ctx label
                     (acons 'block-followed-by label stack)))))
      (define (push-if ctx)
        (match ctx
          ((next-label . stack)
           (make-ctx next-label (cons 'if-then-else stack)))))
      (define (lookup-label k ctx)
        (match ctx
          ((next-label . stack)
           (let lp ((stack stack) (depth 0))
             (match stack
               (('if-then-else . stack) (lp stack (1+ depth)))
               ((((or 'loop-headed-by 'block-followed-by) . label) . stack)
                (if (eqv? label k)
                    depth
                    (lp stack (1+ depth))))
               (_ (error "block label not found" k ctx)))))))

      (define (do-tree label ctx)
        (define (code-for-label ctx)
          (let ((children (intmap-ref dom-children label)))
            (node-within
             label
             (match (intmap-ref cps label)
               (($ $kargs names vars ($ $switch))
                children)
               (_
                (intset-filter merge-cont? children)))
             ctx)))
        (if (loop-cont? label)
            `((loop #f ,void-block-type
                    ,(code-for-label (push-loop label ctx))))
            (code-for-label ctx)))
      (define (do-branch pred succ ctx)
        (cond
         ((or (<= succ pred)
              (merge-cont? succ))
          ;; Backward branch or branch to merge: jump.
          (match ctx
            ((next-label . stack)
             (if (eqv? succ next-label)
                 '()
                 `((br ,(lookup-label succ ctx)))))))
         (else
          ;; Otherwise render successor inline.
          (do-tree succ ctx))))
      (define (node-within label ys ctx)
        (call-with-values (lambda () (intset-pop-right ys))
          (lambda (ys y)
            (match y
              (#f
               (match (intmap-ref cps label)
                 (($ $kargs names vars term)
                  ;; could change to bind names at continuation?
                  (match term
                    (($ $continue k src exp)
                     (match (intmap-ref cps k)
                       (($ $ktail)
                        (compile-tail exp))
                       (($ $kargs _ vars)
                        `(,@(compile-values exp)
                          ,@(reverse (map local.set vars))
                          ,@(do-branch label k ctx)))
                       (($ $kreceive ($ $arity req () rest () #f) kargs)
                        (error "kreceive should be tailified away"))))
                    (($ $branch kf kt src op param args)
                     `(,@(compile-test op param args)
                       (if #f ,void-block-type
                           ,(do-branch label kt (push-if ctx))
                           ,(do-branch label kf (push-if ctx)))))
                    (($ $switch kf kt* src arg)
                     `(,(local.get arg)
                       (i32.wrap_i64)
                       (br_table ,(map (lambda (k) (lookup-label k ctx)) kt*)
                                 ,(lookup-label kf ctx))))
                    (($ $prompt k kh src escape? tag)
                     (error "prompts should be removed by tailification?"))
                    (($ $throw src op param args)
                     (compile-throw src op param args))))
                 (($ $kreceive)
                  (error "kreceive should be tailified away"))
                 (($ $kfun src meta self ktail kentry)
                  (match (intmap-ref cps kentry)
                    (($ $kclause)
                     ;; An arity-checking function; let the clause check
                     ;; the arity.
                     (let ((tail (do-branch label kentry ctx)))
                       (if (and self (var-used? self))
                           `(,@(arg-ref 0)
                             ,(local.set self)
                             . ,tail)
                           tail)))
                    (($ $kargs names vars _)
                     ;; A function whose callers all pass the expected
                     ;; number of arguments.
                     (let ((vars (if self (cons self vars) vars)))
                       ;; FIXME: no need to rebind vars.
                       `(,@(append-map (lambda (var idx)
                                         `((local.get ,idx)
                                           ,(local.set var)))
                                       vars (iota (length vars)))
                         ,@(do-tree kentry ctx))))))
                 (($ $kclause ($ $arity req opt rest kw allow-other-keys?)
                     kbody kalt)
                  (when allow-other-keys? (error "allow-other-keys? unimplemented"))
                  (when (not (null? kw)) (error "kwargs unimplemented"))
                  (match (intmap-ref cps kbody)
                    (($ $kargs names vars)
                     (let ((nreq (length req))
                           (nopt (length opt)))
                       (define req-vars (list-head vars nreq))
                       (define opt-vars (list-head (list-tail vars nreq) nopt))
                       (define rest-var
                         (and rest (car (list-tail vars (+ nreq nopt)))))
                       (define (check-positional min max strict?)
                         (define (check count test)
                           (let ((count (if has-closure? (1+ count) count)))
                             `((local.get $nargs)
                               (i32.const ,count)
                               ,test)))
                         (let ((check-req
                                (if (or elide-arity-check?
                                        (and (not strict?) (zero? min)))
                                    '()
                                    (check min
                                           (if (and strict? (eqv? min max))
                                               '(i32.ne)
                                               '(i32.lt_u)))))
                               (check-opt
                                (if (or elide-arity-check?
                                        (eqv? min max) (not strict?))
                                    '()
                                    (check max '(i32.gt_u)))))
                           (define (combine-checks a b)
                             (cond
                              ((null? a) b)
                              ((null? b) a)
                              (else `(,@a ,@b (i32.or)))))
                           (match (combine-checks check-req check-opt)
                             (() '())
                             (checks
                              `(,@checks
                                (if #f ,void-block-type
                                    ,(if kalt
                                         (do-branch label kalt ctx)
                                         `(,(match func-name
                                              (#f '(ref.null string))
                                              (name
                                               `(string.const
                                                 ,(symbol->string func-name))))
                                           (local.get $arg0)
                                           (return_call $raise-arity-error)))
                                    ()))))))
                       (define (init-positional min max)
                         (define (add-closure n) (if has-closure? (1+ n) n))
                         (define init-req
                           (append-map
                            (lambda (arg idx)
                              (if (var-used? arg)
                                  `(,@(arg-ref idx)
                                    ,(local.set arg))
                                  '()))
                            req-vars (iota min (add-closure 0))))
                         (define init-opt
                           (append-map
                            (lambda (arg idx)
                              (if (var-used? arg)
                                  `((local.get $nargs)
                                    (i32.const ,idx)
                                    (i32.gt_u)
                                    (if #f ,scm-block-type
                                        (,@(arg-ref idx))
                                        ((i32.const 57) ; undefined
                                         (ref.i31)))
                                    ,(local.set arg))
                                  '()))
                            opt-vars (iota (- max min) (add-closure min))))
                         (define init-rest
                           (if (and rest-var (var-used? rest-var))
                               `((local.get $nargs)
                                 (local.get $arg0)
                                 (local.get $arg1)
                                 (local.get $arg2)
                                 (i32.const ,(add-closure max))
                                 (call $collect-rest-args)
                                 ,(local.set rest-var))
                               '()))
                         `(,@init-req ,@init-opt ,@init-rest))
                       (define (positional-prelude)
                         `(,@(check-positional nreq (+ nreq nopt) (not rest))
                           ,@(init-positional nreq (+ nreq nopt))))
                       (define (kw-prelude)
                         (error "keyword args unimplemented"))
                       (define prelude
                         (cond
                          ((or allow-other-keys? (pair? kw))
                           (kw-prelude))
                          (else
                           (positional-prelude))))
                       `(,@prelude
                         ,@(do-branch label kbody ctx))))))
                 (($ $ktail)
                  '())))
              (y
               `((block #f ,void-block-type
                        ,(node-within label ys (push-block y ctx)))
                 ,@(do-tree y ctx)))))))
      (define code
        (do-tree kfun (make-ctx #f '())))
      (define (type-for-repr repr)
        (match repr
          ('scm scm-type)
          ('f64 'f64)
          ((or 's64 'u64) 'i64)
          ('bv-contents (make-ref-type #f '$raw-bytevector))
          ('code (make-ref-type #f '$kvarargs))))
      (define (type-for-named-temporary name)
        (match name
          ((or '$raw-sp '$scm-sp '$ret-sp '$dyn-sp) 'i32)
          ((or '$i0 '$i1 '$i2) 'i32)
          ((or '$f0 '$f1 '$f2) 'f64)
          ('$str_iter (make-ref-type #f 'stringview_iter))
          ('$s0 scm-type)
          ('$vu0 (make-ref-type #f '$raw-bytevector))
          ('$v0 (make-ref-type #f '$raw-scmvector))
          (_ #f)))
      (define (add-locals-from-code code)
        (define locals (make-hash-table))
        (define (visit-inst inst)
          (match inst
            (((or 'block 'loop) label type body)
             (visit-expr body))
            (('if label type consequent alternate)
             (visit-expr consequent)
             (visit-expr alternate))
            (('try label type body catches catch-all)
             (visit-expr body)
             (for-each visit-expr catches)
             (when catch-all (visit-expr catch-all)))
            (('try_delegate label type body handler)
             (visit-expr body))
            (((or 'local.set 'local.tee) label)
             (let ((type (type-for-named-temporary label)))
               (when type
                 (hashq-set! locals label type))))
            (_ #f)))
        (define (visit-expr expr)
          (match expr
            (() (values))
            ((inst . expr)
             (visit-inst inst)
             (visit-expr expr))))
        (visit-expr code)
        (sort (hash-map->list make-local locals)
              (lambda (a b)
                (string<? (match a (($ <local> id) (symbol->string id)))
                          (match b (($ <local> id) (symbol->string id)))))))
      (define reprs
        (compute-var-representations cps #:primcall-raw-representations
                                     hoot-primcall-raw-representations))
      (define locals
        (append
         (add-locals-from-code code)
         (intmap-fold-right (lambda (var repr out)
                              (cons (make-local (var-label var)
                                                (type-for-repr repr))
                                    out))
                            reprs '())))
      (define (init-joins code)
        (intset-fold (lambda (var code)
                       (if (var-used? var)
                           (match (intmap-ref reprs var)
                             ((or 'f64 's64 'u64) code)
                             ((or 'code 'bv-contents)
                              (error "unexpected join repr" var))
                             ('scm
                              `((i32.const 57)
                                (ref.i31)
                                ,(local.set var)
                                . ,code)))
                           code))
                     join-vars
                     code))
      ;; FIXME: Here attach a name, other debug info to the function
      (make-func (func-label kfun)
                 (match (known-arity kfun)
                   (#f (make-type-use '$kvarargs kvarargs-sig))
                   (vars (make-type-use
                          #f
                          (make-func-sig
                           (map (lambda (var)
                                  (define repr (intmap-ref reprs var))
                                  (define type (type-for-repr repr))
                                  (make-param #f type))
                                vars)
                           '()))))
                 locals
                 (init-joins code))))

  (define (compute-globals)
    (fold1 (lambda (entry globals)
             (match entry
               (#(name type init-expr reloc-expr)
                (cons (make-global name
                                   (make-global-type #f type)
                                   init-expr)
                      globals))))
           heap-constants
           (list (make-global '$load
                              (make-global-type #t scm-type)
                              `((i32.const 0) (ref.i31))))))

  (define (compute-exports)
    (list (make-export "$load" 'global '$load)))

  (define (compute-start-function funcs)
    (define load-function-id
      (match funcs
        ;; Assume that the first function is the "load" function.
        ((($ <func> id) . _) id)))
    (define relocs
      (fold1 (lambda (entry relocs)
               (match entry
                 (#(name type init-expr #f) relocs)
                 (#(name type init-expr make-reloc)
                  (append (make-reloc name) relocs))))
             heap-constants
             '()))
    (define maybe-grow-argv
      (if (> max-args 8)
          `((i32.const ,(- max-args 8))
            (call $maybe-grow-argv))
          '()))
    (make-func '$start
               void-block-type
               '()
               `(,@maybe-grow-argv
                 (i32.const 0)
                 (ref.func ,load-function-id)
                 (struct.new $proc)
                 (global.set $load)
                 . ,relocs)))

  (let* ((funcs
          (intmap-map->list lower-func (compute-reachable-functions cps 0)))
         (start-func (compute-start-function funcs))
         (types (append (intmap-map->list make-closure-type closure-types)
                        (make-struct-types)))
         (tables '())
         (memories '())
         (globals (compute-globals))
         (exports (compute-exports))
         (start '$start)
         (elems '())
         (tags '())
         (datas (reverse datas))
         (strings '())
         (custom '()))
    (make-wasm '$scheme types imports
               (cons start-func funcs)
               tables memories globals exports
               start elems datas tags strings custom)))

(define* (high-level-cps->wasm cps #:key
                               (import-abi? #f)
                               (export-abi? #t)
                               (env #f)
                               (optimization-level #f)
                               (warning-level #f)
                               (dump-cps? #f)
                               (dump-wasm? #f)
                               (emit-names? #f)
                               (opts '()))
  (define (lower-and-tailify cps)
    (define lower-cps
      (let ((make-lower (language-lowerer (lookup-language 'cps))))
        (make-lower optimization-level opts)))
    (lower-cps cps env))
  (let ((cps (lower-and-tailify cps)))
    (when dump-cps?
      (dump cps))
    (let* ((wasm (lower-to-wasm cps #:import-abi? import-abi?))
           (wasm (if export-abi? (export-abi wasm) wasm))
           (wasm (add-stdlib wasm (compute-stdlib import-abi?)))
           (wasm (lower-wasm wasm #:emit-names? emit-names?)))
      (when dump-wasm?
        (format #t "\n\nThe wasm we are going to emit:\n")
        (dump-wasm wasm))
      wasm)))

(define-syntax-rule (with-hoot-target . body)
  (with-target "wasm32-unknown-hoot"
    (lambda ()
      (parameterize ((target-runtime 'hoot))
        . body))))