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