src/compiler/x86-64/type-vops.lisp

   1 ;;;; type testing and checking VOPs for the x86 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
  16 ;;; Emit the most compact form of the test immediate instruction,
  17 ;;; using an 8 bit test when the immediate is only 8 bits and the
  18 ;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
  19 ;;; control stack.
  20 (defun generate-fixnum-test (value)
  21   "zero flag set if VALUE is fixnum"
  22   (let ((offset (tn-offset value)))
  23     (cond ((and (sc-is value any-reg descriptor-reg)
  24                 (or (= offset eax-offset) (= offset ebx-offset)
  25                     (= offset ecx-offset) (= offset edx-offset)))
  26            (inst test (make-random-tn :kind :normal
  27                                       :sc (sc-or-lose 'byte-reg)
  28                                       :offset offset)
  29                  7))
  30           ((sc-is value control-stack)
  31            (inst test (make-ea :byte :base rbp-tn
  32                                :disp (- (* (1+ offset) n-word-bytes)))
  33                  7))
  34           (t
  35            (inst test value 7)))))
  36
  37 (defun %test-fixnum (value target not-p)
  38   (generate-fixnum-test value)
  39   (inst jmp (if not-p :nz :z) target))
  40
  41 (defun %test-fixnum-and-headers (value target not-p headers)
  42   (let ((drop-through (gen-label)))
  43     (generate-fixnum-test value)
  44     (inst jmp :z (if not-p drop-through target))
  45     (%test-headers value target not-p nil headers drop-through)))
  46
  47 (defun %test-immediate (value target not-p immediate)
  48   ;; Code a single instruction byte test if possible.
  49   (let ((offset (tn-offset value)))
  50     (cond ((and (sc-is value any-reg descriptor-reg)
  51                 (or (= offset rax-offset) (= offset rbx-offset)
  52                     (= offset rcx-offset) (= offset rdx-offset)))
  53            (inst cmp (make-random-tn :kind :normal
  54                                      :sc (sc-or-lose 'byte-reg)
  55                                      :offset offset)
  56                  immediate))
  57           (t
  58            (move rax-tn value)
  59            (inst cmp al-tn immediate))))
  60   (inst jmp (if not-p :ne :e) target))
  61
  62 (defun %test-lowtag (value target not-p lowtag &optional al-loaded)
  63   (unless al-loaded
  64     (move rax-tn value)
  65     (inst and al-tn lowtag-mask))
  66   (inst cmp al-tn lowtag)
  67   (inst jmp (if not-p :ne :e) target))
  68
  69 (defun %test-headers (value target not-p function-p headers
  70                             &optional (drop-through (gen-label)) al-loaded)
  71   (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
  72     (multiple-value-bind (equal less-or-equal when-true when-false)
  73         ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
  74         ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
  75         ;; it's true and when we know it's false respectively.
  76         (if not-p
  77             (values :ne :a drop-through target)
  78             (values :e :na target drop-through))
  79       (%test-lowtag value when-false t lowtag al-loaded)
  80       (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
  81       (do ((remaining headers (cdr remaining)))
  82           ((null remaining))
  83         (let ((header (car remaining))
  84               (last (null (cdr remaining))))
  85           (cond
  86            ((atom header)
  87             (inst cmp al-tn header)
  88             (if last
  89                 (inst jmp equal target)
  90                 (inst jmp :e when-true)))
  91            (t
  92              (let ((start (car header))
  93                    (end (cdr header)))
  94                (unless (= start bignum-widetag)
  95                  (inst cmp al-tn start)
  96                  (inst jmp :b when-false)) ; was :l
  97                (inst cmp al-tn end)
  98                (if last
  99                    (inst jmp less-or-equal target)
 100                    (inst jmp :be when-true))))))) ; was :le
 101       (emit-label drop-through))))
 102
 103 \f
 104 ;;;; type checking and testing
 105
 106 (define-vop (check-type)
 107   (:args (value :target result :scs (any-reg descriptor-reg)))
 108   (:results (result :scs (any-reg descriptor-reg)))
 109   (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
 110   (:ignore eax)
 111   (:vop-var vop)
 112   (:save-p :compute-only))
 113
 114 (define-vop (type-predicate)
 115   (:args (value :scs (any-reg descriptor-reg)))
 116   (:temporary (:sc unsigned-reg :offset eax-offset) eax)
 117   (:ignore eax)
 118   (:conditional)
 119   (:info target not-p)
 120   (:policy :fast-safe))
 121
 122 ;;; simpler VOP that don't need a temporary register
 123 (define-vop (simple-check-type)
 124   (:args (value :target result :scs (any-reg descriptor-reg)))
 125   (:results (result :scs (any-reg descriptor-reg)
 126                     :load-if (not (and (sc-is value any-reg descriptor-reg)
 127                                        (sc-is result control-stack)))))
 128   (:vop-var vop)
 129   (:save-p :compute-only))
 130
 131 (define-vop (simple-type-predicate)
 132   (:args (value :scs (any-reg descriptor-reg control-stack)))
 133   (:conditional)
 134   (:info target not-p)
 135   (:policy :fast-safe))
 136
 137 (defun cost-to-test-types (type-codes)
 138   (+ (* 2 (length type-codes))
 139      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 140
 141 (defmacro !define-type-vops (pred-name check-name ptype error-code
 142                              (&rest type-codes)
 143                              &key (variant nil variant-p) &allow-other-keys)
 144   ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the
 145   ;; expansion?
 146   (let* ((cost (cost-to-test-types (mapcar #'eval type-codes)))
 147          (prefix (if variant-p
 148                      (concatenate 'string (string variant) "-")
 149                      "")))
 150     `(progn
 151        ,@(when pred-name
 152            `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE")))
 153                (:translate ,pred-name)
 154                (:generator ,cost
 155                  (test-type value target not-p (,@type-codes))))))
 156        ,@(when check-name
 157            `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE")))
 158                (:generator ,cost
 159                  (let ((err-lab
 160                         (generate-error-code vop ,error-code value)))
 161                    (test-type value err-lab t (,@type-codes))
 162                    (move result value))))))
 163        ,@(when ptype
 164            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 165 \f
 166 ;;;; other integer ranges
 167
 168 (define-vop (fixnump/unsigned-byte-64 simple-type-predicate)
 169   (:args (value :scs (unsigned-reg)))
 170   (:arg-types unsigned-num)
 171   (:translate fixnump)
 172   (:temporary (:sc unsigned-reg) tmp)
 173   (:generator 5
 174     (inst mov tmp value)
 175     (inst shr tmp 61)
 176     (inst jmp (if not-p :nz :z) target)))
 177
 178 (define-vop (signed-byte-32-p type-predicate)
 179   (:translate signed-byte-32-p)
 180   (:generator 45
 181     ;; (and (fixnum) (no bits set >32))
 182     (move rax-tn value)
 183     (inst test rax-tn 7)
 184     (inst jmp :ne (if not-p target not-target))
 185     (inst sar rax-tn (+ 32 3))
 186     (inst jmp (if not-p :nz :z) target)
 187     NOT-TARGET))
 188
 189 (define-vop (check-signed-byte-32 check-type)
 190   (:generator 45
 191     (let ((nope (generate-error-code vop
 192                                      object-not-signed-byte-32-error
 193                                      value)))
 194       (move rax-tn value)
 195       (inst test rax-tn 7)
 196       (inst jmp :ne nope)
 197       (inst sar rax-tn (+ 32 3))
 198       (inst jmp :nz nope)
 199       (move result value))))
 200
 201
 202 (define-vop (unsigned-byte-32-p type-predicate)
 203   (:translate unsigned-byte-32-p)
 204   (:generator 45
 205     ;; (and (fixnum) (no bits set >31))
 206     (move rax-tn value)
 207     (inst test rax-tn 7)
 208     (inst jmp :ne (if not-p target not-target))
 209     (inst sar rax-tn (+ 32 3 -1))
 210     (inst jmp (if not-p :nz :z) target)
 211     NOT-TARGET))
 212
 213 (define-vop (check-unsigned-byte-32 check-type)
 214   (:generator 45
 215     (let ((nope
 216            (generate-error-code vop object-not-unsigned-byte-32-error value)))
 217       (move rax-tn value)
 218       (inst test rax-tn 7)
 219       (inst jmp :ne nope)
 220       (inst sar rax-tn (+ 32 3 -1))
 221       (inst jmp :nz nope)
 222       (move result value))))
 223 \f
 224 ;;;; list/symbol types
 225 ;;;
 226 ;;; symbolp (or symbol (eq nil))
 227 ;;; consp (and list (not (eq nil)))
 228
 229 (define-vop (symbolp type-predicate)
 230   (:translate symbolp)
 231   (:generator 12
 232     (let ((is-symbol-label (if not-p drop-thru target)))
 233       (inst cmp value nil-value)
 234       (inst jmp :e is-symbol-label)
 235       (test-type value target not-p (symbol-header-widetag)))
 236     DROP-THRU))
 237
 238 (define-vop (check-symbol check-type)
 239   (:generator 12
 240     (let ((error (generate-error-code vop object-not-symbol-error value)))
 241       (inst cmp value nil-value)
 242       (inst jmp :e drop-thru)
 243       (test-type value error t (symbol-header-widetag)))
 244     DROP-THRU
 245     (move result value)))
 246
 247 (define-vop (consp type-predicate)
 248   (:translate consp)
 249   (:generator 8
 250     (let ((is-not-cons-label (if not-p target drop-thru)))
 251       (inst cmp value nil-value)
 252       (inst jmp :e is-not-cons-label)
 253       (test-type value target not-p (list-pointer-lowtag)))
 254     DROP-THRU))
 255
 256 (define-vop (check-cons check-type)
 257   (:generator 8
 258     (let ((error (generate-error-code vop object-not-cons-error value)))
 259       (inst cmp value nil-value)
 260       (inst jmp :e error)
 261       (test-type value error t (list-pointer-lowtag))
 262       (move result value))))