From a3649ba68e298d9203e8bb1de5629ff788586fe1 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Mon, 14 Mar 2005 17:39:37 +0000 Subject: [PATCH] 0.8.20.21: Add immediate single-floats on x86-64. The implementation is conditionalized on (= SB!VM:N-WORD-BITS 64), so the following bits need to be done for the 64-bit Alpha port too: * Add some new type-test generators (%TEST-FIXNUM-AND-IMMEDIATE, %TEST-FIXNUM-IMMEDIATE-AND-HEADERS, %TEST-IMMEDIATE-AND-HEADERS). * Modify single-float move-vops and SINGLE-FLOAT-BITS. --- NEWS | 4 ++- src/compiler/generic/early-type-vops.lisp | 55 ++++++++++++++++++++--------- src/compiler/generic/genesis.lisp | 5 +++ src/compiler/generic/objdef.lisp | 1 + src/compiler/x86-64/float.lisp | 29 +++++++-------- src/compiler/x86-64/type-vops.lisp | 31 ++++++++++++++-- src/runtime/gc-common.c | 13 +++++++ src/runtime/print.c | 3 +- src/runtime/purify.c | 22 ++++++++++-- version.lisp-expr | 2 +- 10 files changed, 126 insertions(+), 39 deletions(-) diff --git a/NEWS b/NEWS index e91d294..46a9a7e 100644 --- a/NEWS +++ b/NEWS @@ -44,7 +44,9 @@ changes in sbcl-0.8.21 (0.9alpha.1?) relative to sbcl-0.8.20: * contrib improvement: SB-INTROSPECT handles more of SLIME's needs than previously; in addition, its test suite is now run on build. (thanks to Luke Gorrie) - * a more robust x86-64 disassembler. (thanks to Lutz Euler) + * a more robust x86-64 disassembler. (thanks to Lutz Euler) + * optimization: added a immediate representation for single-floats + on x86-64 * fixed some bugs revealed by Paul Dietz' test suite: ** MISC.564: defined out-of-line version of %ATAN2 on x86. diff --git a/src/compiler/generic/early-type-vops.lisp b/src/compiler/generic/early-type-vops.lisp index 8c854fb..8f289da 100644 --- a/src/compiler/generic/early-type-vops.lisp +++ b/src/compiler/generic/early-type-vops.lisp @@ -11,7 +11,9 @@ (in-package "SB!VM") (defparameter *immediate-types* - (list unbound-marker-widetag character-widetag)) + (list* unbound-marker-widetag character-widetag + (when (= sb!vm::n-word-bits 64) + (list single-float-widetag)))) (defparameter *fun-header-widetags* (list funcallable-instance-header-widetag @@ -70,23 +72,42 @@ (error "can't mix fixnum testing with other lowtags")) (when function-p (error "can't mix fixnum testing with function subtype testing")) - (when immediates - (error "can't mix fixnum testing with other immediates")) - (if headers - `(%test-fixnum-and-headers ,value ,target ,not-p - ',(canonicalize-headers headers) - ,@other-args) - `(%test-fixnum ,value ,target ,not-p - ,@other-args))) + (cond + ((and (= sb!vm:n-word-bits 64) immediates headers) + `(%test-fixnum-immediate-and-headers ,value ,target ,not-p + ,(car immediates) + ',(canonicalize-headers + headers) + ,@other-args)) + (immediates + (if (= sb!vm:n-word-bits 64) + `(%test-fixnum-and-immediate ,value ,target ,not-p + ,(car immediates) + ,@other-args) + (error "can't mix fixnum testing with other immediates"))) + (headers + `(%test-fixnum-and-headers ,value ,target ,not-p + ',(canonicalize-headers headers) + ,@other-args)) + (t + `(%test-fixnum ,value ,target ,not-p + ,@other-args)))) (immediates - (when headers - (error "can't mix testing of immediates with testing of headers")) - (when lowtags - (error "can't mix testing of immediates with testing of lowtags")) - (when (cdr immediates) - (error "can't test multiple immediates at the same time")) - `(%test-immediate ,value ,target ,not-p ,(car immediates) - ,@other-args)) + (cond + (headers + (if (= sb!vm:n-word-bits 64) + `(%test-immediate-and-headers ,value ,target ,not-p + ,(car immediates) + ',(canonicalize-headers headers) + ,@other-args) + (error "can't mix testing of immediates with testing of headers"))) + (lowtags + (error "can't mix testing of immediates with testing of lowtags")) + ((cdr immediates) + (error "can't test multiple immediates at the same time")) + (t + `(%test-immediate ,value ,target ,not-p ,(car immediates) + ,@other-args)))) (lowtags (when (cdr lowtags) (error "can't test multiple lowtags at the same time")) diff --git a/src/compiler/generic/genesis.lisp b/src/compiler/generic/genesis.lisp index 6c1ae19..624f8b2 100644 --- a/src/compiler/generic/genesis.lisp +++ b/src/compiler/generic/genesis.lisp @@ -690,6 +690,11 @@ core and return a descriptor to it." (defun float-to-core (x) (etypecase x (single-float + ;; 64-bit platforms have immediate single-floats. + #!+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or)) + (make-random-descriptor (logior (ash (single-float-bits x) 32) + sb!vm::single-float-widetag)) + #!-#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or)) (let ((des (allocate-unboxed-object *dynamic* sb!vm:n-word-bits (1- sb!vm:single-float-size) diff --git a/src/compiler/generic/objdef.lisp b/src/compiler/generic/objdef.lisp index 1e4fc8b..760f8ca 100644 --- a/src/compiler/generic/objdef.lisp +++ b/src/compiler/generic/objdef.lisp @@ -66,6 +66,7 @@ :ref-trans %denominator :init :arg)) +#!+#.(cl:if (cl:= sb!vm:n-word-bits 32) '(and) '(or)) (define-primitive-object (single-float :lowtag other-pointer-lowtag :widetag single-float-widetag) (value :c-type "float")) diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp index b0dfce0..6cce969 100644 --- a/src/compiler/x86-64/float.lisp +++ b/src/compiler/x86-64/float.lisp @@ -16,8 +16,6 @@ :qword :base ,tn :disp (- (* ,slot n-word-bytes) other-pointer-lowtag)))) - (defun ea-for-sf-desc (tn) - (ea-for-xf-desc tn single-float-value-slot)) (defun ea-for-df-desc (tn) (ea-for-xf-desc tn double-float-value-slot)) ;; complex floats @@ -207,13 +205,12 @@ (define-vop (move-from-single) (:args (x :scs (single-reg) :to :save)) (:results (y :scs (descriptor-reg))) - (:node-var node) (:note "float to pointer coercion") - (:generator 13 - (with-fixed-allocation (y - single-float-widetag - single-float-size node) - (inst movss (ea-for-sf-desc y) x)))) + (:generator 4 + (inst movd y x) + (inst shl y 32) + (inst or y single-float-widetag))) + (define-move-vop move-from-single :move (single-reg) (descriptor-reg)) @@ -247,11 +244,15 @@ ;;; Move from a descriptor to a float register. (define-vop (move-to-single) - (:args (x :scs (descriptor-reg))) + (:args (x :scs (descriptor-reg) :target tmp)) + (:temporary (:sc unsigned-reg) tmp) (:results (y :scs (single-reg))) (:note "pointer to float coercion") (:generator 2 - (inst movss y (ea-for-sf-desc x)))) + (move tmp x) + (inst shr tmp 32) + (inst movd y tmp))) + (define-move-vop move-to-single :move (descriptor-reg) (single-reg)) (define-vop (move-to-double) @@ -430,7 +431,7 @@ (macrolet ((frob (name sc ptype) `(define-vop (,name float-op) - (:args (x :scs (,sc)) + (:args (x :scs (,sc) :target r) (y :scs (,sc))) (:results (r :scs (,sc))) (:arg-types ,ptype ,ptype) @@ -469,6 +470,7 @@ (frob * mulss */single-float 4 mulsd */double-float 5 t) (frob / divss //single-float 12 divsd //double-float 19 nil)) + (macrolet ((frob ((name translate sc type) &body body) `(define-vop (,name) @@ -800,9 +802,8 @@ (single-stack (move bits float)) (descriptor-reg - (loadw - bits float single-float-value-slot - other-pointer-lowtag)))) + (move bits float) + (inst shr bits 32)))) (signed-stack (sc-case float (single-reg diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp index 6dbaaab..e77d167 100644 --- a/src/compiler/x86-64/type-vops.lisp +++ b/src/compiler/x86-64/type-vops.lisp @@ -42,14 +42,41 @@ (inst jmp :z (if not-p drop-through target)) (%test-headers value target not-p nil headers drop-through))) -(defun %test-immediate (value target not-p immediate) +(defun %test-fixnum-and-immediate (value target not-p immediate) + (let ((drop-through (gen-label))) + (generate-fixnum-test value) + (inst jmp :z (if not-p drop-through target)) + (%test-immediate value target not-p immediate drop-through))) + +(defun %test-fixnum-immediate-and-headers (value target not-p immediate + headers) + (let ((drop-through (gen-label))) + (generate-fixnum-test value) + (inst jmp :z (if not-p drop-through target)) + (%test-immediate-and-headers value target not-p immediate headers + drop-through))) + +(defun %test-immediate (value target not-p immediate + &optional (drop-through (gen-label))) ;; Code a single instruction byte test if possible. (cond ((sc-is value any-reg descriptor-reg) (inst cmp (make-byte-tn value) immediate)) (t (move rax-tn value) (inst cmp al-tn immediate))) - (inst jmp (if not-p :ne :e) target)) + (inst jmp (if not-p :ne :e) target) + (emit-label drop-through)) + +(defun %test-immediate-and-headers (value target not-p immediate headers + &optional (drop-through (gen-label))) + ;; Code a single instruction byte test if possible. + (cond ((sc-is value any-reg descriptor-reg) + (inst cmp (make-byte-tn value) immediate)) + (t + (move rax-tn value) + (inst cmp al-tn immediate))) + (inst jmp :e (if not-p drop-through target)) + (%test-headers value target not-p nil headers drop-through)) (defun %test-lowtag (value target not-p lowtag) (move rax-tn value) diff --git a/src/runtime/gc-common.c b/src/runtime/gc-common.c index ed70962..946873c 100644 --- a/src/runtime/gc-common.c +++ b/src/runtime/gc-common.c @@ -1585,7 +1585,11 @@ gc_init_tables(void) * tag) get one entry each in the scavenge table. */ scavtab[BIGNUM_WIDETAG] = scav_unboxed; scavtab[RATIO_WIDETAG] = scav_boxed; +#if N_WORD_BITS == 64 + scavtab[SINGLE_FLOAT_WIDETAG] = scav_immediate; +#else scavtab[SINGLE_FLOAT_WIDETAG] = scav_unboxed; +#endif scavtab[DOUBLE_FLOAT_WIDETAG] = scav_unboxed; #ifdef LONG_FLOAT_WIDETAG scavtab[LONG_FLOAT_WIDETAG] = scav_unboxed; @@ -1716,7 +1720,12 @@ gc_init_tables(void) transother[i] = trans_lose; transother[BIGNUM_WIDETAG] = trans_unboxed; transother[RATIO_WIDETAG] = trans_boxed; + +#if N_WORD_BITS == 64 + transother[SINGLE_FLOAT_WIDETAG] = trans_immediate; +#else transother[SINGLE_FLOAT_WIDETAG] = trans_unboxed; +#endif transother[DOUBLE_FLOAT_WIDETAG] = trans_unboxed; #ifdef LONG_FLOAT_WIDETAG transother[LONG_FLOAT_WIDETAG] = trans_unboxed; @@ -1852,7 +1861,11 @@ gc_init_tables(void) } sizetab[BIGNUM_WIDETAG] = size_unboxed; sizetab[RATIO_WIDETAG] = size_boxed; +#if N_WORD_BITS == 64 + sizetab[SINGLE_FLOAT_WIDETAG] = size_immediate; +#else sizetab[SINGLE_FLOAT_WIDETAG] = size_unboxed; +#endif sizetab[DOUBLE_FLOAT_WIDETAG] = size_unboxed; #ifdef LONG_FLOAT_WIDETAG sizetab[LONG_FLOAT_WIDETAG] = size_unboxed; diff --git a/src/runtime/print.c b/src/runtime/print.c index 30e2669..46f2b2f 100644 --- a/src/runtime/print.c +++ b/src/runtime/print.c @@ -491,11 +491,12 @@ static void print_otherptr(lispobj obj) print_slots(symbol_slots, count, ptr); break; +#if N_WORD_BITS == 32 case SINGLE_FLOAT_WIDETAG: NEWLINE_OR_RETURN; printf("%g", ((struct single_float *)native_pointer(obj))->value); break; - +#endif case DOUBLE_FLOAT_WIDETAG: NEWLINE_OR_RETURN; printf("%g", ((struct double_float *)native_pointer(obj))->value); diff --git a/src/runtime/purify.c b/src/runtime/purify.c index 480227d..35635ee 100644 --- a/src/runtime/purify.c +++ b/src/runtime/purify.c @@ -205,12 +205,18 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) } /* Is it plausible cons? */ if ((is_lisp_pointer(start_addr[0]) - || ((start_addr[0] & 3) == 0) /* fixnum */ + || ((start_addr[0] & FIXNUM_TAG_MASK) == 0) /* fixnum */ || (widetag_of(start_addr[0]) == CHARACTER_WIDETAG) +#if N_WORD_BITS == 64 + || (widetag_of(start_addr[1]) == SINGLE_FLOAT_WIDETAG) +#endif || (widetag_of(start_addr[0]) == UNBOUND_MARKER_WIDETAG)) && (is_lisp_pointer(start_addr[1]) - || ((start_addr[1] & 3) == 0) /* fixnum */ + || ((start_addr[1] & FIXNUM_TAG_MASK) == 0) /* fixnum */ || (widetag_of(start_addr[1]) == CHARACTER_WIDETAG) +#if N_WORD_BITS == 64 + || (widetag_of(start_addr[1]) == SINGLE_FLOAT_WIDETAG) +#endif || (widetag_of(start_addr[1]) == UNBOUND_MARKER_WIDETAG))) { break; } else { @@ -245,7 +251,7 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) return 0; } /* Is it plausible? Not a cons. XXX should check the headers. */ - if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) { + if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & FIXNUM_TAG_MASK) == 0)) { if (pointer_filter_verbose) { fprintf(stderr,"*Wo2: %x %x %x\n", (unsigned long) pointer, (unsigned long) start_addr, *start_addr); @@ -255,6 +261,9 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) switch (widetag_of(start_addr[0])) { case UNBOUND_MARKER_WIDETAG: case CHARACTER_WIDETAG: +#if N_WORD_BITS == 64 + case SINGLE_FLOAT_WIDETAG: +#endif if (pointer_filter_verbose) { fprintf(stderr,"*Wo3: %x %x %x\n", (unsigned long) pointer, (unsigned long) start_addr, *start_addr); @@ -304,7 +313,9 @@ valid_dynamic_space_pointer(lispobj *pointer, lispobj *start_addr) case FDEFN_WIDETAG: case CODE_HEADER_WIDETAG: case BIGNUM_WIDETAG: +#if N_WORD_BITS != 64 case SINGLE_FLOAT_WIDETAG: +#endif case DOUBLE_FLOAT_WIDETAG: #ifdef LONG_FLOAT_WIDETAG case LONG_FLOAT_WIDETAG: @@ -1186,6 +1197,11 @@ pscav(lispobj *addr, long nwords, boolean constant) } count = 1; } +#if N_WORD_BITS == 64 + else if (widetag_of(thing) == SINGLE_FLOAT_WIDETAG) { + count = 1; + } +#endif else if (thing & FIXNUM_TAG_MASK) { /* It's an other immediate. Maybe the header for an unboxed */ /* object. */ diff --git a/version.lisp-expr b/version.lisp-expr index 27d35ea..8cd992f 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.20.20" +"0.8.20.21" -- 1.7.10.4