summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2015-10-21 10:48:58 +0200
committerAndy Wingo <wingo@pobox.com>2015-10-21 11:49:20 +0200
commit70c317ab5173e26d9f2a9b8b81a9441ef3ef7008 (patch)
tree09cff8c7ea63dd36eab1920eb31a89cd91c256aa /module
parent9b1ac02a8584ee7ca73a8f5920d7b33c0487bfc0 (diff)
downloadguile-70c317ab5173e26d9f2a9b8b81a9441ef3ef7008.tar.gz
SP-relative local addressing
* libguile/vm-engine.c: S24/S12/S8 operands addressed relative to the SP, not the FP. Cache the SP instead of a FP-relative locals pointer. Further cleanups to follow. * libguile/vm.c (vm_builtin_call_with_values_code): Adapt to mov operand addresing change. * module/language/cps/compile-bytecode.scm (compile-function): Reify SP-relative local indexes where appropriate. * module/system/vm/assembler.scm (emit-fmov*): New helper, exported as emit-fmov. (shuffling-assembler, define-shuffling-assembler): Rewrite to shuffle via push/pop/drop. (standard-prelude, opt-prelude, kw-prelude): No need to provide for shuffling args. * test-suite/tests/rtl.test: Update. * module/language/cps/slot-allocation.scm: Don't reserve slots 253-255.
Diffstat (limited to 'module')
-rw-r--r--module/language/cps/compile-bytecode.scm185
-rw-r--r--module/language/cps/slot-allocation.scm23
-rw-r--r--module/system/vm/assembler.scm338
3 files changed, 285 insertions, 261 deletions
diff --git a/module/language/cps/compile-bytecode.scm b/module/language/cps/compile-bytecode.scm
index 498bac9b3..5b0c32990 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -100,9 +100,12 @@
(define (constant sym)
(lookup-constant-value sym allocation))
+ (define (from-sp var)
+ (- frame-size 1 var))
+
(define (maybe-mov dst src)
(unless (= dst src)
- (emit-mov asm dst src)))
+ (emit-mov asm (from-sp dst) (from-sp src))))
(define (compile-tail label exp)
;; There are only three kinds of expressions in tail position:
@@ -110,12 +113,12 @@
(match exp
(($ $call proc args)
(for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
+ ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
(emit-tail-call asm (1+ (length args))))
(($ $callk k proc args)
(for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
+ ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
(emit-tail-call-label asm (1+ (length args)) k))
(($ $values ())
@@ -123,83 +126,109 @@
(emit-return-values asm))
(($ $values (arg))
(if (maybe-slot arg)
- (emit-return asm (slot arg))
+ (emit-return asm (from-sp (slot arg)))
(begin
- (emit-load-constant asm 1 (constant arg))
- (emit-return asm 1))))
+ (when (< frame-size 2)
+ (emit-alloc-frame asm 2))
+ (emit-load-constant asm (from-sp 1) (constant arg))
+ (emit-return asm (from-sp 1)))))
(($ $values args)
(for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
+ ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
(emit-reset-frame asm (1+ (length args)))
(emit-return-values asm))
(($ $primcall 'return (arg))
- (emit-return asm (slot arg)))))
+ (emit-return asm (from-sp (slot arg))))))
(define (compile-value label exp dst)
(match exp
(($ $values (arg))
(maybe-mov dst (slot arg)))
(($ $const exp)
- (emit-load-constant asm dst exp))
+ (emit-load-constant asm (from-sp dst) exp))
(($ $closure k 0)
- (emit-load-static-procedure asm dst k))
+ (emit-load-static-procedure asm (from-sp dst) k))
(($ $closure k nfree)
- (emit-make-closure asm dst k nfree))
+ (emit-make-closure asm (from-sp dst) k nfree))
(($ $primcall 'current-module)
- (emit-current-module asm dst))
+ (emit-current-module asm (from-sp dst)))
(($ $primcall 'cached-toplevel-box (scope name bound?))
- (emit-cached-toplevel-box asm dst (constant scope) (constant name)
+ (emit-cached-toplevel-box asm (from-sp dst)
+ (constant scope) (constant name)
(constant bound?)))
(($ $primcall 'cached-module-box (mod name public? bound?))
- (emit-cached-module-box asm dst (constant mod) (constant name)
+ (emit-cached-module-box asm (from-sp dst)
+ (constant mod) (constant name)
(constant public?) (constant bound?)))
(($ $primcall 'resolve (name bound?))
- (emit-resolve asm dst (constant bound?) (slot name)))
+ (emit-resolve asm (from-sp dst) (constant bound?)
+ (from-sp (slot name))))
(($ $primcall 'free-ref (closure idx))
- (emit-free-ref asm dst (slot closure) (constant idx)))
+ (emit-free-ref asm (from-sp dst) (from-sp (slot closure))
+ (constant idx)))
(($ $primcall 'vector-ref (vector index))
- (emit-vector-ref asm dst (slot vector) (slot index)))
+ (emit-vector-ref asm (from-sp dst) (from-sp (slot vector))
+ (from-sp (slot index))))
(($ $primcall 'make-vector (length init))
- (emit-make-vector asm dst (slot length) (slot init)))
+ (emit-make-vector asm (from-sp dst) (from-sp (slot length))
+ (from-sp (slot init))))
(($ $primcall 'make-vector/immediate (length init))
- (emit-make-vector/immediate asm dst (constant length) (slot init)))
+ (emit-make-vector/immediate asm (from-sp dst) (constant length)
+ (from-sp (slot init))))
(($ $primcall 'vector-ref/immediate (vector index))
- (emit-vector-ref/immediate asm dst (slot vector) (constant index)))
+ (emit-vector-ref/immediate asm (from-sp dst) (from-sp (slot vector))
+ (constant index)))
(($ $primcall 'allocate-struct (vtable nfields))
- (emit-allocate-struct asm dst (slot vtable) (slot nfields)))
+ (emit-allocate-struct asm (from-sp dst) (from-sp (slot vtable))
+ (from-sp (slot nfields))))
(($ $primcall 'allocate-struct/immediate (vtable nfields))
- (emit-allocate-struct/immediate asm dst (slot vtable) (constant nfields)))
+ (emit-allocate-struct/immediate asm (from-sp dst)
+ (from-sp (slot vtable))
+ (constant nfields)))
(($ $primcall 'struct-ref (struct n))
- (emit-struct-ref asm dst (slot struct) (slot n)))
+ (emit-struct-ref asm (from-sp dst) (from-sp (slot struct))
+ (from-sp (slot n))))
(($ $primcall 'struct-ref/immediate (struct n))
- (emit-struct-ref/immediate asm dst (slot struct) (constant n)))
+ (emit-struct-ref/immediate asm (from-sp dst) (from-sp (slot struct))
+ (constant n)))
(($ $primcall 'builtin-ref (name))
- (emit-builtin-ref asm dst (constant name)))
+ (emit-builtin-ref asm (from-sp dst) (constant name)))
(($ $primcall 'bv-u8-ref (bv idx))
- (emit-bv-u8-ref asm dst (slot bv) (slot idx)))
+ (emit-bv-u8-ref asm (from-sp dst) (from-sp (slot bv))
+ (from-sp (slot idx))))
(($ $primcall 'bv-s8-ref (bv idx))
- (emit-bv-s8-ref asm dst (slot bv) (slot idx)))
+ (emit-bv-s8-ref asm (from-sp dst) (from-sp (slot bv))
+ (from-sp (slot idx))))
(($ $primcall 'bv-u16-ref (bv idx))
- (emit-bv-u16-ref asm dst (slot bv) (slot idx)))
+ (emit-bv-u16-ref asm (from-sp dst) (from-sp (slot bv))
+ (from-sp (slot idx))))
(($ $primcall 'bv-s16-ref (bv idx))
- (emit-bv-s16-ref asm dst (slot bv) (slot idx)))
+ (emit-bv-s16-ref asm (from-sp dst) (from-sp (slot bv))
+ (from-sp (slot idx))))
(($ $primcall 'bv-u32-ref (bv idx val))
- (emit-bv-u32-ref asm dst (slot bv) (slot idx)))
+ (emit-bv-u32-ref asm (from-sp dst) (from-sp (slot bv))
+ (from-sp (slot idx))))
(($ $primcall 'bv-s32-ref (bv idx val))
- (emit-bv-s32-ref asm dst (slot bv) (slot idx)))
+ (emit-bv-s32-ref asm (from-sp dst) (from-sp (slot bv))
+ (from-sp (slot idx))))
(($ $primcall 'bv-u64-ref (bv idx val))
- (emit-bv-u64-ref asm dst (slot bv) (slot idx)))
+ (emit-bv-u64-ref asm (from-sp dst) (from-sp (slot bv))
+ (from-sp (slot idx))))
(($ $primcall 'bv-s64-ref (bv idx val))
- (emit-bv-s64-ref asm dst (slot bv) (slot idx)))
+ (emit-bv-s64-ref asm (from-sp dst) (from-sp (slot bv))
+ (from-sp (slot idx))))
(($ $primcall 'bv-f32-ref (bv idx val))
- (emit-bv-f32-ref asm dst (slot bv) (slot idx)))
+ (emit-bv-f32-ref asm (from-sp dst) (from-sp (slot bv))
+ (from-sp (slot idx))))
(($ $primcall 'bv-f64-ref (bv idx val))
- (emit-bv-f64-ref asm dst (slot bv) (slot idx)))
+ (emit-bv-f64-ref asm (from-sp dst) (from-sp (slot bv))
+ (from-sp (slot idx))))
(($ $primcall name args)
;; FIXME: Inline all the cases.
(let ((inst (prim-instruction name)))
- (emit-text asm `((,inst ,dst ,@(map slot args))))))))
+ (emit-text asm `((,inst ,(from-sp dst)
+ ,@(map (compose from-sp slot) args))))))))
(define (compile-effect label exp k)
(match exp
@@ -210,7 +239,8 @@
(let ((receive-args (gensym "handler"))
(nreq (length req))
(proc-slot (lookup-call-proc-slot label allocation)))
- (emit-prompt asm (slot tag) escape? proc-slot receive-args)
+ (emit-prompt asm (from-sp (slot tag)) escape? proc-slot
+ receive-args)
(emit-br asm k)
(emit-label asm receive-args)
(unless (and rest (zero? nreq))
@@ -221,57 +251,71 @@
(maybe-slot rest))))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
+ ((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves handler allocation))
(emit-reset-frame asm frame-size)
(emit-br asm (forward-label khandler-body))))))
(($ $primcall 'cache-current-module! (sym scope))
- (emit-cache-current-module! asm (slot sym) (constant scope)))
+ (emit-cache-current-module! asm (from-sp (slot sym)) (constant scope)))
(($ $primcall 'free-set! (closure idx value))
- (emit-free-set! asm (slot closure) (slot value) (constant idx)))
+ (emit-free-set! asm (from-sp (slot closure)) (from-sp (slot value))
+ (constant idx)))
(($ $primcall 'box-set! (box value))
- (emit-box-set! asm (slot box) (slot value)))
+ (emit-box-set! asm (from-sp (slot box)) (from-sp (slot value))))
(($ $primcall 'struct-set! (struct index value))
- (emit-struct-set! asm (slot struct) (slot index) (slot value)))
+ (emit-struct-set! asm (from-sp (slot struct)) (from-sp (slot index))
+ (from-sp (slot value))))
(($ $primcall 'struct-set!/immediate (struct index value))
- (emit-struct-set!/immediate asm (slot struct) (constant index) (slot value)))
+ (emit-struct-set!/immediate asm (from-sp (slot struct))
+ (constant index) (from-sp (slot value))))
(($ $primcall 'vector-set! (vector index value))
- (emit-vector-set! asm (slot vector) (slot index) (slot value)))
+ (emit-vector-set! asm (from-sp (slot vector)) (from-sp (slot index))
+ (from-sp (slot value))))
(($ $primcall 'vector-set!/immediate (vector index value))
- (emit-vector-set!/immediate asm (slot vector) (constant index)
- (slot value)))
+ (emit-vector-set!/immediate asm (from-sp (slot vector))
+ (constant index) (from-sp (slot value))))
(($ $primcall 'set-car! (pair value))
- (emit-set-car! asm (slot pair) (slot value)))
+ (emit-set-car! asm (from-sp (slot pair)) (from-sp (slot value))))
(($ $primcall 'set-cdr! (pair value))
- (emit-set-cdr! asm (slot pair) (slot value)))
+ (emit-set-cdr! asm (from-sp (slot pair)) (from-sp (slot value))))
(($ $primcall 'define! (sym value))
- (emit-define! asm (slot sym) (slot value)))
+ (emit-define! asm (from-sp (slot sym)) (from-sp (slot value))))
(($ $primcall 'push-fluid (fluid val))
- (emit-push-fluid asm (slot fluid) (slot val)))
+ (emit-push-fluid asm (from-sp (slot fluid)) (from-sp (slot val))))
(($ $primcall 'pop-fluid ())
(emit-pop-fluid asm))
(($ $primcall 'wind (winder unwinder))
- (emit-wind asm (slot winder) (slot unwinder)))
+ (emit-wind asm (from-sp (slot winder)) (from-sp (slot unwinder))))
(($ $primcall 'bv-u8-set! (bv idx val))
- (emit-bv-u8-set! asm (slot bv) (slot idx) (slot val)))
+ (emit-bv-u8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
+ (from-sp (slot val))))
(($ $primcall 'bv-s8-set! (bv idx val))
- (emit-bv-s8-set! asm (slot bv) (slot idx) (slot val)))
+ (emit-bv-s8-set! asm (from-sp (slot bv)) (from-sp (slot idx))
+ (from-sp (slot val))))
(($ $primcall 'bv-u16-set! (bv idx val))
- (emit-bv-u16-set! asm (slot bv) (slot idx) (slot val)))
+ (emit-bv-u16-set! asm (from-sp (slot bv)) (from-sp (slot idx))
+ (from-sp (slot val))))
(($ $primcall 'bv-s16-set! (bv idx val))
- (emit-bv-s16-set! asm (slot bv) (slot idx) (slot val)))
+ (emit-bv-s16-set! asm (from-sp (slot bv)) (from-sp (slot idx))
+ (from-sp (slot val))))
(($ $primcall 'bv-u32-set! (bv idx val))
- (emit-bv-u32-set! asm (slot bv) (slot idx) (slot val)))
+ (emit-bv-u32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
+ (from-sp (slot val))))
(($ $primcall 'bv-s32-set! (bv idx val))
- (emit-bv-s32-set! asm (slot bv) (slot idx) (slot val)))
+ (emit-bv-s32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
+ (from-sp (slot val))))
(($ $primcall 'bv-u64-set! (bv idx val))
- (emit-bv-u64-set! asm (slot bv) (slot idx) (slot val)))
+ (emit-bv-u64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
+ (from-sp (slot val))))
(($ $primcall 'bv-s64-set! (bv idx val))
- (emit-bv-s64-set! asm (slot bv) (slot idx) (slot val)))
+ (emit-bv-s64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
+ (from-sp (slot val))))
(($ $primcall 'bv-f32-set! (bv idx val))
- (emit-bv-f32-set! asm (slot bv) (slot idx) (slot val)))
+ (emit-bv-f32-set! asm (from-sp (slot bv)) (from-sp (slot idx))
+ (from-sp (slot val))))
(($ $primcall 'bv-f64-set! (bv idx val))
- (emit-bv-f64-set! asm (slot bv) (slot idx) (slot val)))
+ (emit-bv-f64-set! asm (from-sp (slot bv)) (from-sp (slot idx))
+ (from-sp (slot val))))
(($ $primcall 'unwind ())
(emit-unwind asm))))
@@ -279,7 +323,7 @@
(match exp
(($ $values args)
(for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
+ ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation)))))
(define (compile-test label exp kt kf next-label)
@@ -294,22 +338,23 @@
(define (unary op sym)
(cond
((eq? kt next-label)
- (op asm (slot sym) #t kf))
+ (op asm (from-sp (slot sym)) #t kf))
((eq? kf next-label)
- (op asm (slot sym) #f kt))
+ (op asm (from-sp (slot sym)) #f kt))
(else
(let ((invert? (not (prefer-true?))))
- (op asm (slot sym) invert? (if invert? kf kt))
+ (op asm (from-sp (slot sym)) invert? (if invert? kf kt))
(emit-br asm (if invert? kt kf))))))
(define (binary op a b)
(cond
((eq? kt next-label)
- (op asm (slot a) (slot b) #t kf))
+ (op asm (from-sp (slot a)) (from-sp (slot b)) #t kf))
((eq? kf next-label)
- (op asm (slot a) (slot b) #f kt))
+ (op asm (from-sp (slot a)) (from-sp (slot b)) #f kt))
(else
(let ((invert? (not (prefer-true?))))
- (op asm (slot a) (slot b) invert? (if invert? kf kt))
+ (op asm (from-sp (slot a)) (from-sp (slot b)) invert?
+ (if invert? kf kt))
(emit-br asm (if invert? kt kf))))))
(match exp
(($ $values (sym)) (unary emit-br-if-true sym))
@@ -344,7 +389,7 @@
(nargs (1+ (length args)))
(arg-slots (map (lambda (x) (+ x proc-slot)) (iota nargs))))
(for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
+ ((src . dst) (emit-mov asm (from-sp dst) (from-sp src))))
(lookup-parallel-moves label allocation))
(emit-call asm proc-slot nargs)
(emit-dead-slot-map asm proc-slot
@@ -365,7 +410,7 @@
(when (and rest-var (maybe-slot rest-var))
(emit-bind-rest asm (+ proc-slot 1 nreq)))
(for-each (match-lambda
- ((src . dst) (emit-mov asm dst src)))
+ ((src . dst) (emit-fmov asm dst src)))
(lookup-parallel-moves k allocation))
(emit-reset-frame asm frame-size)))))
(match exp
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm
index 8be36e716..b3068985c 100644
--- a/module/language/cps/slot-allocation.scm
+++ b/module/language/cps/slot-allocation.scm
@@ -537,12 +537,6 @@ are comparable with eqv?. A tmp slot may be used."
;; could be that they are out of the computed live set. In that case
;; they need to be adjoined to the live set, used when choosing a
;; temporary slot.
- ;;
- ;; Note that although we reserve slots 253-255 for shuffling operands
- ;; that address less than the full 24-bit range of locals, that
- ;; reservation doesn't apply here, because this temporary itself is
- ;; used while doing parallel assignment via "mov", and "mov" does not
- ;; need shuffling.
(define (compute-tmp-slot live stack-slots)
(find-first-zero (fold add-live-slot live stack-slots)))
@@ -687,10 +681,9 @@ are comparable with eqv?. A tmp slot may be used."
(match vars
(() slots)
((var . vars)
- (let ((n (if (<= 253 n 255) 256 n)))
- (lp vars
- (intmap-add! slots var n)
- (1+ n)))))))))
+ (lp vars
+ (intmap-add! slots var n)
+ (1+ n))))))))
(_ slots)))
cps empty-intmap))
@@ -701,15 +694,9 @@ are comparable with eqv?. A tmp slot may be used."
(logand live-slots (lognot (ash 1 slot))))
(define-inlinable (compute-slot live-slots hint)
- ;; Slots 253-255 are reserved for shuffling; see comments in
- ;; assembler.scm.
- (if (and hint (not (logbit? hint live-slots))
- (or (< hint 253) (> hint 255)))
+ (if (and hint (not (logbit? hint live-slots)))
hint
- (let ((slot (find-first-zero live-slots)))
- (if (or (< slot 253) (> slot 255))
- slot
- (+ 256 (find-first-zero (ash live-slots -256)))))))
+ (find-first-zero live-slots)))
(define (allocate-lazy-vars cps slots call-allocs live-in lazy)
(define (compute-live-slots slots label)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index f29105108..bad298d0d 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -97,6 +97,7 @@
emit-br-if-<=
emit-br-if-logtest
(emit-mov* . emit-mov)
+ (emit-fmov* . emit-fmov)
(emit-box* . emit-box)
(emit-box-ref* . emit-box-ref)
(emit-box-set!* . emit-box-set!)
@@ -638,166 +639,170 @@ later by the linker."
(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).
+ ;; 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.
;;
- ;; 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
- ((X8_S8_I16 <- a imm)
- (values (if (< a (ash 1 8)) a 253)
- imm))
- ((X8_S12_S12 ! 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))))
- ((X8_S12_S12 <- a b)
- (values (if (< a (ash 1 12)) a 253)
- (if (< b (ash 1 12)) b (begin (emit-mov* asm 254 b) 254))))
- ((X8_S12_C12 <- a b)
- (values (if (< a (ash 1 12)) a 253)
- b))
-
- ((X8_S8_S8_S8 ! 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))))
- ((X8_S8_S8_S8 <- 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))))
-
- ((X8_S8_S8_C8 ! 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))
- c))
- ((X8_S8_S8_C8 <- a b c)
- (values (if (< a (ash 1 8)) a 253)
- (if (< b (ash 1 8)) b (begin (emit-mov* asm 254 b) 254))
- c))
-
- ((X8_S8_C8_S8 ! a b c)
- (values (if (< a (ash 1 8)) a (begin (emit-mov* asm 253 a) 253))
- b
- (if (< c (ash 1 8)) c (begin (emit-mov* asm 255 c) 255))))
- ((X8_S8_C8_S8 <- a b c)
- (values (if (< a (ash 1 8)) a 253)
- b
- (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
- (C32 a)
- (I32 imm)
- (A32 imm)
- (B32)
- (N32 label)
- (R32 label)
- (L32 label)
- (LO32 label offset)
- (C8_C24 a b)
- (B1_C7_L24 a b label)
- (B1_X7_S24 a b)
- (B1_X7_F24 a b)
- (B1_X7_C24 a b)
- (B1_X7_L24 a label)
- (B1_X31 a)
- (X8_S24 a)
- (X8_F24 a)
- (X8_C24 a)
- (X8_L24 label)))
-
- (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
- ((X8_S8_I16 X8_S8_S8_S8 X8_S8_S8_C8 X8_S8_C8_S8)
- (unless (< dst (ash 1 8))
- (emit-mov* asm dst 253)))
- ((X8_S12_S12 X8_S12_C12)
- (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 ...))))))
+ ;; 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 c)
+ (cond
+ ((< (logior dst a) (ash 1 12))
+ (emit asm dst a c))
+ (else
+ (emit-push asm a)
+ (emit asm 0 0 c)
+ (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* ...)
- (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))))))))
+ (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))
@@ -809,6 +814,9 @@ later by the linker."
(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)
@@ -1104,19 +1112,6 @@ returned instead."
(set-arity-definitions! arity (reverse (arity-definitions arity)))
(set-arity-high-pc! arity (asm-start asm))))
-;; As noted above, we reserve locals 253 through 255 for shuffling large
-;; operands. However the calling convention has all arguments passed in
-;; a contiguous block. This helper, called after the clause has been
-;; chosen and the keyword/optional/rest arguments have been processed,
-;; shuffles up arguments from slot 253 and higher into their final
-;; allocations.
-;;
-(define (shuffle-up-args asm nargs)
- (when (> nargs 253)
- (let ((slot (1- nargs)))
- (emit-mov asm (+ slot 3) slot)
- (shuffle-up-args asm (1- nargs)))))
-
(define-macro-assembler (standard-prelude asm nreq nlocals alternate)
(cond
(alternate
@@ -1126,8 +1121,7 @@ returned instead."
(emit-assert-nargs-ee/locals asm nreq (- nlocals nreq)))
(else
(emit-assert-nargs-ee asm nreq)
- (emit-alloc-frame asm nlocals)))
- (shuffle-up-args asm nreq))
+ (emit-alloc-frame asm nlocals))))
(define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate)
(if alternate
@@ -1140,8 +1134,7 @@ returned instead."
(emit-br-if-nargs-gt asm (+ nreq nopt) alternate))
(else
(emit-assert-nargs-le asm (+ nreq nopt))))
- (emit-alloc-frame asm nlocals)
- (shuffle-up-args asm (+ nreq nopt (if rest? 1 0))))
+ (emit-alloc-frame asm nlocals))
(define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices
allow-other-keys? nlocals alternate)
@@ -1162,8 +1155,7 @@ returned instead."
(+ nreq nopt)
ntotal
(intern-constant asm kw-indices))
- (emit-alloc-frame asm nlocals)
- (shuffle-up-args asm ntotal)))
+ (emit-alloc-frame asm nlocals)))
(define-macro-assembler (label asm sym)
(hashq-set! (asm-labels asm) sym (asm-start asm)))