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