mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-30 15:00:21 +02:00
Code Activity

Assembler O(n) in instruction encodings, not instruction count

Browse source 
* module/system/vm/assembler.scm: Change define encoders for all of the
  kinds of instructions and have the emit-foo procedures call the common
  encoders.  No change to public interface.  This decreases the amount
  of generated code in the assembler.
This commit is contained in:
Andy Wingo 2015-12-26 15:11:44 +01:00
parent 362907810b
commit 8a39162160
1 changed files with 324 additions and 276 deletions
Download patch file Download diff file Expand all files Collapse all files

600
module/system/vm/assembler.scm
View file

@ -58,17 +58,20 @@
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:export (make-assembler #:export (make-assembler
(emit-receive* . emit-receive)
(emit-mov* . emit-mov)
(emit-fmov* . emit-fmov)
emit-call emit-call
emit-call-label emit-call-label
emit-tail-call emit-tail-call
emit-tail-call-label emit-tail-call-label
(emit-receive* . emit-receive)
emit-receive-values emit-receive-values
emit-return emit-return
emit-return-values emit-return-values
emit-call/cc emit-call/cc
emit-abort emit-abort
(emit-builtin-ref* . emit-builtin-ref) emit-builtin-ref
emit-br-if-nargs-ne emit-br-if-nargs-ne
emit-br-if-nargs-lt emit-br-if-nargs-lt
emit-br-if-nargs-gt emit-br-if-nargs-gt
@ -103,115 +106,113 @@
emit-br-if-u64-=-scm emit-br-if-u64-=-scm
emit-br-if-u64->=-scm emit-br-if-u64->=-scm
emit-br-if-u64->-scm emit-br-if-u64->-scm
(emit-mov* . emit-mov) emit-box
(emit-fmov* . emit-fmov) emit-box-ref
(emit-box* . emit-box) emit-box-set!
(emit-box-ref* . emit-box-ref)
(emit-box-set!* . emit-box-set!)
emit-make-closure emit-make-closure
(emit-free-ref* . emit-free-ref) emit-free-ref
(emit-free-set!* . emit-free-set!) emit-free-set!
emit-current-module emit-current-module
emit-resolve emit-resolve
(emit-define!* . emit-define!) emit-define!
emit-toplevel-box emit-toplevel-box
emit-module-box emit-module-box
emit-prompt emit-prompt
(emit-wind* . emit-wind) emit-wind
emit-unwind emit-unwind
(emit-push-fluid* . emit-push-fluid) emit-push-fluid
emit-pop-fluid emit-pop-fluid
emit-current-thread emit-current-thread
(emit-fluid-ref* . emit-fluid-ref) emit-fluid-ref
(emit-fluid-set* . emit-fluid-set) emit-fluid-set
(emit-string-length* . emit-string-length) emit-string-length
(emit-string-ref* . emit-string-ref) emit-string-ref
(emit-string->number* . emit-string->number) emit-string->number
(emit-string->symbol* . emit-string->symbol) emit-string->symbol
(emit-symbol->keyword* . emit-symbol->keyword) emit-symbol->keyword
(emit-cons* . emit-cons) emit-cons
(emit-car* . emit-car) emit-car
(emit-cdr* . emit-cdr) emit-cdr
(emit-set-car!* . emit-set-car!) emit-set-car!
(emit-set-cdr!* . emit-set-cdr!) emit-set-cdr!
(emit-add* . emit-add) emit-add
(emit-add/immediate* . emit-add/immediate) emit-add/immediate
(emit-sub* . emit-sub) emit-sub
(emit-sub/immediate* . emit-sub/immediate) emit-sub/immediate
(emit-mul* . emit-mul) emit-mul
(emit-div* . emit-div) emit-div
(emit-quo* . emit-quo) emit-quo
(emit-rem* . emit-rem) emit-rem
(emit-mod* . emit-mod) emit-mod
(emit-ash* . emit-ash) emit-ash
(emit-fadd* . emit-fadd) emit-fadd
(emit-fsub* . emit-fsub) emit-fsub
(emit-fmul* . emit-fmul) emit-fmul
(emit-fdiv* . emit-fdiv) emit-fdiv
(emit-uadd* . emit-uadd) emit-uadd
(emit-usub* . emit-usub) emit-usub
(emit-umul* . emit-umul) emit-umul
(emit-uadd/immediate* . emit-uadd/immediate) emit-uadd/immediate
(emit-usub/immediate* . emit-usub/immediate) emit-usub/immediate
(emit-umul/immediate* . emit-umul/immediate) emit-umul/immediate
(emit-logand* . emit-logand) emit-logand
(emit-logior* . emit-logior) emit-logior
(emit-logxor* . emit-logxor) emit-logxor
(emit-logsub* . emit-logsub) emit-logsub
(emit-ulogand* . emit-ulogand) emit-ulogand
(emit-ulogior* . emit-ulogior) emit-ulogior
(emit-ulogsub* . emit-ulogsub) emit-ulogsub
(emit-ursh* . emit-ursh) emit-ursh
(emit-ulsh* . emit-ulsh) emit-ulsh
(emit-ursh/immediate* . emit-ursh/immediate) emit-ursh/immediate
(emit-ulsh/immediate* . emit-ulsh/immediate) emit-ulsh/immediate
(emit-make-vector* . emit-make-vector) emit-make-vector
(emit-make-vector/immediate* . emit-make-vector/immediate) emit-make-vector/immediate
(emit-vector-length* . emit-vector-length) emit-vector-length
(emit-vector-ref* . emit-vector-ref) emit-vector-ref
(emit-vector-ref/immediate* . emit-vector-ref/immediate) emit-vector-ref/immediate
(emit-vector-set!* . emit-vector-set!) emit-vector-set!
(emit-vector-set!/immediate* . emit-vector-set!/immediate) emit-vector-set!/immediate
(emit-struct-vtable* . emit-struct-vtable) emit-struct-vtable
(emit-allocate-struct/immediate* . emit-allocate-struct/immediate) emit-allocate-struct/immediate
(emit-struct-ref/immediate* . emit-struct-ref/immediate) emit-struct-ref/immediate
(emit-struct-set!/immediate* . emit-struct-set!/immediate) emit-struct-set!/immediate
(emit-allocate-struct* . emit-allocate-struct) emit-allocate-struct
(emit-struct-ref* . emit-struct-ref) emit-struct-ref
(emit-struct-set!* . emit-struct-set!) emit-struct-set!
(emit-class-of* . emit-class-of) emit-class-of
emit-make-array emit-make-array
(emit-scm->f64* . emit-scm->f64) emit-scm->f64
emit-load-f64 emit-load-f64
(emit-f64->scm* . emit-f64->scm) emit-f64->scm
(emit-scm->u64* . emit-scm->u64) emit-scm->u64
(emit-scm->u64/truncate* . emit-scm->u64/truncate) emit-scm->u64/truncate
emit-load-u64 emit-load-u64
(emit-u64->scm* . emit-u64->scm) emit-u64->scm
(emit-scm->s64* . emit-scm->s64) emit-scm->s64
emit-load-s64 emit-load-s64
(emit-s64->scm* . emit-s64->scm) emit-s64->scm
(emit-bv-length* . emit-bv-length) emit-bv-length
(emit-bv-u8-ref* . emit-bv-u8-ref) emit-bv-u8-ref
(emit-bv-s8-ref* . emit-bv-s8-ref) emit-bv-s8-ref
(emit-bv-u16-ref* . emit-bv-u16-ref) emit-bv-u16-ref
(emit-bv-s16-ref* . emit-bv-s16-ref) emit-bv-s16-ref
(emit-bv-u32-ref* . emit-bv-u32-ref) emit-bv-u32-ref
(emit-bv-s32-ref* . emit-bv-s32-ref) emit-bv-s32-ref
(emit-bv-u64-ref* . emit-bv-u64-ref) emit-bv-u64-ref
(emit-bv-s64-ref* . emit-bv-s64-ref) emit-bv-s64-ref
(emit-bv-f32-ref* . emit-bv-f32-ref) emit-bv-f32-ref
(emit-bv-f64-ref* . emit-bv-f64-ref) emit-bv-f64-ref
(emit-bv-u8-set!* . emit-bv-u8-set!) emit-bv-u8-set!
(emit-bv-s8-set!* . emit-bv-s8-set!) emit-bv-s8-set!
(emit-bv-u16-set!* . emit-bv-u16-set!) emit-bv-u16-set!
(emit-bv-s16-set!* . emit-bv-s16-set!) emit-bv-s16-set!
(emit-bv-u32-set!* . emit-bv-u32-set!) emit-bv-u32-set!
(emit-bv-s32-set!* . emit-bv-s32-set!) emit-bv-s32-set!
(emit-bv-u64-set!* . emit-bv-u64-set!) emit-bv-u64-set!
(emit-bv-s64-set!* . emit-bv-s64-set!) emit-bv-s64-set!
(emit-bv-f32-set!* . emit-bv-f32-set!) emit-bv-f32-set!
(emit-bv-f64-set!* . emit-bv-f64-set!) emit-bv-f64-set!
emit-text emit-text
link-assembly)) link-assembly))
@ -494,7 +495,7 @@ later by the linker."
(define (id-append ctx a b) (define (id-append ctx a b)
(datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b)))) (datum->syntax ctx (symbol-append (syntax->datum a) (syntax->datum b))))
(define-syntax assembler (define-syntax encoder
(lambda (x) (lambda (x)
(define-syntax op-case (define-syntax op-case
(lambda (x) (lambda (x)
@ -610,17 +611,19 @@ later by the linker."
(emit asm 0)))) (emit asm 0))))
(syntax-case x () (syntax-case x ()
((_ name opcode word0 word* ...) ((_ word0 word* ...)
(with-syntax ((((formal0 ...) (with-syntax ((((formal0 ...)
code0 ...) code0 ...)
(pack-first-word #'asm (pack-first-word #'asm #'opcode
(syntax->datum #'opcode)
(syntax->datum #'word0))) (syntax->datum #'word0)))
((((formal* ...) ((((formal* ...)
code* ...) ...) code* ...) ...)
(map (lambda (word) (pack-tail-word #'asm word)) (map (lambda (word) (pack-tail-word #'asm word))
(syntax->datum #'(word* ...))))) (syntax->datum #'(word* ...)))))
#'(lambda (asm formal0 ... formal* ... ...) ;; 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 lp ()
(let ((words (length '(word0 word* ...)))) (let ((words (length '(word0 word* ...))))
(unless (<= (+ (asm-pos asm) (* 4 words)) (unless (<= (+ (asm-pos asm) (* 4 words))
@ -629,7 +632,219 @@ later by the linker."
(lp)))) (lp))))
code0 ... code0 ...
code* ... ... code* ... ...
(reset-asm-start! asm)))))))) (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)) (define assemblers (make-hash-table))
@ -640,7 +855,7 @@ later by the linker."
((_ name opcode kind arg ...) ((_ name opcode kind arg ...)
(with-syntax ((emit (id-append #'name #'emit- #'name))) (with-syntax ((emit (id-append #'name #'emit- #'name)))
#'(define emit #'(define emit
(let ((emit (assembler name opcode arg ...))) (let ((emit (assembler name opcode kind arg ...)))
(hashq-set! assemblers 'name emit) (hashq-set! assemblers 'name emit)
emit))))))) emit)))))))
@ -657,177 +872,10 @@ later by the linker."
(visit-opcodes define-assembler) (visit-opcodes define-assembler)
(eval-when (expand) ;; Shuffling is a general mechanism to get around address space
;; limitations for SP-relative variable references. FP-relative
;; In Guile's VM, locals are usually addressed via the stack pointer ;; variables need special support. Also, some instructions like `mov'
;; (SP). There can be up to 2^24 slots for local variables in a ;; have multiple variations with different addressing limits.
;; 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 emitters that have the same
;; arity as the emitter they wrap, e.g. emit-cons* that wraps
;; emit-cons. We expose these wrappers as the public interface for
;; emitting `cons' instructions. That way we solve the problem fully
;; and in just one place. The only manual care that need be taken is
;; in the exports list at the top of the file -- to be sure that we
;; export the wrapper and not the wrapped emitter.
(define (shuffling-assembler emit kind word0 word*)
(with-syntax ((emit emit))
(match (cons* word0 kind word*)
(('X8_S12_S12 '!)
#'(lambda (asm a b)
(cond
((< (logior a b) (ash 1 12))
(emit asm a b))
(else
(emit-push asm a)
(emit-push asm (1+ b))
(emit asm 1 0)
(emit-drop asm 2)))))
(('X8_S12_S12 '<-)
#'(lambda (asm dst a)
(cond
((< (logior dst a) (ash 1 12))
(emit asm dst a))
(else
(emit-push asm a)
(emit asm 0 0)
(emit-pop asm dst)))))
(('X8_S12_S12 '! 'X8_C24)
#'(lambda (asm a b c)
(cond
((< (logior a b) (ash 1 12))
(emit asm a b c))
(else
(emit-push asm a)
(emit-push asm (1+ b))
(emit asm 1 0 c)
(emit-drop asm 2)))))
(('X8_S12_S12 '<- 'X8_C24)
#'(lambda (asm dst a const)
(cond
((< (logior dst a) (ash 1 12))
(emit asm dst a const))
(else
(emit-push asm a)
(emit asm 0 0 const)
(emit-pop asm dst)))))
(('X8_S12_C12 '<-)
#'(lambda (asm dst const)
(cond
((< dst (ash 1 12))
(emit asm dst const))
(else
;; Push garbage value to make space for dst.
(emit-push asm dst)
(emit asm 0 const)
(emit-pop asm dst)))))
(('X8_S8_I16 '<-)
#'(lambda (asm dst imm)
(cond
((< dst (ash 1 8))
(emit asm dst imm))
(else
;; Push garbage value to make space for dst.
(emit-push asm dst)
(emit asm 0 imm)
(emit-pop asm dst)))))
(('X8_S8_S8_S8 '!)
#'(lambda (asm a b c)
(cond
((< (logior a b c) (ash 1 8))
(emit asm a b c))
(else
(emit-push asm a)
(emit-push asm (+ b 1))
(emit-push asm (+ c 2))
(emit asm 2 1 0)
(emit-drop asm 3)))))
(('X8_S8_S8_S8 '<-)
#'(lambda (asm dst a b)
(cond
((< (logior dst a b) (ash 1 8))
(emit asm dst a b))
(else
(emit-push asm a)
(emit-push asm (1+ b))
(emit asm 1 1 0)
(emit-drop asm 1)
(emit-pop asm dst)))))
(('X8_S8_S8_C8 '<-)
#'(lambda (asm dst a const)
(cond
((< (logior dst a) (ash 1 8))
(emit asm dst a const))
(else
(emit-push asm a)
(emit asm 0 0 const)
(emit-pop asm dst)))))
(('X8_S8_C8_S8 '!)
#'(lambda (asm a const b)
(cond
((< (logior a b) (ash 1 8))
(emit asm a const b))
(else
(emit-push asm a)
(emit-push asm (1+ b))
(emit asm 1 const 0)
(emit-drop asm 2)))))
(('X8_S8_C8_S8 '<-)
#'(lambda (asm dst const a)
(cond
((< (logior dst a) (ash 1 8))
(emit asm dst const a))
(else
(emit-push asm a)
(emit asm 0 const 0)
(emit-pop asm dst))))))))
(define-syntax define-shuffling-assembler
(lambda (stx)
(define (might-shuffle? word0)
(case word0
((X8_S12_S12 X8_S12_C12
X8_S8_I16
X8_S8_S8_S8 X8_S8_S8_C8 X8_S8_C8_S8) #t)
(else #f)))
(syntax-case stx ()
((_ #:except (except ...) name opcode kind word0 word* ...)
(let ((_except (syntax->datum #'(except ...)))
(_name (syntax->datum #'name))
(_kind (syntax->datum #'kind))
(_word0 (syntax->datum #'word0))
(_word* (syntax->datum #'(word* ...)))
(emit (id-append #'name #'emit- #'name)))
(cond
((and (might-shuffle? _word0) (not (memq _name _except)))
(with-syntax
((emit* (id-append #'name emit #'*))
(proc (shuffling-assembler emit _kind _word0 _word*)))
#'(define emit*
(let ((emit* proc))
(hashq-set! assemblers 'name emit*)
emit*))))
(else
#'(begin)))))))))
(visit-opcodes define-shuffling-assembler #:except (receive mov))
;; Mov and receive are two special cases that can work without wrappers.
;; Indeed it is important that they do so.
(define (emit-mov* asm dst src) (define (emit-mov* asm dst src)
(if (and (< dst (ash 1 12)) (< src (ash 1 12))) (if (and (< dst (ash 1 12)) (< src (ash 1 12)))