src/compiler/alpha/type-vops.lisp

   1 ;;;; type testing and checking VOPs for the Alpha 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 and value 3 temp)
  17     (if not-p
  18         (inst bne temp target)
  19         (inst beq temp target))))
  20
  21 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
  22   (let ((drop-through (gen-label)))
  23     (assemble ()
  24       (inst and value 3 temp)
  25       (inst beq temp (if not-p drop-through target)))
  26     (%test-headers value target not-p nil headers
  27                    :drop-through drop-through :temp temp)))
  28
  29 (defun %test-immediate (value target not-p immediate &key temp)
  30   (assemble ()
  31     (inst and value 255 temp)
  32     (inst xor temp immediate temp)
  33     (if not-p
  34         (inst bne temp target)
  35         (inst beq temp target))))
  36
  37 (defun %test-lowtag (value target not-p lowtag &key temp)
  38   (assemble ()
  39     (inst and value lowtag-mask temp)
  40     (inst xor temp lowtag temp)
  41     (if not-p
  42         (inst bne temp target)
  43         (inst beq temp target))))
  44
  45 (defun %test-headers (value target not-p function-p headers
  46                       &key (drop-through (gen-label)) temp)
  47   (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
  48     (multiple-value-bind
  49         (when-true when-false)
  50         ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
  51         ;; we know it's true and when we know it's false respectively.
  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         (let ((delta 0))
  59           (do ((remaining headers (cdr remaining)))
  60               ((null remaining))
  61             (let ((header (car remaining))
  62                   (last (null (cdr remaining))))
  63               (cond
  64                ((atom header)
  65                 (inst subq temp (- header delta) temp)
  66                 (setf delta header)
  67                 (if last
  68                     (if not-p
  69                         (inst bne temp target)
  70                         (inst beq temp target))
  71                     (inst beq temp when-true)))
  72                (t
  73                 (let ((start (car header))
  74                       (end (cdr header)))
  75                   (unless (= start bignum-widetag)
  76                     (inst subq temp (- start delta) temp)
  77                     (setf delta start)
  78                     (inst blt temp when-false))
  79                   (inst subq temp (- end delta) temp)
  80                   (setf delta end)
  81                   (if last
  82                       (if not-p
  83                           (inst bgt temp target)
  84                           (inst ble temp target))
  85                       (inst ble temp when-true))))))))
  86         (emit-label drop-through)))))
  87 \f
  88 ;;;; Type checking and testing:
  89
  90 (define-vop (check-type)
  91   (:args (value :target result :scs (any-reg descriptor-reg)))
  92   (:results (result :scs (any-reg descriptor-reg)))
  93   (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
  94   (:vop-var vop)
  95   (:save-p :compute-only))
  96
  97 (define-vop (type-predicate)
  98   (:args (value :scs (any-reg descriptor-reg)))
  99   (:temporary (:scs (non-descriptor-reg)) temp)
 100   (:conditional)
 101   (:info target not-p)
 102   (:policy :fast-safe))
 103
 104 (defun cost-to-test-types (type-codes)
 105   (+ (* 2 (length type-codes))
 106      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 107
 108 (defmacro !define-type-vops (pred-name check-name ptype error-code
 109                              (&rest type-codes)
 110                              &key &allow-other-keys)
 111   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
 112     `(progn
 113        ,@(when pred-name
 114            `((define-vop (,pred-name type-predicate)
 115                (:translate ,pred-name)
 116                (:generator ,cost
 117                  (test-type value target not-p (,@type-codes) :temp temp)))))
 118        ,@(when check-name
 119            `((define-vop (,check-name check-type)
 120                (:generator ,cost
 121                  (let ((err-lab
 122                         (generate-error-code vop ,error-code value)))
 123                    (test-type value err-lab t (,@type-codes) :temp temp)
 124                    (move value result))))))
 125        ,@(when ptype
 126            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 127 \f
 128 ;;;; Other integer ranges.
 129
 130 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
 131 ;;; exactly one digit.
 132
 133 (defun signed-byte-32-test (value temp temp1 not-p target not-target)
 134   (multiple-value-bind
 135       (yep nope)
 136       (if not-p
 137           (values not-target target)
 138           (values target not-target))
 139     (assemble ()
 140       (inst and value 3 temp)
 141       (inst beq temp yep)
 142       (inst and value lowtag-mask temp)
 143       (inst xor temp other-pointer-lowtag temp)
 144       (inst bne temp nope)
 145       (loadw temp value 0 other-pointer-lowtag)
 146       (inst li (+ (ash 1 n-widetag-bits) bignum-widetag) temp1)
 147       (inst xor temp temp1 temp)
 148       (if not-p
 149           (inst bne temp target)
 150           (inst beq temp target))))
 151   (values))
 152
 153 (define-vop (signed-byte-32-p type-predicate)
 154   (:translate signed-byte-32-p)
 155   (:temporary (:scs (non-descriptor-reg)) temp1)
 156   (:generator 45
 157     (signed-byte-32-test value temp temp1 not-p target not-target)
 158     NOT-TARGET))
 159
 160 (define-vop (check-signed-byte-32 check-type)
 161   (:temporary (:scs (non-descriptor-reg)) temp1)
 162   (:generator 45
 163     (let ((loose (generate-error-code vop object-not-signed-byte-32-error
 164                                       value)))
 165       (signed-byte-32-test value temp temp1 t loose okay))
 166     OKAY
 167     (move value result)))
 168
 169 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 170 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 171 ;;; and the second digit all zeros.
 172
 173 (defun unsigned-byte-32-test (value temp temp1 not-p target not-target)
 174   (multiple-value-bind (yep nope)
 175                        (if not-p
 176                            (values not-target target)
 177                            (values target not-target))
 178     (assemble ()
 179       ;; Is it a fixnum?
 180       (inst and value 3 temp1)
 181       (inst move value temp)
 182       (inst beq temp1 fixnum)
 183
 184       ;; If not, is it an other pointer?
 185       (inst and value lowtag-mask temp)
 186       (inst xor temp other-pointer-lowtag temp)
 187       (inst bne temp nope)
 188       ;; Get the header.
 189       (loadw temp value 0 other-pointer-lowtag)
 190       ;; Is it one?
 191       (inst li  (+ (ash 1 n-widetag-bits) bignum-widetag) temp1)
 192       (inst xor temp temp1 temp)
 193       (inst beq temp single-word)
 194       ;; If it's other than two, we can't be an (unsigned-byte 32)
 195       (inst li (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
 196                        (+ (ash 2 n-widetag-bits) bignum-widetag))
 197             temp1)
 198       (inst xor temp temp1 temp)
 199       (inst bne temp nope)
 200       ;; Get the second digit.
 201       (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 202       ;; All zeros, its an (unsigned-byte 32).
 203       (inst beq temp yep)
 204       (inst br zero-tn nope)
 205
 206       SINGLE-WORD
 207       ;; Get the single digit.
 208       (loadw temp value bignum-digits-offset other-pointer-lowtag)
 209
 210       ;; positive implies (unsigned-byte 32).
 211       FIXNUM
 212       (if not-p
 213           (inst blt temp target)
 214           (inst bge temp target))))
 215   (values))
 216
 217 (define-vop (unsigned-byte-32-p type-predicate)
 218   (:translate unsigned-byte-32-p)
 219   (:temporary (:scs (non-descriptor-reg)) temp1)
 220   (:generator 45
 221     (unsigned-byte-32-test value temp temp1 not-p target not-target)
 222     NOT-TARGET))
 223
 224 (define-vop (check-unsigned-byte-32 check-type)
 225   (:temporary (:scs (non-descriptor-reg)) temp1)
 226   (:generator 45
 227     (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
 228                                       value)))
 229       (unsigned-byte-32-test value temp temp1 t loose okay))
 230     OKAY
 231     (move value result)))
 232
 233
 234 \f
 235 ;;;; List/symbol types:
 236 ;;;
 237 ;;; symbolp (or symbol (eq nil))
 238 ;;; consp (and list (not (eq nil)))
 239
 240 (define-vop (symbolp type-predicate)
 241   (:translate symbolp)
 242   (:temporary (:scs (non-descriptor-reg)) temp)
 243   (:generator 12
 244     (inst cmpeq value null-tn temp)
 245     (inst bne temp (if not-p drop-thru target))
 246     (test-type value target not-p (symbol-header-widetag) :temp temp)
 247     DROP-THRU))
 248
 249 (define-vop (check-symbol check-type)
 250   (:temporary (:scs (non-descriptor-reg)) temp)
 251   (:generator 12
 252     (inst cmpeq value null-tn temp)
 253     (inst bne temp drop-thru)
 254     (let ((error (generate-error-code vop object-not-symbol-error value)))
 255       (test-type value error t (symbol-header-widetag) :temp temp))
 256     DROP-THRU
 257     (move value result)))
 258
 259 (define-vop (consp type-predicate)
 260   (:translate consp)
 261   (:temporary (:scs (non-descriptor-reg)) temp)
 262   (:generator 8
 263     (inst cmpeq value null-tn temp)
 264     (inst bne temp (if not-p target drop-thru))
 265     (test-type value target not-p (list-pointer-lowtag) :temp temp)
 266     DROP-THRU))
 267
 268 (define-vop (check-cons check-type)
 269   (:temporary (:scs (non-descriptor-reg)) temp)
 270   (:generator 8
 271     (let ((error (generate-error-code vop object-not-cons-error value)))
 272       (inst cmpeq value null-tn temp)
 273       (inst bne temp error)
 274       (test-type value error t (list-pointer-lowtag) :temp temp))
 275     (move value result)))
 276