src/compiler/ppc/type-vops.lisp

   1 (in-package "SB!VM")
   2
   3 \f
   4 ;;;; Simple type checking and testing:
   5 ;;;
   6 ;;;    These types are represented by a single type code, so are easily
   7 ;;; open-coded as a mask and compare.
   8
   9 (define-vop (check-type)
  10   (:args (value :target result :scs (any-reg descriptor-reg)))
  11   (:results (result :scs (any-reg descriptor-reg)))
  12   (:temporary (:scs (non-descriptor-reg)) temp)
  13   (:vop-var vop)
  14   (:save-p :compute-only))
  15
  16 (define-vop (type-predicate)
  17   (:args (value :scs (any-reg descriptor-reg)))
  18   (:conditional)
  19   (:info target not-p)
  20   (:policy :fast-safe)
  21   (:temporary (:scs (non-descriptor-reg)) temp))
  22
  23 (eval-when (:compile-toplevel :load-toplevel)
  24   (defun cost-to-test-types (type-codes)
  25     (+ (* 2 (length type-codes))
  26        (if (> (apply #'max type-codes) lowtag-limit) 7 2))))
  27
  28 (macrolet ((def-type-vops (pred-name check-name ptype error-code
  29                                      &rest type-codes)
  30                (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
  31     `(progn
  32        ,@(when pred-name
  33            `((define-vop (,pred-name type-predicate)
  34                (:translate ,pred-name)
  35                (:generator ,cost
  36                  (test-type value temp target not-p ,@type-codes)))))
  37        ,@(when check-name
  38            `((define-vop (,check-name check-type)
  39                (:generator ,cost
  40                  (let ((err-lab
  41                         (generate-error-code vop ,error-code value)))
  42                    (test-type value temp err-lab t ,@type-codes)
  43                    (move result value))))))
  44        ,@(when ptype
  45            `((primitive-type-vop ,check-name (:check) ,ptype)))))))
  46
  47   (def-type-vops fixnump nil nil object-not-fixnum-error
  48                  sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag)
  49   (define-vop (check-fixnum check-type)
  50       (:generator 3
  51                   (inst andi. temp value 3)
  52                   (inst twi 0 value (error-number-or-lose 'object-not-fixnum-error))
  53                   (inst twi :ne temp 0)
  54                   (move result value)))
  55   (primitive-type-vop check-fixnum (:check) fixnum)
  56   (def-type-vops functionp nil nil
  57                  object-not-fun-error sb!vm:fun-pointer-lowtag)
  58
  59   (define-vop (check-fun check-type)
  60       (:generator 3
  61                   (inst andi. temp value 7)
  62                   (inst twi 0 value (error-number-or-lose 'object-not-fun-error))
  63                   (inst twi :ne temp sb!vm:fun-pointer-lowtag)
  64                   (move result value)))
  65   (primitive-type-vop check-fun (:check) function)
  66
  67   (def-type-vops listp nil nil
  68                  object-not-list-error sb!vm:list-pointer-lowtag)
  69   (define-vop (check-list check-type)
  70       (:generator 3
  71                   (inst andi. temp value 7)
  72                   (inst twi 0 value (error-number-or-lose 'object-not-list-error))
  73                   (inst twi :ne temp sb!vm:list-pointer-lowtag)
  74                   (move result value)))
  75   (primitive-type-vop check-list (:check) list)
  76
  77   (def-type-vops %instancep nil nil
  78                  object-not-instance-error sb!vm:instance-pointer-lowtag)
  79   (define-vop (check-instance check-type)
  80       (:generator 3
  81                   (inst andi. temp value 7)
  82                   (inst twi 0 value (error-number-or-lose 'object-not-instance-error))
  83                   (inst twi :ne temp sb!vm:instance-pointer-lowtag)
  84                   (move result value)))
  85   (primitive-type-vop check-instance (:check) instance)
  86
  87
  88   (def-type-vops bignump check-bignum bignum
  89                  object-not-bignum-error sb!vm:bignum-widetag)
  90
  91   (def-type-vops ratiop check-ratio ratio
  92                  object-not-ratio-error sb!vm:ratio-widetag)
  93
  94   (def-type-vops complexp check-complex complex
  95                  object-not-complex-error sb!vm:complex-widetag
  96                  complex-single-float-widetag complex-double-float-widetag)
  97
  98   (def-type-vops complex-rational-p check-complex-rational nil
  99                  object-not-complex-rational-error complex-widetag)
 100
 101   (def-type-vops complex-float-p check-complex-float nil
 102                  object-not-complex-float-error
 103                  complex-single-float-widetag complex-double-float-widetag)
 104
 105   (def-type-vops complex-single-float-p check-complex-single-float
 106     complex-single-float object-not-complex-single-float-error
 107     complex-single-float-widetag)
 108
 109   (def-type-vops complex-double-float-p check-complex-double-float
 110     complex-double-float object-not-complex-double-float-error
 111     complex-double-float-widetag)
 112
 113 (def-type-vops single-float-p check-single-float single-float
 114   object-not-single-float-error sb!vm:single-float-widetag)
 115
 116 (def-type-vops double-float-p check-double-float double-float
 117   object-not-double-float-error sb!vm:double-float-widetag)
 118
 119 (def-type-vops simple-string-p check-simple-string simple-string
 120   object-not-simple-string-error sb!vm:simple-string-widetag)
 121
 122 (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
 123   object-not-simple-bit-vector-error simple-bit-vector-widetag)
 124
 125 (def-type-vops simple-vector-p check-simple-vector simple-vector
 126   object-not-simple-vector-error sb!vm:simple-vector-widetag)
 127
 128 (def-type-vops simple-array-unsigned-byte-2-p
 129   check-simple-array-unsigned-byte-2
 130   simple-array-unsigned-byte-2
 131   object-not-simple-array-unsigned-byte-2-error
 132   sb!vm:simple-array-unsigned-byte-2-widetag)
 133
 134 (def-type-vops simple-array-unsigned-byte-4-p
 135   check-simple-array-unsigned-byte-4
 136   simple-array-unsigned-byte-4
 137   object-not-simple-array-unsigned-byte-4-error
 138   sb!vm:simple-array-unsigned-byte-4-widetag)
 139
 140 (def-type-vops simple-array-unsigned-byte-8-p
 141   check-simple-array-unsigned-byte-8
 142   simple-array-unsigned-byte-8
 143   object-not-simple-array-unsigned-byte-8-error
 144   sb!vm:simple-array-unsigned-byte-8-widetag)
 145
 146 (def-type-vops simple-array-unsigned-byte-16-p
 147   check-simple-array-unsigned-byte-16
 148   simple-array-unsigned-byte-16
 149   object-not-simple-array-unsigned-byte-16-error
 150   sb!vm:simple-array-unsigned-byte-16-widetag)
 151
 152 (def-type-vops simple-array-unsigned-byte-32-p
 153   check-simple-array-unsigned-byte-32
 154   simple-array-unsigned-byte-32
 155   object-not-simple-array-unsigned-byte-32-error
 156   sb!vm:simple-array-unsigned-byte-32-widetag)
 157
 158 (def-type-vops simple-array-signed-byte-8-p
 159   check-simple-array-signed-byte-8
 160   simple-array-signed-byte-8
 161   object-not-simple-array-signed-byte-8-error
 162   simple-array-signed-byte-8-widetag)
 163
 164 (def-type-vops simple-array-signed-byte-16-p
 165   check-simple-array-signed-byte-16
 166   simple-array-signed-byte-16
 167   object-not-simple-array-signed-byte-16-error
 168   simple-array-signed-byte-16-widetag)
 169
 170 (def-type-vops simple-array-signed-byte-30-p
 171   check-simple-array-signed-byte-30
 172   simple-array-signed-byte-30
 173   object-not-simple-array-signed-byte-30-error
 174   simple-array-signed-byte-30-widetag)
 175
 176 (def-type-vops simple-array-signed-byte-32-p
 177   check-simple-array-signed-byte-32
 178   simple-array-signed-byte-32
 179   object-not-simple-array-signed-byte-32-error
 180   simple-array-signed-byte-32-widetag)
 181
 182 (def-type-vops simple-array-single-float-p check-simple-array-single-float
 183   simple-array-single-float object-not-simple-array-single-float-error
 184   sb!vm:simple-array-single-float-widetag)
 185
 186 (def-type-vops simple-array-double-float-p check-simple-array-double-float
 187   simple-array-double-float object-not-simple-array-double-float-error
 188   sb!vm:simple-array-double-float-widetag)
 189
 190 (def-type-vops simple-array-complex-single-float-p
 191   check-simple-array-complex-single-float
 192   simple-array-complex-single-float
 193   object-not-simple-array-complex-single-float-error
 194   simple-array-complex-single-float-widetag)
 195
 196 (def-type-vops simple-array-complex-double-float-p
 197   check-simple-array-complex-double-float
 198   simple-array-complex-double-float
 199   object-not-simple-array-complex-double-float-error
 200   simple-array-complex-double-float-widetag)
 201
 202 (def-type-vops base-char-p check-base-char base-char
 203   object-not-base-char-error sb!vm:base-char-widetag)
 204
 205 (def-type-vops system-area-pointer-p check-system-area-pointer
 206   system-area-pointer object-not-sap-error sb!vm:sap-widetag)
 207
 208 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
 209   object-not-weak-pointer-error sb!vm:weak-pointer-widetag)
 210
 211 (def-type-vops code-component-p nil nil nil
 212   sb!vm:code-header-widetag)
 213
 214 (def-type-vops lra-p nil nil nil
 215   sb!vm:return-pc-header-widetag)
 216
 217 (def-type-vops fdefn-p nil nil nil
 218   sb!vm:fdefn-widetag)
 219
 220 (def-type-vops funcallable-instance-p nil nil nil
 221   sb!vm:funcallable-instance-header-widetag)
 222
 223 (def-type-vops array-header-p nil nil nil
 224   sb!vm:simple-array-widetag sb!vm:complex-string-widetag sb!vm:complex-bit-vector-widetag
 225   sb!vm:complex-vector-widetag sb!vm:complex-array-widetag)
 226
 227 (def-type-vops nil check-function-or-symbol nil object-not-function-or-symbol-error
 228   sb!vm:fun-pointer-lowtag sb!vm:symbol-header-widetag)
 229
 230 (def-type-vops stringp check-string nil object-not-string-error
 231   sb!vm:simple-string-widetag sb!vm:complex-string-widetag)
 232
 233 (def-type-vops complex-vector-p check-complex-vector nil
 234  object-not-complex-vector-error complex-vector-widetag)
 235
 236 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
 237   sb!vm:simple-bit-vector-widetag sb!vm:complex-bit-vector-widetag)
 238
 239 (def-type-vops vectorp check-vector nil object-not-vector-error
 240   simple-string-widetag simple-bit-vector-widetag simple-vector-widetag
 241   simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag
 242   simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag
 243   simple-array-unsigned-byte-32-widetag
 244   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 245   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 246   simple-array-single-float-widetag simple-array-double-float-widetag
 247   simple-array-complex-single-float-widetag
 248   simple-array-complex-double-float-widetag
 249   complex-string-widetag complex-bit-vector-widetag complex-vector-widetag)
 250
 251 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
 252   simple-array-widetag simple-string-widetag simple-bit-vector-widetag
 253   simple-vector-widetag simple-array-unsigned-byte-2-widetag
 254   simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
 255   simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
 256   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 257   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 258   simple-array-single-float-widetag simple-array-double-float-widetag
 259   simple-array-complex-single-float-widetag
 260   simple-array-complex-double-float-widetag)
 261
 262 (def-type-vops arrayp check-array nil object-not-array-error
 263   simple-array-widetag simple-string-widetag simple-bit-vector-widetag
 264   simple-vector-widetag simple-array-unsigned-byte-2-widetag
 265   simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
 266   simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
 267   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 268   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 269   simple-array-single-float-widetag simple-array-double-float-widetag
 270   simple-array-complex-single-float-widetag
 271   simple-array-complex-double-float-widetag
 272   complex-string-widetag complex-bit-vector-widetag complex-vector-widetag
 273   complex-array-widetag)
 274
 275 (def-type-vops numberp check-number nil object-not-number-error
 276   even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag
 277   single-float-widetag double-float-widetag complex-widetag
 278   complex-single-float-widetag complex-double-float-widetag)
 279
 280 (def-type-vops rationalp check-rational nil object-not-rational-error
 281   sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag sb!vm:ratio-widetag sb!vm:bignum-widetag)
 282
 283 (def-type-vops integerp check-integer nil object-not-integer-error
 284   sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag sb!vm:bignum-widetag)
 285
 286 (def-type-vops floatp check-float nil object-not-float-error
 287   sb!vm:single-float-widetag sb!vm:double-float-widetag)
 288
 289 (def-type-vops realp check-real nil object-not-real-error
 290   sb!vm:even-fixnum-lowtag sb!vm:odd-fixnum-lowtag sb!vm:ratio-widetag sb!vm:bignum-widetag
 291   sb!vm:single-float-widetag sb!vm:double-float-widetag))
 292
 293 \f
 294 ;;;; Other integer ranges.
 295
 296 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
 297 ;;; exactly one digit.
 298
 299 (define-vop (signed-byte-32-p type-predicate)
 300   (:translate signed-byte-32-p)
 301   (:generator 45
 302     (let ((not-target (gen-label)))
 303       (multiple-value-bind
 304           (yep nope)
 305           (if not-p
 306               (values not-target target)
 307               (values target not-target))
 308         (inst andi. temp value #x3)
 309         (inst beq yep)
 310         (test-type value temp nope t sb!vm:other-pointer-lowtag)
 311         (loadw temp value 0 sb!vm:other-pointer-lowtag)
 312         (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits)
 313                           sb!vm:bignum-widetag))
 314         (inst b? (if not-p :ne :eq) target)
 315         (emit-label not-target)))))
 316
 317 (define-vop (check-signed-byte-32 check-type)
 318   (:generator 45
 319     (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
 320           (yep (gen-label)))
 321       (inst andi. temp value #x3)
 322       (inst beq yep)
 323       (test-type value temp nope t sb!vm:other-pointer-lowtag)
 324       (loadw temp value 0 sb!vm:other-pointer-lowtag)
 325       (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits) sb!vm:bignum-widetag))
 326       (inst bne nope)
 327       (emit-label yep)
 328       (move result value))))
 329
 330
 331 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 332 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 333 ;;; and the second digit all zeros.
 334
 335 (define-vop (unsigned-byte-32-p type-predicate)
 336   (:translate unsigned-byte-32-p)
 337   (:generator 45
 338     (let ((not-target (gen-label))
 339           (single-word (gen-label))
 340           (fixnum (gen-label)))
 341       (multiple-value-bind
 342           (yep nope)
 343           (if not-p
 344               (values not-target target)
 345               (values target not-target))
 346         ;; Is it a fixnum?
 347         (inst andi. temp value #x3)
 348         (inst cmpwi :cr1 value 0)
 349         (inst beq fixnum)
 350
 351         ;; If not, is it an other pointer?
 352         (test-type value temp nope t sb!vm:other-pointer-lowtag)
 353         ;; Get the header.
 354         (loadw temp value 0 sb!vm:other-pointer-lowtag)
 355         ;; Is it one?
 356         (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits) sb!vm:bignum-widetag))
 357         (inst beq single-word)
 358         ;; If it's other than two, we can't be an (unsigned-byte 32)
 359         (inst cmpwi temp (+ (ash 2 sb!vm:n-widetag-bits) sb!vm:bignum-widetag))
 360         (inst bne nope)
 361         ;; Get the second digit.
 362         (loadw temp value (1+ sb!vm:bignum-digits-offset) sb!vm:other-pointer-lowtag)
 363         ;; All zeros, its an (unsigned-byte 32).
 364         (inst cmpwi temp 0)
 365         (inst beq yep)
 366         ;; Otherwise, it isn't.
 367         (inst b nope)
 368
 369         (emit-label single-word)
 370         ;; Get the single digit.
 371         (loadw temp value sb!vm:bignum-digits-offset sb!vm:other-pointer-lowtag)
 372         (inst cmpwi :cr1 temp 0)
 373
 374         ;; positive implies (unsigned-byte 32).
 375         (emit-label fixnum)
 376         (inst b?  :cr1 (if not-p :lt :ge) target)
 377
 378         (emit-label not-target)))))
 379
 380 (define-vop (check-unsigned-byte-32 check-type)
 381   (:generator 45
 382     (let ((nope
 383            (generate-error-code vop object-not-unsigned-byte-32-error value))
 384           (yep (gen-label))
 385           (fixnum (gen-label))
 386           (single-word (gen-label)))
 387       ;; Is it a fixnum?
 388       (inst andi. temp value #x3)
 389       (inst cmpwi :cr1 value 0)
 390       (inst beq fixnum)
 391
 392       ;; If not, is it an other pointer?
 393       (test-type value temp nope t sb!vm:other-pointer-lowtag)
 394       ;; Get the number of digits.
 395       (loadw temp value 0 sb!vm:other-pointer-lowtag)
 396       ;; Is it one?
 397       (inst cmpwi temp (+ (ash 1 sb!vm:n-widetag-bits) sb!vm:bignum-widetag))
 398       (inst beq single-word)
 399       ;; If it's other than two, we can't be an (unsigned-byte 32)
 400       (inst cmpwi temp (+ (ash 2 sb!vm:n-widetag-bits) sb!vm:bignum-widetag))
 401       (inst bne nope)
 402       ;; Get the second digit.
 403       (loadw temp value (1+ sb!vm:bignum-digits-offset) sb!vm:other-pointer-lowtag)
 404       ;; All zeros, its an (unsigned-byte 32).
 405       (inst cmpwi temp 0)
 406       (inst beq yep)
 407       ;; Otherwise, it isn't.
 408       (inst b nope)
 409
 410       (emit-label single-word)
 411       ;; Get the single digit.
 412       (loadw temp value sb!vm:bignum-digits-offset sb!vm:other-pointer-lowtag)
 413       ;; positive implies (unsigned-byte 32).
 414       (inst cmpwi :cr1 temp 0)
 415
 416       (emit-label fixnum)
 417       (inst blt :cr1 nope)
 418
 419       (emit-label yep)
 420       (move result value))))
 421
 422
 423
 424 \f
 425 ;;;; List/symbol types:
 426 ;;;
 427 ;;; symbolp (or symbol (eq nil))
 428 ;;; consp (and list (not (eq nil)))
 429
 430 (define-vop (symbolp type-predicate)
 431   (:translate symbolp)
 432   (:generator 12
 433     (let* ((drop-thru (gen-label))
 434            (is-symbol-label (if not-p drop-thru target)))
 435       (inst cmpw value null-tn)
 436       (inst beq is-symbol-label)
 437       (test-type value temp target not-p sb!vm:symbol-header-widetag)
 438       (emit-label drop-thru))))
 439
 440 (define-vop (check-symbol check-type)
 441   (:generator 12
 442     (let ((drop-thru (gen-label))
 443           (error (generate-error-code vop object-not-symbol-error value)))
 444       (inst cmpw value null-tn)
 445       (inst beq drop-thru)
 446       (test-type value temp error t sb!vm:symbol-header-widetag)
 447       (emit-label drop-thru)
 448       (move result value))))
 449
 450 (define-vop (consp type-predicate)
 451   (:translate consp)
 452   (:generator 8
 453     (let* ((drop-thru (gen-label))
 454            (is-not-cons-label (if not-p target drop-thru)))
 455       (inst cmpw value null-tn)
 456       (inst beq is-not-cons-label)
 457       (test-type value temp target not-p sb!vm:list-pointer-lowtag)
 458       (emit-label drop-thru))))
 459
 460 (define-vop (check-cons check-type)
 461   (:generator 8
 462     (let ((error (generate-error-code vop object-not-cons-error value)))
 463       (inst cmpw value null-tn)
 464       (inst beq error)
 465       (test-type value temp error t sb!vm:list-pointer-lowtag)
 466       (move result value))))
 467