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

   1 ;;;; generic type testing and checking apparatus
   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 (defparameter *immediate-types*
  14   (list unbound-marker-widetag character-widetag
  15         #!+64-bit single-float-widetag))
  16
  17 (defparameter *fun-header-widetags*
  18   (list funcallable-instance-header-widetag
  19         simple-fun-header-widetag
  20         closure-header-widetag))
  21
  22 ;; Given a list of widetags in HEADERS, compress into a minimal list of ranges
  23 ;; and/or singletons that should be tested.
  24 ;; FIXME: At present the "is it effectively a one-sided test" is re-implemented
  25 ;;        in an ad-hoc way by each backend. The range convention should be
  26 ;;        changed to indicate explicitly when either limit needn't be checked.
  27 ;;        (Use NIL or * as a bound perhaps)
  28 (defun canonicalize-headers (headers)
  29   (collect ((results))
  30     (let ((start nil)
  31           (prev nil)
  32           (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
  33       (flet ((emit-test ()
  34                (results (if (= start prev)
  35                             start
  36                             (cons start prev)))))
  37         ;; COPY-LIST because the argument may come from immutable source code
  38         (dolist (header (sort (copy-list headers) #'<))
  39           (cond ((null start)
  40                  (setf start header)
  41                  (setf prev header))
  42                 ((= header (+ prev delta))
  43                  (setf prev header))
  44                 (t
  45                  (emit-test)
  46                  (setf start header)
  47                  (setf prev header))))
  48         (emit-test)))
  49     (results)))
  50
  51 ;; If WIDETAGS is comprised of two ranges that are nearly adjacent,
  52 ;; return a single range spanning both original ranges,
  53 ;; and as a second value the widetag(s) to exclude;
  54 ;; or return the unmodified ranges and NIL.
  55 ;; This could be generalized: three ranges that collapse to one with at most
  56 ;; two exceptions, or three collapsing to two with one exception, etc.
  57 (defun canonicalize-headers-and-exceptions (widetags)
  58   (let ((ranges (canonicalize-headers widetags)))
  59     (if (and (cdr ranges) (endp (cddr ranges))
  60              (listp (car ranges)) (listp (cadr ranges)) ; 2 ranges
  61              (let ((end-range-1 (cdar ranges))
  62                    (start-range-2 (caadr ranges)))
  63                (= start-range-2 (+ end-range-1 8))))
  64         ;; Return ((start-range-1 . end-range-2))
  65         (values (list (cons (caar ranges) (cdadr ranges)))
  66                 (list (+ (cdar ranges) 4))) ; the excluded value
  67         (values ranges nil))))
  68
  69 (defmacro test-type (value target not-p
  70                      (&rest type-codes)
  71                      &rest other-args
  72                      &key &allow-other-keys)
  73   ;; Determine what interesting combinations we need to test for.
  74   (let* ((type-codes (mapcar #'eval type-codes))
  75          (fixnump (and (every (lambda (lowtag)
  76                                 (member lowtag type-codes))
  77                               '#.(mapcar #'symbol-value fixnum-lowtags))
  78                        t))
  79          (lowtags (remove lowtag-limit type-codes :test #'<))
  80          (extended (remove lowtag-limit type-codes :test #'>))
  81          (immediates (intersection extended *immediate-types* :test #'eql))
  82          ;; To collapse the range of widetags comprising real numbers on 64-bit
  83          ;; machines, consider SHORT-FLOAT-WIDETAG both a header and immediate.
  84          ;; No OTHER-POINTER-LOWTAG object can ever have that header tag.
  85          ;; But only do so if there would otherwise be a discontinuity
  86          ;; in the set of headers.
  87          ;; Another approach would have been to flip DOUBLE- and SINGLE- float,
  88          ;; but that would not help NUMBERP, only REALP. Putting SINGLE-
  89          ;; after the complex widetags would work but harm 32-bit machines.
  90          (headers (set-difference
  91                    extended
  92                    (if (and (= n-word-bits 64)
  93                             (member (- single-float-widetag 4) extended)
  94                             (member (+ single-float-widetag 4) extended))
  95                        (remove single-float-widetag *immediate-types*)
  96                        *immediate-types*)
  97                    :test #'eql))
  98          (function-p (if (intersection headers *fun-header-widetags*)
  99                          (if (subsetp headers *fun-header-widetags*)
 100                              t
 101                              (error "can't test for mix of function subtypes ~
 102                                      and normal header types"))
 103                          nil)))
 104     (unless type-codes
 105       (error "At least one type must be supplied for TEST-TYPE."))
 106     (cond
 107       (fixnump
 108        (when (remove-if (lambda (x)
 109                           (member x '#.(mapcar #'symbol-value fixnum-lowtags)))
 110                         lowtags)
 111          (error "can't mix fixnum testing with other lowtags"))
 112        (when function-p
 113          (error "can't mix fixnum testing with function subtype testing"))
 114        (cond
 115          ((and (= n-word-bits 64) immediates headers)
 116           `(%test-fixnum-immediate-and-headers ,value ,target ,not-p
 117                                                ,(car immediates)
 118                                                ',(canonicalize-headers
 119                                                   headers)
 120                                                ,@other-args))
 121          (immediates
 122           (if (= n-word-bits 64)
 123               `(%test-fixnum-and-immediate ,value ,target ,not-p
 124                                            ,(car immediates)
 125                                            ,@other-args)
 126               (error "can't mix fixnum testing with other immediates")))
 127          (headers
 128           `(%test-fixnum-and-headers ,value ,target ,not-p
 129                                      ',(canonicalize-headers headers)
 130                                      ,@other-args))
 131          (t
 132           `(%test-fixnum ,value ,target ,not-p
 133                          ,@other-args))))
 134       (immediates
 135        (cond
 136          (headers
 137           (if (= n-word-bits 64)
 138               `(%test-immediate-and-headers ,value ,target ,not-p
 139                                             ,(car immediates)
 140                                             ',(canonicalize-headers headers)
 141                                             ,@other-args)
 142               (error "can't mix testing of immediates with testing of headers")))
 143          (lowtags
 144           (error "can't mix testing of immediates with testing of lowtags"))
 145          ((cdr immediates)
 146           (error "can't test multiple immediates at the same time"))
 147          (t
 148           `(%test-immediate ,value ,target ,not-p ,(car immediates)
 149                             ,@other-args))))
 150       (lowtags
 151        (when (cdr lowtags)
 152          (error "can't test multiple lowtags at the same time"))
 153        (when headers
 154          (error "can't test non-fixnum lowtags and headers at the same time"))
 155        `(%test-lowtag ,value ,target ,not-p ,(car lowtags) ,@other-args))
 156       (headers
 157        `(%test-headers ,value ,target ,not-p ,function-p
 158          ',(canonicalize-headers headers)
 159          ,@other-args))
 160       (t
 161        (error "nothing to test?")))))