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     ;; FIXME: again, this 3 should be FIXNUM-MASK
  17     (inst andi. temp value 3)
  18     (inst b? (if not-p :ne :eq) target)))
  19
  20 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
  21   (let ((drop-through (gen-label)))
  22     (assemble ()
  23       (inst andi. temp value 3)
  24       (inst beq (if not-p drop-through target)))
  25     (%test-headers value target not-p nil headers
  26                    :drop-through drop-through :temp temp)))
  27
  28 (defun %test-immediate (value target not-p immediate &key temp)
  29   (assemble ()
  30     (inst andi. temp value widetag-mask)
  31     (inst cmpwi temp immediate)
  32     (inst b? (if not-p :ne :eq) target)))
  33
  34 (defun %test-lowtag (value target not-p lowtag &key temp)
  35   (assemble ()
  36     (inst andi. temp value lowtag-mask)
  37     (inst cmpwi temp lowtag)
  38     (inst b? (if not-p :ne :eq) target)))
  39
  40 (defun %test-headers (value target not-p function-p headers
  41                       &key temp (drop-through (gen-label)))
  42     (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
  43     (multiple-value-bind (when-true when-false)
  44         (if not-p
  45             (values drop-through target)
  46             (values target drop-through))
  47       (assemble ()
  48         (%test-lowtag value when-false t lowtag :temp temp)
  49         (load-type temp value (- lowtag))
  50         (do ((remaining headers (cdr remaining)))
  51             ((null remaining))
  52           (let ((header (car remaining))
  53                 (last (null (cdr remaining))))
  54             (cond
  55               ((atom header)
  56                (cond
  57                  ((and (not last) (null (cddr remaining))
  58                        (atom (cadr remaining))
  59                        (= (logcount (logxor header (cadr remaining))) 1))
  60                   (inst andi. temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
  61                   (inst cmpwi temp (ldb (byte 8 0) (logand header (cadr remaining))))
  62                   (inst b? (if not-p :ne :eq) target)
  63                   (return))
  64                  (t
  65                   (inst cmpwi temp header)
  66                   (if last
  67                       (inst b? (if not-p :ne :eq) target)
  68                       (inst beq when-true)))))
  69               (t
  70                (let ((start (car header))
  71                      (end (cdr header)))
  72                  (cond
  73                    ((and last (not (= start bignum-widetag))
  74                          (= (+ start 4) end)
  75                          (= (logcount (logxor start end)) 1))
  76                     (inst andi. temp temp (ldb (byte 8 0) (logeqv start end)))
  77                     (inst cmpwi temp (ldb (byte 8 0) (logand start end)))
  78                     (inst b? (if not-p :ne :eq) target))
  79                    ((and (not last) (null (cddr remaining))
  80                          (= (+ start 4) end) (= (logcount (logxor start end)) 1)
  81                          (listp (cadr remaining))
  82                          (= (+ (caadr remaining) 4) (cdadr remaining))
  83                          (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
  84                          (= (logcount (logxor (caadr remaining) start)) 1))
  85                     (inst andi. temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
  86                     (inst cmpwi temp (ldb (byte 8 0) (logand start (cdadr remaining))))
  87                     (inst b? (if not-p :ne :eq) target)
  88                     (return))
  89                    (t
  90                     (unless (= start bignum-widetag)
  91                       (inst cmpwi temp start)
  92                       (if (= end complex-array-widetag)
  93                           (progn
  94                             (aver last)
  95                             (inst b? (if not-p :lt :ge) target))
  96                           (inst blt when-false)))
  97                     (unless (= end complex-array-widetag)
  98                       (inst cmpwi temp end)
  99                       (if last
 100                           (inst b? (if not-p :gt :le) target)
 101                           (inst ble when-true))))))))))
 102         (emit-label drop-through)))))
 103
 104 ;;; Simple type checking and testing:
 105 (define-vop (check-type)
 106   (:args (value :target result :scs (any-reg descriptor-reg)))
 107   (:results (result :scs (any-reg descriptor-reg)))
 108   (:temporary (:scs (non-descriptor-reg)) temp)
 109   (:vop-var vop)
 110   (:save-p :compute-only))
 111
 112 (define-vop (type-predicate)
 113   (:args (value :scs (any-reg descriptor-reg)))
 114   (:conditional)
 115   (:info target not-p)
 116   (:policy :fast-safe)
 117   (:temporary (:scs (non-descriptor-reg)) temp))
 118
 119 (defun cost-to-test-types (type-codes)
 120   (+ (* 2 (length type-codes))
 121      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 122
 123 (defmacro !define-type-vops (pred-name check-name ptype error-code
 124                              (&rest type-codes)
 125                              ;; KLUDGE: ideally, the compiler could
 126                              ;; derive that it can use the sneaky trap
 127                              ;; twice mechanism itself.  However, one
 128                              ;; thing at a time...
 129                              &key mask &allow-other-keys)
 130   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
 131     `(progn
 132        ,@(when pred-name
 133            `((define-vop (,pred-name type-predicate)
 134                (:translate ,pred-name)
 135                (:generator ,cost
 136                  (test-type value target not-p (,@type-codes) :temp temp)))))
 137        ,@(when check-name
 138            `((define-vop (,check-name check-type)
 139                (:generator ,cost
 140                  ,@(if mask
 141                        `((inst andi. temp value ,mask)
 142                          (inst twi 0 value (error-number-or-lose ',error-code))
 143                          (inst twi :ne temp ,@(if ;; KLUDGE: At
 144                                                   ;; present, MASK is
 145                                                   ;; 3 or LOWTAG-MASK
 146                                                   (eql mask 3)
 147                                                   ;; KLUDGE
 148                                                   `(0)
 149                                                   type-codes))
 150                          (move result value))
 151                        `((let ((err-lab
 152                                 (generate-error-code vop ,error-code value)))
 153                            (test-type value err-lab t (,@type-codes) :temp temp)
 154                            (move result value))))))))
 155        ,@(when ptype
 156            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 157 \f
 158 ;;;; Other integer ranges.
 159
 160 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
 161 ;;; exactly one digit.
 162
 163 (define-vop (signed-byte-32-p type-predicate)
 164   (:translate signed-byte-32-p)
 165   (:generator 45
 166     (let ((not-target (gen-label)))
 167       (multiple-value-bind
 168           (yep nope)
 169           (if not-p
 170               (values not-target target)
 171               (values target not-target))
 172         (inst andi. temp value #x3)
 173         (inst beq yep)
 174         (test-type value nope t (other-pointer-lowtag) :temp temp)
 175         (loadw temp value 0 other-pointer-lowtag)
 176         (inst cmpwi temp (+ (ash 1 n-widetag-bits)
 177                           bignum-widetag))
 178         (inst b? (if not-p :ne :eq) target)
 179         (emit-label not-target)))))
 180
 181 (define-vop (check-signed-byte-32 check-type)
 182   (:generator 45
 183     (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
 184           (yep (gen-label)))
 185       (inst andi. temp value #x3)
 186       (inst beq yep)
 187       (test-type value nope t (other-pointer-lowtag) :temp temp)
 188       (loadw temp value 0 other-pointer-lowtag)
 189       (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 190       (inst bne nope)
 191       (emit-label yep)
 192       (move result value))))
 193
 194
 195 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 196 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 197 ;;; and the second digit all zeros.
 198
 199 (define-vop (unsigned-byte-32-p type-predicate)
 200   (:translate unsigned-byte-32-p)
 201   (:generator 45
 202     (let ((not-target (gen-label))
 203           (single-word (gen-label))
 204           (fixnum (gen-label)))
 205       (multiple-value-bind
 206           (yep nope)
 207           (if not-p
 208               (values not-target target)
 209               (values target not-target))
 210         ;; Is it a fixnum?
 211         (inst andi. temp value #x3)
 212         (inst cmpwi :cr1 value 0)
 213         (inst beq fixnum)
 214
 215         ;; If not, is it an other pointer?
 216         (test-type value nope t (other-pointer-lowtag) :temp temp)
 217         ;; Get the header.
 218         (loadw temp value 0 other-pointer-lowtag)
 219         ;; Is it one?
 220         (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 221         (inst beq single-word)
 222         ;; If it's other than two, we can't be an (unsigned-byte 32)
 223         (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
 224         (inst bne nope)
 225         ;; Get the second digit.
 226         (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 227         ;; All zeros, its an (unsigned-byte 32).
 228         (inst cmpwi temp 0)
 229         (inst beq yep)
 230         ;; Otherwise, it isn't.
 231         (inst b nope)
 232
 233         (emit-label single-word)
 234         ;; Get the single digit.
 235         (loadw temp value bignum-digits-offset other-pointer-lowtag)
 236         (inst cmpwi :cr1 temp 0)
 237
 238         ;; positive implies (unsigned-byte 32).
 239         (emit-label fixnum)
 240         (inst b?  :cr1 (if not-p :lt :ge) target)
 241
 242         (emit-label not-target)))))
 243
 244 (define-vop (check-unsigned-byte-32 check-type)
 245   (:generator 45
 246     (let ((nope
 247            (generate-error-code vop object-not-unsigned-byte-32-error value))
 248           (yep (gen-label))
 249           (fixnum (gen-label))
 250           (single-word (gen-label)))
 251       ;; Is it a fixnum?
 252       (inst andi. temp value #x3)
 253       (inst cmpwi :cr1 value 0)
 254       (inst beq fixnum)
 255
 256       ;; If not, is it an other pointer?
 257       (test-type value nope t (other-pointer-lowtag) :temp temp)
 258       ;; Get the number of digits.
 259       (loadw temp value 0 other-pointer-lowtag)
 260       ;; Is it one?
 261       (inst cmpwi temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 262       (inst beq single-word)
 263       ;; If it's other than two, we can't be an (unsigned-byte 32)
 264       (inst cmpwi temp (+ (ash 2 n-widetag-bits) bignum-widetag))
 265       (inst bne nope)
 266       ;; Get the second digit.
 267       (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 268       ;; All zeros, its an (unsigned-byte 32).
 269       (inst cmpwi temp 0)
 270       (inst beq yep)
 271       ;; Otherwise, it isn't.
 272       (inst b nope)
 273
 274       (emit-label single-word)
 275       ;; Get the single digit.
 276       (loadw temp value bignum-digits-offset other-pointer-lowtag)
 277       ;; positive implies (unsigned-byte 32).
 278       (inst cmpwi :cr1 temp 0)
 279
 280       (emit-label fixnum)
 281       (inst blt :cr1 nope)
 282
 283       (emit-label yep)
 284       (move result value))))
 285
 286
 287
 288 \f
 289 ;;;; List/symbol types:
 290 ;;;
 291 ;;; symbolp (or symbol (eq nil))
 292 ;;; consp (and list (not (eq nil)))
 293
 294 (define-vop (symbolp type-predicate)
 295   (:translate symbolp)
 296   (:generator 12
 297     (let* ((drop-thru (gen-label))
 298            (is-symbol-label (if not-p drop-thru target)))
 299       (inst cmpw value null-tn)
 300       (inst beq is-symbol-label)
 301       (test-type value target not-p (symbol-header-widetag) :temp temp)
 302       (emit-label drop-thru))))
 303
 304 (define-vop (check-symbol check-type)
 305   (:generator 12
 306     (let ((drop-thru (gen-label))
 307           (error (generate-error-code vop object-not-symbol-error value)))
 308       (inst cmpw value null-tn)
 309       (inst beq drop-thru)
 310       (test-type value error t (symbol-header-widetag) :temp temp)
 311       (emit-label drop-thru)
 312       (move result value))))
 313
 314 (define-vop (consp type-predicate)
 315   (:translate consp)
 316   (:generator 8
 317     (let* ((drop-thru (gen-label))
 318            (is-not-cons-label (if not-p target drop-thru)))
 319       (inst cmpw value null-tn)
 320       (inst beq is-not-cons-label)
 321       (test-type value target not-p (list-pointer-lowtag) :temp temp)
 322       (emit-label drop-thru))))
 323
 324 (define-vop (check-cons check-type)
 325   (:generator 8
 326     (let ((error (generate-error-code vop object-not-cons-error value)))
 327       (inst cmpw value null-tn)
 328       (inst beq error)
 329       (test-type value error t (list-pointer-lowtag) :temp temp)
 330       (move result value))))
 331