1 ;;;; generic type testing and checking apparatus
3 ;;;; This software is part of the SBCL system. See the README file for
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.
13 (defparameter *immediate-types
*
14 (list unbound-marker-widetag character-widetag
15 #!+64-bit single-float-widetag
))
17 ;; Given a list of widetags in HEADERS, compress into a minimal list of ranges
18 ;; and/or singletons that should be tested.
19 ;; FIXME: At present the "is it effectively a one-sided test" is re-implemented
20 ;; in an ad-hoc way by each backend. The range convention should be
21 ;; changed to indicate explicitly when either limit needn't be checked.
22 ;; (Use NIL or * as a bound perhaps)
23 (defun canonicalize-widetags (headers)
27 (delta (- other-immediate-1-lowtag other-immediate-0-lowtag
)))
29 (results (if (= start prev
)
32 ;; COPY-LIST because the argument may come from immutable source code
33 (dolist (header (sort (copy-list headers
) #'<))
37 ((= header
(+ prev delta
))
46 ;; If WIDETAGS is comprised of two ranges that are nearly adjacent,
47 ;; return a single range spanning both original ranges,
48 ;; and as a second value the widetag(s) to exclude;
49 ;; or return the unmodified ranges and NIL.
50 ;; This could be generalized: three ranges that collapse to one with at most
51 ;; two exceptions, or three collapsing to two with one exception, etc.
52 (defun canonicalize-widetags+exceptions
(widetags)
53 (let ((ranges (canonicalize-widetags widetags
)))
54 (flet ((begin (x) (if (listp x
) (car x
) x
))
55 (end (x) (if (listp x
) (cdr x
) x
)))
56 (when (and (cdr ranges
) (endp (cddr ranges
))) ; 2 ranges
57 (let* ((range-1 (first ranges
))
58 (range-2 (second ranges
))
59 (begin-1 (begin range-1
))
61 (begin-2 (begin range-2
))
63 (delta (- other-immediate-1-lowtag other-immediate-0-lowtag
)))
64 (when (and (= (+ end-1
(* 2 delta
)) begin-2
)
65 ;; Don't return {X} - {Y} if {X} spans only 3 widetags,
66 ;; because clearly we can just test the 2 members of X.
67 ;; fencepost: 3 delta is 4 widetags.
68 (>= (- end-2 begin-1
) (* 3 delta
)))
69 (return-from canonicalize-widetags
+exceptions
70 (values `((,begin-1 .
,end-2
))
71 `(,(+ end-1 delta
)))))))) ; the excluded value
74 (defmacro test-type
(value target not-p
77 &key
&allow-other-keys
)
78 ;; Determine what interesting combinations we need to test for.
79 (let* ((type-codes (mapcar #'eval type-codes
))
80 (fixnump (and (every (lambda (lowtag)
81 (member lowtag type-codes
))
82 '#.
(mapcar #'symbol-value fixnum-lowtags
))
84 (lowtags (remove lowtag-limit type-codes
:test
#'<))
85 (extended (remove lowtag-limit type-codes
:test
#'>))
86 (immediates (intersection extended
*immediate-types
* :test
#'eql
))
87 ;; To collapse the range of widetags comprising real numbers on 64-bit
88 ;; machines, consider SHORT-FLOAT-WIDETAG both a header and immediate.
89 ;; No OTHER-POINTER-LOWTAG object can ever have that header tag.
90 ;; But only do so if there would otherwise be a discontinuity
91 ;; in the set of headers.
92 ;; Another approach would have been to flip DOUBLE- and SINGLE- float,
93 ;; but that would not help NUMBERP, only REALP. Putting SINGLE-
94 ;; after the complex widetags would work but harm 32-bit machines.
95 (headers (set-difference
97 (if (and (= n-word-bits
64)
98 (member (- single-float-widetag
4) extended
)
99 (member (+ single-float-widetag
4) extended
))
100 (remove single-float-widetag
*immediate-types
*)
103 (function-p (if (intersection headers
+fun-header-widetags
+)
104 (if (subsetp headers
+fun-header-widetags
+)
106 (error "can't test for mix of function subtypes ~
107 and normal header types"))
110 (error "At least one type must be supplied for TEST-TYPE."))
113 (when (remove-if (lambda (x)
114 (member x
'#.
(mapcar #'symbol-value fixnum-lowtags
)))
116 (error "can't mix fixnum testing with other lowtags"))
118 (error "can't mix fixnum testing with function subtype testing"))
120 ((and (= n-word-bits
64) immediates headers
)
121 `(%test-fixnum-immediate-and-headers
,value
,target
,not-p
123 ',(canonicalize-widetags
127 (if (= n-word-bits
64)
128 `(%test-fixnum-and-immediate
,value
,target
,not-p
131 (error "can't mix fixnum testing with other immediates")))
133 `(%test-fixnum-and-headers
,value
,target
,not-p
134 ',(canonicalize-widetags headers
)
137 `(%test-fixnum
,value
,target
,not-p
142 (if (= n-word-bits
64)
143 `(%test-immediate-and-headers
,value
,target
,not-p
145 ',(canonicalize-widetags headers
)
147 (error "can't mix testing of immediates with testing of headers")))
149 (error "can't mix testing of immediates with testing of lowtags"))
151 (error "can't test multiple immediates at the same time"))
153 `(%test-immediate
,value
,target
,not-p
,(car immediates
)
157 (error "can't test multiple lowtags at the same time"))
159 (error "can't test non-fixnum lowtags and headers at the same time"))
160 `(%test-lowtag
,value
,target
,not-p
,(car lowtags
) ,@other-args
))
162 `(%test-headers
,value
,target
,not-p
,function-p
163 ',(canonicalize-widetags headers
)
166 (error "nothing to test?")))))