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          (when (= sb!vm::n-word-bits 64)
  16            (list single-float-widetag))))
  17
  18 (defparameter *fun-header-widetags*
  19   (list funcallable-instance-header-widetag
  20         simple-fun-header-widetag
  21         closure-header-widetag))
  22
  23 (defun canonicalize-headers (headers)
  24   (collect ((results))
  25     (let ((start nil)
  26           (prev nil)
  27           (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
  28       (flet ((emit-test ()
  29                (results (if (= start prev)
  30                             start
  31                             (cons start prev)))))
  32         (dolist (header (sort headers #'<))
  33           (cond ((null start)
  34                  (setf start header)
  35                  (setf prev header))
  36                 ((= header (+ prev delta))
  37                  (setf prev header))
  38                 (t
  39                  (emit-test)
  40                  (setf start header)
  41                  (setf prev header))))
  42         (emit-test)))
  43     (results)))
  44
  45 (defmacro test-type (value target not-p
  46                      (&rest type-codes)
  47                      &rest other-args
  48                      &key &allow-other-keys)
  49   ;; Determine what interesting combinations we need to test for.
  50   (let* ((type-codes (mapcar #'eval type-codes))
  51          (fixnump (and (member even-fixnum-lowtag type-codes)
  52                        (member odd-fixnum-lowtag type-codes)
  53                        t))
  54          (lowtags (remove lowtag-limit type-codes :test #'<))
  55          (extended (remove lowtag-limit type-codes :test #'>))
  56          (immediates (intersection extended *immediate-types* :test #'eql))
  57          (headers (set-difference extended *immediate-types* :test #'eql))
  58          (function-p (if (intersection headers *fun-header-widetags*)
  59                          (if (subsetp headers *fun-header-widetags*)
  60                              t
  61                              (error "can't test for mix of function subtypes ~
  62                                      and normal header types"))
  63                          nil)))
  64     (unless type-codes
  65       (error "At least one type must be supplied for TEST-TYPE."))
  66     (cond
  67       (fixnump
  68        (when (remove-if (lambda (x)
  69                           (or (= x even-fixnum-lowtag)
  70                               (= x odd-fixnum-lowtag)))
  71                         lowtags)
  72          (error "can't mix fixnum testing with other lowtags"))
  73        (when function-p
  74          (error "can't mix fixnum testing with function subtype testing"))
  75        (cond
  76          ((and (= sb!vm:n-word-bits 64) immediates headers)
  77           `(%test-fixnum-immediate-and-headers ,value ,target ,not-p
  78                                                ,(car immediates)
  79                                                ',(canonicalize-headers
  80                                                   headers)
  81                                                ,@other-args))
  82          (immediates
  83           (if (= sb!vm:n-word-bits 64)
  84               `(%test-fixnum-and-immediate ,value ,target ,not-p
  85                                            ,(car immediates)
  86                                            ,@other-args)
  87               (error "can't mix fixnum testing with other immediates")))
  88          (headers
  89           `(%test-fixnum-and-headers ,value ,target ,not-p
  90                                      ',(canonicalize-headers headers)
  91                                      ,@other-args))
  92          (t
  93           `(%test-fixnum ,value ,target ,not-p
  94                          ,@other-args))))
  95       (immediates
  96        (cond
  97          (headers
  98           (if (= sb!vm:n-word-bits 64)
  99               `(%test-immediate-and-headers ,value ,target ,not-p
 100                                             ,(car immediates)
 101                                             ',(canonicalize-headers headers)
 102                                             ,@other-args)
 103               (error "can't mix testing of immediates with testing of headers")))
 104          (lowtags
 105           (error "can't mix testing of immediates with testing of lowtags"))
 106          ((cdr immediates)
 107           (error "can't test multiple immediates at the same time"))
 108          (t
 109           `(%test-immediate ,value ,target ,not-p ,(car immediates)
 110                             ,@other-args))))
 111       (lowtags
 112        (when (cdr lowtags)
 113          (error "can't test multiple lowtags at the same time"))
 114        (when headers
 115          (error "can't test non-fixnum lowtags and headers at the same time"))
 116        `(%test-lowtag ,value ,target ,not-p ,(car lowtags) ,@other-args))
 117       (headers
 118        `(%test-headers ,value ,target ,not-p ,function-p
 119          ',(canonicalize-headers headers)
 120          ,@other-args))
 121       (t
 122        (error "nothing to test?")))))
 123