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