* 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.
(in-package "SB!VM")
\f
(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
(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"))
(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)
: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"))
: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
(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))
;;; 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)
(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)
(frob * mulss */single-float 4 mulsd */double-float 5 t)
(frob / divss //single-float 12 divsd //double-float 19 nil))
+
\f
(macrolet ((frob ((name translate sc type) &body body)
`(define-vop (,name)
(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
(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)
* 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;
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;
}
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;
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);
}
/* 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 {
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);
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);
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:
}
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. */
;;; 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"
projects / sbcl.git / commitdiff