cord-far-label-reference asm label)
          (emit asm 0))
         ((R32 label)
          (record-far-label-reference asm label)
          (emit asm 0))
         ((L32 label)
          (record-far-label-reference asm label)
          (emit asm 0))
         ((LO32 label offset)
          (record-far-label-reference asm label
                                      (* offset (asm-word-size asm)))
          (emit asm 0))
         ((C8_C24 a b)
          (emit asm (pack-u8-u24 a b)))
         ((B1_X7_L24 a label)
          (record-label-reference asm label)
          (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
         ((B1_C7_L24 a b label)
          (record-label-reference asm label)
          (emit asm (pack-u1-u7-u24 (if a 1 0) b 0)))
         ((B1_X31 a)
          (emit asm (pack-u1-u7-u24 (if a 1 0) 0 0)))
         ((B1_X7_S24 a b)
          (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))
         ((B1_X7_F24 a b)
          (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))
         ((B1_X7_C24 a b)
          (emit asm (pack-u1-u7-u24 (if a 1 0) 0 b)))
         ((X8_S24 a)
          (emit asm (pack-u8-u24 0 a)))
         ((X8_F24 a)
          (emit asm (pack-u8-u24 0 a)))
         ((X8_C24 a)
          (emit asm (pack-u8-u24 0 a)))
         ((X8_L24 label)
          (record-label-reference asm label)
          (emit asm 0))))

      (syntax-case x ()
        ((_ word0 word* ...)
         (with-syntax ((((formal0 ...)
                         code0 ...)
                        (pack-first-word #'asm #'opcode
                                         (syntax->datum #'word0)))
                       ((((formal* ...)
                          code* ...) ...)
                        (map (lambda (word) (pack-tail-word #'asm word))
                             (syntax->datum #'(word* ...)))))
           ;; The opcode is the last argument, so that assemblers don't
           ;; have to shuffle their arguments before tail-calling an
           ;; encoder.
           #'(lambda (asm formal0 ... formal* ... ... opcode)
               (let lp ()
                 (let ((words (length '(word0 word* ...))))
                   (unless (<= (+ (asm-pos asm) (* 4 words))
                               (bytevector-length (asm-buf asm)))
                     (grow-buffer! asm)
                     (lp))))
               code0 ...
               code* ... ...
               (reset-asm-start! asm)))))))

  (define (encoder-name operands)
    (let lp ((operands operands) (out #'encode))
      (syntax-case operands ()
        (() out)
        ((operand . operands)
         (lp #'operands
             (id-append #'operand (id-append out out #'-) #'operand))))))

  (define-syntax define-encoder
    (lambda (x)
      (syntax-case x ()
        ((_ operand ...)
         (with-syntax ((encode (encoder-name #'(operand ...))))
           #'(define encode (encoder operand ...)))))))

  (define-syntax visit-instruction-kinds
    (lambda (x)
      (syntax-case x ()
        ((visit-instruction-kinds macro arg ...)
         (with-syntax (((operands ...)
                        (delete-duplicates
                         (map (match-lambda
                                ((name opcode kind . operands)
                                 (datum->syntax #'macro operands)))
                              (instruction-list)))))
           #'(begin
               (macro arg ... . operands)
               ...)))))))

(visit-instruction-kinds define-encoder)

;; In Guile's VM, locals are usually addressed via the stack pointer
;; (SP).  There can be up to 2^24 slots for local variables in a
;; frame.  Some instructions encode their operands using a restricted
;; subset of the full 24-bit local address space, in order to make the
;; bytecode more dense in the usual case that a function needs few
;; local slots.  To allow these instructions to be used when there are
;; many local slots, we can temporarily push the values on the stack,
;; operate on them there, and then store back any result as we pop the
;; SP to its original position.
;;
;; We implement this shuffling via wrapper encoders that have the same
;; arity as the encoder they wrap, e.g. encode-X8_S12_S12/shuffle that
;; wraps encode-X8_S12_S12.  We make the emit-cons public interface
;; use the shuffling encoder.  That way we solve the problem fully and
;; in just one place.

(define (encode-X8_S12_S12!/shuffle asm a b opcode)
  (cond
   ((< (logior a b) (ash 1 12))
    (encode-X8_S12_S12 asm a b opcode))
   (else
    (emit-push asm a)
    (emit-push asm (1+ b))
    (encode-X8_S12_S12 asm 1 0 opcode)
    (emit-drop asm 2))))
(define (encode-X8_S12_S12<-/shuffle asm dst a opcode)
  (cond
   ((< (logior dst a) (ash 1 12))
    (encode-X8_S12_S12 asm dst a opcode))
   (else
    (emit-push asm a)
    (encode-X8_S12_S12 asm 0 0 opcode)
    (emit-pop asm dst))))
(define (encode-X8_S12_S12-X8_C24!/shuffle asm a b c opcode)
  (cond
   ((< (logior a b) (ash 1 12))
    (encode-X8_S12_S12-X8_C24 asm a b c opcode))
   (else
    (emit-push asm a)
    (emit-push asm (1+ b))
    (encode-X8_S12_S12-X8_C24 asm 1 0 c opcode)
    (emit-drop asm 2))))
(define (encode-X8_S12_S12-X8_C24<-/shuffle asm dst a const opcode)
  (cond
   ((< (logior dst a) (ash 1 12))
    (encode-X8_S12_S12-X8_C24 asm dst a const opcode))
   (else
    (emit-push asm a)
    (encode-X8_S12_S12-X8_C24 asm 0 0 const opcode)
    (emit-pop asm dst))))
(define (encode-X8_S12_C12<-/shuffle asm dst const opcode)
  (cond
   ((< dst (ash 1 12))
    (encode-X8_S12_C12 asm dst const opcode))
   (else
    ;; Push garbage value to make space for dst.
    (emit-push asm dst)
    (encode-X8_S12_C12 asm 0 const opcode)
    (emit-pop asm dst))))
(define (encode-X8_S8_I16<-/shuffle asm dst imm opcode)
  (cond
   ((< dst (ash 1 8))
    (encode-X8_S8_I16 asm dst imm opcode))
   (else
    ;; Push garbage value to make space for dst.
    (emit-push asm dst)
    (encode-X8_S8_I16 asm 0 imm opcode)
    (emit-pop asm dst))))
(define (encode-X8_S8_S8_S8!/shuffle asm a b c opcode)
  (cond
   ((< (logior a b c) (ash 1 8))
    (encode-X8_S8_S8_S8 asm a b c opcode))
   (else
    (emit-push asm a)
    (emit-push asm (+ b 1))
    (emit-push asm (+ c 2))
    (encode-X8_S8_S8_S8 asm 2 1 0 opcode)
    (emit-drop asm 3))))
(define (encode-X8_S8_S8_S8<-/shuffle asm dst a b opcode)
  (cond
   ((< (logior dst a b) (ash 1 8))
    (encode-X8_S8_S8_S8 asm dst a b opcode))
   (else
    (emit-push asm a)
    (emit-push asm (1+ b))
    (encode-X8_S8_S8_S8 asm 1 1 0 opcode)
    (emit-drop asm 1)
    (emit-pop asm dst))))
(define (encode-X8_S8_S8_C8<-/shuffle asm dst a const opcode)
  (cond
   ((< (logior dst a) (ash 1 8))
    (encode-X8_S8_S8_C8 asm dst a const opcode))
   (else
    (emit-push asm a)
    (encode-X8_S8_S8_C8 asm 0 0 const opcode)
    (emit-pop asm dst))))
(define (encode-X8_S8_C8_S8!/shuffle asm a const b opcode)
  (cond
   ((< (logior a b) (ash 1 8))
    (encode-X8_S8_C8_S8 asm a const b opcode))
   (else
    (emit-push asm a)
    (emit-push asm (1+ b))
    (encode-X8_S8_C8_S8 asm 1 const 0 opcode)
    (emit-drop asm 2))))
(define (encode-X8_S8_C8_S8<-/shuffle asm dst const a opcode)
  (cond
   ((< (logior dst a) (ash 1 8))
    (encode-X8_S8_C8_S8 asm dst const a opcode))
   (else
    (emit-push asm a)
    (encode-X8_S8_C8_S8 asm 0 const 0 opcode)
    (emit-pop asm dst))))

(eval-when (expand)
  (define (id-append ctx a b)
    (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))

  (define (shuffling-encoder-name kind operands)
    (match (cons (syntax->datum kind) (syntax->datum operands))
      (('! 'X8_S12_S12)          #'encode-X8_S12_S12!/shuffle)
      (('<- 'X8_S12_S12)         #'encode-X8_S12_S12<-/shuffle)
      (('! 'X8_S12_S12 'X8_C24)  #'encode-X8_S12_S12-X8_C24!/shuffle)
      (('<- 'X8_S12_S12 'X8_C24) #'encode-X8_S12_S12-X8_C24<-/shuffle)
      (('<- 'X8_S12_C12)         #'encode-X8_S12_C12<-/shuffle)
      (('<- 'X8_S8_I16)          #'encode-X8_S8_I16<-/shuffle)
      (('! 'X8_S8_S8_S8)         #'encode-X8_S8_S8_S8!/shuffle)
      (('<- 'X8_S8_S8_S8)        #'encode-X8_S8_S8_S8<-/shuffle)
      (('<- 'X8_S8_S8_C8)        #'encode-X8_S8_S8_C8<-/shuffle)
      (('! 'X8_S8_C8_S8)         #'encode-X8_S8_C8_S8!/shuffle)
      (('<- 'X8_S8_C8_S8)        #'encode-X8_S8_C8_S8<-/shuffle)
      (else (encoder-name operands))))

  (define-syntax assembler
    (lambda (x)
      (define (word-args word)
        (match word
          ('C32 #'(a))
          ('I32 #'(imm))
          ('A32 #'(imm))
          ('AF32 #'(f64))
          ('AU32 #'(u64))
          ('AS32 #'(s64))
          ('B32 #'())
          ('BU32 #'())
          ('BS32 #'())
          ('BF32 #'())
          ('N32 #'(label))
          ('R32 #'(label))
          ('L32 #'(label))
          ('LO32 #'(label offset))
          ('C8_C24 #'(a b))
          ('B1_X7_L24 #'(a label))
          ('B1_C7_L24 #'(a b label))
          ('B1_X31 #'(a))
          ('B1_X7_S24 #'(a b))
          ('B1_X7_F24 #'(a b))
          ('B1_X7_C24 #'(a b))
          ('X8_S24 #'(arg))
          ('X8_F24 #'(arg))
          ('X8_C24 #'(arg))
          ('X8_L24 #'(label))
          ('X8_S8_I16 #'(a imm))
          ('X8_S12_S12 #'(a b))
          ('X8_S12_C12 #'(a b))
          ('X8_C12_C12 #'(a b))
          ('X8_F12_F12 #'(a b))
          ('X8_S8_S8_S8 #'(a b c))
          ('X8_S8_S8_C8 #'(a b c))
          ('X8_S8_C8_S8 #'(a b c))
          ('X32 #'())))

      (syntax-case x ()
        ((_ name opcode kind word ...)
         (with-syntax (((formal ...)
                        (generate-temporaries
                         (append-map word-args (syntax->datum #'(word ...)))))
                       (encode (shuffling-encoder-name #'kind #'(word ...))))
           #'(lambda (asm formal ...)
               (encode asm formal ... opcode))))))))

(define assemblers (make-hash-table))

(eval-when (expand)
  (define-syntax define-assembler
    (lambda (x)
      (syntax-case x ()
        ((_ name opcode kind arg ...)
         (with-syntax ((emit (id-append #'name #'emit- #'name)))
           #'(define emit
               (let ((emit (assembler name opcode kind arg ...)))
                 (hashq-set! assemblers 'name emit)
                 emit)))))))

  (define-syntax visit-opcodes
    (lambda (x)
      (syntax-case x ()
        ((visit-opcodes macro arg ...)
         (with-syntax (((inst ...)
                        (map (lambda (x) (datum->syntax #'macro x))
                             (instruction-list))))
           #'(begin
               (macro arg ... . inst)
               ...)))))))

(visit-opcodes define-assembler)

;; Shuffling is a general mechanism to get around address space
;; limitations for SP-relative variable references.  FP-relative
;; variables need special support.  Also, some instructions like `mov'
;; have multiple variations with different addressing limits.

(define (emit-mov* asm dst src)
  (if (and (< dst (ash 1 12)) (< src (ash 1 12)))
      (emit-mov asm dst src)
      (emit-long-mov asm dst src)))

(define (emit-fmov* asm dst src)
  (emit-long-fmov asm dst src))

(define (emit-receive* asm dst proc nlocals)
  (if (and (< dst (ash 1 12)) (< proc (ash 1 12)))
      (emit-receive asm dst proc nlocals)
      (begin
        (emit-receive-values asm proc #t 1)
        (emit-fmov* asm dst (1+ proc))
        (emit-reset-frame asm nlocals))))

(define (emit-text asm instructions)
  "Assemble @var{instructions} using the assembler @var{asm}.
@var{instructions} is a sequence of instructions, expressed as a list of
lists.  This procedure can be called many times before calling
@code{link-assembly}."
  (for-each (lambda (inst)
              (apply (or (hashq-ref assemblers (car inst))
                         (error 'bad-instruction inst))
                     asm
                     (cdr inst)))
            instructions))