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-lowtag-and-headers (value target not-p lowtag function-p headers
  53                                  &key temp)
  54   (let ((drop-through (gen-label)))
  55     (%test-lowtag value (if not-p drop-through target) not-p lowtag
  56                   :temp temp :skip-nop t)
  57     (%test-headers value target not-p function-p headers
  58                    :temp temp :drop-through drop-through)))
  59
  60 (defun %test-headers (value target not-p function-p headers
  61                       &key temp (drop-through (gen-label)))
  62   (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
  63     (multiple-value-bind (when-true when-false)
  64         (if not-p
  65             (values drop-through target)
  66             (values target drop-through))
  67       (assemble ()
  68         (%test-lowtag value when-false t lowtag :temp temp)
  69         (load-type temp value (- lowtag))
  70         (do ((remaining headers (cdr remaining)))
  71             ((null remaining))
  72           (let ((header (car remaining))
  73                 (last (null (cdr remaining))))
  74             (cond
  75               ((atom header)
  76                (inst cmp temp header)
  77                (if last
  78                    ;; FIXME: Some SPARC-V9 magic might not go amiss
  79                    ;; here, too, if I can figure out what it should
  80                    ;; be.
  81                    (inst b (if not-p :ne :eq) target)
  82                    (inst b :eq when-true)))
  83               (t
  84                (let ((start (car header))
  85                      (end (cdr header)))
  86                  ;; FIXME: BIGNUM-WIDETAG here actually means (MIN
  87                  ;; <widetags>).
  88                  (unless (= start bignum-widetag)
  89                    (inst cmp temp start)
  90                    (inst b :lt when-false))
  91                  ;; FIXME: conceivably, it might be worth having a
  92                  ;; (MAX <widetags>) here too.
  93                  (inst cmp temp end)
  94                  (if last
  95                      (inst b (if not-p :gt :le) target)
  96                      (inst b :le when-true)))))))
  97         (inst nop)
  98         (emit-label drop-through)))))
  99
 100 ;;;; Simple type checking and testing:
 101 ;;;
 102 ;;; These types are represented by a single type code, so are easily
 103 ;;; open-coded as a mask and compare.
 104 (define-vop (check-type)
 105   (:args (value :target result :scs (any-reg descriptor-reg)))
 106   (:results (result :scs (any-reg descriptor-reg)))
 107   (:temporary (:scs (non-descriptor-reg)) temp)
 108   (:vop-var vop)
 109   (:save-p :compute-only))
 110
 111 (define-vop (type-predicate)
 112   (:args (value :scs (any-reg descriptor-reg)))
 113   (:conditional)
 114   (:info target not-p)
 115   (:policy :fast-safe)
 116   (:temporary (:scs (non-descriptor-reg)) temp))
 117
 118 (defun cost-to-test-types (type-codes)
 119   (+ (* 2 (length type-codes))
 120      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 121
 122 (defmacro !define-type-vops (pred-name check-name ptype error-code
 123                          (&rest type-codes)
 124                          &key &allow-other-keys)
 125   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
 126     `(progn
 127       ,@(when pred-name
 128            `((define-vop (,pred-name type-predicate)
 129                (:translate ,pred-name)
 130                (:generator ,cost
 131                  (test-type value target not-p (,@type-codes)
 132                             :temp temp)))))
 133       ,@(when check-name
 134            `((define-vop (,check-name check-type)
 135                (:generator ,cost
 136                  (let ((err-lab
 137                         (generate-error-code vop ,error-code value)))
 138                    (test-type value err-lab t (,@type-codes)
 139                               :temp temp)
 140                    (move result value))))))
 141        ,@(when ptype
 142            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 143
 144 \f
 145 ;;;; Other integer ranges.
 146
 147   ;; A (signed-byte 32) can be represented with either fixnum or a
 148   ;; bignum with exactly one digit.
 149
 150 (define-vop (signed-byte-32-p type-predicate)
 151   (:translate signed-byte-32-p)
 152   (:generator 45
 153               (let ((not-target (gen-label)))
 154                 (multiple-value-bind
 155                       (yep nope)
 156                     (if not-p
 157                         (values not-target target)
 158                         (values target not-target))
 159                   (inst andcc zero-tn value #x3)
 160                   (inst b :eq yep)
 161                   (test-type value nope t (other-pointer-lowtag) :temp temp)
 162                   (loadw temp value 0 other-pointer-lowtag)
 163                   (inst cmp temp (+ (ash 1 n-widetag-bits)
 164                                     bignum-widetag))
 165                   (inst b (if not-p :ne :eq) target)
 166                   (inst nop)
 167                   (emit-label not-target)))))
 168
 169 (define-vop (check-signed-byte-32 check-type)
 170   (:generator 45
 171               (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
 172                     (yep (gen-label)))
 173                 (inst andcc temp value #x3)
 174                 (inst b :eq yep)
 175                 (test-type value nope t (other-pointer-lowtag) :temp temp)
 176                 (loadw temp value 0 other-pointer-lowtag)
 177                 (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 178                 (inst b :ne nope)
 179                 (inst nop)
 180                 (emit-label yep)
 181                 (move result value))))
 182
 183
 184   ;; An (unsigned-byte 32) can be represented with either a
 185   ;; positive fixnum, a bignum with exactly one positive digit, or
 186   ;; a bignum with exactly two digits and the second digit all
 187   ;; zeros.
 188
 189 (define-vop (unsigned-byte-32-p type-predicate)
 190   (:translate unsigned-byte-32-p)
 191   (:generator 45
 192               (let ((not-target (gen-label))
 193                     (single-word (gen-label))
 194                     (fixnum (gen-label)))
 195                 (multiple-value-bind
 196                       (yep nope)
 197                     (if not-p
 198                         (values not-target target)
 199                         (values target not-target))
 200                   ;; Is it a fixnum?
 201                   (inst andcc temp value #x3)
 202                   (inst b :eq fixnum)
 203                   (inst cmp value)
 204
 205                   ;; If not, is it an other pointer?
 206                   (test-type value nope t (other-pointer-lowtag) :temp temp)
 207                   ;; Get the header.
 208                   (loadw temp value 0 other-pointer-lowtag)
 209                   ;; Is it one?
 210                   (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 211                   (inst b :eq single-word)
 212                   ;; If it's other than two, we can't be an
 213                   ;; (unsigned-byte 32)
 214                   (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
 215                   (inst b :ne nope)
 216                   ;; Get the second digit.
 217                   (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 218                   ;; All zeros, its an (unsigned-byte 32).
 219                   (inst cmp temp)
 220                   (inst b :eq yep)
 221                   (inst nop)
 222                   ;; Otherwise, it isn't.
 223                   (inst b nope)
 224                   (inst nop)
 225
 226                   (emit-label single-word)
 227                   ;; Get the single digit.
 228                   (loadw temp value bignum-digits-offset other-pointer-lowtag)
 229                   (inst cmp temp)
 230
 231                   ;; positive implies (unsigned-byte 32).
 232                   (emit-label fixnum)
 233                   (inst b (if not-p :lt :ge) target)
 234                   (inst nop)
 235
 236                   (emit-label not-target)))))
 237
 238 (define-vop (check-unsigned-byte-32 check-type)
 239   (:generator 45
 240               (let ((nope
 241                      (generate-error-code vop object-not-unsigned-byte-32-error value))
 242                     (yep (gen-label))
 243                     (fixnum (gen-label))
 244                     (single-word (gen-label)))
 245                 ;; Is it a fixnum?
 246                 (inst andcc temp value #x3)
 247                 (inst b :eq fixnum)
 248                 (inst cmp value)
 249
 250                 ;; If not, is it an other pointer?
 251                 (test-type value nope t (other-pointer-lowtag) :temp temp)
 252                 ;; Get the number of digits.
 253                 (loadw temp value 0 other-pointer-lowtag)
 254                 ;; Is it one?
 255                 (inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 256                 (inst b :eq single-word)
 257                 ;; If it's other than two, we can't be an (unsigned-byte 32)
 258                 (inst cmp temp (+ (ash 2 n-widetag-bits) bignum-widetag))
 259                 (inst b :ne nope)
 260                 ;; Get the second digit.
 261                 (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 262                 ;; All zeros, its an (unsigned-byte 32).
 263                 (inst cmp temp)
 264                 (inst b :eq yep)
 265                 ;; Otherwise, it isn't.
 266                 (inst b :ne nope)
 267                 (inst nop)
 268
 269                 (emit-label single-word)
 270                 ;; Get the single digit.
 271                 (loadw temp value bignum-digits-offset other-pointer-lowtag)
 272                 ;; positive implies (unsigned-byte 32).
 273                 (inst cmp temp)
 274
 275                 (emit-label fixnum)
 276                 (inst b :lt nope)
 277                 (inst nop)
 278
 279                 (emit-label yep)
 280                 (move result value))))
 281
 282
 283   \f
 284 ;;;; List/symbol types:
 285
 286   ;; symbolp (or symbol (eq nil))
 287   ;; consp (and list (not (eq nil)))
 288
 289 (define-vop (symbolp type-predicate)
 290   (:translate symbolp)
 291   (:generator 12
 292               (let* ((drop-thru (gen-label))
 293                      (is-symbol-label (if not-p drop-thru target)))
 294                 (inst cmp value null-tn)
 295                 (inst b :eq is-symbol-label)
 296                 (test-type value target not-p (symbol-header-widetag) :temp temp)
 297                 (emit-label drop-thru))))
 298
 299 (define-vop (check-symbol check-type)
 300   (:generator 12
 301               (let ((drop-thru (gen-label))
 302                     (error (generate-error-code vop object-not-symbol-error value)))
 303                 (inst cmp value null-tn)
 304                 (inst b :eq drop-thru)
 305                 (test-type value error t (symbol-header-widetag) :temp temp)
 306                 (emit-label drop-thru)
 307                 (move result value))))
 308
 309 (define-vop (consp type-predicate)
 310   (:translate consp)
 311   (:generator 8
 312               (let* ((drop-thru (gen-label))
 313                      (is-not-cons-label (if not-p target drop-thru)))
 314                 (inst cmp value null-tn)
 315                 (inst b :eq is-not-cons-label)
 316                 (test-type value target not-p (list-pointer-lowtag) :temp temp)
 317                 (emit-label drop-thru))))
 318
 319 (define-vop (check-cons check-type)
 320   (:generator 8
 321               (let ((error (generate-error-code vop object-not-cons-error value)))
 322                 (inst cmp value null-tn)
 323                 (inst b :eq error)
 324                 (test-type value error t (list-pointer-lowtag) :temp temp)
 325                 (move result value))))