src/compiler/generic/late-type-vops.lisp

   1 ;;;; generic type testing and checking VOPs
   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 (in-package "SB!VM")
  12 \f
  13
  14 (define-vop (type-predicate)
  15   (:args (value :scs (any-reg descriptor-reg)))
  16   (:temporary #!+(or x86 x86-64)
  17               (:sc unsigned-reg :offset eax-offset)
  18               #!-(or x86 x86-64)
  19               (:sc non-descriptor-reg)
  20               temp)
  21   #!+(or x86 x86-64)
  22   (:ignore temp)
  23   (:conditional)
  24   (:info target not-p)
  25   (:policy :fast-safe))
  26
  27 #!+(or x86 x86-64)
  28 (define-vop (simple-type-predicate)
  29   (:args (value :scs (any-reg descriptor-reg control-stack)))
  30   (:conditional)
  31   (:info target not-p)
  32   (:policy :fast-safe))
  33
  34 (defmacro !define-type-vop (pred-name type-codes
  35                              &optional (inherit 'type-predicate))
  36   (let ((cost (+ (* 2 (length type-codes))
  37                  (if (> (reduce #'max type-codes :key #'eval) lowtag-limit)
  38                      7
  39                      2))))
  40     `(define-vop (,pred-name ,inherit)
  41        (:translate ,pred-name)
  42        (:generator ,cost
  43          (test-type value target not-p ,type-codes
  44                     #!-(or x86-64 x86) :temp #!-(or x86-64 x86) temp)))))
  45
  46 (!define-type-vop fixnump
  47   #.fixnum-lowtags
  48   #!+(or x86-64 x86) simple-type-predicate) ;; save a register
  49
  50 (!define-type-vop functionp (fun-pointer-lowtag))
  51
  52 (!define-type-vop listp (list-pointer-lowtag))
  53
  54 (!define-type-vop %instancep (instance-pointer-lowtag))
  55
  56 (!define-type-vop %other-pointer-p (other-pointer-lowtag))
  57
  58 (!define-type-vop bignump (bignum-widetag))
  59
  60 (!define-type-vop ratiop (ratio-widetag))
  61
  62 (!define-type-vop complexp
  63   (complex-widetag complex-single-float-widetag complex-double-float-widetag
  64                    #!+long-float complex-long-float-widetag))
  65
  66 (!define-type-vop complex-rational-p (complex-widetag))
  67
  68 (!define-type-vop complex-float-p
  69   (complex-single-float-widetag complex-double-float-widetag
  70                                 #!+long-float complex-long-float-widetag))
  71
  72 (!define-type-vop complex-single-float-p (complex-single-float-widetag))
  73
  74 (!define-type-vop complex-double-float-p (complex-double-float-widetag))
  75
  76 (!define-type-vop single-float-p (single-float-widetag))
  77
  78 (!define-type-vop double-float-p (double-float-widetag))
  79
  80 (!define-type-vop simple-string-p
  81   (#!+sb-unicode simple-character-string-widetag
  82    simple-base-string-widetag simple-array-nil-widetag))
  83
  84 (macrolet
  85     ((define-simple-array-type-vops ()
  86          `(progn
  87            ,@(map 'list
  88                   (lambda (saetp)
  89                     (let ((primtype (saetp-primitive-type-name saetp)))
  90                     `(!define-type-vop
  91                       ,(symbolicate primtype "-P")
  92                       (,(saetp-typecode saetp)))))
  93                   *specialized-array-element-type-properties*))))
  94   (define-simple-array-type-vops))
  95
  96 (macrolet
  97     ((def ()
  98        `(!define-type-vop simple-rank-1-array-*-p
  99          ,(map 'list #'saetp-typecode
 100                *specialized-array-element-type-properties*))))
 101   (def)) ; simple-rank-1-array-*-p
 102
 103 (!define-type-vop characterp (character-widetag))
 104
 105 (!define-type-vop system-area-pointer-p (sap-widetag))
 106
 107 (!define-type-vop weak-pointer-p (weak-pointer-widetag))
 108
 109 (!define-type-vop code-component-p (code-header-widetag))
 110
 111 #!-(or x86 x86-64) (!define-type-vop lra-p (return-pc-widetag))
 112
 113 (!define-type-vop fdefn-p (fdefn-widetag))
 114
 115 (!define-type-vop closurep (closure-widetag))
 116
 117 (!define-type-vop simple-fun-p (simple-fun-widetag))
 118
 119 (!define-type-vop funcallable-instance-p (funcallable-instance-widetag))
 120
 121 (!define-type-vop array-header-p
 122   (simple-array-widetag
 123    #!+sb-unicode complex-character-string-widetag
 124    complex-base-string-widetag complex-bit-vector-widetag
 125    complex-vector-widetag complex-array-widetag complex-vector-nil-widetag))
 126
 127 (!define-type-vop stringp
 128   (#!+sb-unicode simple-character-string-widetag
 129    #!+sb-unicode complex-character-string-widetag
 130    simple-base-string-widetag complex-base-string-widetag
 131    simple-array-nil-widetag complex-vector-nil-widetag))
 132
 133 (!define-type-vop base-string-p
 134   (simple-base-string-widetag complex-base-string-widetag))
 135
 136 (!define-type-vop bit-vector-p
 137   (simple-bit-vector-widetag complex-bit-vector-widetag))
 138
 139 (!define-type-vop vector-nil-p
 140   (simple-array-nil-widetag complex-vector-nil-widetag))
 141
 142 #!+sb-unicode
 143 (!define-type-vop character-string-p
 144   (simple-character-string-widetag complex-character-string-widetag))
 145
 146 (!define-type-vop vectorp
 147   (complex-vector-widetag .
 148    #.(append
 149       (map 'list
 150            #'saetp-typecode
 151            *specialized-array-element-type-properties*)
 152       (mapcan (lambda (saetp)
 153                 (when (saetp-complex-typecode saetp)
 154                   (list (saetp-complex-typecode saetp))))
 155               (coerce *specialized-array-element-type-properties* 'list)))))
 156
 157 ;;; Note that this "type VOP" is sort of an oddball; it doesn't so
 158 ;;; much test for a Lisp-level type as just expose a low-level type
 159 ;;; code at the Lisp level. It is used as a building block to help us
 160 ;;; to express things like the test for (TYPEP FOO '(VECTOR T))
 161 ;;; efficiently in Lisp code, but it doesn't correspond to any type
 162 ;;; expression which would actually occur in reasonable application
 163 ;;; code. (Common Lisp doesn't have any natural way of expressing this
 164 ;;; type.) Thus, there's no point in building up the full machinery of
 165 ;;; associated backend type predicates and so forth as we do for
 166 ;;; ordinary type VOPs.
 167 (!define-type-vop complex-vector-p (complex-vector-widetag))
 168
 169 (!define-type-vop simple-array-p
 170   (simple-array-widetag .
 171    #.(map 'list
 172           #'saetp-typecode
 173           *specialized-array-element-type-properties*)))
 174
 175 (!define-type-vop arrayp
 176   (simple-array-widetag
 177    complex-array-widetag
 178    complex-vector-widetag .
 179    #.(append
 180       (map 'list
 181            #'saetp-typecode
 182            *specialized-array-element-type-properties*)
 183       (mapcan (lambda (saetp)
 184                 (when (saetp-complex-typecode saetp)
 185                   (list (saetp-complex-typecode saetp))))
 186               (coerce *specialized-array-element-type-properties* 'list)))))
 187
 188 (!define-type-vop numberp
 189   (bignum-widetag
 190    ratio-widetag
 191    single-float-widetag
 192    double-float-widetag
 193    #!+long-float long-float-widetag
 194    complex-widetag
 195    complex-single-float-widetag
 196    complex-double-float-widetag
 197    #!+long-float complex-long-float-widetag
 198    . #.fixnum-lowtags))
 199
 200 (!define-type-vop rationalp
 201   (ratio-widetag bignum-widetag . #.fixnum-lowtags))
 202
 203 (!define-type-vop integerp
 204   (bignum-widetag . #.fixnum-lowtags))
 205
 206 (!define-type-vop floatp
 207   (single-float-widetag double-float-widetag #!+long-float long-float-widetag))
 208
 209 (!define-type-vop realp
 210   (ratio-widetag
 211    bignum-widetag
 212    single-float-widetag
 213    double-float-widetag
 214    #!+long-float long-float-widetag
 215    . #.fixnum-lowtags))
 216
 217 #!+sb-simd-pack
 218 (!define-type-vop simd-pack-p (simd-pack-widetag))
 219
 220 (!define-type-vop unbound-marker-p (unbound-marker-widetag))