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

   1 (in-package "SB!VM")
   2
   3 (defparameter *immediate-types*
   4   (list unbound-marker-widetag base-char-widetag))
   5
   6 (defparameter *fun-header-widetags*
   7   (list funcallable-instance-header-widetag
   8         simple-fun-header-widetag
   9         closure-fun-header-widetag
  10         closure-header-widetag))
  11
  12 (defun canonicalize-headers (headers)
  13   (collect ((results))
  14     (let ((start nil)
  15           (prev nil)
  16           (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
  17       (flet ((emit-test ()
  18                (results (if (= start prev)
  19                             start
  20                             (cons start prev)))))
  21         (dolist (header (sort headers #'<))
  22           (cond ((null start)
  23                  (setf start header)
  24                  (setf prev header))
  25                 ((= header (+ prev delta))
  26                  (setf prev header))
  27                 (t
  28                  (emit-test)
  29                  (setf start header)
  30                  (setf prev header))))
  31         (emit-test)))
  32     (results)))
  33
  34 (defmacro test-type (value target not-p
  35                      (&rest type-codes)
  36                      &rest other-args
  37                      &key &allow-other-keys)
  38   ;; Determine what interesting combinations we need to test for.
  39   (let* ((type-codes (mapcar #'eval type-codes))
  40          (fixnump (and (member even-fixnum-lowtag type-codes)
  41                        (member odd-fixnum-lowtag type-codes)
  42                        t))
  43          (lowtags (remove lowtag-limit type-codes :test #'<))
  44          (extended (remove lowtag-limit type-codes :test #'>))
  45          (immediates (intersection extended *immediate-types* :test #'eql))
  46          (headers (set-difference extended *immediate-types* :test #'eql))
  47          (function-p (if (intersection headers *fun-header-widetags*)
  48                          (if (subsetp headers *fun-header-widetags*)
  49                              t
  50                              (error "can't test for mix of function subtypes ~
  51                                      and normal header types"))
  52                          nil)))
  53     (unless type-codes
  54       (error "At least one type must be supplied for TEST-TYPE."))
  55     (cond
  56       (fixnump
  57        (when (remove-if (lambda (x)
  58                           (or (= x even-fixnum-lowtag)
  59                               (= x odd-fixnum-lowtag)))
  60                         lowtags)
  61          (error "can't mix fixnum testing with other lowtags"))
  62        (when function-p
  63          (error "can't mix fixnum testing with function subtype testing"))
  64        (when immediates
  65          (error "can't mix fixnum testing with other immediates"))
  66        (if headers
  67            `(%test-fixnum-and-headers ,value ,target ,not-p
  68              ',(canonicalize-headers headers)
  69              ,@other-args)
  70            `(%test-fixnum ,value ,target ,not-p
  71              ,@other-args)))
  72       (immediates
  73        (when headers
  74          (error "can't mix testing of immediates with testing of headers"))
  75        (when lowtags
  76          (error "can't mix testing of immediates with testing of lowtags"))
  77        (when (cdr immediates)
  78          (error "can't test multiple immediates at the same time"))
  79        `(%test-immediate ,value ,target ,not-p ,(car immediates)
  80          ,@other-args))
  81       (lowtags
  82        (when (cdr lowtags)
  83          (error "can't test multiple lowtags at the same time"))
  84        (if headers
  85            `(%test-lowtag-and-headers
  86              ,value ,target ,not-p ,(car lowtags)
  87              ,function-p ',(canonicalize-headers headers)
  88              ,@other-args)
  89            `(%test-lowtag ,value ,target ,not-p ,(car lowtags)
  90              ,@other-args)))
  91       (headers
  92        `(%test-headers ,value ,target ,not-p ,function-p
  93          ',(canonicalize-headers headers)
  94          ,@other-args))
  95       (t
  96        (error "nothing to test?")))))
  97