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 fixnum-tag-mask 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 fixnum-tag-mask 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
  88 ;;;; Other integer ranges.
  89
  90 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
  91 ;;; exactly one digit.
  92 (define-vop (signed-byte-32-p type-predicate)
  93   (:translate signed-byte-32-p)
  94   (:temporary (:scs (non-descriptor-reg)) temp1)
  95   (:generator 45
  96     (multiple-value-bind
  97           (yep nope)
  98         (if not-p
  99             (values not-target target)
 100             (values target not-target))
 101       (assemble ()
 102         (inst and value fixnum-tag-mask temp)
 103         (inst beq temp yep)
 104         (inst and value lowtag-mask temp)
 105         (inst xor temp other-pointer-lowtag temp)
 106         (inst bne temp nope)
 107         (loadw temp value 0 other-pointer-lowtag)
 108         (inst li (+ (ash 1 n-widetag-bits) bignum-widetag) temp1)
 109         (inst xor temp temp1 temp)
 110         (if not-p
 111             (inst bne temp target)
 112             (inst beq temp target))))
 113     NOT-TARGET))
 114
 115 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 116 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 117 ;;; and the second digit all zeros.
 118
 119 (define-vop (unsigned-byte-32-p type-predicate)
 120   (:translate unsigned-byte-32-p)
 121   (:temporary (:scs (non-descriptor-reg)) temp1)
 122   (:generator 45
 123     (multiple-value-bind (yep nope)
 124         (if not-p
 125             (values not-target target)
 126             (values target not-target))
 127       (assemble ()
 128         ;; Is it a fixnum?
 129         (inst and value fixnum-tag-mask temp1)
 130         (inst move value temp)
 131         (inst beq temp1 fixnum)
 132
 133         ;; If not, is it an other pointer?
 134         (inst and value lowtag-mask temp)
 135         (inst xor temp other-pointer-lowtag temp)
 136         (inst bne temp nope)
 137         ;; Get the header.
 138         (loadw temp value 0 other-pointer-lowtag)
 139         ;; Is it one?
 140         (inst li  (+ (ash 1 n-widetag-bits) bignum-widetag) temp1)
 141         (inst xor temp temp1 temp)
 142         (inst beq temp single-word)
 143         ;; If it's other than two, we can't be an (unsigned-byte 32)
 144         (inst li (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
 145                          (+ (ash 2 n-widetag-bits) bignum-widetag))
 146               temp1)
 147         (inst xor temp temp1 temp)
 148         (inst bne temp nope)
 149         ;; Get the second digit.
 150         (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 151         ;; All zeros, its an (unsigned-byte 32).
 152         (inst beq temp yep)
 153         (inst br zero-tn nope)
 154
 155         SINGLE-WORD
 156         ;; Get the single digit.
 157         (loadw temp value bignum-digits-offset other-pointer-lowtag)
 158
 159         ;; positive implies (unsigned-byte 32).
 160         FIXNUM
 161         (if not-p
 162             (inst blt temp target)
 163             (inst bge temp target))))
 164     NOT-TARGET))
 165 \f
 166 ;;;; List/symbol types:
 167 ;;;
 168 ;;; symbolp (or symbol (eq nil))
 169 ;;; consp (and list (not (eq nil)))
 170
 171 (define-vop (symbolp type-predicate)
 172   (:translate symbolp)
 173   (:temporary (:scs (non-descriptor-reg)) temp)
 174   (:generator 12
 175     (inst cmpeq value null-tn temp)
 176     (inst bne temp (if not-p drop-thru target))
 177     (test-type value target not-p (symbol-widetag) :temp temp)
 178     DROP-THRU))
 179
 180 (define-vop (consp type-predicate)
 181   (:translate consp)
 182   (:temporary (:scs (non-descriptor-reg)) temp)
 183   (:generator 8
 184     (inst cmpeq value null-tn temp)
 185     (inst bne temp (if not-p target drop-thru))
 186     (test-type value target not-p (list-pointer-lowtag) :temp temp)
 187     DROP-THRU))