X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsparc%2Ftype-vops.lisp;h=960ce711b573010f3a210f736e5f836466539e0f;hb=389b5755b2eab960c1f4c14045a26de5dbd510c1;hp=e9de8dff0a5a63a6e70d6218b6d4be6a0c07af88;hpb=68fd2d2dd6f265669a8957accd8a33e62786a97e;p=sbcl.git diff --git a/src/compiler/sparc/type-vops.lisp b/src/compiler/sparc/type-vops.lisp index e9de8df..960ce71 100644 --- a/src/compiler/sparc/type-vops.lisp +++ b/src/compiler/sparc/type-vops.lisp @@ -11,6 +11,119 @@ (in-package "SB!VM") + +(defun %test-fixnum (value target not-p &key temp) + (declare (ignore temp)) + (assemble () + (inst andcc zero-tn value fixnum-tag-mask) + (if (member :sparc-v9 *backend-subfeatures*) + (inst b (if not-p :ne :eq) target (if not-p :pn :pt)) + (inst b (if not-p :ne :eq) target)) + (inst nop))) + +(defun %test-fixnum-and-headers (value target not-p headers + &key temp) + (let ((drop-through (gen-label))) + (assemble () + (inst andcc zero-tn value fixnum-tag-mask) + (inst b :eq (if not-p drop-through target))) + (%test-headers value target not-p nil headers + :drop-through drop-through + :temp temp))) + +(defun %test-immediate (value target not-p immediate &key temp) + (assemble () + (inst and temp value widetag-mask) + (inst cmp temp immediate) + ;; FIXME: include SPARC-V9 magic + (inst b (if not-p :ne :eq) target) + (inst nop))) + +(defun %test-lowtag (value target not-p lowtag + &key temp skip-nop) + (assemble () + (inst and temp value lowtag-mask) + (inst cmp temp lowtag) + ;; FIXME: include SPARC-V9 magic + (inst b (if not-p :ne :eq) target) + (unless skip-nop + (inst nop)))) + +(defun %test-headers (value target not-p function-p headers + &key temp (drop-through (gen-label))) + (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag))) + (multiple-value-bind (when-true when-false) + (if not-p + (values drop-through target) + (values target drop-through)) + (assemble () + (%test-lowtag value when-false t lowtag :temp temp) + (load-type temp value (- lowtag)) + (do ((remaining headers (cdr remaining))) + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (cond + ((and (not last) (null (cddr remaining)) + (atom (cadr remaining)) + (= (logcount (logxor header (cadr remaining))) 1)) + (inst and temp temp (ldb (byte 8 0) (logeqv header (cadr remaining)))) + (inst cmp temp (ldb (byte 8 0) (logand header (cadr remaining)))) + (inst b (if not-p :ne :eq) target) + (return)) + (t + (inst cmp temp header) + (if last + ;; FIXME: Some SPARC-V9 magic might not go amiss + ;; here, too, if I can figure out what it should + ;; be. + (inst b (if not-p :ne :eq) target) + (inst b :eq when-true))))) + (t + (let ((start (car header)) + (end (cdr header))) + ;; FIXME: BIGNUM-WIDETAG here actually means (MIN + ;; ). + (cond + ;; FIXME: this doesn't catch the {0x2 0x6 0xA 0xE} + ;; group + ;; + ;; also FIXME: exuberant cut'n'paste between + ;; backends + ((and last (not (= start bignum-widetag)) + (= (+ start 4) end) + (= (logcount (logxor start end)) 1)) + (inst and temp temp (ldb (byte 8 0) (logeqv start end))) + (inst cmp temp (ldb (byte 8 0) (logand start end))) + (inst b (if not-p :ne :eq) 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)) + (inst and temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining)))) + (inst cmp temp (ldb (byte 8 0) (logand start (cdadr remaining)))) + (inst b (if not-p :ne :eq) target) + (return)) + (t + (unless (= start bignum-widetag) + (inst cmp temp start) + (if (= end complex-array-widetag) + (progn + (aver last) + (inst b (if not-p :lt :ge) target)) + (inst b :lt when-false))) + (unless (= end complex-array-widetag) + (inst cmp temp end) + (if last + (inst b (if not-p :gt :le) target) + (inst b :le when-true)))))))))) + (inst nop) + (emit-label drop-through))))) + ;;;; Simple type checking and testing: ;;; ;;; These types are represented by a single type code, so are easily @@ -29,373 +142,70 @@ (:policy :fast-safe) (:temporary (:scs (non-descriptor-reg)) temp)) -;;; moved to macros. FIXME. -;;;(defun cost-to-test-types (type-codes) -;;; (+ (* 2 (length type-codes)) -;;; (if (> (apply #'max type-codes) lowtag-limit) 7 2))) -;;; -;;;(defparameter immediate-types -;;; (list base-char-type unbound-marker-type)) -;;; -;;;(defparameter function-header-types -;;; (list funcallable-instance-header-type -;;; byte-code-function-type byte-code-closure-type -;;; function-header-type closure-function-header-type -;;; closure-header-type)) -;;; -;; FIXME: there's a canonicalize-headers in alpha/ and x86/ +(defun cost-to-test-types (type-codes) + (+ (* 2 (length type-codes)) + (if (> (apply #'max type-codes) lowtag-limit) 7 2))) -(defmacro def-type-vops (pred-name check-name ptype error-code - &rest type-codes) - ;;; FIXME: #+sb-xc-host? +(defmacro !define-type-vops (pred-name check-name ptype error-code + (&rest type-codes) + &key &allow-other-keys) (let ((cost (cost-to-test-types (mapcar #'eval type-codes)))) `(progn ,@(when pred-name - `((define-vop (,pred-name type-predicate) - (:translate ,pred-name) - (:generator ,cost - (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 temp err-lab t ,@type-codes) - (move result value)))))) + `((define-vop (,pred-name type-predicate) + (:translate ,pred-name) + (:generator ,cost + (test-type value target not-p (,@type-codes) + :temp temp))))) + ,@(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) + :temp temp) + (move result value)))))) ,@(when ptype - `((primitive-type-vop ,check-name (:check) ,ptype)))))) - -;;; This is a direct translation of the code in CMUCL -;;; compiler/sparc/macros.lisp. Don't blame me if it doesn't work. - -;;; moved test-type back to macros.lisp, as other bits of code use it -;;; too. FIXME. - - - - - -;; Don't use this because it uses the deprecated taddcctv instruction. -#+ignore -(progn - (def-type-vops fixnump nil nil nil even-fixnum-lowtag odd-fixnum-lowtag) - (define-vop (check-fixnum check-type) - (:ignore temp) - (:generator 1 - (inst taddcctv result value zero-tn))) - (primitive-type-vop check-fixnum (:check) fixnum)) - -;; This avoids the taddcctv instruction -(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error - even-fixnum-lowtag odd-fixnum-lowtag) -(def-type-vops functionp check-fun function - object-not-fun-error fun-pointer-lowtag) - - ;; The following encode the error type and register in the trap - ;; instruction, however this breaks on the later sparc Ultra. - #+ignore - (progn - (def-type-vops listp nil nil nil list-pointer-lowtag) - (define-vop (check-list check-type) - (:generator 3 - (inst and temp value lowtag-mask) - (inst cmp temp list-pointer-lowtag) - (inst t :ne (logior (ash (tn-offset value) 8) object-not-list-trap)) - (move result value))) - (primitive-type-vop check-list (:check) list) - - (def-type-vops %instancep nil nil nil instance-pointer-lowtag) - (define-vop (check-instance check-type) - (:generator 3 - (inst and temp value lowtag-mask) - (inst cmp temp instance-pointer-lowtag) - (inst t :ne (logior (ash (tn-offset value) 8) object-not-instance-trap)) - (move result value))) - (primitive-type-vop check-instance (:check) instance)) - - ;; These avoid the trap instruction. - (def-type-vops listp check-list list object-not-list-error - list-pointer-lowtag) - (def-type-vops %instancep check-instance instance object-not-instance-error - instance-pointer-lowtag) - - (def-type-vops bignump check-bignum bignum - object-not-bignum-error bignum-widetag) - - (def-type-vops ratiop check-ratio ratio - object-not-ratio-error ratio-widetag) - - (def-type-vops complexp check-complex complex object-not-complex-error - complex-widetag complex-single-float-widetag - complex-double-float-widetag #!+long-float complex-long-float-widetag) - - (def-type-vops complex-rational-p check-complex-rational nil - object-not-complex-rational-error complex-widetag) - - (def-type-vops complex-float-p check-complex-float nil - object-not-complex-float-error - complex-single-float-widetag complex-double-float-widetag - #!+long-float complex-long-float-widetag) - - (def-type-vops complex-single-float-p check-complex-single-float - complex-single-float object-not-complex-single-float-error - complex-single-float-widetag) - - (def-type-vops complex-double-float-p check-complex-double-float - complex-double-float object-not-complex-double-float-error - complex-double-float-widetag) - - #!+long-float - (def-type-vops complex-long-float-p check-complex-long-float - complex-long-float object-not-complex-long-float-error - complex-long-float-widetag) - - (def-type-vops single-float-p check-single-float single-float - object-not-single-float-error single-float-widetag) - - (def-type-vops double-float-p check-double-float double-float - object-not-double-float-error double-float-widetag) - - #!+long-float - (def-type-vops long-float-p check-long-float long-float - object-not-long-float-error long-float-widetag) - - (def-type-vops simple-string-p check-simple-string simple-string - object-not-simple-string-error simple-string-widetag) - - (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector - object-not-simple-bit-vector-error simple-bit-vector-widetag) - - (def-type-vops simple-vector-p check-simple-vector simple-vector - object-not-simple-vector-error simple-vector-widetag) - - (def-type-vops simple-array-unsigned-byte-2-p - check-simple-array-unsigned-byte-2 - simple-array-unsigned-byte-2 - object-not-simple-array-unsigned-byte-2-error - simple-array-unsigned-byte-2-widetag) - - (def-type-vops simple-array-unsigned-byte-4-p - check-simple-array-unsigned-byte-4 - simple-array-unsigned-byte-4 - object-not-simple-array-unsigned-byte-4-error - simple-array-unsigned-byte-4-widetag) - - (def-type-vops simple-array-unsigned-byte-8-p - check-simple-array-unsigned-byte-8 - simple-array-unsigned-byte-8 - object-not-simple-array-unsigned-byte-8-error - simple-array-unsigned-byte-8-widetag) - - (def-type-vops simple-array-unsigned-byte-16-p - check-simple-array-unsigned-byte-16 - simple-array-unsigned-byte-16 - object-not-simple-array-unsigned-byte-16-error - simple-array-unsigned-byte-16-widetag) - - (def-type-vops simple-array-unsigned-byte-32-p - check-simple-array-unsigned-byte-32 - simple-array-unsigned-byte-32 - object-not-simple-array-unsigned-byte-32-error - simple-array-unsigned-byte-32-widetag) - - (def-type-vops simple-array-signed-byte-8-p - check-simple-array-signed-byte-8 - simple-array-signed-byte-8 - object-not-simple-array-signed-byte-8-error - simple-array-signed-byte-8-widetag) - - (def-type-vops simple-array-signed-byte-16-p - check-simple-array-signed-byte-16 - simple-array-signed-byte-16 - object-not-simple-array-signed-byte-16-error - simple-array-signed-byte-16-widetag) - - (def-type-vops simple-array-signed-byte-30-p - check-simple-array-signed-byte-30 - simple-array-signed-byte-30 - object-not-simple-array-signed-byte-30-error - simple-array-signed-byte-30-widetag) - - (def-type-vops simple-array-signed-byte-32-p - check-simple-array-signed-byte-32 - simple-array-signed-byte-32 - object-not-simple-array-signed-byte-32-error - simple-array-signed-byte-32-widetag) - - (def-type-vops simple-array-single-float-p check-simple-array-single-float - simple-array-single-float object-not-simple-array-single-float-error - simple-array-single-float-widetag) - - (def-type-vops simple-array-double-float-p check-simple-array-double-float - simple-array-double-float object-not-simple-array-double-float-error - simple-array-double-float-widetag) - - #!+long-float - (def-type-vops simple-array-long-float-p check-simple-array-long-float - simple-array-long-float object-not-simple-array-long-float-error - simple-array-long-float-widetag) - - (def-type-vops simple-array-complex-single-float-p - check-simple-array-complex-single-float - simple-array-complex-single-float - object-not-simple-array-complex-single-float-error - simple-array-complex-single-float-widetag) - - (def-type-vops simple-array-complex-double-float-p - check-simple-array-complex-double-float - simple-array-complex-double-float - object-not-simple-array-complex-double-float-error - simple-array-complex-double-float-widetag) - - #!+long-float - (def-type-vops simple-array-complex-long-float-p - check-simple-array-complex-long-float - simple-array-complex-long-float - object-not-simple-array-complex-long-float-error - simple-array-complex-long-float-widetag) - - (def-type-vops base-char-p check-base-char base-char - object-not-base-char-error base-char-widetag) - - (def-type-vops system-area-pointer-p check-system-area-pointer - system-area-pointer object-not-sap-error sap-widetag) - - (def-type-vops weak-pointer-p check-weak-pointer weak-pointer - object-not-weak-pointer-error weak-pointer-widetag) - ;; FIXME -#| - (def-type-vops scavenger-hook-p nil nil nil - 0) -|# - (def-type-vops code-component-p nil nil nil - code-header-widetag) - - (def-type-vops lra-p nil nil nil - return-pc-header-widetag) - - (def-type-vops fdefn-p nil nil nil - fdefn-widetag) - - (def-type-vops funcallable-instance-p nil nil nil - funcallable-instance-header-widetag) - - (def-type-vops array-header-p nil nil nil - simple-array-widetag complex-string-widetag complex-bit-vector-widetag - complex-vector-widetag complex-array-widetag) - - ;; This appears to have disappeared. FIXME -- CSR - (def-type-vops nil check-fun-or-symbol nil object-not-fun-or-symbol-error - fun-pointer-lowtag symbol-header-widetag) - - (def-type-vops stringp check-string nil object-not-string-error - simple-string-widetag complex-string-widetag) - - (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error - simple-bit-vector-widetag complex-bit-vector-widetag) - - (def-type-vops vectorp check-vector nil object-not-vector-error - simple-string-widetag simple-bit-vector-widetag simple-vector-widetag - simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag - simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag - simple-array-unsigned-byte-32-widetag - simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag - simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag - simple-array-single-float-widetag simple-array-double-float-widetag - #!+long-float simple-array-long-float-widetag - simple-array-complex-single-float-widetag - simple-array-complex-double-float-widetag - #!+long-float simple-array-complex-long-float-widetag - complex-string-widetag complex-bit-vector-widetag complex-vector-widetag) - -(def-type-vops complex-vector-p check-complex-vector nil object-not-complex-vector-error - complex-vector-widetag) - - (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error - simple-array-widetag simple-string-widetag simple-bit-vector-widetag - simple-vector-widetag simple-array-unsigned-byte-2-widetag - simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag - simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag - simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag - simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag - simple-array-single-float-widetag simple-array-double-float-widetag - #!+long-float simple-array-long-float-widetag - simple-array-complex-single-float-widetag - simple-array-complex-double-float-widetag - #!+long-float simple-array-complex-long-float-widetag) - - (def-type-vops arrayp check-array nil object-not-array-error - simple-array-widetag simple-string-widetag simple-bit-vector-widetag - simple-vector-widetag simple-array-unsigned-byte-2-widetag - simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag - simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag - simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag - simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag - simple-array-single-float-widetag simple-array-double-float-widetag - #!+long-float simple-array-long-float-widetag - simple-array-complex-single-float-widetag - simple-array-complex-double-float-widetag - #!+long-float simple-array-complex-long-float-widetag - complex-string-widetag complex-bit-vector-widetag complex-vector-widetag - complex-array-widetag) - - (def-type-vops numberp check-number nil object-not-number-error - even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag - single-float-widetag double-float-widetag #!+long-float long-float-widetag - complex-widetag complex-single-float-widetag complex-double-float-widetag - #!+long-float complex-long-float-widetag) - - (def-type-vops rationalp check-rational nil object-not-rational-error - even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag) - - (def-type-vops integerp check-integer nil object-not-integer-error - even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag) - - (def-type-vops floatp check-float nil object-not-float-error - single-float-widetag double-float-widetag #!+long-float long-float-widetag) - - (def-type-vops realp check-real nil object-not-real-error - even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag - single-float-widetag double-float-widetag #!+long-float long-float-widetag) + `((primitive-type-vop ,check-name (:check) ,ptype)))))) - + ;;;; Other integer ranges. ;; A (signed-byte 32) can be represented with either fixnum or a ;; bignum with exactly one digit. - (define-vop (signed-byte-32-p type-predicate) +(define-vop (signed-byte-32-p type-predicate) (:translate signed-byte-32-p) (:generator 45 - (let ((not-target (gen-label))) - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - (inst andcc zero-tn value #x3) - (inst b :eq yep) - (test-type value temp nope t other-pointer-lowtag) - (loadw temp value 0 other-pointer-lowtag) - (inst cmp temp (+ (ash 1 n-widetag-bits) - bignum-widetag)) - (inst b (if not-p :ne :eq) target) - (inst nop) - (emit-label not-target))))) - - (define-vop (check-signed-byte-32 check-type) + (let ((not-target (gen-label))) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (inst andcc zero-tn value #x3) + (inst b :eq yep) + (test-type value nope t (other-pointer-lowtag) :temp temp) + (loadw temp value 0 other-pointer-lowtag) + (inst cmp temp (+ (ash 1 n-widetag-bits) + bignum-widetag)) + (inst b (if not-p :ne :eq) target) + (inst nop) + (emit-label not-target))))) + +(define-vop (check-signed-byte-32 check-type) (:generator 45 - (let ((nope (generate-error-code vop object-not-signed-byte-32-error value)) - (yep (gen-label))) - (inst andcc temp value #x3) - (inst b :eq yep) - (test-type value temp nope t other-pointer-lowtag) - (loadw temp value 0 other-pointer-lowtag) - (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag)) - (inst b :ne nope) - (inst nop) - (emit-label yep) - (move result value)))) + (let ((nope (generate-error-code vop object-not-signed-byte-32-error value)) + (yep (gen-label))) + (inst andcc temp value #x3) + (inst b :eq yep) + (test-type value nope t (other-pointer-lowtag) :temp temp) + (loadw temp value 0 other-pointer-lowtag) + (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst b :ne nope) + (inst nop) + (emit-label yep) + (move result value)))) ;; An (unsigned-byte 32) can be represented with either a @@ -403,98 +213,98 @@ ;; a bignum with exactly two digits and the second digit all ;; zeros. - (define-vop (unsigned-byte-32-p type-predicate) +(define-vop (unsigned-byte-32-p type-predicate) (:translate unsigned-byte-32-p) (:generator 45 - (let ((not-target (gen-label)) - (single-word (gen-label)) - (fixnum (gen-label))) - (multiple-value-bind - (yep nope) - (if not-p - (values not-target target) - (values target not-target)) - ;; Is it a fixnum? - (inst andcc temp value #x3) - (inst b :eq fixnum) - (inst cmp value) - - ;; If not, is it an other pointer? - (test-type value temp nope t other-pointer-lowtag) - ;; Get the header. - (loadw temp value 0 other-pointer-lowtag) - ;; Is it one? - (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag)) - (inst b :eq single-word) - ;; If it's other than two, we can't be an - ;; (unsigned-byte 32) - (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag)) - (inst b :ne nope) - ;; Get the second digit. - (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag) - ;; All zeros, its an (unsigned-byte 32). - (inst cmp temp) - (inst b :eq yep) - (inst nop) - ;; Otherwise, it isn't. - (inst b nope) - (inst nop) - - (emit-label single-word) - ;; Get the single digit. - (loadw temp value bignum-digits-offset other-pointer-lowtag) - (inst cmp temp) - - ;; positive implies (unsigned-byte 32). - (emit-label fixnum) - (inst b (if not-p :lt :ge) target) - (inst nop) - - (emit-label not-target))))) - - (define-vop (check-unsigned-byte-32 check-type) + (let ((not-target (gen-label)) + (single-word (gen-label)) + (fixnum (gen-label))) + (multiple-value-bind + (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + ;; Is it a fixnum? + (inst andcc temp value #x3) + (inst b :eq fixnum) + (inst cmp value) + + ;; If not, is it an other pointer? + (test-type value nope t (other-pointer-lowtag) :temp temp) + ;; Get the header. + (loadw temp value 0 other-pointer-lowtag) + ;; Is it one? + (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst b :eq single-word) + ;; If it's other than two, we can't be an + ;; (unsigned-byte 32) + (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag)) + (inst b :ne nope) + ;; Get the second digit. + (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag) + ;; All zeros, its an (unsigned-byte 32). + (inst cmp temp) + (inst b :eq yep) + (inst nop) + ;; Otherwise, it isn't. + (inst b nope) + (inst nop) + + (emit-label single-word) + ;; Get the single digit. + (loadw temp value bignum-digits-offset other-pointer-lowtag) + (inst cmp temp) + + ;; positive implies (unsigned-byte 32). + (emit-label fixnum) + (inst b (if not-p :lt :ge) target) + (inst nop) + + (emit-label not-target))))) + +(define-vop (check-unsigned-byte-32 check-type) (:generator 45 - (let ((nope - (generate-error-code vop object-not-unsigned-byte-32-error value)) - (yep (gen-label)) - (fixnum (gen-label)) - (single-word (gen-label))) - ;; Is it a fixnum? - (inst andcc temp value #x3) - (inst b :eq fixnum) - (inst cmp value) - - ;; If not, is it an other pointer? - (test-type value temp nope t other-pointer-lowtag) - ;; Get the number of digits. - (loadw temp value 0 other-pointer-lowtag) - ;; Is it one? - (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag)) - (inst b :eq single-word) - ;; If it's other than two, we can't be an (unsigned-byte 32) - (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag)) - (inst b :ne nope) - ;; Get the second digit. - (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag) - ;; All zeros, its an (unsigned-byte 32). - (inst cmp temp) - (inst b :eq yep) - ;; Otherwise, it isn't. - (inst b :ne nope) - (inst nop) - - (emit-label single-word) - ;; Get the single digit. - (loadw temp value bignum-digits-offset other-pointer-lowtag) - ;; positive implies (unsigned-byte 32). - (inst cmp temp) - - (emit-label fixnum) - (inst b :lt nope) - (inst nop) - - (emit-label yep) - (move result value)))) + (let ((nope + (generate-error-code vop object-not-unsigned-byte-32-error value)) + (yep (gen-label)) + (fixnum (gen-label)) + (single-word (gen-label))) + ;; Is it a fixnum? + (inst andcc temp value #x3) + (inst b :eq fixnum) + (inst cmp value) + + ;; If not, is it an other pointer? + (test-type value nope t (other-pointer-lowtag) :temp temp) + ;; Get the number of digits. + (loadw temp value 0 other-pointer-lowtag) + ;; Is it one? + (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst b :eq single-word) + ;; If it's other than two, we can't be an (unsigned-byte 32) + (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag)) + (inst b :ne nope) + ;; Get the second digit. + (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag) + ;; All zeros, its an (unsigned-byte 32). + (inst cmp temp) + (inst b :eq yep) + ;; Otherwise, it isn't. + (inst b :ne nope) + (inst nop) + + (emit-label single-word) + ;; Get the single digit. + (loadw temp value bignum-digits-offset other-pointer-lowtag) + ;; positive implies (unsigned-byte 32). + (inst cmp temp) + + (emit-label fixnum) + (inst b :lt nope) + (inst nop) + + (emit-label yep) + (move result value)))) @@ -502,41 +312,41 @@ ;; symbolp (or symbol (eq nil)) ;; consp (and list (not (eq nil))) - - (define-vop (symbolp type-predicate) + +(define-vop (symbolp type-predicate) (:translate symbolp) (:generator 12 - (let* ((drop-thru (gen-label)) - (is-symbol-label (if not-p drop-thru target))) - (inst cmp value null-tn) - (inst b :eq is-symbol-label) - (test-type value temp target not-p symbol-header-widetag) - (emit-label drop-thru)))) - - (define-vop (check-symbol check-type) + (let* ((drop-thru (gen-label)) + (is-symbol-label (if not-p drop-thru target))) + (inst cmp value null-tn) + (inst b :eq is-symbol-label) + (test-type value target not-p (symbol-header-widetag) :temp temp) + (emit-label drop-thru)))) + +(define-vop (check-symbol check-type) (:generator 12 - (let ((drop-thru (gen-label)) - (error (generate-error-code vop object-not-symbol-error value))) - (inst cmp value null-tn) - (inst b :eq drop-thru) - (test-type value temp error t symbol-header-widetag) - (emit-label drop-thru) - (move result value)))) - - (define-vop (consp type-predicate) + (let ((drop-thru (gen-label)) + (error (generate-error-code vop object-not-symbol-error value))) + (inst cmp value null-tn) + (inst b :eq drop-thru) + (test-type value error t (symbol-header-widetag) :temp temp) + (emit-label drop-thru) + (move result value)))) + +(define-vop (consp type-predicate) (:translate consp) (:generator 8 - (let* ((drop-thru (gen-label)) - (is-not-cons-label (if not-p target drop-thru))) - (inst cmp value null-tn) - (inst b :eq is-not-cons-label) - (test-type value temp target not-p list-pointer-lowtag) - (emit-label drop-thru)))) - - (define-vop (check-cons check-type) + (let* ((drop-thru (gen-label)) + (is-not-cons-label (if not-p target drop-thru))) + (inst cmp value null-tn) + (inst b :eq is-not-cons-label) + (test-type value target not-p (list-pointer-lowtag) :temp temp) + (emit-label drop-thru)))) + +(define-vop (check-cons check-type) (:generator 8 - (let ((error (generate-error-code vop object-not-cons-error value))) - (inst cmp value null-tn) - (inst b :eq error) - (test-type value temp error t list-pointer-lowtag) - (move result value)))) + (let ((error (generate-error-code vop object-not-cons-error value))) + (inst cmp value null-tn) + (inst b :eq error) + (test-type value error t (list-pointer-lowtag) :temp temp) + (move result value))))