;;; Stack effects for instruction validation
;;; Copyright (C) 2023, 2024, 2025, 2026 Igalia, S.L.
;;; 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:
;;;
;;; Computes and applies stack effects for individual instructions for
;;; the purposes of validation.
;;;
;;; Code:

(define-module (wasm stack)
  #:use-module (ice-9 match)
  #:use-module ((srfi srfi-1) #:select (append-map filter-map))
  #:use-module (srfi srfi-9)
  #:use-module (wasm canonical-types)
  #:use-module (wasm subtyping)
  #:use-module (wasm types)
  #:export (<wasm-info>
            make-wasm-info
            wasm-info?
            wasm-info-type-mapping
            wasm-info-types
            wasm-info-funcs
            wasm-info-globals
            wasm-info-memories
            wasm-info-tables
            wasm-info-tags
            wasm-info-canonicalization

            <ctx>
            ctx?
            ctx-func-info
            ctx-block
            ctx-stack

            <unreachable-ctx>
            unreachable-ctx?
            unreachable-ctx-block
            unreachable-ctx-stack

            <invalid-ctx>
            invalid-ctx?
            invalid-ctx-reason

            <block>
            block?
            block-id
            block-type
            block-branch-arg-types
            block-result-types
            block-parent

            <stack-effect>
            stack-effect?
            stack-effect-params
            stack-effect-results
            stack-effect-block-end?

            initial-ctx
            push-block
            lookup-block
            lookup-tag
            compute-stack-effect
            apply-stack-effect
            fallthrough-stack-effect
            fallthrough))

(define-record-type <wasm-info>
  (%make-wasm-info type-mapping types funcs globals memories tables tags
                   canonicalization)
  wasm-info?
  (type-mapping wasm-info-type-mapping)
  (types wasm-info-types)
  (funcs wasm-info-funcs)
  (globals wasm-info-globals)
  (memories wasm-info-memories)
  (tables wasm-info-tables)
  (tags wasm-info-tags)
  (canonicalization wasm-info-canonicalization))

(define-record-type <func-info>
  (%make-func-info type-mapping types funcs globals tables tags locals
                   canonicalization)
  func-info?
  (type-mapping func-info-type-mapping)
  (types func-info-types)
  (funcs func-info-funcs)
  (globals func-info-globals)
  (tables func-info-tables)
  (tags func-info-tags)
  (locals func-info-locals)
  (canonicalization func-info-canonicalization))

(define-record-type <ctx>
  (make-ctx func-info block stack)
  ctx?
  (func-info ctx-func-info)
  (block ctx-block)
  (stack ctx-stack))

(define-record-type <unreachable-ctx>
  (make-unreachable-ctx func-info block stack)
  unreachable-ctx?
  (func-info unreachable-ctx-func-info)
  (block unreachable-ctx-block)
  (stack unreachable-ctx-stack))

(define-record-type <invalid-ctx>
  (make-invalid-ctx reason)
  invalid-ctx?
  (reason invalid-ctx-reason))

(define-record-type <block>
  (make-block id type branch-arg-types result-types parent)
  block?
  (id block-id)
  (type block-type) ; 'block', 'loop', 'try', 'catch', etc.
  ;; If you jump to this block's label, what types do you pass?  Usually
  ;; the block results, but for loops it's the loop parameters.
  (branch-arg-types block-branch-arg-types)
  ;; When control falls through the end of a block, what types must be
  ;; on the stack?
  (result-types block-result-types)
  (parent block-parent))

(define-record-type <stack-effect>
  (make-stack-effect params results block-end?)
  stack-effect?
  (params stack-effect-params)
  ;; Results can be #f if the effect causes an exit.
  (results stack-effect-results)
  ;; The stack at the end of a block is expected to contain the param
  ;; types and nothing else below them.
  (block-end? stack-effect-block-end?))

(define (make-wasm-info wasm canonicalization)
  (define type-mapping
    (canonicalize-types! canonicalization (wasm-types wasm)))
  (define types
    (list->vector
     (map
      (lambda (id canonical-idx)
        (cons id (canonical-type-ref canonicalization canonical-idx)))
      (append-map (match-lambda
                    (($ <type> id type) (list id))
                    (($ <rec-group> (($ <type> id type) ...)) id))
                  (wasm-types wasm))
      (vector->list type-mapping))))

  (define (intern-heap-type ht)
    (match ht
      ((? symbol?) ht)
      ((? exact-integer?) (vector-ref type-mapping ht))))
  (define (intern-ref-type rt)
    (match rt
      (($ <ref-type> nullable? ht)
       (make-ref-type nullable? (intern-heap-type ht)))))
  (define (intern-val-type typ)
    (match typ
      ((? symbol?) typ)
      (_ (intern-ref-type typ))))
  (define (intern-func-sig sig)
    (match sig
      (($ <func-sig> (($ <param> pid ptype) ...) (rtype ...))
       (make-func-sig
        (map make-param pid (map intern-val-type ptype))
        (map intern-val-type rtype)))))
  (define (intern-type-use use)
    (match use
      (($ <type-use> (? exact-integer? typid) sig)
       (make-type-use (vector-ref type-mapping typid)
                      (intern-func-sig sig)))))
  (define (intern-global-type gt)
    (match gt
      (($ <global-type> mutable? type)
       (make-global-type mutable? (intern-val-type type)))))
  (define (intern-table-type tt)
    (match tt
      (($ <table-type> limits elem-type)
       (make-table-type limits (intern-val-type elem-type)))))
  (define (intern-tag-type tag)
    (match tag
      (($ <tag-type> tid type-use)
       (make-tag-type tid (intern-type-use type-use)))))

  (define (select-imports kind)
    (filter-map (lambda (import)
                  (and (eq? (import-kind import) kind)
                       (cons (import-id import) (import-type import))))
                (wasm-imports wasm)))

  (define (intern import-kind get-defs def-id def-type intern-type)
    (list->vector
     (map (match-lambda ((id . x) (cons id (intern-type x))))
          (append (select-imports import-kind)
                  (map (lambda (def)
                         (cons (def-id def) (def-type def)))
                       (get-defs wasm))))))

  (define funcs
    (intern 'func wasm-funcs func-id func-type intern-type-use))
  (define globals
    (intern 'global wasm-globals global-id global-type intern-global-type))
  (define memories
    (intern 'memory wasm-memories memory-id memory-type identity))
  (define tables
    (intern 'table wasm-tables table-id table-type intern-table-type))
  (define tags
    (intern 'tag wasm-tags tag-id tag-type intern-tag-type))

  (%make-wasm-info type-mapping types funcs globals memories tables tags
                   canonicalization))

(define (initial-ctx wasm-info func)
  (match wasm-info
    (($ <wasm-info> type-mapping types funcs globals memories tables tags
        canonicalization)
     (define (intern-heap-type ht)
       (match ht
         ((? symbol?) ht)
         ((? exact-integer?) (vector-ref type-mapping ht))))
     (define (intern-ref-type typ)
       (match typ
         (($ <ref-type> nullable? ht)
          (make-ref-type nullable? (intern-heap-type ht)))))
     (define (intern-val-type typ)
       (match typ
         ((? symbol?) typ)
         (_ (intern-ref-type typ))))

     (match func
       (($ <func> _
           ($ <type-use> _
              ($ <func-sig>
                 (($ <param> param-id param-type) ...)
                 (result-type ...))
              )
           (($ <local> local-id local-type) ...)
           body)
        (define locals
          (list->vector
           (append (map cons param-id (map intern-val-type param-type))
                   (map cons local-id (map intern-val-type local-type)))))
        (define results
          (map intern-val-type result-type))

        (make-ctx
         (%make-func-info type-mapping types funcs globals tables tags locals
                          canonicalization)
         (make-block 'func #f results results #f)
         '()))))))

(define (push-block ctx id type param-types result-types)
  (match ctx
    (($ <ctx> info block _)
     (let ((branch-arg-types (if (eq? type 'loop) param-types result-types)))
       (make-ctx info
                 (make-block id type branch-arg-types result-types block)
                 (reverse param-types))))))

(define (peek ctx)
  (match ctx
    ((or ($ <ctx> _ _ stack)
         ($ <unreachable-ctx> _ _ stack))
     (match stack
       ((top . stack) top)
       (() #f)))
    (($ <invalid-ctx>) #f)))

(define (peek-under ctx)
  (match ctx
    ((or ($ <ctx> _ _ stack)
         ($ <unreachable-ctx> _ _ stack))
     (match stack
       ((top next . stack) next)
       ((top) #f)
       (() #f)))
    (($ <invalid-ctx>) #f)))

(define (vector-assq v k)
  (let lp ((i 0))
    (and (< i (vector-length v))
         (let ((pair (vector-ref v i)))
           (if (eq? k (car pair))
               pair
               (lp (1+ i)))))))
(define (vector-lookup v k)
  (if (integer? k)
      (vector-ref v k)
      (vector-assq v k)))

(define (ctx-info-lookup ctx getter def)
  (match ctx
    (($ <ctx> info)
     (cdr (vector-lookup (getter info) def)))
    (($ <unreachable-ctx> info)
     (cdr (vector-lookup (getter info) def)))))

(define (lookup-type ctx def)
  (ctx-info-lookup ctx func-info-types def))
(define (lookup-func-type-use ctx def)
  (ctx-info-lookup ctx func-info-funcs def))
(define (lookup-global ctx def)
  (ctx-info-lookup ctx func-info-globals def))
(define (lookup-table ctx def)
  (ctx-info-lookup ctx func-info-tables def))
(define (lookup-tag ctx def)
  (ctx-info-lookup ctx func-info-tags def))
(define (lookup-local ctx def)
  (ctx-info-lookup ctx func-info-locals def))

(define (lookup-type-mapping ctx use-idx)
  (vector-ref (func-info-type-mapping
               (match ctx
                 (($ <ctx> info) info)
                 (($ <unreachable-ctx> info) info)))
              use-idx))

(define (lookup-func-sig ctx def)
  (match (lookup-type ctx def)
    (($ <sub-type> _ _ (and sig ($ <func-sig>))) sig)
    ((and sig ($ <func-sig>)) sig)
    (x (error "unexpected type" def x))))

(define (storage-type->val-type typ)
  (case typ
    ((i8 i16) 'i32)
    (else typ)))

(define (lookup-struct-fields ctx def)
  (match (lookup-type ctx def)
    (($ <sub-type> _ _ ($ <struct-type> fields)) fields)
    (($ <struct-type> fields) fields)))
(define (lookup-struct-field-type ctx struct-type field)
  (match (lookup-struct-fields ctx struct-type)
    ((($ <field> id mutable? type) ...)
     (vector-lookup (list->vector type) field))))

(define (lookup-array-type ctx def)
  (match (lookup-type ctx def)
    (($ <sub-type> _ _ ($ <array-type> mutable? type)) type)
    (($ <array-type> mutable? type) type)))

(define (lookup-return-type ctx)
  (let lp ((block (ctx-block ctx)))
    (cond
     ((block-parent block) => lp)
     (else (block-branch-arg-types block)))))

(define (lookup-block ctx target)
  (match ctx
    ((or ($ <ctx> _ block) ($ <unreachable-ctx> _ block))
     (if (integer? target)
         (let lp ((block block) (target target))
           (match block
             (($ <block> id _ _ _ parent)
              (if (zero? target)
                  block
                  (lp parent (1- target))))))
         (let lp ((block block))
           (match block
             (($ <block> id _ _ _ parent)
              (if (eq? target id)
                  block
                  (lp parent)))))))))

(define (ref-type-difference rt1 rt2)
  (match rt1
    (($ <ref-type> nullable1? ht1)
     (match rt2
       (($ <ref-type> nullable2? ht2)
        (if nullable2?
            (make-ref-type #f ht1)
            (make-ref-type nullable1? ht1)))))))

(define (compute-stack-effect ctx inst)
  (define (-> params results)
    (make-stack-effect params results #f))
  (define (intern-heap-type ht)
    (match ht
      ((? symbol?) ht)
      ((? exact-integer?) (lookup-type-mapping ctx ht))))
  (define (intern-ref-type rt)
    (match rt
      (($ <ref-type> nullable? ht)
       (make-ref-type nullable? (intern-heap-type ht)))))
  (define (intern-val-type typ)
    (match typ
      ((? symbol?) typ)
      (($ <ref-type>) (intern-ref-type typ))))
  (define (%lookup-func-sig type) (lookup-func-sig ctx type))
  (define (%lookup-func-type-use type) (lookup-func-type-use ctx type))
  (define (%lookup-struct-fields type) (lookup-struct-fields ctx type))
  (define (%lookup-array-type type) (lookup-array-type ctx type))
  (define (%lookup-tag tag) (lookup-tag ctx tag))
  (define (%lookup-local local) (lookup-local ctx local))
  (define (lookup-canonicalization ctx)
    (match ctx
      ((or ($ <ctx> info) ($ <unreachable-ctx> info))
       (func-info-canonicalization info))))
  (define (nullable-mutable-i8-array-type)
    (make-ref-type #t (canonical-mutable-i8-array-heap-type
                       (lookup-canonicalization ctx))))
  (define (nullable-mutable-i16-array-type)
    (make-ref-type #t (canonical-mutable-i16-array-heap-type
                       (lookup-canonicalization ctx))))
  (define (branch-arg-types target)
    (block-branch-arg-types (lookup-block ctx target)))
  (define (block-stack-effect type)
    (match type
      (#f (-> '() '()))
      ;; Lookup signature by index in func info.
      ((? exact-integer? idx)
       (match ctx
         ((or ($ <ctx> func-info)
              ($ <unreachable-ctx> func-info))
          (match (vector-ref (func-info-types func-info) idx)
            ((_ . ($ <func-sig> (($ <param> _ params) ...) results))
             (-> params results))))))
      (($ <type-use> _
          ($ <func-sig> (($ <param> _ params) ...) results))
       (-> (map intern-val-type params) (map intern-val-type results)))
      (_
       (-> '() (list (intern-val-type type))))))
  (define (global-type global)
    (match (lookup-global ctx global)
      (($ <global-type> mutable? type) type)))
  (define (table-type def)
    (match (lookup-table ctx def)
      (($ <table-type> limits elem-type) elem-type)))
  (match inst
    ((op . args)
     (match op
       ('unreachable (-> '() #f))
       ('nop (-> '() '()))

       ((or 'block 'loop 'try 'try_delegate)
        (match args
          ((label type . _)
           (block-stack-effect type))))
       ('if
        (match args
          ((label type _ _)
           (match (block-stack-effect type)
             (($ <stack-effect> params results)
              (-> (append params '(i32)) results))))))

       ('throw
        (match args
          (((= %lookup-tag
               ($ <tag-type>
                  _ ($ <type-use>
                       _ ($ <func-sig> (($ <param> _ type) ...))))))
           (-> type #f))))
       ('rethrow
        (-> '() #f))
       ('br
        (match args
          ((target)
           (-> (branch-arg-types target) #f))))
       ('br_if
        (match args
          ((target)
           (let ((types (branch-arg-types target)))
             (-> (append types '(i32)) types)))))
       ('br_table
        (match args
          ((_ target)
           (-> (append (branch-arg-types target) '(i32)) #f))))
       ('return
        (-> (lookup-return-type ctx) #f))

       ('call
        (match args
          (((= %lookup-func-type-use
               ($ <type-use> _
                  ($ <func-sig> (($ <param> id type) ...) results))))
           (-> type results))))
       ('call_indirect
        (match args
          ((table (= %lookup-func-sig
                     ($ <func-sig> (($ <param> id type) ...) results)))
           (-> (append type '(i32)) results))))
       ('return_call
        (match args
          (((= %lookup-func-type-use
               ($ <type-use> _
                 ($ <func-sig> (($ <param> id type) ...) results))))
           (-> type #f))))
       ('return_call_indirect
        (match args
          (((= %lookup-func-sig
               ($ <func-sig> (($ <param> id type) ...) results)))
           (-> (append type '(i32)) #f))))
       ('call_ref
        (match args
          (((and (= intern-heap-type ht)
                 (= %lookup-func-sig
                    ($ <func-sig> (($ <param> id params) ...) results))))
           (-> (append params (list (make-ref-type #t ht))) results))))
       ('return_call_ref
        (match args
          (((and (= intern-heap-type ht)
                 (= %lookup-func-sig
                    ($ <func-sig> (($ <param> id params) ...) results))))
           (-> (append params (list (make-ref-type #t ht))) #f))))

       ('drop (-> (list (peek ctx)) '()))
       ('select (match args
                  (()
                   (let ((top (peek-under ctx)))
                     (-> (list top top 'i32) (list top))))
                  ((((= intern-val-type type) ...))
                   (-> (append type type '(i32)) type))))

       ('local.get (match args
                     (((= %lookup-local type))
                      (-> '() (list type)))))
       ('local.set (match args
                     (((= %lookup-local type))
                      (-> (list type) '()))))
       ('local.tee (match args
                     (((= %lookup-local type))
                      (-> (list type) (list type)))))

       ('global.get (match args
                      ((global)
                       (-> '() (list (global-type global))))))
       ('global.set (match args
                      ((global)
                       (-> (list (global-type global)) '()))))

       ('table.get  (match args
                      ((table)
                       (-> '(i32) (list (table-type table))))))
       ('table.set  (match args
                      ((table)
                       (-> (list 'i32 (table-type table)) '()))))
       ('table.size (-> '() '(i32)))
       ('table.init (-> '(i32 i32 i32) '()))
       ('table.copy (-> '(i32 i32 i32) '()))
       ('table.fill (match args
                      ((table)
                       (-> (list 'i32 (table-type table) 'i32) '()))))
       ('table.grow (match args
                      ((table)
                       (-> (list (table-type table) 'i32) '(i32)))))
       ('elem.drop  (-> '() '()))

       ('memory.size (-> '() '(i32)))
       ('memory.grow (-> '(i32) '(i32)))
       ('memory.fill (-> '(i32 i32 i32) '()))
       ('memory.copy (-> '(i32 i32 i32) '()))
       ('memory.init (-> '(i32 i32 i32) '()))
       ('data.drop (-> '() '()))

       ('i32.const (-> '() '(i32)))
       ('i64.const (-> '() '(i64)))
       ('f32.const (-> '() '(f32)))
       ('f64.const (-> '() '(f64)))

       ((or 'i32.load
            'i32.load8_s 'i32.load8_u 'i32.load16_s 'i32.load16_u)
        (-> '(i32) '(i32)))

       ((or 'i64.load
            'i64.load8_s 'i64.load8_u 'i64.load16_s 'i64.load16_u
            'i64.load32_s 'i64.load32_u)
        (-> '(i32) '(i64)))

       ('f32.load (-> '(i32) '(f32)))
       ('f64.load (-> '(i32) '(f64)))

       ((or 'i32.store 'i32.store8 'i32.store16)
        (-> '(i32 i32) '()))
       ((or 'i64.store 'i64.store8 'i64.store16 'i64.store32)
        (-> '(i32 i64) '()))
       ('f32.store (-> '(i32 f32) '()))
       ('f64.store (-> '(i32 f64) '()))

       ('i32.eqz (-> '(i32) '(i32)))
       ((or 'i32.eq 'i32.ne 'i32.lt_s 'i32.lt_u 'i32.gt_s
            'i32.gt_u 'i32.le_s 'i32.le_u 'i32.ge_s 'i32.ge_u)
        (-> '(i32 i32) '(i32)))
       ('i64.eqz (-> '(i64) '(i32)))
       ((or 'i64.eq 'i64.ne 'i64.lt_s 'i64.lt_u 'i64.gt_s
            'i64.gt_u 'i64.le_s 'i64.le_u 'i64.ge_s 'i64.ge_u)
        (-> '(i64 i64) '(i32)))

       ((or 'f32.eq 'f32.ne 'f32.lt 'f32.gt 'f32.le 'f32.ge)
        (-> '(f32 f32) '(i32)))
       ((or 'f64.eq 'f64.ne 'f64.lt 'f64.gt 'f64.le 'f64.ge)
        (-> '(f64 f64) '(i32)))

       ((or 'i32.clz 'i32.ctz 'i32.popcnt
            'i32.extend8_s 'i32.extend16_s)
        (-> '(i32) '(i32)))
       ((or 'i32.add 'i32.sub 'i32.mul 'i32.div_s 'i32.div_u
            'i32.rem_s 'i32.rem_u
            'i32.and 'i32.or 'i32.xor 'i32.shl 'i32.shr_s 'i32.shr_u
            'i32.rotl 'i32.rotr)
        (-> '(i32 i32) '(i32)))
       ('i32.wrap_i64
        (-> '(i64) '(i32)))
       ((or 'i32.trunc_f32_s 'i32.trunc_f32_u
            'i32.trunc_sat_f32_s 'i32.trunc_sat_f32_u
            'i32.reinterpret_f32)
        (-> '(f32) '(i32)))
       ((or 'i32.trunc_f64_s 'i32.trunc_f64_u
            'i32.trunc_sat_f64_s 'i32.trunc_sat_f64_u)
        (-> '(f64) '(i32)))

       ((or 'i64.clz 'i64.ctz 'i64.popcnt
            'i64.extend8_s 'i64.extend16_s 'i64.extend32_s)
        (-> '(i64) '(i64)))
       ((or 'i64.add 'i64.sub 'i64.mul 'i64.div_s 'i64.div_u
            'i64.rem_s 'i64.rem_u
            'i64.and 'i64.or 'i64.xor 'i64.shl 'i64.shr_s 'i64.shr_u
            'i64.rotl 'i64.rotr)
        (-> '(i64 i64) '(i64)))
       ((or 'i64.extend_i32_s 'i64.extend_i32_u)
        (-> '(i32) '(i64)))
       ((or 'i64.trunc_f32_s 'i64.trunc_f32_u
            'i64.trunc_sat_f32_s 'i64.trunc_sat_f32_u)
        (-> '(f32) '(i64)))
       ((or 'i64.trunc_f64_s 'i64.trunc_f64_u
            'i64.trunc_sat_f64_s 'i64.trunc_sat_f64_u
            'i64.reinterpret_f64)
        (-> '(f64) '(i64)))

       ((or 'f32.abs 'f32.neg 'f32.ceil 'f32.floor 'f32.trunc 'f32.nearest
            'f32.sqrt)
        (-> '(f32) '(f32)))
       ((or 'f32.add 'f32.sub 'f32.mul 'f32.div 'f32.min 'f32.max
            'f32.copysign)
        (-> '(f32 f32) '(f32)))
       ((or 'f32.convert_i32_s 'f32.convert_i32_u
            'f32.reinterpret_i32)
        (-> '(i32) '(f32)))
       ((or 'f32.convert_i64_s 'f32.convert_i64_u)
        (-> '(i64) '(f32)))
       ('f32.demote_f64
        (-> '(f64) '(f32)))

       ((or 'f64.abs 'f64.neg 'f64.ceil 'f64.floor 'f64.trunc 'f64.nearest
            'f64.sqrt)
        (-> '(f64) '(f64)))
       ((or 'f64.add 'f64.sub 'f64.mul 'f64.div 'f64.min 'f64.max
            'f64.copysign)
        (-> '(f64 f64) '(f64)))
       ((or 'f64.convert_i32_s 'f64.convert_i32_u)
        (-> '(i32) '(f64)))
       ((or 'f64.convert_i64_s 'f64.convert_i64_u
            'f64.reinterpret_i64)
        (-> '(i64) '(f64)))
       ('f64.promote_f32
        (-> '(f32) '(f64)))

       ('ref.null
        (match args
          (((= intern-heap-type ht))
           (-> '() (list (make-ref-type #t ht))))))
       ((or 'ref.is_null 'ref.test)
        ;; FIXME: ref.is_null only valid on ref types
        ;; FIXME: ref.test only valid if tested type matches top
        (-> (list (peek ctx)) '(i32)))
       ('ref.eq
        (-> (list (make-ref-type #t 'eq) (make-ref-type #t 'eq)) '(i32)))
       ('ref.func
        (match args
          (((= %lookup-func-type-use ($ <type-use> ht sig)))
           (-> '() (list (make-ref-type #f ht))))))
       ('ref.as_non_null
        (match (peek ctx)
          ((and top ($ <ref-type> nullable? ht))
           (-> (list top)
               (list (make-ref-type #f ht))))))
       ('ref.cast
        (match args
          (((= intern-ref-type dst))
           (let ((src (peek ctx)))
             ;; FIXME: assert that dst <= src
             (-> (list src) (list dst))))))
       ((or 'br_on_cast 'br_on_cast_fail)
        (match args
          ((target (= intern-ref-type rt1) (= intern-ref-type rt2))
           ;; FIXME: assert that last type is rt1.
           (match (branch-arg-types target)
             ((first ... last)
              (-> (append first (list rt1))
                  (append first (list (if (eq? op 'br_on_cast)
                                          (ref-type-difference rt1 rt2)
                                          rt2)))))))))

       ('struct.get
        (match args
          (((and (= intern-heap-type ht) orig-idx) field)
           (-> (list (make-ref-type #t ht))
               (list (storage-type->val-type
                      (lookup-struct-field-type ctx orig-idx field)))))))
       ((or 'struct.get_s 'struct.get_u)
        (match args
          (((= intern-heap-type ht) field)
           (-> (list (make-ref-type #t ht)) '(i32)))))
       ('struct.set
        (match args
          (((and (= intern-heap-type ht) orig-idx) field)
           (-> (list (make-ref-type #t ht)
                     (storage-type->val-type
                      (lookup-struct-field-type ctx orig-idx field)))
               '()))))
       ('struct.new
        (match args
          (((and (= intern-heap-type ht)
                 (= %lookup-struct-fields
                    ((= field-type (= storage-type->val-type field)) ...))))
           (-> field
               (list (make-ref-type #f ht))))))
       ('struct.new_default
        (match args
          (((= intern-heap-type ht))
           (-> '() (list (make-ref-type #f ht))))))

       ('array.get
        (match args
          (((and (= intern-heap-type ht)
                 (= %lookup-array-type (= storage-type->val-type field-type))))
           (-> (list (make-ref-type #t ht) 'i32)
               (list field-type)))))
       ((or 'array.get_s 'array.get_u)
        (match args
          (((= intern-heap-type ht))
           (-> (list (make-ref-type #t ht) 'i32)
               '(i32)))))
       ('array.set
        (match args
          (((and (= intern-heap-type ht)
                 (= %lookup-array-type (= storage-type->val-type field-type))))
           (-> (list (make-ref-type #t ht) 'i32 field-type)
               '()))))
       ('array.fill
        (match args
          (((and (= intern-heap-type ht)
                 (= %lookup-array-type (= storage-type->val-type field-type))))
           (-> (list (make-ref-type #t ht) 'i32 field-type 'i32)
               '()))))
       ('array.copy
        (match args
          (((= intern-heap-type ht1) (= intern-heap-type ht2))
           (-> (list
                (make-ref-type #t ht1) 'i32 (make-ref-type #t ht2) 'i32 'i32)
               '()))))
       ('array.len
        (-> (list (make-ref-type #t 'array)) '(i32)))
       ('array.new
        (match args
          (((and (= intern-heap-type ht)
                 (= %lookup-array-type (= storage-type->val-type field-type))))
           (-> (list field-type 'i32)
               (list (make-ref-type #f ht))))))
       ('array.new_fixed
        (match args
          (((and (= intern-heap-type ht)
                 (= %lookup-array-type (= storage-type->val-type field-type)))
            len)
           (-> (make-list len field-type)
               (list (make-ref-type #f ht))))))
       ('array.new_default
        (match args
          (((= intern-heap-type ht))
           (-> '(i32) (list (make-ref-type #f ht))))))
       ((or 'array.new_data 'array.new_elem)
        ;; FIXME: Verify data/elem idx in bounds.
        (match args
          (((= intern-heap-type ht) idx)
           (-> '(i32 i32) (list (make-ref-type #f ht))))))
       ((or 'array.init_data 'array.init_elem)
        ;; FIXME: Verify data/elem idx in bounds.
        (match args
          (((= intern-heap-type ht) idx)
           (-> (list (make-ref-type #t ht) 'i32 'i32 'i32)
               '()))))

       ('ref.i31
        (-> '(i32) (list (make-ref-type #f 'i31))))
       ((or 'i31.get_s 'i31.get_u)
        (-> (list (make-ref-type #f 'i31)) '(i32)))

       ('any.convert_extern
        (match (peek ctx)
          (($ <ref-type> nullable? _)
           (-> (list (make-ref-type nullable? 'extern))
               (list (make-ref-type nullable? 'any))))))
       ('extern.convert_any
        (match (peek ctx)
          (($ <ref-type> nullable? _)
           (-> (list (make-ref-type nullable? 'any))
               (list (make-ref-type nullable? 'extern))))))

       ((or 'string.new_utf8 'string.new_lossy_utf8 'string.new_wtf8
            'string.new_wtf16)
        (-> '(i32 i32)
            (list (make-ref-type #f 'string))))
       ((or 'string.new_utf8_array 'string.new_lossy_utf8_array
            'string.new_wtf8_array)
        (-> (list (nullable-mutable-i8-array-type) 'i32 'i32)
            (list (make-ref-type #f 'string))))
       ((or 'string.new_wtf16_array)
        (-> (list (nullable-mutable-i16-array-type) 'i32 'i32)
            (list (make-ref-type #f 'string))))
       ((or 'string.measure_utf8 'string.measure_wtf8
            'string.measure_wtf16)
        (-> (list (make-ref-type #t 'string))
            '(i32)))
       ((or 'string.encode_utf8 'string.encode_lossy_utf8 'string.encode_wtf8
            'string.encode_wtf16)
        (-> (list (make-ref-type #t 'string) 'i32)
            '(i32)))
       ((or 'string.encode_utf8_array 'string.encode_lossy_utf8_array
            'string.encode_wtf8_array)
        (-> (list (make-ref-type #t 'string)
                  (nullable-mutable-i8-array-type)
                  'i32)
            '(i32)))
       ('string.encode_wtf16_array
        (-> (list (make-ref-type #t 'string)
                  (nullable-mutable-i16-array-type)
                  'i32)
            '(i32)))
       ('string.const
        (-> '() (list (make-ref-type #f 'string))))
       ('string.concat
        (-> (list (make-ref-type #t 'string)
                  (make-ref-type #t 'string))
            (list (make-ref-type #f 'string))))
       ((or 'string.eq 'string.compare)
        (-> (list (make-ref-type #t 'string)
                  (make-ref-type #t 'string))
            '(i32)))
       ('string.is_usv_sequence
        (-> (list (make-ref-type #t 'string))
            '(i32)))
       ('string.from_code_point
        (-> (list 'i32)
            (list (make-ref-type #f 'string))))

       ('string.as_wtf8
        (-> (list (make-ref-type #t 'string))
            (list (make-ref-type #f 'stringview_wtf8))))
       ((or 'stringview_wtf8.encode_utf8
            'stringview_wtf8.encode_lossy_utf8
            'stringview_wtf8.encode_wtf8)
        (-> (list (make-ref-type #t 'stringview_wtf8)
                  'i32 'i32 'i32)
            '(i32 i32)))
       ('stringview_wtf8.advance
        (-> (list (make-ref-type #t 'stringview_wtf8)
                  'i32 'i32)
            '(i32)))
       ('stringview_wtf8.slice
        (-> (list (make-ref-type #t 'stringview_wtf8)
                  'i32 'i32)
            (list (make-ref-type #f 'string))))

       ('string.as_wtf16
        (-> (list (make-ref-type #t 'string))
            (list (make-ref-type #f 'stringview_wtf16))))
       ('stringview_wtf16.length
        (-> (list (make-ref-type #t 'stringview_wtf16))
            '(i32)))
       ('stringview_wtf16.get_codeunit
        (-> (list (make-ref-type #t 'stringview_wtf16) 'i32)
            '(i32)))
       ('stringview_wtf16.encode
        (-> (list (make-ref-type #t 'stringview_wtf16) 'i32 'i32 'i32)
            '(i32)))
       ('stringview_wtf16.slice
        (-> (list (make-ref-type #t 'stringview_wtf16)
                  'i32 'i32)
            (list (make-ref-type #f 'string))))

       ('string.as_iter
        (-> (list (make-ref-type #t 'string))
            (list (make-ref-type #f 'stringview_iter))))
       ('stringview_iter.next
        (-> (list (make-ref-type #t 'stringview_iter))
            '(i32)))
       ((or 'stringview_iter.advance 'stringview_iter.rewind)
        (-> (list (make-ref-type #t 'stringview_iter) 'i32)
            '(i32)))
       ('stringview_iter.slice
        (-> (list (make-ref-type #t 'stringview_iter)
                  'i32)
            (list (make-ref-type #f 'string))))

       ((or 'i8x16.splat 'i16x8.splat 'i32x4.splat)
        (-> '(i32) '(i128)))
       ('i64x2.splat (-> '(i64) '(i128)))
       ('f32x4.splat (-> '(f32) '(i128)))
       ('f64x2.splat (-> '(f64) '(i128)))

       (_ (error "unhandled instruction" op))))))

(define (apply-stack-effect ctx effect)
  (match ctx
    (($ <invalid-ctx>) ctx)
    (($ <unreachable-ctx> info block stack)
     (match effect
       (($ <stack-effect> params results block-end?)
        (let lp ((params (reverse params)) (stack stack))
          (match params
            ((param . params)
             (match stack
               ;; The bottom of the unreachable stack is treated as a
               ;; polymorphic stack that contains any type, so there
               ;; is no reason to continue type checking.
               (()
                (lp '() '()))
               ;; Peeking at the unreachable stack may return #f,
               ;; which can stand in for any type.
               ((#f . stack)
                (lp params stack))
               ;; A proper type is on top of the stack, type checking
               ;; happens the same as in <ctx>.
               ((top . stack)
                (if (val-type<=? top param (func-info-canonicalization info))
                    (lp params stack)
                    (make-invalid-ctx
                     (format #f "expected ~a, got ~a" param top))))))
            (()
             (if (and block-end? (not (null? stack)))
                 (make-invalid-ctx
                  (format #f "extra values on stack at block end ~a" stack))
                 (match results
                   (#f (make-unreachable-ctx info block '()))
                   ((result ...)
                    (make-unreachable-ctx info block (append (reverse result) stack)))))))))))
    (($ <ctx> info block stack)
     (match effect
       (($ <stack-effect> params results block-end?)
        (let lp ((params (reverse params)) (stack stack))
          (match params
            ((param . params)
             (match stack
               (()
                (make-invalid-ctx
                 (format #f "expected ~a, got empty stack" param)))
               ((top . stack)
                (if (val-type<=? top param (func-info-canonicalization info))
                    (lp params stack)
                    ;; FIXME: more info here.
                    (make-invalid-ctx
                     (format #f "expected ~a, got ~a" param top))))))
            (()
             (if (and block-end? (not (null? stack)))
                 (make-invalid-ctx
                  (format #f "extra values on stack at block end ~a" stack))
                 (match results
                   (#f (make-unreachable-ctx info block '()))
                   ((result ...)
                    (make-ctx info block (append (reverse result) stack)))))))))))))

(define (fallthrough-stack-effect ctx)
  (let ((types
         (match ctx
           (($ <unreachable-ctx> _ ($ <block> _ _ _ types)) types)
           (($ <ctx> _ ($ <block> _ _ _ types)) types))))
    (make-stack-effect types #f #t)))

(define (fallthrough ctx)
  (apply-stack-effect ctx (fallthrough-stack-effect ctx)))
