src/compiler/ppc/type-vops.lisp

   1 ;;;; type testing and checking VOPs for the PPC 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 (defun %test-fixnum (value target not-p &key temp)
  15   (assemble ()
  16     (inst andi. temp value fixnum-tag-mask)
  17     (inst b? (if not-p :ne :eq) target)))
  18
  19 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
  20   (let ((drop-through (gen-label)))
  21     (assemble ()
  22       (inst andi. temp value fixnum-tag-mask)
  23       (inst beq (if not-p drop-through target)))
  24     (%test-headers value target not-p nil headers
  25                    :drop-through drop-through :temp temp)))
  26
  27 (defun %test-immediate (value target not-p immediate &key temp)
  28   (assemble ()
  29     (inst andi. temp value widetag-mask)
  30     (inst cmpwi temp immediate)
  31     (inst b? (if not-p :ne :eq) target)))
  32
  33 (defun %test-lowtag (value target not-p lowtag &key temp)
  34   (assemble ()
  35     (inst andi. temp value lowtag-mask)
  36     (inst cmpwi temp lowtag)
  37     (inst b? (if not-p :ne :eq) target)))
  38
  39 (defun %test-headers (value target not-p function-p headers
  40                       &key temp (drop-through (gen-label)))
  41     (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
  42     (multiple-value-bind (when-true when-false)
  43         (if not-p
  44             (values drop-through target)
  45             (values target drop-through))
  46       (assemble ()
  47         (%test-lowtag value when-false t lowtag :temp temp)
  48         (load-type temp value (- lowtag))
  49         (do ((remaining headers (cdr remaining)))
  50             ((null remaining))
  51           (let ((header (car remaining))
  52                 (last (null (cdr remaining))))
  53             (cond
  54               ((atom header)
  55                (cond
  56                  ((and (not last) (null (cddr remaining))
  57                        (atom (cadr remaining))
  58                        (= (logcount (logxor header (cadr remaining))) 1))
  59                   (inst andi. temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
  60                   (inst cmpwi temp (ldb (byte 8 0) (logand header (cadr remaining))))
  61                   (inst b? (if not-p :ne :eq) target)
  62                   (return))
  63                  (t
  64                   (inst cmpwi temp header)
  65                   (if last
  66                       (inst b? (if not-p :ne :eq) target)
  67                       (inst beq when-true)))))
  68               (t
  69                (let ((start (car header))
  70                      (end (cdr header)))
  71                  (cond
  72                    ((and last (not (= start bignum-widetag))
  73                          (= (+ start 4) end)
  74                          (= (logcount (logxor start end)) 1))
  75                     (inst andi. temp temp (ldb (byte 8 0) (logeqv start end)))
  76                     (inst cmpwi temp (ldb (byte 8 0) (logand start end)))
  77                     (inst b? (if not-p :ne :eq) target))
  78                    ((and (not last) (null (cddr remaining))
  79                          (= (+ start 4) end) (= (logcount (logxor start end)) 1)
  80                          (listp (cadr remaining))
  81                          (= (+ (caadr remaining) 4) (cdadr remaining))
  82                          (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
  83                          (= (logcount (logxor (caadr remaining) start)) 1))
  84                     (inst andi. temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
  85                     (inst cmpwi temp (ldb (byte 8 0) (logand start (cdadr remaining))))
  86                     (inst b? (if not-p :ne :eq) target)
  87                     (return))
  88                    (t
  89                     (unless (= start bignum-widetag)
  90                       (inst cmpwi temp start)
  91                       (if (= end complex-array-widetag)
  92                           (progn
  93                             (aver last)
  94                             (inst b? (if not-p :lt :ge) target))
  95                           (inst blt when-false)))
  96                     (unless (= end complex-array-widetag)
  97                       (inst cmpwi temp end)
  98                       (if last
  99                           (inst b? (if not-p :gt :le) target)
 100                           (inst ble when-true))))))))))
 101         (emit-label drop-through)))))
 102
 103 ;;; Simple type checking and testing:
 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                              ;; KLUDGE: ideally, the compiler could
 125                              ;; derive that it can use the sneaky trap
 126                              ;; twice mechanism itself.  However, one
 127                              ;; thing at a time...
 128                              &key mask &allow-other-keys)
 129   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
 130     `(progn
 131        ,@(when pred-name
 132            `((define-vop (,pred-name type-predicate)
 133                (:translate ,pred-name)
 134                (:generator ,cost
 135                  (test-type value target not-p (,@type-codes) :temp temp)))))
 136        ,@(when check-name
 137            `((define-vop (,check-name check-type)
 138                (:generator ,cost
 139                  ,@(if mask
 140                        `((inst andi. temp value ,mask)
 141                          (inst twi 0 value (error-number-or-lose ',error-code))
 142                          (inst twi :ne temp ,@(ecase mask
 143                                                 ((fixnum-tag-mask) `(0))
 144                                                 ((lowtag-mask) type-codes)))
 145                          (move result value))
 146                        `((let ((err-lab
 147                                 (generate-error-code vop ',error-code value)))
 148                            (test-type value err-lab t (,@type-codes) :temp temp)
 149                            (move result value))))))))
 150        ,@(when ptype
 151            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 152 \f
 153 ;;;; Other integer ranges.
 154
 155 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
 156 ;;; exactly one digit.
 157
 158 (define-vop (signed-byte-32-p type-predicate)
 159   (:translate signed-byte-32-p)
 160   (:generator 45
 161     (let ((not-target (gen-label)))
 162       (multiple-value-bind
 163           (yep nope)
 164           (if not-p
 165               (values not-target target)
 166               (values target not-target))
 167         (inst andi. temp value fixnum-tag-mask)
 168         (inst beq yep)
 169         (test-type value nope t (other-pointer-lowtag) :temp temp)
 170         (loadw temp value 0 other-pointer-lowtag)
 171         (inst cmpwi temp (+ (ash 1 n-widetag-bits)
 172                           bignum-widetag))
 173         (inst b? (if not-p :ne :eq) target)
 174         (emit-label not-target)))))
 175
 176 (define-vop (check-signed-byte-32 check-type)
 177   (:generator 45
 178     (let ((nope (generate-error-code vop 'object-not-signed-byte-32-error value))
 179           (yep (gen-label)))
 180       (inst andi. temp value fixnum-tag-mask)
 181       (inst beq yep)
 182       (test-type value nope t (other-pointer-lowtag) :temp temp)
 183       (loadw temp value 0 other-pointer-lowtag)
 184       (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 185       (inst bne nope)
 186       (emit-label yep)
 187       (move result value))))
 188
 189
 190 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 191 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 192 ;;; and the second digit all zeros.
 193
 194 (define-vop (unsigned-byte-32-p type-predicate)
 195   (:translate unsigned-byte-32-p)
 196   (:generator 45
 197     (let ((not-target (gen-label))
 198           (single-word (gen-label))
 199           (fixnum (gen-label)))
 200       (multiple-value-bind
 201           (yep nope)
 202           (if not-p
 203               (values not-target target)
 204               (values target not-target))
 205         ;; Is it a fixnum?
 206         (inst andi. temp value fixnum-tag-mask)
 207         (inst cmpwi :cr1 value 0)
 208         (inst beq fixnum)
 209
 210         ;; If not, is it an other pointer?
 211         (test-type value nope t (other-pointer-lowtag) :temp temp)
 212         ;; Get the header.
 213         (loadw temp value 0 other-pointer-lowtag)
 214         ;; Is it one?
 215         (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 216         (inst beq single-word)
 217         ;; If it's other than two, we can't be an (unsigned-byte 32)
 218         (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
 219         (inst bne nope)
 220         ;; Get the second digit.
 221         (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 222         ;; All zeros, its an (unsigned-byte 32).
 223         (inst cmpwi temp 0)
 224         (inst beq yep)
 225         ;; Otherwise, it isn't.
 226         (inst b nope)
 227
 228         (emit-label single-word)
 229         ;; Get the single digit.
 230         (loadw temp value bignum-digits-offset other-pointer-lowtag)
 231         (inst cmpwi :cr1 temp 0)
 232
 233         ;; positive implies (unsigned-byte 32).
 234         (emit-label fixnum)
 235         (inst b?  :cr1 (if not-p :lt :ge) target)
 236
 237         (emit-label not-target)))))
 238
 239 (define-vop (check-unsigned-byte-32 check-type)
 240   (:generator 45
 241     (let ((nope
 242            (generate-error-code vop 'object-not-unsigned-byte-32-error value))
 243           (yep (gen-label))
 244           (fixnum (gen-label))
 245           (single-word (gen-label)))
 246       ;; Is it a fixnum?
 247       (inst andi. temp value fixnum-tag-mask)
 248       (inst cmpwi :cr1 value 0)
 249       (inst beq fixnum)
 250
 251       ;; If not, is it an other pointer?
 252       (test-type value nope t (other-pointer-lowtag) :temp temp)
 253       ;; Get the number of digits.
 254       (loadw temp value 0 other-pointer-lowtag)
 255       ;; Is it one?
 256       (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 257       (inst beq single-word)
 258       ;; If it's other than two, we can't be an (unsigned-byte 32)
 259       (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
 260       (inst bne nope)
 261       ;; Get the second digit.
 262       (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 263       ;; All zeros, its an (unsigned-byte 32).
 264       (inst cmpwi temp 0)
 265       (inst beq yep)
 266       ;; Otherwise, it isn't.
 267       (inst b nope)
 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 cmpwi :cr1 temp 0)
 274
 275       (emit-label fixnum)
 276       (inst blt :cr1 nope)
 277
 278       (emit-label yep)
 279       (move result value))))
 280
 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 cmpw value null-tn)
 295       (inst beq 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 cmpw value null-tn)
 304       (inst beq 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 cmpw value null-tn)
 315       (inst beq 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 cmpw value null-tn)
 323       (inst beq error)
 324       (test-type value error t (list-pointer-lowtag) :temp temp)
 325       (move result value))))
 326