src/compiler/arm/type-vops.lisp

   1 ;;;; type testing and checking VOPs for the ARM 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   (declare (ignore temp))
  16   (assemble ()
  17     (inst tst value fixnum-tag-mask)
  18     (inst b (if not-p :ne :eq) target)))
  19
  20 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
  21   (let ((drop-through (gen-label)))
  22     (assemble ()
  23       (inst ands temp value fixnum-tag-mask)
  24       (inst b :eq (if not-p drop-through target)))
  25     (%test-headers value target not-p nil headers
  26                    :drop-through drop-through :temp temp)))
  27
  28 (defun %test-immediate (value target not-p immediate &key temp)
  29   (assemble ()
  30     (inst and temp value widetag-mask)
  31     (inst cmp temp immediate)
  32     (inst b (if not-p :ne :eq) target)))
  33
  34 (defun %test-lowtag (value target not-p lowtag &key temp)
  35   (assemble ()
  36     (inst and temp value lowtag-mask)
  37     (inst cmp temp lowtag)
  38     (inst b (if not-p :ne :eq) target)))
  39
  40 (defun %test-headers (value target not-p function-p headers
  41                       &key temp (drop-through (gen-label)))
  42     (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
  43     (multiple-value-bind (when-true when-false)
  44         (if not-p
  45             (values drop-through target)
  46             (values target drop-through))
  47       (assemble ()
  48         (%test-lowtag value when-false t lowtag :temp temp)
  49         (load-type temp value (- lowtag))
  50         (do ((remaining headers (cdr remaining)))
  51             ((null remaining))
  52           (let ((header (car remaining))
  53                 (last (null (cdr remaining))))
  54             (cond
  55               ((atom header)
  56                (cond
  57                  ((and (not last) (null (cddr remaining))
  58                        (atom (cadr remaining))
  59                        (= (logcount (logxor header (cadr remaining))) 1))
  60                   (inst and temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
  61                   (inst cmp temp (ldb (byte 8 0) (logand header (cadr remaining))))
  62                   (inst b (if not-p :ne :eq) target)
  63                   (return))
  64                  (t
  65                   (inst cmp temp header)
  66                   (if last
  67                       (inst b (if not-p :ne :eq) target)
  68                       (inst b :eq when-true)))))
  69               (t
  70                (let ((start (car header))
  71                      (end (cdr header)))
  72                  (cond
  73                    ((and last (not (= start bignum-widetag))
  74                          (= (+ start 4) end)
  75                          (= (logcount (logxor start end)) 1))
  76                     (inst and temp temp (ldb (byte 8 0) (logeqv start end)))
  77                     (inst cmp temp (ldb (byte 8 0) (logand start end)))
  78                     (inst b (if not-p :ne :eq) target))
  79                    ((and (not last) (null (cddr remaining))
  80                          (= (+ start 4) end) (= (logcount (logxor start end)) 1)
  81                          (listp (cadr remaining))
  82                          (= (+ (caadr remaining) 4) (cdadr remaining))
  83                          (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
  84                          (= (logcount (logxor (caadr remaining) start)) 1))
  85                     (inst and temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
  86                     (inst cmp temp (ldb (byte 8 0) (logand start (cdadr remaining))))
  87                     (inst b (if not-p :ne :eq) target)
  88                     (return))
  89                    (t
  90                     (unless (= start bignum-widetag)
  91                       (inst cmp temp start)
  92                       (if (= end complex-array-widetag)
  93                           (progn
  94                             (aver last)
  95                             (inst b (if not-p :lt :ge) target))
  96                           (inst b :lt when-false)))
  97                     (unless (= end complex-array-widetag)
  98                       (inst cmp temp end)
  99                       (if last
 100                           (inst b (if not-p :gt :le) target)
 101                           (inst b :le when-true))))))))))
 102         (emit-label drop-through)))))
 103 \f
 104 ;;;; Other integer ranges.
 105
 106 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
 107 ;;; exactly one digit.
 108 (defun signed-byte-32-test (value temp not-p target not-target)
 109   (multiple-value-bind
 110         (yep nope)
 111       (if not-p
 112           (values not-target target)
 113           (values target not-target))
 114     (assemble ()
 115       (inst ands temp value fixnum-tag-mask)
 116       (inst b :eq yep)
 117       (test-type value nope t (other-pointer-lowtag) :temp temp)
 118       (loadw temp value 0 other-pointer-lowtag)
 119       ;; (+ (ash 1 n-widetag-bits) bignum-widetag) does not fit into a single immediate
 120       (inst eor temp temp (ash 1 n-widetag-bits))
 121       (inst eors temp temp bignum-widetag)
 122       (inst b (if not-p :ne :eq) target)))
 123   (values))
 124
 125 (define-vop (signed-byte-32-p type-predicate)
 126   (:translate signed-byte-32-p)
 127   (:generator 45
 128    (let ((not-target (gen-label)))
 129      (signed-byte-32-test value temp not-p target not-target)
 130      (emit-label not-target))))
 131
 132 ;;; An (UNSIGNED-BYTE 32) can be represented with either a positive
 133 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
 134 ;;; exactly two digits and the second digit all zeros.
 135 (defun unsigned-byte-32-test (value temp not-p target not-target)
 136   (let ((single-word (gen-label))
 137         (fixnum (gen-label)))
 138     (multiple-value-bind (yep nope)
 139         (if not-p
 140             (values not-target target)
 141             (values target not-target))
 142       (assemble ()
 143         ;; Is it a fixnum?
 144         (move temp value)
 145         (%test-fixnum temp fixnum nil)
 146
 147         ;; If not, is it an other pointer?
 148         (test-type value nope t (other-pointer-lowtag) :temp temp)
 149         ;; Get the header.
 150         (loadw temp value 0 other-pointer-lowtag)
 151         ;; Is it one?
 152         ;; (+ (ash 1 n-widetag-bits) bignum-widetag) does not fit into a single immediate
 153         (inst eor temp temp (ash 1 n-widetag-bits))
 154         (inst eors temp temp bignum-widetag)
 155         (inst b :eq single-word)
 156         ;; If it's other than two, we can't be an (unsigned-byte 32)
 157         (inst eors temp temp (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
 158                                      (+ (ash 2 n-widetag-bits) bignum-widetag)))
 159         (inst b :ne nope)
 160         ;; Get the second digit.
 161         (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 162         ;; All zeros, its an (unsigned-byte 32).
 163         (inst cmp temp 0)
 164         (inst b :eq yep)
 165         (inst b nope)
 166
 167         (emit-label single-word)
 168         ;; Get the single digit.
 169         (loadw temp value bignum-digits-offset other-pointer-lowtag)
 170
 171         ;; positive implies (unsigned-byte 32).
 172         (emit-label fixnum)
 173         (inst cmp temp 0)
 174         (if not-p
 175             (inst b :lt target)
 176             (inst b :ge target))))
 177     (values)))
 178
 179 (define-vop (unsigned-byte-32-p type-predicate)
 180   (:translate unsigned-byte-32-p)
 181   (:generator 45
 182    (let ((not-target (gen-label)))
 183      (unsigned-byte-32-test value temp not-p target not-target)
 184      (emit-label not-target))))
 185
 186 \f
 187 ;;; MOD type checks
 188 (defun power-of-two-limit-p (x)
 189   (and (fixnump x)
 190        (= (logcount (1+ x)) 1)
 191        ;; Immediate encodable
 192        (> x (expt 2 23))))
 193
 194 (define-vop (test-fixnum-mod-power-of-two)
 195   (:args (value :scs (any-reg descriptor-reg
 196                               unsigned-reg signed-reg
 197                               immediate)))
 198   (:arg-types *
 199               (:constant (satisfies power-of-two-limit-p)))
 200   (:translate fixnum-mod-p)
 201   (:conditional :eq)
 202   (:info hi)
 203   (:save-p :compute-only)
 204   (:policy :fast-safe)
 205   (:generator 2
 206      (aver (not (sc-is value immediate)))
 207      (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
 208                            hi
 209                            (fixnumize hi))))
 210        (inst tst value (lognot fixnum-hi)))))
 211
 212 (define-vop (test-fixnum-mod-tagged-unsigned-imm)
 213   (:args (value :scs (any-reg descriptor-reg
 214                               unsigned-reg signed-reg
 215                               immediate)))
 216   (:arg-types (:or tagged-num unsigned-num signed-num)
 217               (:constant (satisfies encodable-immediate)))
 218   (:translate fixnum-mod-p)
 219   (:conditional :ls)
 220   (:info hi)
 221   (:save-p :compute-only)
 222   (:policy :fast-safe)
 223   (:generator 3
 224      (aver (not (sc-is value immediate)))
 225      (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
 226                           hi
 227                           (fixnumize hi))))
 228        (inst cmp value fixnum-hi))))
 229
 230 (defun encodable-immediate+1 (x)
 231   (encodable-immediate (1+ x)))
 232
 233 ;;; Adding 1 and changing the codntions from <= to < allows to encode
 234 ;;; more immediates.
 235 (define-vop (test-fixnum-mod-tagged-unsigned-imm+1)
 236   (:args (value :scs (any-reg descriptor-reg
 237                               unsigned-reg signed-reg
 238                               immediate)))
 239   (:arg-types (:or tagged-num unsigned-num signed-num)
 240               (:constant (satisfies encodable-immediate+1)))
 241   (:translate fixnum-mod-p)
 242   (:conditional :cc)
 243   (:info hi)
 244   (:save-p :compute-only)
 245   (:policy :fast-safe)
 246   (:generator 3
 247      (aver (not (sc-is value immediate)))
 248      (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
 249                           (1+ hi)
 250                           (fixnumize (1+ hi)))))
 251        (inst cmp value fixnum-hi))))
 252
 253 (define-vop (test-fixnum-mod-tagged-unsigned)
 254   (:args (value :scs (any-reg descriptor-reg
 255                               unsigned-reg signed-reg
 256                               immediate)))
 257   (:arg-types (:or tagged-num unsigned-num signed-num)
 258               (:constant fixnum))
 259   (:temporary (:scs (non-descriptor-reg)) temp)
 260   (:translate fixnum-mod-p)
 261   (:conditional :ls)
 262   (:info hi)
 263   (:save-p :compute-only)
 264   (:policy :fast-safe)
 265   (:generator 4
 266      (aver (not (sc-is value immediate)))
 267      (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg)
 268                           hi
 269                           (fixnumize hi))))
 270        (load-immediate-word temp fixnum-hi)
 271        (inst cmp value temp))))
 272
 273 (defun encodable-immediate/+1 (x)
 274   (or (encodable-immediate x)
 275       (encodable-immediate (1+ x))))
 276
 277 (define-vop (test-fixnum-mod-*-imm)
 278   (:args (value :scs (any-reg descriptor-reg)))
 279   (:arg-types * (:constant (satisfies encodable-immediate/+1)))
 280   (:translate fixnum-mod-p)
 281   (:conditional)
 282   (:info target not-p hi)
 283   (:save-p :compute-only)
 284   (:policy :fast-safe)
 285   (:generator 5
 286     (let* ((1+ (not (encodable-immediate hi)))
 287            (fixnum-hi (fixnumize (if 1+
 288                                      (1+ hi)
 289                                      hi)))
 290            (skip (gen-label)))
 291       (inst tst value fixnum-tag-mask)
 292       (inst b :ne (if not-p target skip))
 293       (inst cmp value fixnum-hi)
 294       (inst b (if not-p
 295                   (if 1+ :cs :hi)
 296                   (if 1+ :cc :ls))
 297             target)
 298       (emit-label SKIP))))
 299
 300 (define-vop (test-fixnum-mod-*)
 301   (:args (value :scs (any-reg descriptor-reg)))
 302   (:arg-types * (:constant fixnum))
 303   (:translate fixnum-mod-p)
 304   (:temporary (:scs (any-reg)) temp)
 305   (:conditional)
 306   (:info target not-p hi)
 307   (:save-p :compute-only)
 308   (:policy :fast-safe)
 309   (:generator 6
 310     (inst tst value fixnum-tag-mask)
 311     (inst b :ne (if not-p target skip))
 312     (let ((condition (if not-p :hi :ls)))
 313       (load-immediate-word temp (fixnumize hi))
 314       (inst cmp value temp)
 315       (inst b condition target))
 316     SKIP))
 317
 318 ;;;; List/symbol types:
 319 ;;;
 320 ;;; symbolp (or symbol (eq nil))
 321 ;;; consp (and list (not (eq nil)))
 322
 323 (define-vop (symbolp type-predicate)
 324   (:translate symbolp)
 325   (:generator 12
 326     (let* ((drop-thru (gen-label))
 327            (is-symbol-label (if not-p drop-thru target)))
 328       (inst cmp value null-tn)
 329       (inst b :eq is-symbol-label)
 330       (test-type value target not-p (symbol-widetag) :temp temp)
 331       (emit-label drop-thru))))
 332
 333 (define-vop (consp type-predicate)
 334   (:translate consp)
 335   (:generator 8
 336     (let* ((drop-thru (gen-label))
 337            (is-not-cons-label (if not-p target drop-thru)))
 338       (inst cmp value null-tn)
 339       (inst b :eq is-not-cons-label)
 340       (test-type value target not-p (list-pointer-lowtag) :temp temp)
 341       (emit-label drop-thru))))