src/compiler/mips/type-vops.lisp

   1 ;;;; type testing and checking VOPs for the MIPS 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 ;;; Test generation utilities.
  15 (defun %test-fixnum (value target not-p &key temp)
  16   (assemble ()
  17     (inst and temp value fixnum-tag-mask)
  18     (if not-p
  19         (inst bne temp target)
  20         (inst beq temp target))
  21     (inst nop)))
  22
  23 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
  24   (let ((drop-through (gen-label)))
  25     (assemble ()
  26       (inst and temp value fixnum-tag-mask)
  27       (inst beq temp (if not-p drop-through target)))
  28     (%test-headers value target not-p nil headers
  29                    :drop-through drop-through :temp temp)))
  30
  31 (defun %test-immediate (value target not-p immediate &key temp)
  32   (assemble ()
  33     (inst and temp value widetag-mask)
  34     (inst xor temp immediate)
  35     (if not-p
  36         (inst bne temp target)
  37         (inst beq temp target))
  38     (inst nop)))
  39
  40 (defun %test-lowtag (value target not-p lowtag &key temp)
  41   (assemble ()
  42     (inst and temp value lowtag-mask)
  43     (inst xor temp lowtag)
  44     (if not-p
  45         (inst bne temp target)
  46         (inst beq temp target))
  47     (inst nop)))
  48
  49 (defun %test-headers (value target not-p function-p headers
  50                       &key (drop-through (gen-label)) temp)
  51   (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
  52     (multiple-value-bind
  53         (when-true when-false)
  54         ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
  55         ;; we know it's true and when we know it's false respectively.
  56         (if not-p
  57             (values drop-through target)
  58             (values target drop-through))
  59       (assemble ()
  60         (%test-lowtag value when-false t lowtag :temp temp)
  61         (load-type temp value (- lowtag))
  62         (inst nop)
  63         (let ((delta 0))
  64           (do ((remaining headers (cdr remaining)))
  65               ((null remaining))
  66             (let ((header (car remaining))
  67                   (last (null (cdr remaining))))
  68               (cond
  69                ((atom header)
  70                 (inst subu temp (- header delta))
  71                 (setf delta header)
  72                 (if last
  73                     (if not-p
  74                         (inst bne temp target)
  75                         (inst beq temp target))
  76                     (inst beq temp when-true)))
  77                (t
  78                 (let ((start (car header))
  79                       (end (cdr header)))
  80                   (unless (= start bignum-widetag)
  81                     (inst subu temp (- start delta))
  82                     (setf delta start)
  83                     (inst bltz temp when-false))
  84                   (inst subu temp (- end delta))
  85                   (setf delta end)
  86                   (if last
  87                       (if not-p
  88                           (inst bgtz temp target)
  89                           (inst blez temp target))
  90                       (inst blez temp when-true))))))))
  91         (inst nop)
  92         (emit-label drop-through)))))
  93 \f
  94 ;;;; TYPE-VOPs for types that are more complex to test for than simple
  95 ;;;; LOWTAG and WIDETAG tests, but that are nevertheless important:
  96
  97 ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a
  98 ;;; bignum with exactly one digit.
  99 (defun signed-byte-32-test (value temp not-p target not-target)
 100   (multiple-value-bind
 101       (yep nope)
 102       (if not-p
 103           (values not-target target)
 104           (values target not-target))
 105     (assemble ()
 106       (inst and temp value fixnum-tag-mask)
 107       (inst beq temp yep)
 108       (inst and temp value lowtag-mask)
 109       (inst xor temp other-pointer-lowtag)
 110       (inst bne temp nope)
 111       (inst nop)
 112       (loadw temp value 0 other-pointer-lowtag)
 113       (inst xor temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 114       (if not-p
 115           (inst bne temp target)
 116           (inst beq temp target))
 117       (inst nop)))
 118   (values))
 119
 120 (define-vop (signed-byte-32-p type-predicate)
 121   (:translate signed-byte-32-p)
 122   (:generator 45
 123     (signed-byte-32-test value temp not-p target not-target)
 124     NOT-TARGET))
 125
 126 ;;; An (UNSIGNED-BYTE 32) can be represented with either a positive
 127 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
 128 ;;; exactly two digits and the second digit all zeros.
 129 (defun unsigned-byte-32-test (value temp not-p target not-target)
 130   (multiple-value-bind (yep nope)
 131                        (if not-p
 132                            (values not-target target)
 133                            (values target not-target))
 134     (assemble ()
 135       ;; Is it a fixnum?
 136       (inst and temp value fixnum-tag-mask)
 137       (inst beq temp fixnum)
 138       (move temp value t)
 139
 140       ;; If not, is it an other pointer?
 141       (inst and temp value lowtag-mask)
 142       (inst xor temp other-pointer-lowtag)
 143       (inst bne temp nope)
 144       (inst nop)
 145       ;; Get the header.
 146       (loadw temp value 0 other-pointer-lowtag)
 147       ;; Is it one?
 148       (inst xor temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 149       (inst beq temp single-word)
 150       ;; If it's other than two, we can't be an (unsigned-byte 32)
 151       (inst xor temp (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
 152                              (+ (ash 2 n-widetag-bits) bignum-widetag)))
 153       (inst bne temp nope)
 154       ;; Get the second digit.
 155       (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 156       ;; All zeros, its an (unsigned-byte 32).
 157       (inst beq temp yep)
 158       (inst nop)
 159       (inst b nope)
 160
 161       SINGLE-WORD
 162       ;; Get the single digit.
 163       (loadw temp value bignum-digits-offset other-pointer-lowtag)
 164
 165       ;; positive implies (unsigned-byte 32).
 166       FIXNUM
 167       (if not-p
 168           (inst bltz temp target)
 169           (inst bgez temp target))
 170       (inst nop)))
 171   (values))
 172
 173 (define-vop (unsigned-byte-32-p type-predicate)
 174   (:translate unsigned-byte-32-p)
 175   (:generator 45
 176     (unsigned-byte-32-test value temp not-p target not-target)
 177     NOT-TARGET))
 178
 179 ;;; Because of our LOWTAG representation, SYMBOLP and CONSP are
 180 ;;; slightly more complex:
 181 ;;;
 182 ;;; * SYMBOLP is true if the object has SYMBOL-WIDETAG or is EQ
 183 ;;; to NIL;
 184 ;;;
 185 ;;; * CONSP is true if the object has LIST-POINTER-LOWTAG and is not
 186 ;;; EQ to NIL.
 187 ;;;
 188 ;;; [ FIXME: This comment should not really be here, in the bowels of
 189 ;;; the MIPS type-vops, but where should it be?]
 190 (define-vop (symbolp type-predicate)
 191   (:translate symbolp)
 192   (:generator 12
 193     (inst beq value null-tn (if not-p drop-thru target))
 194     (test-type value target not-p (symbol-widetag) :temp temp)
 195     DROP-THRU))
 196
 197 (define-vop (consp type-predicate)
 198   (:translate consp)
 199   (:generator 8
 200     (inst beq value null-tn (if not-p target drop-thru))
 201     (test-type value target not-p (list-pointer-lowtag) :temp temp)
 202     DROP-THRU))