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