Skip to content
Snippets Groups Projects
Commit dcaac995 authored by Carl Shapiro's avatar Carl Shapiro
Browse files

Allow any unsigned-reg for the check-type and type-predicate temporary.

parent b90e144d
No related branches found
No related tags found
No related merge requests found
...@@ -60,7 +60,7 @@ ...@@ -60,7 +60,7 @@
(emit-test))) (emit-test)))
(results))) (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. ;; Determine what interesting combinations we need to test for.
(let* ((type-codes (mapcar #'eval type-codes)) (let* ((type-codes (mapcar #'eval type-codes))
(fixnump (and (member even-fixnum-type type-codes) (fixnump (and (member even-fixnum-type type-codes)
...@@ -90,7 +90,7 @@ ...@@ -90,7 +90,7 @@
(when immediates (when immediates
(error "Can't mix fixnum testing with other immediates.")) (error "Can't mix fixnum testing with other immediates."))
(if headers (if headers
`(%test-fixnum-and-headers ,value ,target ,not-p `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
',(canonicalize-headers headers)) ',(canonicalize-headers headers))
`(%test-fixnum ,value ,target ,not-p))) `(%test-fixnum ,value ,target ,not-p)))
(immediates (immediates
...@@ -100,17 +100,17 @@ ...@@ -100,17 +100,17 @@
(error "Can't mix testing of immediates with testing of lowtags.")) (error "Can't mix testing of immediates with testing of lowtags."))
(when (cdr immediates) (when (cdr immediates)
(error "Can't test multiple immediates at the same time.")) (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 (lowtags
(when (cdr lowtags) (when (cdr lowtags)
(error "Can't test multiple lowtags at the same time.")) (error "Can't test multiple lowtags at the same time."))
(if headers (if headers
`(%test-lowtag-and-headers `(%test-lowtag-and-headers
,value ,target ,not-p ,(car lowtags) ,value ,temp ,target ,not-p ,(car lowtags)
,function-p ',(canonicalize-headers headers)) ,function-p ',(canonicalize-headers headers))
`(%test-lowtag ,value ,target ,not-p ,(car lowtags)))) `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
(headers (headers
`(%test-headers ,value ,target ,not-p ,function-p `(%test-headers ,value ,temp ,target ,not-p ,function-p
',(canonicalize-headers headers))) ',(canonicalize-headers headers)))
(t (t
(error "Nothing to test?"))))) (error "Nothing to test?")))))
...@@ -143,13 +143,13 @@ ...@@ -143,13 +143,13 @@
(generate-fixnum-test value) (generate-fixnum-test value)
(inst jmp (if not-p :nz :z) target)) (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))) (let ((drop-through (gen-label)))
(generate-fixnum-test value) (generate-fixnum-test value)
(inst jmp :z (if not-p drop-through target)) (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. ;; Code a single instruction byte test if possible.
(let ((offset (tn-offset value))) (let ((offset (tn-offset value)))
(cond ((and (sc-is value any-reg descriptor-reg) (cond ((and (sc-is value any-reg descriptor-reg)
...@@ -160,25 +160,27 @@ ...@@ -160,25 +160,27 @@
:offset offset) :offset offset)
immediate)) immediate))
(t (t
(move eax-tn value) (move temp value)
(inst cmp al-tn immediate)))) (inst and temp type-mask)
(inst cmp temp immediate))))
(inst jmp (if not-p :ne :e) target)) (inst jmp (if not-p :ne :e) target))
(defun %test-lowtag (value target not-p lowtag &optional al-loaded) (defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded)
(unless al-loaded (unless temp-loaded
(move eax-tn value) (move temp value)
(inst and al-tn lowtag-mask)) (inst and temp lowtag-mask))
(inst cmp al-tn lowtag) (inst cmp temp lowtag)
(inst jmp (if not-p :ne :e) target)) (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))) (let ((drop-through (gen-label)))
(%test-lowtag value (if not-p drop-through target) nil lowtag) (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
(%test-headers value target not-p function-p headers drop-through t))) (%test-headers value temp target not-p function-p headers drop-through t)))
(defun %test-headers (value target not-p function-p headers (defun %test-headers (value temp 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))) (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
(multiple-value-bind (multiple-value-bind
(equal less-or-equal when-true when-false) (equal less-or-equal when-true when-false)
...@@ -188,15 +190,15 @@ ...@@ -188,15 +190,15 @@
(if not-p (if not-p
(values :ne :a drop-through target) (values :ne :a drop-through target)
(values :e :na target drop-through)) (values :e :na target drop-through))
(%test-lowtag value when-false t lowtag al-loaded) (%test-lowtag value temp when-false t lowtag temp-loaded)
(inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) (load-type temp value (- lowtag))
(do ((remaining headers (cdr remaining))) (do ((remaining headers (cdr remaining)))
((null remaining)) ((null remaining))
(let ((header (car remaining)) (let ((header (car remaining))
(last (null (cdr remaining)))) (last (null (cdr remaining))))
(cond (cond
((atom header) ((atom header)
(inst cmp al-tn header) (inst cmp temp header)
(if last (if last
(inst jmp equal target) (inst jmp equal target)
(inst jmp :e when-true))) (inst jmp :e when-true)))
...@@ -204,9 +206,9 @@ ...@@ -204,9 +206,9 @@
(let ((start (car header)) (let ((start (car header))
(end (cdr header))) (end (cdr header)))
(unless (= start bignum-type) (unless (= start bignum-type)
(inst cmp al-tn start) (inst cmp temp start)
(inst jmp :b when-false)) ; was :l (inst jmp :b when-false)) ; was :l
(inst cmp al-tn end) (inst cmp temp end)
(if last (if last
(inst jmp less-or-equal target) (inst jmp less-or-equal target)
(inst jmp :be when-true))))))) ; was :le (inst jmp :be when-true))))))) ; was :le
...@@ -217,7 +219,7 @@ ...@@ -217,7 +219,7 @@
;; both cmp and sub take 2 cycles so maybe its a wash ;; both cmp and sub take 2 cycles so maybe its a wash
#+nil #+nil
(defun %test-headers (value target not-p function-p headers (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))) (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
(multiple-value-bind (multiple-value-bind
(equal less-or-equal when-true when-false) (equal less-or-equal when-true when-false)
...@@ -227,8 +229,8 @@ ...@@ -227,8 +229,8 @@
(if not-p (if not-p
(values :ne :a drop-through target) (values :ne :a drop-through target)
(values :e :na target drop-through)) (values :e :na target drop-through))
(%test-lowtag value when-false t lowtag al-loaded) (%test-lowtag value when-false t lowtag temp-loaded)
(inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) (load-type temp value (- lowtag))
(let ((delta 0)) (let ((delta 0))
(do ((remaining headers (cdr remaining))) (do ((remaining headers (cdr remaining)))
((null remaining)) ((null remaining))
...@@ -236,7 +238,7 @@ ...@@ -236,7 +238,7 @@
(last (null (cdr remaining)))) (last (null (cdr remaining))))
(cond (cond
((atom header) ((atom header)
(inst sub al-tn (- header delta)) (inst sub temp (- header delta))
(setf delta header) (setf delta header)
(if last (if last
(inst jmp equal target) (inst jmp equal target)
...@@ -245,10 +247,10 @@ ...@@ -245,10 +247,10 @@
(let ((start (car header)) (let ((start (car header))
(end (cdr header))) (end (cdr header)))
(unless (= start bignum-type) (unless (= start bignum-type)
(inst sub al-tn (- start delta)) (inst sub temp (- start delta))
(setf delta start) (setf delta start)
(inst jmp :l when-false)) (inst jmp :l when-false))
(inst sub al-tn (- end delta)) (inst sub temp (- end delta))
(setf delta end) (setf delta end)
(if last (if last
(inst jmp less-or-equal target) (inst jmp less-or-equal target)
...@@ -261,15 +263,13 @@ ...@@ -261,15 +263,13 @@
(define-vop (check-type) (define-vop (check-type)
(:args (value :target result :scs (any-reg descriptor-reg))) (:args (value :target result :scs (any-reg descriptor-reg)))
(:results (result :scs (any-reg descriptor-reg))) (:results (result :scs (any-reg descriptor-reg)))
(:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax) (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
(:ignore eax)
(:vop-var vop) (:vop-var vop)
(:save-p :compute-only)) (:save-p :compute-only))
(define-vop (type-predicate) (define-vop (type-predicate)
(:args (value :scs (any-reg descriptor-reg))) (:args (value :scs (any-reg descriptor-reg)))
(:temporary (:sc unsigned-reg :offset eax-offset) eax) (:temporary (:scs (unsigned-reg)) temp)
(:ignore eax)
(:conditional) (:conditional)
(:info target not-p) (:info target not-p)
(:policy :fast-safe)) (:policy :fast-safe))
...@@ -303,13 +303,13 @@ ...@@ -303,13 +303,13 @@
`((define-vop (,pred-name type-predicate) `((define-vop (,pred-name type-predicate)
(:translate ,pred-name) (:translate ,pred-name)
(:generator ,cost (:generator ,cost
(test-type value target not-p ,@type-codes))))) (test-type value temp target not-p ,@type-codes)))))
,@(when check-name ,@(when check-name
`((define-vop (,check-name check-type) `((define-vop (,check-name check-type)
(:generator ,cost (:generator ,cost
(let ((err-lab (let ((err-lab
(generate-error-code vop ,error-code value))) (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)))))) (move result value))))))
,@(when ptype ,@(when ptype
`((primitive-type-vop ,check-name (:check) ,ptype)))))) `((primitive-type-vop ,check-name (:check) ,ptype))))))
...@@ -322,13 +322,13 @@ ...@@ -322,13 +322,13 @@
`((define-vop (,pred-name simple-type-predicate) `((define-vop (,pred-name simple-type-predicate)
(:translate ,pred-name) (:translate ,pred-name)
(:generator ,cost (:generator ,cost
(test-type value target not-p ,@type-codes))))) (test-type value temp target not-p ,@type-codes)))))
,@(when check-name ,@(when check-name
`((define-vop (,check-name simple-check-type) `((define-vop (,check-name simple-check-type)
(:generator ,cost (:generator ,cost
(let ((err-lab (let ((err-lab
(generate-error-code vop ,error-code value))) (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)))))) (move result value))))))
,@(when ptype ,@(when ptype
`((primitive-type-vop ,check-name (:check) ,ptype)))))) `((primitive-type-vop ,check-name (:check) ,ptype))))))
...@@ -634,12 +634,12 @@ ...@@ -634,12 +634,12 @@
(values target not-target)) (values target not-target))
(generate-fixnum-test value) (generate-fixnum-test value)
(inst jmp :e yep) (inst jmp :e yep)
(move eax-tn value) (move temp value)
(inst and al-tn lowtag-mask) (inst and temp lowtag-mask)
(inst cmp al-tn other-pointer-type) (inst cmp temp other-pointer-type)
(inst jmp :ne nope) (inst jmp :ne nope)
(loadw eax-tn value 0 other-pointer-type) (loadw temp value 0 other-pointer-type)
(inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) (inst cmp temp (+ (ash 1 type-bits) bignum-type))
(inst jmp (if not-p :ne :e) target)) (inst jmp (if not-p :ne :e) target))
NOT-TARGET)) NOT-TARGET))
...@@ -650,12 +650,12 @@ ...@@ -650,12 +650,12 @@
value))) value)))
(generate-fixnum-test value) (generate-fixnum-test value)
(inst jmp :e yep) (inst jmp :e yep)
(move eax-tn value) (move temp value)
(inst and al-tn lowtag-mask) (inst and temp lowtag-mask)
(inst cmp al-tn other-pointer-type) (inst cmp temp other-pointer-type)
(inst jmp :ne nope) (inst jmp :ne nope)
(loadw eax-tn value 0 other-pointer-type) (loadw temp value 0 other-pointer-type)
(inst cmp eax-tn (+ (ash 1 type-bits) bignum-type)) (inst cmp temp (+ (ash 1 type-bits) bignum-type))
(inst jmp :ne nope)) (inst jmp :ne nope))
YEP YEP
(move result value))) (move result value)))
...@@ -677,35 +677,35 @@ ...@@ -677,35 +677,35 @@
(values target not-target)) (values target not-target))
;; Is it a fixnum? ;; Is it a fixnum?
(generate-fixnum-test value) (generate-fixnum-test value)
(move eax-tn value) (move temp value)
(inst jmp :e fixnum) (inst jmp :e fixnum)
;; If not, is it an other pointer? ;; If not, is it an other pointer?
(inst and al-tn lowtag-mask) (inst and temp lowtag-mask)
(inst cmp al-tn other-pointer-type) (inst cmp temp other-pointer-type)
(inst jmp :ne nope) (inst jmp :ne nope)
;; Get the header. ;; Get the header.
(loadw eax-tn value 0 other-pointer-type) (loadw temp value 0 other-pointer-type)
;; Is it one? ;; 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) (inst jmp :e single-word)
;; If it's other than two, we can't be an (unsigned-byte 32) ;; 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) (inst jmp :ne nope)
;; Get the second digit. ;; 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). ;; All zeros, its an (unsigned-byte 32).
(inst or eax-tn eax-tn) (inst test temp temp)
(inst jmp :z yep) (inst jmp :z yep)
(inst jmp nope) (inst jmp nope)
(emit-label single-word) (emit-label single-word)
;; Get the single digit. ;; 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). ;; positive implies (unsigned-byte 32).
(emit-label fixnum) (emit-label fixnum)
(inst or eax-tn eax-tn) (inst test temp temp)
(inst jmp (if not-p :s :ns) target) (inst jmp (if not-p :s :ns) target)
(emit-label not-target))))) (emit-label not-target)))))
...@@ -720,35 +720,35 @@ ...@@ -720,35 +720,35 @@
;; Is it a fixnum? ;; Is it a fixnum?
(generate-fixnum-test value) (generate-fixnum-test value)
(move eax-tn value) (move temp value)
(inst jmp :e fixnum) (inst jmp :e fixnum)
;; If not, is it an other pointer? ;; If not, is it an other pointer?
(inst and al-tn lowtag-mask) (inst and temp lowtag-mask)
(inst cmp al-tn other-pointer-type) (inst cmp temp other-pointer-type)
(inst jmp :ne nope) (inst jmp :ne nope)
;; Get the header. ;; Get the header.
(loadw eax-tn value 0 other-pointer-type) (loadw temp value 0 other-pointer-type)
;; Is it one? ;; 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) (inst jmp :e single-word)
;; If it's other than two, we can't be an (unsigned-byte 32) ;; 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) (inst jmp :ne nope)
;; Get the second digit. ;; 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). ;; All zeros, its an (unsigned-byte 32).
(inst or eax-tn eax-tn) (inst or temp temp)
(inst jmp :z yep) (inst jmp :z yep)
(inst jmp nope) (inst jmp nope)
(emit-label single-word) (emit-label single-word)
;; Get the single digit. ;; 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). ;; positive implies (unsigned-byte 32).
(emit-label fixnum) (emit-label fixnum)
(inst or eax-tn eax-tn) (inst or temp temp)
(inst jmp :s nope) (inst jmp :s nope)
(emit-label yep) (emit-label yep)
...@@ -766,7 +766,7 @@ ...@@ -766,7 +766,7 @@
(let ((is-symbol-label (if not-p drop-thru target))) (let ((is-symbol-label (if not-p drop-thru target)))
(inst cmp value nil-value) (inst cmp value nil-value)
(inst jmp :e is-symbol-label) (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)) DROP-THRU))
(define-vop (check-symbol check-type) (define-vop (check-symbol check-type)
...@@ -774,7 +774,7 @@ ...@@ -774,7 +774,7 @@
(let ((error (generate-error-code vop object-not-symbol-error value))) (let ((error (generate-error-code vop object-not-symbol-error value)))
(inst cmp value nil-value) (inst cmp value nil-value)
(inst jmp :e drop-thru) (inst jmp :e drop-thru)
(test-type value error t symbol-header-type)) (test-type value temp error t symbol-header-type))
DROP-THRU DROP-THRU
(move result value))) (move result value)))
...@@ -784,7 +784,7 @@ ...@@ -784,7 +784,7 @@
(let ((is-not-cons-label (if not-p target drop-thru))) (let ((is-not-cons-label (if not-p target drop-thru)))
(inst cmp value nil-value) (inst cmp value nil-value)
(inst jmp :e is-not-cons-label) (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)) DROP-THRU))
(define-vop (check-cons check-type) (define-vop (check-cons check-type)
...@@ -792,5 +792,5 @@ ...@@ -792,5 +792,5 @@
(let ((error (generate-error-code vop object-not-cons-error value))) (let ((error (generate-error-code vop object-not-cons-error value)))
(inst cmp value nil-value) (inst cmp value nil-value)
(inst jmp :e error) (inst jmp :e error)
(test-type value error t list-pointer-type) (test-type value temp error t list-pointer-type)
(move result value)))) (move result value))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment