[git] CMU Common Lisp branch master updated. snapshot-2013-08-2-gdcaac99
Carl S. Shapiro
cshapiro at common-lisp.net
Thu Aug 8 07:28:49 UTC 2013
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".
The branch, master has been updated
via dcaac995271f5ec60221877673e080361b1d2d27 (commit)
from b90e144d86ca206d498891a2eb4b552cecef59ab (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit dcaac995271f5ec60221877673e080361b1d2d27
Author: Carl Shapiro <cshapiro at common-lisp.net>
Date: Thu Aug 8 00:19:52 2013 -0700
Allow any unsigned-reg for the check-type and type-predicate temporary.
diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp
index 2597c6d..95ede9d 100644
--- a/src/compiler/x86/type-vops.lisp
+++ b/src/compiler/x86/type-vops.lisp
@@ -60,7 +60,7 @@
(emit-test)))
(results)))
-(defmacro test-type (value target not-p &rest type-codes)
+(defmacro test-type (value temp target not-p &rest type-codes)
;; Determine what interesting combinations we need to test for.
(let* ((type-codes (mapcar #'eval type-codes))
(fixnump (and (member even-fixnum-type type-codes)
@@ -90,7 +90,7 @@
(when immediates
(error "Can't mix fixnum testing with other immediates."))
(if headers
- `(%test-fixnum-and-headers ,value ,target ,not-p
+ `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
',(canonicalize-headers headers))
`(%test-fixnum ,value ,target ,not-p)))
(immediates
@@ -100,17 +100,17 @@
(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)))
+ `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
(lowtags
(when (cdr lowtags)
(error "Can't test multiple lowtags at the same time."))
(if headers
`(%test-lowtag-and-headers
- ,value ,target ,not-p ,(car lowtags)
+ ,value ,temp ,target ,not-p ,(car lowtags)
,function-p ',(canonicalize-headers headers))
- `(%test-lowtag ,value ,target ,not-p ,(car lowtags))))
+ `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
(headers
- `(%test-headers ,value ,target ,not-p ,function-p
+ `(%test-headers ,value ,temp ,target ,not-p ,function-p
',(canonicalize-headers headers)))
(t
(error "Nothing to test?")))))
@@ -143,13 +143,13 @@
(generate-fixnum-test value)
(inst jmp (if not-p :nz :z) target))
-(defun %test-fixnum-and-headers (value target not-p headers)
+(defun %test-fixnum-and-headers (value temp target not-p headers)
(let ((drop-through (gen-label)))
(generate-fixnum-test value)
(inst jmp :z (if not-p drop-through target))
- (%test-headers value target not-p nil headers drop-through)))
+ (%test-headers value temp target not-p nil headers drop-through)))
-(defun %test-immediate (value target not-p immediate)
+(defun %test-immediate (value temp target not-p immediate)
;; Code a single instruction byte test if possible.
(let ((offset (tn-offset value)))
(cond ((and (sc-is value any-reg descriptor-reg)
@@ -160,25 +160,27 @@
:offset offset)
immediate))
(t
- (move eax-tn value)
- (inst cmp al-tn immediate))))
+ (move temp value)
+ (inst and temp type-mask)
+ (inst cmp temp immediate))))
(inst jmp (if not-p :ne :e) target))
-(defun %test-lowtag (value target not-p lowtag &optional al-loaded)
- (unless al-loaded
- (move eax-tn value)
- (inst and al-tn lowtag-mask))
- (inst cmp al-tn lowtag)
+(defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded)
+ (unless temp-loaded
+ (move temp value)
+ (inst and temp lowtag-mask))
+ (inst cmp temp lowtag)
(inst jmp (if not-p :ne :e) target))
-(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers)
+(defun %test-lowtag-and-headers (value temp 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)))
+ (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
+ (%test-headers value temp 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)
+(defun %test-headers (value temp target not-p function-p headers
+ &optional (drop-through (gen-label)) temp-loaded)
(let ((lowtag (if function-p function-pointer-type other-pointer-type)))
(multiple-value-bind
(equal less-or-equal when-true when-false)
@@ -188,15 +190,15 @@
(if not-p
(values :ne :a drop-through target)
(values :e :na target drop-through))
- (%test-lowtag value when-false t lowtag al-loaded)
- (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
+ (%test-lowtag value temp when-false t lowtag temp-loaded)
+ (load-type temp value (- lowtag))
(do ((remaining headers (cdr remaining)))
((null remaining))
(let ((header (car remaining))
(last (null (cdr remaining))))
(cond
((atom header)
- (inst cmp al-tn header)
+ (inst cmp temp header)
(if last
(inst jmp equal target)
(inst jmp :e when-true)))
@@ -204,9 +206,9 @@
(let ((start (car header))
(end (cdr header)))
(unless (= start bignum-type)
- (inst cmp al-tn start)
+ (inst cmp temp start)
(inst jmp :b when-false)) ; was :l
- (inst cmp al-tn end)
+ (inst cmp temp end)
(if last
(inst jmp less-or-equal target)
(inst jmp :be when-true))))))) ; was :le
@@ -217,7 +219,7 @@
;; both cmp and sub take 2 cycles so maybe its a wash
#+nil
(defun %test-headers (value target not-p function-p headers
- &optional (drop-through (gen-label)) al-loaded)
+ &optional (drop-through (gen-label)) temp-loaded)
(let ((lowtag (if function-p function-pointer-type other-pointer-type)))
(multiple-value-bind
(equal less-or-equal when-true when-false)
@@ -227,8 +229,8 @@
(if not-p
(values :ne :a drop-through target)
(values :e :na target drop-through))
- (%test-lowtag value when-false t lowtag al-loaded)
- (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
+ (%test-lowtag value when-false t lowtag temp-loaded)
+ (load-type temp value (- lowtag))
(let ((delta 0))
(do ((remaining headers (cdr remaining)))
((null remaining))
@@ -236,7 +238,7 @@
(last (null (cdr remaining))))
(cond
((atom header)
- (inst sub al-tn (- header delta))
+ (inst sub temp (- header delta))
(setf delta header)
(if last
(inst jmp equal target)
@@ -245,10 +247,10 @@
(let ((start (car header))
(end (cdr header)))
(unless (= start bignum-type)
- (inst sub al-tn (- start delta))
+ (inst sub temp (- start delta))
(setf delta start)
(inst jmp :l when-false))
- (inst sub al-tn (- end delta))
+ (inst sub temp (- end delta))
(setf delta end)
(if last
(inst jmp less-or-equal target)
@@ -261,15 +263,13 @@
(define-vop (check-type)
(:args (value :target result :scs (any-reg descriptor-reg)))
(:results (result :scs (any-reg descriptor-reg)))
- (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
- (:ignore eax)
+ (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:vop-var vop)
(:save-p :compute-only))
(define-vop (type-predicate)
(:args (value :scs (any-reg descriptor-reg)))
- (:temporary (:sc unsigned-reg :offset eax-offset) eax)
- (:ignore eax)
+ (:temporary (:scs (unsigned-reg)) temp)
(:conditional)
(:info target not-p)
(:policy :fast-safe))
@@ -303,13 +303,13 @@
`((define-vop (,pred-name type-predicate)
(:translate ,pred-name)
(:generator ,cost
- (test-type value target not-p , at type-codes)))))
+ (test-type value temp target not-p , at type-codes)))))
,@(when check-name
`((define-vop (,check-name check-type)
(:generator ,cost
(let ((err-lab
(generate-error-code vop ,error-code value)))
- (test-type value err-lab t , at type-codes)
+ (test-type value temp err-lab t , at type-codes)
(move result value))))))
,@(when ptype
`((primitive-type-vop ,check-name (:check) ,ptype))))))
@@ -322,13 +322,13 @@
`((define-vop (,pred-name simple-type-predicate)
(:translate ,pred-name)
(:generator ,cost
- (test-type value target not-p , at type-codes)))))
+ (test-type value temp target not-p , at type-codes)))))
,@(when check-name
`((define-vop (,check-name simple-check-type)
(:generator ,cost
(let ((err-lab
(generate-error-code vop ,error-code value)))
- (test-type value err-lab t , at type-codes)
+ (test-type value temp err-lab t , at type-codes)
(move result value))))))
,@(when ptype
`((primitive-type-vop ,check-name (:check) ,ptype))))))
@@ -634,12 +634,12 @@
(values target not-target))
(generate-fixnum-test value)
(inst jmp :e yep)
- (move eax-tn value)
- (inst and al-tn lowtag-mask)
- (inst cmp al-tn other-pointer-type)
+ (move temp value)
+ (inst and temp lowtag-mask)
+ (inst cmp temp other-pointer-type)
(inst jmp :ne nope)
- (loadw eax-tn value 0 other-pointer-type)
- (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+ (loadw temp value 0 other-pointer-type)
+ (inst cmp temp (+ (ash 1 type-bits) bignum-type))
(inst jmp (if not-p :ne :e) target))
NOT-TARGET))
@@ -650,12 +650,12 @@
value)))
(generate-fixnum-test value)
(inst jmp :e yep)
- (move eax-tn value)
- (inst and al-tn lowtag-mask)
- (inst cmp al-tn other-pointer-type)
+ (move temp value)
+ (inst and temp lowtag-mask)
+ (inst cmp temp other-pointer-type)
(inst jmp :ne nope)
- (loadw eax-tn value 0 other-pointer-type)
- (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+ (loadw temp value 0 other-pointer-type)
+ (inst cmp temp (+ (ash 1 type-bits) bignum-type))
(inst jmp :ne nope))
YEP
(move result value)))
@@ -677,35 +677,35 @@
(values target not-target))
;; Is it a fixnum?
(generate-fixnum-test value)
- (move eax-tn value)
+ (move temp value)
(inst jmp :e fixnum)
;; If not, is it an other pointer?
- (inst and al-tn lowtag-mask)
- (inst cmp al-tn other-pointer-type)
+ (inst and temp lowtag-mask)
+ (inst cmp temp other-pointer-type)
(inst jmp :ne nope)
;; Get the header.
- (loadw eax-tn value 0 other-pointer-type)
+ (loadw temp value 0 other-pointer-type)
;; Is it one?
- (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+ (inst cmp temp (+ (ash 1 type-bits) bignum-type))
(inst jmp :e single-word)
;; If it's other than two, we can't be an (unsigned-byte 32)
- (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
+ (inst cmp temp (+ (ash 2 type-bits) bignum-type))
(inst jmp :ne nope)
;; Get the second digit.
- (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
;; All zeros, its an (unsigned-byte 32).
- (inst or eax-tn eax-tn)
+ (inst test temp temp)
(inst jmp :z yep)
(inst jmp nope)
(emit-label single-word)
;; Get the single digit.
- (loadw eax-tn value bignum-digits-offset other-pointer-type)
+ (loadw temp value bignum-digits-offset other-pointer-type)
;; positive implies (unsigned-byte 32).
(emit-label fixnum)
- (inst or eax-tn eax-tn)
+ (inst test temp temp)
(inst jmp (if not-p :s :ns) target)
(emit-label not-target)))))
@@ -720,35 +720,35 @@
;; Is it a fixnum?
(generate-fixnum-test value)
- (move eax-tn value)
+ (move temp value)
(inst jmp :e fixnum)
;; If not, is it an other pointer?
- (inst and al-tn lowtag-mask)
- (inst cmp al-tn other-pointer-type)
+ (inst and temp lowtag-mask)
+ (inst cmp temp other-pointer-type)
(inst jmp :ne nope)
;; Get the header.
- (loadw eax-tn value 0 other-pointer-type)
+ (loadw temp value 0 other-pointer-type)
;; Is it one?
- (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
+ (inst cmp temp (+ (ash 1 type-bits) bignum-type))
(inst jmp :e single-word)
;; If it's other than two, we can't be an (unsigned-byte 32)
- (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
+ (inst cmp temp (+ (ash 2 type-bits) bignum-type))
(inst jmp :ne nope)
;; Get the second digit.
- (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
+ (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
;; All zeros, its an (unsigned-byte 32).
- (inst or eax-tn eax-tn)
+ (inst or temp temp)
(inst jmp :z yep)
(inst jmp nope)
(emit-label single-word)
;; Get the single digit.
- (loadw eax-tn value bignum-digits-offset other-pointer-type)
+ (loadw temp value bignum-digits-offset other-pointer-type)
;; positive implies (unsigned-byte 32).
(emit-label fixnum)
- (inst or eax-tn eax-tn)
+ (inst or temp temp)
(inst jmp :s nope)
(emit-label yep)
@@ -766,7 +766,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-type))
+ (test-type value temp target not-p symbol-header-type))
DROP-THRU))
(define-vop (check-symbol check-type)
@@ -774,7 +774,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-type))
+ (test-type value temp error t symbol-header-type))
DROP-THRU
(move result value)))
@@ -784,7 +784,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-type))
+ (test-type value temp target not-p list-pointer-type))
DROP-THRU))
(define-vop (check-cons check-type)
@@ -792,5 +792,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-type)
+ (test-type value temp error t list-pointer-type)
(move result value))))
-----------------------------------------------------------------------
Summary of changes:
src/compiler/x86/type-vops.lisp | 148 +++++++++++++++++++--------------------
1 file changed, 74 insertions(+), 74 deletions(-)
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-cvs
mailing list