+(eval-when (expand)
+
+ ;; Some operands are encoded 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 there are few live locals. Here we
+ ;; define wrapper emitters that shuffle out-of-range operands into and
+ ;; out of the reserved range of locals [233,255]. This range is
+ ;; sufficient because these restricted operands are only present in
+ ;; the first word of an instruction. Since 8 bits is the smallest
+ ;; slot-addressing operand size, that means we can fit 3 operands in
+ ;; the 24 bits of payload of the first word (the lower 8 bits being
+ ;; taken by the opcode).
+ ;;
+ ;; The result are wrapper emitters with the same arity,
+ ;; 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 name kind word0 word*)
+ (define (analyze-first-word)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((_ type ((%type %kind arg ...) values) clause ...)
+ (if (and (eq? type '%type) (eq? kind '%kind))
+ (with-syntax (((arg ...) (generate-temporaries #'(arg ...))))
+ #'((arg ...) values))
+ (op-case type clause ...)))
+ ((_ type)
+ #f)))
+ (op-case
+ word0
+ ((U8_U8_I16 ! a imm)
+ (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253))
+ imm))
+ ((U8_U8_I16 <- a imm)
+ (values (if (< a (ash 1 8)) a 253)
+ imm))
+ ((U8_U12_U12 ! a b)
+ (values (if (< a (ash 1 12)) a (begin (emit-mov* asm 253 a) 253))
+ (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254))))
+ ((U8_U12_U12 <- a b)
+ (values (if (< a (ash 1 12)) a 253)
+ (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254))))
+ ((U8_U8_U8_U8 ! a b c)
+ (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253))
+ (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254))
+ (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255))))
+ ((U8_U8_U8_U8 <- a b c)
+ (values (if (< a (ash 1 8)) a 253)
+ (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254))
+ (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255))))))
+
+ (define (tail-formals type)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((op-case type (%type arg ...) clause ...)
+ (if (eq? type '%type)
+ (generate-temporaries #'(arg ...))
+ (op-case type clause ...)))
+ ((op-case type)
+ (error "unmatched type" type))))
+ (op-case type
+ (U8_U24 a b)
+ (U8_L24 a label)
+ (U32 a)
+ (I32 imm)
+ (A32 imm)
+ (B32)
+ (N32 label)
+ (S32 label)
+ (L32 label)
+ (LO32 label offset)
+ (X8_U24 a)
+ (X8_L24 label)
+ (B1_X7_L24 a label)
+ (B1_U7_L24 a b label)
+ (B1_X31 a)
+ (B1_X7_U24 a b)))
+
+ (define (shuffle-up dst)
+ (define-syntax op-case
+ (syntax-rules ()
+ ((_ type ((%type ...) exp) clause ...)
+ (if (memq type '(%type ...))
+ #'exp
+ (op-case type clause ...)))
+ ((_ type)
+ (error "unexpected type" type))))
+ (with-syntax ((dst dst))
+ (op-case
+ word0
+ ((U8_U8_I16 U8_U8_U8_U8)
+ (unless (< dst (ash 1 8))
+ (emit-mov* asm dst 253)))
+ ((U8_U12_U12)
+ (unless (< dst (ash 1 12))
+ (emit-mov* asm dst 253))))))
+
+ (and=>
+ (analyze-first-word)
+ (lambda (formals+shuffle)
+ (with-syntax ((emit-name (id-append name #'emit- name))
+ (((formal0 ...) shuffle) formals+shuffle)
+ (((formal* ...) ...) (map tail-formals word*)))
+ (with-syntax (((shuffle-up-dst ...)
+ (if (eq? kind '<-)
+ (syntax-case #'(formal0 ...) ()
+ ((dst . _)
+ (list (shuffle-up #'dst))))
+ '())))
+ #'(lambda (asm formal0 ... formal* ... ...)
+ (call-with-values (lambda () shuffle)
+ (lambda (formal0 ...)
+ (emit-name asm formal0 ... formal* ... ...)))
+ shuffle-up-dst ...))))))
+
+ (define-syntax define-shuffling-assembler
+ (lambda (stx)
+ (syntax-case stx ()
+ ((_ #:except (except ...) name opcode kind word0 word* ...)
+ (cond
+ ((or-map (lambda (op) (eq? (syntax->datum #'name) op))
+ (map syntax->datum #'(except ...)))
+ #'(begin))
+ ((shuffling-assembler #'name (syntax->datum #'kind)
+ (syntax->datum #'word0)
+ (map syntax->datum #'(word* ...)))
+ => (lambda (proc)
+ (with-syntax ((emit (id-append #'name
+ (id-append #'name #'emit- #'name)
+ #'*))
+ (proc proc))
+ #'(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)
+ (if (and (< dst (ash 1 12)) (< src (ash 1 12)))
+ (emit-mov asm dst src)
+ (emit-long-mov 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-mov* asm dst (1+ proc))
+ (emit-reset-frame asm nlocals))))
+