X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ftype-vops.lisp;h=fda5f1308ab87335a873aed686ab109d71fa7731;hb=079ef9dad558ca07cb8178ef428bf738112174fa;hp=ca114cf22316f814c040df9ca4f961c39c8cfd88;hpb=760b572425ddd9ffeec81566999c862b3812be83;p=sbcl.git diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index ca114cf..fda5f13 100644 --- a/src/compiler/x86/type-vops.lisp +++ b/src/compiler/x86/type-vops.lisp @@ -62,25 +62,28 @@ (unless al-loaded (move eax-tn value) (inst and al-tn lowtag-mask)) + ;; FIXME: another 'optimization' which doesn't appear to work: + ;; prefetching the hypothetically pointed-to version should help, + ;; but this is in fact non-ideal in plenty of ways: we emit way too + ;; many of these prefetch instructions; pointed-to objects are very + ;; often in the cache anyway; etc. etc. Still, as proof-of-concept, + ;; not too bad. -- CSR, 2004-07-27 + (when (member :prefetch *backend-subfeatures*) + (inst prefetchnta (make-ea :byte :base value :disp (- lowtag)))) (inst cmp al-tn lowtag) (inst jmp (if not-p :ne :e) target)) - -(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers) - (let ((drop-through (gen-label))) - (%test-lowtag value (if not-p drop-through target) nil lowtag) - (%test-headers value target not-p function-p headers drop-through t))) - - + (defun %test-headers (value target not-p function-p headers &optional (drop-through (gen-label)) al-loaded) (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag))) - (multiple-value-bind (equal less-or-equal when-true when-false) - ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET. - ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know - ;; it's true and when we know it's false respectively. + (multiple-value-bind (equal less-or-equal greater-or-equal when-true when-false) + ;; EQUAL, LESS-OR-EQUAL and GREATER-OR-EQUAL are the conditions for + ;; branching to TARGET. WHEN-TRUE and WHEN-FALSE are the + ;; labels to branch to when we know it's true and when we know + ;; it's false respectively. (if not-p - (values :ne :a drop-through target) - (values :e :na target drop-through)) + (values :ne :a :b drop-through target) + (values :e :na :nb target drop-through)) (%test-lowtag value when-false t lowtag al-loaded) (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) (do ((remaining headers (cdr remaining))) @@ -89,22 +92,59 @@ (last (null (cdr remaining)))) (cond ((atom header) - (inst cmp al-tn header) - (if last - (inst jmp equal target) - (inst jmp :e when-true))) + (cond + ((and (not last) (null (cddr remaining)) + (atom (cadr remaining)) + (= (logcount (logxor header (cadr remaining))) 1)) + ;; BASE-STRING, (VECTOR NIL), BIT-VECTOR, (VECTOR T) + (inst and al-tn (ldb (byte 8 0) (logeqv header (cadr remaining)))) + (inst cmp al-tn (ldb (byte 8 0) (logand header (cadr remaining)))) + (inst jmp equal target) + (return)) + (t + (inst cmp al-tn header) + (if last + (inst jmp equal target) + (inst jmp :e when-true))))) (t (let ((start (car header)) (end (cdr header))) - (unless (= start bignum-widetag) - (inst cmp al-tn start) - (inst jmp :b when-false)) ; was :l - (inst cmp al-tn end) - (if last - (inst jmp less-or-equal target) - (inst jmp :be when-true))))))) ; was :le + (cond + ;; LAST = don't need al-tn later + ((and last (not (= start bignum-widetag)) + (= (+ start 4) end) (= (logcount (logxor start end)) 1)) + ;; SIMPLE-STRING + (inst and al-tn (ldb (byte 8 0) (logeqv start end))) + (inst cmp al-tn (ldb (byte 8 0) (logand start end))) + (inst jmp equal target)) + ((and (not last) (null (cddr remaining)) + (= (+ start 4) end) (= (logcount (logxor start end)) 1) + (listp (cadr remaining)) + (= (+ (caadr remaining) 4) (cdadr remaining)) + (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1) + (= (logcount (logxor (caadr remaining) start)) 1)) + ;; STRING + (inst and al-tn (ldb (byte 8 0) (logeqv start (cdadr remaining)))) + (inst cmp al-tn (ldb (byte 8 0) (logand start (cdadr remaining)))) + (inst jmp equal target) + ;; we've shortcircuited the DO, so we must return. + ;; It's OK to do so, because (NULL (CDDR REMAINING)) + ;; was true. + (return)) + (t + (unless (= start bignum-widetag) + (inst cmp al-tn start) + (if (= end complex-array-widetag) + (progn + (aver last) + (inst jmp greater-or-equal target)) + (inst jmp :b when-false))) ; was :l + (unless (= end complex-array-widetag) + (inst cmp al-tn end) + (if last + (inst jmp less-or-equal target) + (inst jmp :be when-true)))))))))) ; was :le (emit-label drop-through)))) - ;;;; type checking and testing @@ -139,17 +179,13 @@ (:info target not-p) (:policy :fast-safe)) -;;; FIXME: DEF-TYPE-VOPS and DEF-SIMPLE-TYPE-VOPS are only used in -;;; this file, so they should be in the EVAL-WHEN above, or otherwise -;;; tweaked so that they don't appear in the target system. - (defun cost-to-test-types (type-codes) (+ (* 2 (length type-codes)) (if (> (apply #'max type-codes) lowtag-limit) 7 2))) (defmacro !define-type-vops (pred-name check-name ptype error-code (&rest type-codes) - &key (variant nil variant-p)) + &key (variant nil variant-p) &allow-other-keys) ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the ;; expansion? (let* ((cost (cost-to-test-types (mapcar #'eval type-codes))) @@ -161,19 +197,27 @@ `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE"))) (:translate ,pred-name) (:generator ,cost - (test-type value target not-p ,@type-codes))))) + (test-type value target not-p (,@type-codes)))))) ,@(when check-name `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE"))) (:generator ,cost (let ((err-lab (generate-error-code vop ,error-code value))) - (test-type value err-lab t ,@type-codes) + (test-type value err-lab t (,@type-codes)) (move result value)))))) ,@(when ptype `((primitive-type-vop ,check-name (:check) ,ptype)))))) ;;;; other integer ranges +(define-vop (fixnump/unsigned-byte-32 simple-type-predicate) + (:args (value :scs (unsigned-reg))) + (:arg-types unsigned-num) + (:translate fixnump) + (:generator 5 + (inst cmp value #.sb!xc:most-positive-fixnum) + (inst jmp (if not-p :a :be) target))) + ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with ;;; exactly one digit. @@ -315,7 +359,7 @@ (let ((is-symbol-label (if not-p drop-thru target))) (inst cmp value nil-value) (inst jmp :e is-symbol-label) - (test-type value target not-p symbol-header-widetag)) + (test-type value target not-p (symbol-header-widetag))) DROP-THRU)) (define-vop (check-symbol check-type) @@ -323,7 +367,7 @@ (let ((error (generate-error-code vop object-not-symbol-error value))) (inst cmp value nil-value) (inst jmp :e drop-thru) - (test-type value error t symbol-header-widetag)) + (test-type value error t (symbol-header-widetag))) DROP-THRU (move result value))) @@ -333,7 +377,7 @@ (let ((is-not-cons-label (if not-p target drop-thru))) (inst cmp value nil-value) (inst jmp :e is-not-cons-label) - (test-type value target not-p list-pointer-lowtag)) + (test-type value target not-p (list-pointer-lowtag))) DROP-THRU)) (define-vop (check-cons check-type) @@ -341,5 +385,5 @@ (let ((error (generate-error-code vop object-not-cons-error value))) (inst cmp value nil-value) (inst jmp :e error) - (test-type value error t list-pointer-lowtag) + (test-type value error t (list-pointer-lowtag)) (move result value))))