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