src/compiler/sparc/type-vops.lisp

   1 ;;;; type testing and checking VOPs for the Sparc VM
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13 \f
  14
  15 (defun %test-fixnum (value target not-p &key temp)
  16   (declare (ignore temp))
  17   (assemble ()
  18     (inst andcc zero-tn value fixnum-tag-mask)
  19     (if (member :sparc-v9 *backend-subfeatures*)
  20         (inst b (if not-p :ne :eq) target (if not-p :pn :pt))
  21         (inst b (if not-p :ne :eq) target))
  22     (inst nop)))
  23
  24 (defun %test-fixnum-and-headers (value target not-p headers
  25                                  &key temp)
  26   (let ((drop-through (gen-label)))
  27     (assemble ()
  28       (inst andcc zero-tn value fixnum-tag-mask)
  29       (inst b :eq (if not-p drop-through target)))
  30     (%test-headers value target not-p nil headers
  31                    :drop-through drop-through
  32                    :temp temp)))
  33
  34 (defun %test-immediate (value target not-p immediate &key temp)
  35   (assemble ()
  36     (inst and temp value widetag-mask)
  37     (inst cmp temp immediate)
  38     ;; FIXME: include SPARC-V9 magic
  39     (inst b (if not-p :ne :eq) target)
  40     (inst nop)))
  41
  42 (defun %test-lowtag (value target not-p lowtag
  43                      &key temp skip-nop)
  44   (assemble ()
  45     (inst and temp value lowtag-mask)
  46     (inst cmp temp lowtag)
  47     ;; FIXME: include SPARC-V9 magic
  48     (inst b (if not-p :ne :eq) target)
  49     (unless skip-nop
  50       (inst nop))))
  51
  52 (defun %test-headers (value target not-p function-p headers
  53                       &key temp (drop-through (gen-label)))
  54   (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
  55     (multiple-value-bind (when-true when-false)
  56         (if not-p
  57             (values drop-through target)
  58             (values target drop-through))
  59       (assemble ()
  60         (%test-lowtag value when-false t lowtag :temp temp)
  61         (load-type temp value (- lowtag))
  62         (do ((remaining headers (cdr remaining)))
  63             ((null remaining))
  64           (let ((header (car remaining))
  65                 (last (null (cdr remaining))))
  66             (cond
  67               ((atom header)
  68                (cond
  69                  ((and (not last) (null (cddr remaining))
  70                        (atom (cadr remaining))
  71                        (= (logcount (logxor header (cadr remaining))) 1))
  72                   (inst and temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
  73                   (inst cmp temp (ldb (byte 8 0) (logand header (cadr remaining))))
  74                   (inst b (if not-p :ne :eq) target)
  75                   (return))
  76                  (t
  77                   (inst cmp temp header)
  78                   (if last
  79                       ;; FIXME: Some SPARC-V9 magic might not go amiss
  80                       ;; here, too, if I can figure out what it should
  81                       ;; be.
  82                       (inst b (if not-p :ne :eq) target)
  83                       (inst b :eq when-true)))))
  84               (t
  85                (let ((start (car header))
  86                      (end (cdr header)))
  87                  ;; FIXME: BIGNUM-WIDETAG here actually means (MIN
  88                  ;; <widetags>).
  89                  (cond
  90                    ;; FIXME: this doesn't catch the {0x2 0x6 0xA 0xE}
  91                    ;; group
  92                    ;;
  93                    ;; also FIXME: exuberant cut'n'paste between
  94                    ;; backends
  95                    ((and last (not (= start bignum-widetag))
  96                          (= (+ start 4) end)
  97                          (= (logcount (logxor start end)) 1))
  98                     (inst and temp temp (ldb (byte 8 0) (logeqv start end)))
  99                     (inst cmp temp (ldb (byte 8 0) (logand start end)))
 100                     (inst b (if not-p :ne :eq) target))
 101                    ((and (not last) (null (cddr remaining))
 102                          (= (+ start 4) end) (= (logcount (logxor start end)) 1)
 103                          (listp (cadr remaining))
 104                          (= (+ (caadr remaining) 4) (cdadr remaining))
 105                          (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
 106                          (= (logcount (logxor (caadr remaining) start)) 1))
 107                     (inst and temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
 108                     (inst cmp temp (ldb (byte 8 0) (logand start (cdadr remaining))))
 109                     (inst b (if not-p :ne :eq) target)
 110                     (return))
 111                    (t
 112                     (unless (= start bignum-widetag)
 113                       (inst cmp temp start)
 114                       (if (= end complex-array-widetag)
 115                           (progn
 116                             (aver last)
 117                             (inst b (if not-p :lt :ge) target))
 118                           (inst b :lt when-false)))
 119                     (unless (= end complex-array-widetag)
 120                       (inst cmp temp end)
 121                       (if last
 122                           (inst b (if not-p :gt :le) target)
 123                           (inst b :le when-true))))))))))
 124         (inst nop)
 125         (emit-label drop-through)))))
 126 \f
 127 ;;;; Other integer ranges.
 128
 129 ;;; A (signed-byte 32) can be represented with either fixnum or a
 130 ;;; bignum with exactly one digit.
 131
 132 (define-vop (signed-byte-32-p type-predicate)
 133   (:translate signed-byte-32-p)
 134   (:generator 45
 135               (let ((not-target (gen-label)))
 136                 (multiple-value-bind
 137                       (yep nope)
 138                     (if not-p
 139                         (values not-target target)
 140                         (values target not-target))
 141                   (inst andcc zero-tn value fixnum-tag-mask)
 142                   (inst b :eq yep)
 143                   (test-type value nope t (other-pointer-lowtag) :temp temp)
 144                   (loadw temp value 0 other-pointer-lowtag)
 145                   (inst cmp temp (+ (ash 1 n-widetag-bits)
 146                                     bignum-widetag))
 147                   (inst b (if not-p :ne :eq) target)
 148                   (inst nop)
 149                   (emit-label not-target)))))
 150
 151
 152
 153
 154 ;;; An (unsigned-byte 32) can be represented with either a
 155 ;;; positive fixnum, a bignum with exactly one positive digit, or
 156 ;;; a bignum with exactly two digits and the second digit all
 157 ;;; zeros.
 158
 159 (define-vop (unsigned-byte-32-p type-predicate)
 160   (:translate unsigned-byte-32-p)
 161   (:generator 45
 162               (let ((not-target (gen-label))
 163                     (single-word (gen-label))
 164                     (fixnum (gen-label)))
 165                 (multiple-value-bind
 166                       (yep nope)
 167                     (if not-p
 168                         (values not-target target)
 169                         (values target not-target))
 170                   ;; Is it a fixnum?
 171                   (inst andcc temp value fixnum-tag-mask)
 172                   (inst b :eq fixnum)
 173                   (inst cmp value)
 174
 175                   ;; If not, is it an other pointer?
 176                   (test-type value nope t (other-pointer-lowtag) :temp temp)
 177                   ;; Get the header.
 178                   (loadw temp value 0 other-pointer-lowtag)
 179                   ;; Is it one?
 180                   (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 181                   (inst b :eq single-word)
 182                   ;; If it's other than two, we can't be an
 183                   ;; (unsigned-byte 32)
 184                   (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
 185                   (inst b :ne nope)
 186                   ;; Get the second digit.
 187                   (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 188                   ;; All zeros, its an (unsigned-byte 32).
 189                   (inst cmp temp)
 190                   (inst b :eq yep)
 191                   (inst nop)
 192                   ;; Otherwise, it isn't.
 193                   (inst b nope)
 194                   (inst nop)
 195
 196                   (emit-label single-word)
 197                   ;; Get the single digit.
 198                   (loadw temp value bignum-digits-offset other-pointer-lowtag)
 199                   (inst cmp temp)
 200
 201                   ;; positive implies (unsigned-byte 32).
 202                   (emit-label fixnum)
 203                   (inst b (if not-p :lt :ge) target)
 204                   (inst nop)
 205
 206                   (emit-label not-target)))))
 207 \f
 208 ;;;; List/symbol types:
 209
 210   ;; symbolp (or symbol (eq nil))
 211   ;; consp (and list (not (eq nil)))
 212
 213 (define-vop (symbolp type-predicate)
 214   (:translate symbolp)
 215   (:generator 12
 216               (let* ((drop-thru (gen-label))
 217                      (is-symbol-label (if not-p drop-thru target)))
 218                 (inst cmp value null-tn)
 219                 (inst b :eq is-symbol-label)
 220                 (test-type value target not-p (symbol-widetag) :temp temp)
 221                 (emit-label drop-thru))))
 222
 223 (define-vop (consp type-predicate)
 224   (:translate consp)
 225   (:generator 8
 226               (let* ((drop-thru (gen-label))
 227                      (is-not-cons-label (if not-p target drop-thru)))
 228                 (inst cmp value null-tn)
 229                 (inst b :eq is-not-cons-label)
 230                 (test-type value target not-p (list-pointer-lowtag) :temp temp)
 231                 (emit-label drop-thru))))