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