diff options
author | Andy Wingo <wingo@pobox.com> | 2015-10-21 10:48:58 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2015-10-21 11:49:20 +0200 |
commit | 70c317ab5173e26d9f2a9b8b81a9441ef3ef7008 (patch) | |
tree | 09cff8c7ea63dd36eab1920eb31a89cd91c256aa /module | |
parent | 9b1ac02a8584ee7ca73a8f5920d7b33c0487bfc0 (diff) | |
download | guile-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.scm | 185 | ||||
-rw-r--r-- | module/language/cps/slot-allocation.scm | 23 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 338 |
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))) |