diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index 2597c6dafef97a296c90d9ba6c15dcdb6a6bb207..95ede9dbb8eb0916bf392702b3772898699c4980 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 ,@type-codes))))) + (test-type value temp target not-p ,@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 ,@type-codes) + (test-type value temp err-lab t ,@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 ,@type-codes))))) + (test-type value temp target not-p ,@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 ,@type-codes) + (test-type value temp err-lab t ,@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))))