src/compiler/hppa/type-vops.lisp

   1 ;;;; type testing and checking VOPs for the HPPA 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   (declare (ignore temp))
  17   (assemble ()
  18     (inst extru value 31 2 zero-tn (if not-p := :<>))
  19     (inst b target :nullify t)))
  20
  21 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
  22   (let ((drop-through (gen-label)))
  23     (assemble ()
  24       (inst extru value 31 2 zero-tn :<>)
  25       (inst b (if not-p drop-through target) :nullify t))
  26     (%test-headers value target not-p nil headers
  27                    :drop-through drop-through :temp temp)))
  28
  29 (defun %test-immediate (value target not-p immediate &key temp)
  30   (assemble ()
  31     (inst extru value 31 8 temp)
  32     (inst bci := not-p immediate temp target)))
  33
  34 (defun %test-lowtag (value target not-p lowtag &key temp temp-loaded)
  35   (assemble ()
  36     (unless temp-loaded
  37       (inst extru value 31 3 temp))
  38     (inst bci := not-p lowtag temp target)))
  39
  40 (defun %test-headers (value target not-p function-p headers
  41                       &key temp (drop-through (gen-label)) temp-loaded)
  42   (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
  43     (multiple-value-bind
  44         (equal greater-or-equal when-true when-false)
  45         ;; EQUAL and GREATER-OR-EQUAL are the conditions for branching to
  46         ;; TARGET.  WHEN-TRUE and WHEN-FALSE are the labels to branch to when
  47         ;; we know it's true and when we know it's false respectively.
  48         (if not-p
  49             (values :<> :< drop-through target)
  50             (values := :>= target drop-through))
  51       (assemble ()
  52         (%test-lowtag value when-false t lowtag
  53                       :temp temp :temp-loaded temp-loaded)
  54         (inst ldb (- 3 lowtag) value temp)
  55         (do ((remaining headers (cdr remaining)))
  56             ((null remaining))
  57           (let ((header (car remaining))
  58                 (last (null (cdr remaining))))
  59             (cond
  60              ((atom header)
  61               (if last
  62                   (inst bci equal nil header temp target)
  63                   (inst bci := nil header temp when-true)))
  64              (t
  65               (let ((start (car header))
  66                     (end (cdr header)))
  67                 (unless (= start bignum-widetag)
  68                   (inst bci :> nil start temp when-false))
  69                 (if last
  70                     (inst bci greater-or-equal nil end temp target)
  71                     (inst bci :>= nil end temp when-true)))))))
  72         (emit-label drop-through)))))
  73 \f
  74 ;;;; Type checking and testing:
  75
  76 (define-vop (check-type)
  77   (:args (value :target result :scs (any-reg descriptor-reg)))
  78   (:results (result :scs (any-reg descriptor-reg)))
  79   (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
  80   (:vop-var vop)
  81   (:save-p :compute-only))
  82
  83 (define-vop (type-predicate)
  84   (:args (value :scs (any-reg descriptor-reg)))
  85   (:temporary (:scs (non-descriptor-reg)) temp)
  86   (:conditional)
  87   (:info target not-p)
  88   (:policy :fast-safe))
  89
  90 (defun cost-to-test-types (type-codes)
  91   (+ (* 2 (length type-codes))
  92      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
  93
  94 (defmacro !define-type-vops (pred-name check-name ptype error-code
  95                              (&rest type-codes)
  96                              &key &allow-other-keys)
  97   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
  98     `(progn
  99        ,@(when pred-name
 100            `((define-vop (,pred-name type-predicate)
 101                (:translate ,pred-name)
 102                (:generator ,cost
 103                  (test-type value target not-p (,@type-codes) :temp temp)))))
 104        ,@(when check-name
 105            `((define-vop (,check-name check-type)
 106                (:generator ,cost
 107                  (let ((err-lab
 108                         (generate-error-code vop ,error-code value)))
 109                    (test-type value err-lab t (,@type-codes) :temp temp)
 110                    (move value result))))))
 111        ,@(when ptype
 112            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 113 \f
 114 ;;;; Other integer ranges.
 115
 116 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
 117 ;;; exactly one digit.
 118 (defun signed-byte-32-test (value temp not-p target not-target)
 119   (multiple-value-bind
 120       (yep nope)
 121       (if not-p
 122           (values not-target target)
 123           (values target not-target))
 124     (assemble ()
 125       (inst extru value 31 2 zero-tn :<>)
 126       (inst b yep :nullify t)
 127       (inst extru value 31 3 temp)
 128       (inst bci :<> nil other-pointer-lowtag temp nope)
 129       (loadw temp value 0 other-pointer-lowtag)
 130       (inst bci := not-p (+ (ash 1 n-widetag-bits) bignum-widetag) temp target)))
 131   (values))
 132
 133 (define-vop (signed-byte-32-p type-predicate)
 134   (:translate signed-byte-32-p)
 135   (:generator 45
 136     (signed-byte-32-test value temp not-p target not-target)
 137     NOT-TARGET))
 138
 139 (define-vop (check-signed-byte-32 check-type)
 140   (:generator 45
 141     (let ((loose (generate-error-code vop object-not-signed-byte-32-error
 142                                       value)))
 143       (signed-byte-32-test value temp t loose okay))
 144     OKAY
 145     (move value result)))
 146
 147 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 148 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 149 ;;; and the second digit all zeros.
 150 (defun unsigned-byte-32-test (value temp not-p target not-target)
 151   (let ((nope (if not-p target not-target)))
 152     (assemble ()
 153       ;; Is it a fixnum?
 154       (inst extru value 31 2 zero-tn :<>)
 155       (inst b fixnum)
 156       (move value temp t)
 157
 158       ;; If not, is it an other pointer?
 159       (inst extru value 31 3 temp)
 160       (inst bci :<> nil other-pointer-lowtag temp nope)
 161       ;; Get the header.
 162       (loadw temp value 0 other-pointer-lowtag)
 163       ;; Is it one?
 164       (inst bci := nil (+ (ash 1 n-widetag-bits) bignum-widetag) temp single-word)
 165       ;; If it's other than two, we can't be an (unsigned-byte 32)
 166       (inst bci :<> nil (+ (ash 2 n-widetag-bits) bignum-widetag) temp nope)
 167       ;; Get the second digit.
 168       (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 169       ;; All zeros, its an (unsigned-byte 32).
 170       ;; Dont nullify comb here, because we cant guarantee target is forward
 171       (inst comb (if not-p := :<>) temp zero-tn not-target)
 172       (inst nop)
 173       (inst b target)
 174
 175       SINGLE-WORD
 176       ;; Get the single digit.
 177       (loadw temp value bignum-digits-offset other-pointer-lowtag)
 178
 179       ;; positive implies (unsigned-byte 32).
 180       FIXNUM
 181       (inst bc :>= not-p temp zero-tn target)))
 182   (values))
 183
 184 (define-vop (unsigned-byte-32-p type-predicate)
 185   (:translate unsigned-byte-32-p)
 186   (:generator 45
 187     (unsigned-byte-32-test value temp not-p target not-target)
 188     NOT-TARGET))
 189
 190 (define-vop (check-unsigned-byte-32 check-type)
 191   (:generator 45
 192     (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
 193                                       value)))
 194       (unsigned-byte-32-test value temp t loose okay))
 195     OKAY
 196     (move value result)))
 197
 198 \f
 199 ;;;; List/symbol types:
 200 ;;;
 201 ;;; symbolp (or symbol (eq nil))
 202 ;;; consp (and list (not (eq nil)))
 203
 204 (define-vop (symbolp type-predicate)
 205   (:translate symbolp)
 206   (:generator 12
 207     (inst bc := nil value null-tn (if not-p drop-thru target))
 208     (test-type value target not-p (symbol-header-widetag) :temp temp)
 209     DROP-THRU))
 210
 211 (define-vop (check-symbol check-type)
 212   (:generator 12
 213     (inst comb := value null-tn drop-thru)
 214     (let ((error (generate-error-code vop object-not-symbol-error value)))
 215       (test-type value error t (symbol-header-widetag) :temp temp))
 216     DROP-THRU
 217     (move value result)))
 218
 219 (define-vop (consp type-predicate)
 220   (:translate consp)
 221   (:generator 8
 222     (inst bc := nil value null-tn (if not-p target drop-thru))
 223     (test-type value target not-p (list-pointer-lowtag) :temp temp)
 224     DROP-THRU))
 225
 226 (define-vop (check-cons check-type)
 227   (:generator 8
 228     (let ((error (generate-error-code vop object-not-cons-error value)))
 229       (inst bc := nil value null-tn error)
 230       (test-type value error t (list-pointer-lowtag) :temp temp))
 231     (move value result)))
 232