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
......@@ -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))))
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment