diff options
-rw-r--r-- | module/language/cps/slot-allocation.scm | 16 | ||||
-rw-r--r-- | module/system/vm/assembler.scm | 304 | ||||
-rw-r--r-- | test-suite/tests/compiler.test | 34 |
3 files changed, 342 insertions, 12 deletions
diff --git a/module/language/cps/slot-allocation.scm b/module/language/cps/slot-allocation.scm index 1cb0fa785..53d6cee5e 100644 --- a/module/language/cps/slot-allocation.scm +++ b/module/language/cps/slot-allocation.scm @@ -262,9 +262,15 @@ are comparable with eqv?. A tmp slot may be used." (logand live-slots (lognot (ash 1 slot)))) (define (compute-slot live-slots hint) - (if (and hint (not (logbit? hint live-slots))) + ;; 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))) hint - (find-first-zero live-slots))) + (let ((slot (find-first-zero live-slots))) + (if (or (< slot 253) (> slot 255)) + slot + (+ 256 (find-first-zero (ash live-slots -256))))))) (define (compute-call-proc-slot live-slots) (+ 2 (find-first-trailing-zero live-slots))) @@ -307,6 +313,12 @@ are comparable with eqv?. A tmp slot may be used." ;; or to function return values -- it 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))) diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm index c61a89081..8cff60561 100644 --- a/module/system/vm/assembler.scm +++ b/module/system/vm/assembler.scm @@ -57,6 +57,119 @@ #:use-module (srfi srfi-9) #:use-module (srfi srfi-11) #:export (make-assembler + + emit-call + emit-call-label + emit-tail-call + emit-tail-call-label + (emit-receive* . emit-receive) + emit-receive-values + emit-return + emit-return-values + emit-call/cc + emit-abort + (emit-builtin-ref* . emit-builtin-ref) + emit-br-if-nargs-ne + emit-br-if-nargs-lt + emit-br-if-nargs-gt + emit-assert-nargs-ee + emit-assert-nargs-ge + emit-assert-nargs-le + emit-alloc-frame + emit-reset-frame + emit-assert-nargs-ee/locals + emit-br-if-npos-gt + emit-bind-kwargs + emit-bind-rest + emit-br + emit-br-if-true + emit-br-if-null + emit-br-if-nil + emit-br-if-pair + emit-br-if-struct + emit-br-if-char + emit-br-if-tc7 + (emit-br-if-eq* . emit-br-if-eq) + (emit-br-if-eqv* . emit-br-if-eqv) + (emit-br-if-equal* . emit-br-if-equal) + (emit-br-if-=* . emit-br-if-=) + (emit-br-if-<* . emit-br-if-<) + (emit-br-if-<=* . emit-br-if-<=) + (emit-mov* . emit-mov) + (emit-box* . emit-box) + (emit-box-ref* . emit-box-ref) + (emit-box-set!* . emit-box-set!) + emit-make-closure + (emit-free-ref* . emit-free-ref) + (emit-free-set!* . emit-free-set!) + emit-current-module + emit-resolve + (emit-define!* . emit-define!) + emit-toplevel-box + emit-module-box + emit-prompt + (emit-wind* . emit-wind) + emit-unwind + (emit-push-fluid* . emit-push-fluid) + emit-pop-fluid + (emit-fluid-ref* . emit-fluid-ref) + (emit-fluid-set* . emit-fluid-set) + (emit-string-length* . emit-string-length) + (emit-string-ref* . emit-string-ref) + (emit-string->number* . emit-string->number) + (emit-string->symbol* . emit-string->symbol) + (emit-symbol->keyword* . emit-symbol->keyword) + (emit-cons* . emit-cons) + (emit-car* . emit-car) + (emit-cdr* . emit-cdr) + (emit-set-car!* . emit-set-car!) + (emit-set-cdr!* . emit-set-cdr!) + (emit-add* . emit-add) + (emit-add1* . emit-add1) + (emit-sub* . emit-sub) + (emit-sub1* . emit-sub1) + (emit-mul* . emit-mul) + (emit-div* . emit-div) + (emit-quo* . emit-quo) + (emit-rem* . emit-rem) + (emit-mod* . emit-mod) + (emit-ash* . emit-ash) + (emit-logand* . emit-logand) + (emit-logior* . emit-logior) + (emit-logxor* . emit-logxor) + (emit-make-vector/immediate* . emit-make-vector/immediate) + (emit-vector-length* . emit-vector-length) + (emit-vector-ref* . emit-vector-ref) + (emit-vector-ref/immediate* . emit-vector-ref/immediate) + (emit-vector-set!* . emit-vector-set!) + (emit-vector-set!/immediate* . emit-vector-set!/immediate) + (emit-struct-vtable* . emit-struct-vtable) + (emit-allocate-struct/immediate* . emit-allocate-struct/immediate) + (emit-struct-ref/immediate* . emit-struct-ref/immediate) + (emit-struct-set!/immediate* . emit-struct-set!/immediate) + (emit-class-of* . emit-class-of) + (emit-make-array* . emit-make-array) + (emit-bv-u8-ref* . emit-bv-u8-ref) + (emit-bv-s8-ref* . emit-bv-s8-ref) + (emit-bv-u16-ref* . emit-bv-u16-ref) + (emit-bv-s16-ref* . emit-bv-s16-ref) + (emit-bv-u32-ref* . emit-bv-u32-ref) + (emit-bv-s32-ref* . emit-bv-s32-ref) + (emit-bv-u64-ref* . emit-bv-u64-ref) + (emit-bv-s64-ref* . emit-bv-s64-ref) + (emit-bv-f32-ref* . emit-bv-f32-ref) + (emit-bv-f64-ref* . emit-bv-f64-ref) + (emit-bv-u8-set!* . emit-bv-u8-set!) + (emit-bv-s8-set!* . emit-bv-s8-set!) + (emit-bv-u16-set!* . emit-bv-u16-set!) + (emit-bv-s16-set!* . emit-bv-s16-set!) + (emit-bv-u32-set!* . emit-bv-u32-set!) + (emit-bv-s32-set!* . emit-bv-s32-set!) + (emit-bv-u64-set!* . emit-bv-u64-set!) + (emit-bv-s64-set!* . emit-bv-s64-set!) + (emit-bv-f32-set!* . emit-bv-f32-set!) + (emit-bv-f64-set!* . emit-bv-f64-set!) + emit-text link-assembly)) @@ -481,12 +594,10 @@ later by the linker." (syntax-case x () ((_ name opcode kind arg ...) (with-syntax ((emit (id-append #'name #'emit- #'name))) - #'(begin - (define emit - (let ((emit (assembler name opcode arg ...))) - (hashq-set! assemblers 'name emit) - emit)) - (export emit))))))) + #'(define emit + (let ((emit (assembler name opcode arg ...))) + (hashq-set! assemblers 'name emit) + emit))))))) (define-syntax visit-opcodes (lambda (x) @@ -501,6 +612,165 @@ later by the linker." (visit-opcodes define-assembler) +(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)))) + (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 @@ -786,6 +1056,19 @@ 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 @@ -795,7 +1078,8 @@ returned instead." (emit-assert-nargs-ee/locals asm nreq (- nlocals nreq))) (else (emit-assert-nargs-ee asm nreq) - (emit-alloc-frame asm nlocals)))) + (emit-alloc-frame asm nlocals))) + (shuffle-up-args asm nreq)) (define-macro-assembler (opt-prelude asm nreq nopt rest? nlocals alternate) (if alternate @@ -808,7 +1092,8 @@ returned instead." (emit-br-if-nargs-gt asm (+ nreq nopt) alternate)) (else (emit-assert-nargs-le asm (+ nreq nopt)))) - (emit-alloc-frame asm nlocals)) + (emit-alloc-frame asm nlocals) + (shuffle-up-args asm (+ nreq nopt (if rest? 1 0)))) (define-macro-assembler (kw-prelude asm nreq nopt rest? kw-indices allow-other-keys? nlocals alternate) @@ -829,7 +1114,8 @@ returned instead." (+ nreq nopt) ntotal (intern-constant asm kw-indices)) - (emit-alloc-frame asm nlocals))) + (emit-alloc-frame asm nlocals) + (shuffle-up-args asm ntotal))) (define-macro-assembler (label asm sym) (hashq-set! (asm-labels asm) sym (asm-start asm))) diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test index 70213ca3d..778a8e1ea 100644 --- a/test-suite/tests/compiler.test +++ b/test-suite/tests/compiler.test @@ -1,5 +1,5 @@ ;;;; compiler.test --- tests for the compiler -*- scheme -*- -;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013 Free Software Foundation, Inc. +;;;; Copyright (C) 2008, 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ;;;; ;;;; This library is free software; you can redistribute it and/or ;;;; modify it under the terms of the GNU Lesser General Public @@ -164,3 +164,35 @@ (list x y)))) (display (t 'x))))) "(x y)(x y)"))) + +(with-test-prefix "limits" + (define (arg n) + (string->symbol (format #f "arg~a" n))) + + ;; Cons and vector-set! take uint8 arguments, so this triggers the + ;; shuffling case. Also there is the case where more than 252 + ;; arguments causes shuffling. + + (pass-if "300 arguments" + (equal? (apply (compile `(lambda ,(map arg (iota 300)) + 'foo)) + (iota 300)) + 'foo)) + + (pass-if "300 arguments with list" + (equal? (apply (compile `(lambda ,(map arg (iota 300)) + (list ,@(reverse (map arg (iota 300)))))) + (iota 300)) + (reverse (iota 300)))) + + (pass-if "300 arguments with vector" + (equal? (apply (compile `(lambda ,(map arg (iota 300)) + (vector ,@(reverse (map arg (iota 300)))))) + (iota 300)) + (list->vector (reverse (iota 300))))) + + (pass-if "0 arguments with list of 300 elements" + (equal? ((compile `(lambda () + (list ,@(map (lambda (n) `(identity ,n)) + (iota 300)))))) + (iota 300)))) |