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
  94
  95 \f
  96 ;;; Type checking and testing (see also the use of !DEFINE-TYPE-VOPS
  97 ;;; in src/compiler/generic/late-type-vops.lisp):
  98 ;;;
  99 ;;; [FIXME: Like some of the other comments in this file, this one
 100 ;;; really belongs somewhere else]
 101 (define-vop (check-type)
 102   (:args (value :target result :scs (any-reg descriptor-reg)))
 103   (:results (result :scs (any-reg descriptor-reg)))
 104   (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
 105   (:vop-var vop)
 106   (:save-p :compute-only))
 107
 108 (define-vop (type-predicate)
 109   (:args (value :scs (any-reg descriptor-reg)))
 110   (:temporary (:scs (non-descriptor-reg)) temp)
 111   (:conditional)
 112   (:info target not-p)
 113   (:policy :fast-safe))
 114
 115 (defun cost-to-test-types (type-codes)
 116   (+ (* 2 (length type-codes))
 117      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 118
 119 (defmacro !define-type-vops (pred-name check-name ptype error-code
 120                              (&rest type-codes)
 121                              &key &allow-other-keys)
 122   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
 123     `(progn
 124        ,@(when pred-name
 125            `((define-vop (,pred-name type-predicate)
 126                (:translate ,pred-name)
 127                (:generator ,cost
 128                  (test-type value target not-p (,@type-codes)
 129                             :temp temp)))))
 130        ,@(when check-name
 131            `((define-vop (,check-name check-type)
 132                (:generator ,cost
 133                  (let ((err-lab
 134                         (generate-error-code vop ,error-code value)))
 135                    (test-type value err-lab t (,@type-codes)
 136                               :temp temp)
 137                    (move result value))))))
 138        ,@(when ptype
 139            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 140 \f
 141 ;;;; TYPE-VOPs for types that are more complex to test for than simple
 142 ;;;; LOWTAG and WIDETAG tests, but that are nevertheless important:
 143
 144 ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a
 145 ;;; bignum with exactly one digit.
 146 (defun signed-byte-32-test (value temp not-p target not-target)
 147   (multiple-value-bind
 148       (yep nope)
 149       (if not-p
 150           (values not-target target)
 151           (values target not-target))
 152     (assemble ()
 153       (inst and temp value fixnum-tag-mask)
 154       (inst beq temp yep)
 155       (inst and temp value lowtag-mask)
 156       (inst xor temp other-pointer-lowtag)
 157       (inst bne temp nope)
 158       (inst nop)
 159       (loadw temp value 0 other-pointer-lowtag)
 160       (inst xor temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 161       (if not-p
 162           (inst bne temp target)
 163           (inst beq temp target))
 164       (inst nop)))
 165   (values))
 166
 167 (define-vop (signed-byte-32-p type-predicate)
 168   (:translate signed-byte-32-p)
 169   (:generator 45
 170     (signed-byte-32-test value temp not-p target not-target)
 171     NOT-TARGET))
 172
 173 (define-vop (check-signed-byte-32 check-type)
 174   (:generator 45
 175     (let ((loose (generate-error-code vop object-not-signed-byte-32-error
 176                                       value)))
 177       (signed-byte-32-test value temp t loose okay))
 178     OKAY
 179     (move result value)))
 180
 181 ;;; An (UNSIGNED-BYTE 32) can be represented with either a positive
 182 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
 183 ;;; exactly two digits and the second digit all zeros.
 184 (defun unsigned-byte-32-test (value temp not-p target not-target)
 185   (multiple-value-bind (yep nope)
 186                        (if not-p
 187                            (values not-target target)
 188                            (values target not-target))
 189     (assemble ()
 190       ;; Is it a fixnum?
 191       (inst and temp value fixnum-tag-mask)
 192       (inst beq temp fixnum)
 193       (move temp value t)
 194
 195       ;; If not, is it an other pointer?
 196       (inst and temp value lowtag-mask)
 197       (inst xor temp other-pointer-lowtag)
 198       (inst bne temp nope)
 199       (inst nop)
 200       ;; Get the header.
 201       (loadw temp value 0 other-pointer-lowtag)
 202       ;; Is it one?
 203       (inst xor temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 204       (inst beq temp single-word)
 205       ;; If it's other than two, we can't be an (unsigned-byte 32)
 206       (inst xor temp (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
 207                              (+ (ash 2 n-widetag-bits) bignum-widetag)))
 208       (inst bne temp nope)
 209       ;; Get the second digit.
 210       (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 211       ;; All zeros, its an (unsigned-byte 32).
 212       (inst beq temp yep)
 213       (inst nop)
 214       (inst b nope)
 215
 216       SINGLE-WORD
 217       ;; Get the single digit.
 218       (loadw temp value bignum-digits-offset other-pointer-lowtag)
 219
 220       ;; positive implies (unsigned-byte 32).
 221       FIXNUM
 222       (if not-p
 223           (inst bltz temp target)
 224           (inst bgez temp target))
 225       (inst nop)))
 226   (values))
 227
 228 (define-vop (unsigned-byte-32-p type-predicate)
 229   (:translate unsigned-byte-32-p)
 230   (:generator 45
 231     (unsigned-byte-32-test value temp not-p target not-target)
 232     NOT-TARGET))
 233
 234 (define-vop (check-unsigned-byte-32 check-type)
 235   (:generator 45
 236     (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
 237                                       value)))
 238       (unsigned-byte-32-test value temp t loose okay))
 239     OKAY
 240     (move result value)))
 241
 242 ;;; Because of our LOWTAG representation, SYMBOLP and CONSP are
 243 ;;; slightly more complex:
 244 ;;;
 245 ;;; * SYMBOLP is true if the object has SYMBOL-HEADER-WIDETAG or is EQ
 246 ;;; to NIL;
 247 ;;;
 248 ;;; * CONSP is true if the object has LIST-POINTER-LOWTAG and is not
 249 ;;; EQ to NIL.
 250 ;;;
 251 ;;; [ FIXME: This comment should not really be here, in the bowels of
 252 ;;; the MIPS type-vops, but where should it be?]
 253 (define-vop (symbolp type-predicate)
 254   (:translate symbolp)
 255   (:generator 12
 256     (inst beq value null-tn (if not-p drop-thru target))
 257     (test-type value target not-p (symbol-header-widetag) :temp temp)
 258     DROP-THRU))
 259
 260 (define-vop (check-symbol check-type)
 261   (:generator 12
 262     (inst beq value null-tn drop-thru)
 263     (let ((error (generate-error-code vop object-not-symbol-error value)))
 264       (test-type value error t (symbol-header-widetag) :temp temp))
 265     DROP-THRU
 266     (move result value)))
 267
 268 (define-vop (consp type-predicate)
 269   (:translate consp)
 270   (:generator 8
 271     (inst beq value null-tn (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   (:generator 8
 277     (let ((error (generate-error-code vop object-not-cons-error value)))
 278       (inst beq value null-tn error)
 279       (test-type value error t (list-pointer-lowtag) :temp temp))
 280     (move result value)))