1 ;;;; machine-independent aspects of the object representation and
4 ;;;; This software is part of the SBCL system. See the README file for
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
15 ;;;; primitive type definitions
17 (/show0
"primtype.lisp 17")
19 (!def-primitive-type t
(descriptor-reg))
20 (/show0
"primtype.lisp 20")
21 (setf *backend-t-primitive-type
* (primitive-type-or-lose t
))
23 ;;; primitive integer types that fit in registers
24 (/show0
"primtype.lisp 24")
25 (!def-primitive-type positive-fixnum
(any-reg signed-reg unsigned-reg
)
26 :type
(unsigned-byte #.sb
!vm
:n-positive-fixnum-bits
))
27 (/show0
"primtype.lisp 27")
28 #!+#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
32) '(and) '(or))
29 (!def-primitive-type unsigned-byte-31
(signed-reg unsigned-reg descriptor-reg
)
30 :type
(unsigned-byte 31))
31 (/show0
"primtype.lisp 31")
32 #!+#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
32) '(and) '(or))
33 (!def-primitive-type unsigned-byte-32
(unsigned-reg descriptor-reg
)
34 :type
(unsigned-byte 32))
35 (/show0
"primtype.lisp 35")
36 #!+#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
64) '(and) '(or))
37 (!def-primitive-type unsigned-byte-63
(signed-reg unsigned-reg descriptor-reg
)
38 :type
(unsigned-byte 63))
39 #!+#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
64) '(and) '(or))
40 (!def-primitive-type unsigned-byte-64
(unsigned-reg descriptor-reg
)
41 :type
(unsigned-byte 64))
42 (!def-primitive-type fixnum
(any-reg signed-reg
)
43 :type
(signed-byte #.
(1+ sb
!vm
:n-positive-fixnum-bits
)))
44 #!+#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
32) '(and) '(or))
45 (!def-primitive-type signed-byte-32
(signed-reg descriptor-reg
)
46 :type
(signed-byte 32))
47 #!+#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
64) '(and) '(or))
48 (!def-primitive-type signed-byte-64
(signed-reg descriptor-reg
)
49 :type
(signed-byte 64))
51 (defvar *fixnum-primitive-type
* (primitive-type-or-lose 'fixnum
))
53 (/show0
"primtype.lisp 53")
54 (!def-primitive-type-alias tagged-num
(:or positive-fixnum fixnum
))
56 (!def-primitive-type-alias unsigned-num
#1=
57 #!+#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
64) '(and) '(or))
58 (:or unsigned-byte-64 unsigned-byte-63 positive-fixnum
)
59 #!-
#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
64) '(and) '(or))
60 (:or unsigned-byte-32 unsigned-byte-31 positive-fixnum
))
61 (!def-primitive-type-alias signed-num
#2=
62 #!+#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
64) '(and) '(or))
63 (:or signed-byte-64 fixnum unsigned-byte-63 positive-fixnum
)
64 #!-
#.
(cl:if
(cl:= sb
!vm
::n-machine-word-bits
64) '(and) '(or))
65 (:or signed-byte-32 fixnum unsigned-byte-31 positive-fixnum
))
66 (!def-primitive-type-alias untagged-num
67 (:or .
#.
(sort (copy-list (union (cdr '#1#) (cdr '#2#))) #'string
<))))
69 ;;; other primitive immediate types
70 (/show0
"primtype.lisp 68")
71 (!def-primitive-type character
(character-reg any-reg
))
73 ;;; primitive pointer types
74 (/show0
"primtype.lisp 73")
75 (!def-primitive-type function
(descriptor-reg))
76 (!def-primitive-type list
(descriptor-reg))
77 (!def-primitive-type instance
(descriptor-reg))
79 (/show0
"primtype.lisp 77")
80 (!def-primitive-type funcallable-instance
(descriptor-reg))
82 ;;; primitive other-pointer number types
83 (/show0
"primtype.lisp 81")
84 (!def-primitive-type bignum
(descriptor-reg))
85 (!def-primitive-type ratio
(descriptor-reg))
86 (!def-primitive-type complex
(descriptor-reg))
87 (/show0
"about to !DEF-PRIMITIVE-TYPE SINGLE-FLOAT")
88 (!def-primitive-type single-float
(single-reg descriptor-reg
))
89 (/show0
"about to !DEF-PRIMITIVE-TYPE DOUBLE-FLOAT")
90 (!def-primitive-type double-float
(double-reg descriptor-reg
))
92 (/show0
"about to !DEF-PRIMITIVE-TYPE COMPLEX-SINGLE-FLOAT")
93 (!def-primitive-type complex-single-float
(complex-single-reg descriptor-reg
)
94 :type
(complex single-float
))
95 (/show0
"about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
96 (!def-primitive-type complex-double-float
(complex-double-reg descriptor-reg
)
97 :type
(complex double-float
))
100 ;;; primitive other-pointer array types
101 (/show0
"primtype.lisp 96")
102 (macrolet ((define-simple-array-primitive-types ()
106 `(!def-primitive-type
107 ,(saetp-primitive-type-name saetp
)
109 :type
(simple-array ,(saetp-specifier saetp
) (*))))
110 *specialized-array-element-type-properties
*))))
111 (define-simple-array-primitive-types))
112 ;;; Note: The complex array types are not included, 'cause it is
113 ;;; pointless to restrict VOPs to them.
115 ;;; other primitive other-pointer types
116 (!def-primitive-type system-area-pointer
(sap-reg descriptor-reg
))
117 (!def-primitive-type weak-pointer
(descriptor-reg))
119 ;;; miscellaneous primitive types that don't exist at the LISP level
120 (!def-primitive-type catch-block
(catch-block) :type nil
)
122 ;;;; PRIMITIVE-TYPE-OF and friends
124 ;;; Return the most restrictive primitive type that contains OBJECT.
125 (/show0
"primtype.lisp 147")
126 (!def-vm-support-routine primitive-type-of
(object)
127 (let ((type (ctype-of object
)))
128 (cond ((not (member-type-p type
)) (primitive-type type
))
129 ((and (eql 1 (member-type-size type
))
130 (equal (member-type-members type
) '(nil)))
131 (primitive-type-or-lose 'list
))
133 *backend-t-primitive-type
*))))
135 ;;; Return the primitive type corresponding to a type descriptor
136 ;;; structure. The second value is true when the primitive type is
137 ;;; exactly equivalent to the argument Lisp type.
139 ;;; In a bootstrapping situation, we should be careful to use the
140 ;;; correct values for the system parameters.
142 ;;; We need an aux function because we need to use both
143 ;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
144 (/show0
"primtype.lisp 188")
145 (!def-vm-support-routine primitive-type
(type)
146 (sb!kernel
::maybe-reparse-specifier
! type
)
147 (primitive-type-aux type
))
148 (/show0
"primtype.lisp 191")
149 (defun-cached (primitive-type-aux
150 :hash-function
(lambda (x)
151 (logand (type-hash-value x
) #x1FF
))
154 :default
(values nil
:empty
))
156 (declare (type ctype type
))
157 (macrolet ((any () '(values *backend-t-primitive-type
* nil
))
159 `(values (primitive-type-or-lose ',type
) t
))
161 `(values (primitive-type-or-lose ',type
) nil
)))
162 (flet ((maybe-numeric-type-union (t1 t2
)
163 (let ((t1-name (primitive-type-name t1
))
164 (t2-name (primitive-type-name t2
)))
167 (if (or (eq t2-name
'fixnum
)
169 (ecase sb
!vm
::n-machine-word-bits
171 (64 'signed-byte-64
)))
173 (ecase sb
!vm
::n-machine-word-bits
174 (32 'unsigned-byte-31
)
175 (64 'unsigned-byte-63
)))
177 (ecase sb
!vm
::n-machine-word-bits
178 (32 'unsigned-byte-32
)
179 (64 'unsigned-byte-64
))))
183 (#.
(ecase sb
!vm
::n-machine-word-bits
185 (64 'signed-byte-64
))
187 (#.
(ecase sb
!vm
::n-machine-word-bits
188 (32 'unsigned-byte-31
)
189 (64 'unsigned-byte-63
))
190 (primitive-type-or-lose
191 (ecase sb
!vm
::n-machine-word-bits
193 (64 'signed-byte-64
))))))
194 (#.
(ecase sb
!vm
::n-machine-word-bits
196 (64 'signed-byte-64
))
198 (ecase sb
!vm
::n-machine-word-bits
199 (32 'unsigned-byte-31
)
200 (64 'unsigned-byte-63
)))
202 (#.
(ecase sb
!vm
::n-machine-word-bits
203 (32 'unsigned-byte-31
)
204 (64 'unsigned-byte-63
))
206 (ecase sb
!vm
::n-machine-word-bits
207 (32 'unsigned-byte-32
)
208 (64 'unsigned-byte-64
)))
212 (let ((lo (numeric-type-low type
))
213 (hi (numeric-type-high type
)))
214 (case (numeric-type-complexp type
)
216 (case (numeric-type-class type
)
220 `((positive-fixnum 0 ,sb
!xc
:most-positive-fixnum
)
221 ,@(ecase sb
!vm
::n-machine-word-bits
226 0 ,(1- (ash 1 32)))))
231 0 ,(1- (ash 1 64))))))
232 (fixnum ,sb
!xc
:most-negative-fixnum
233 ,sb
!xc
:most-positive-fixnum
)
234 ,(ecase sb
!vm
::n-machine-word-bits
236 `(signed-byte-32 ,(ash -
1 31)
239 `(signed-byte-64 ,(ash -
1 63)
241 (if (or (< hi sb
!xc
:most-negative-fixnum
)
242 (> lo sb
!xc
:most-positive-fixnum
))
245 (let ((type (car spec
))
248 (when (<= min lo hi max
)
250 (primitive-type-or-lose type
)
251 (and (= lo min
) (= hi max
))))))))
252 ((or (and hi
(< hi sb
!xc
:most-negative-fixnum
))
253 (and lo
(> lo sb
!xc
:most-positive-fixnum
)))
258 (let ((exact (and (null lo
) (null hi
))))
259 (case (numeric-type-format type
)
260 ((short-float single-float
)
261 (values (primitive-type-or-lose 'single-float
)
264 (values (primitive-type-or-lose 'double-float
)
271 (if (eq (numeric-type-class type
) 'float
)
272 (let ((exact (and (null lo
) (null hi
))))
273 (case (numeric-type-format type
)
274 ((short-float single-float
)
275 (values (primitive-type-or-lose 'complex-single-float
)
277 ((double-float long-float
)
278 (values (primitive-type-or-lose 'complex-double-float
)
286 (if (array-type-complexp type
)
288 (let* ((dims (array-type-dimensions type
))
289 (etype (array-type-specialized-element-type type
))
290 (type-spec (type-specifier etype
))
291 ;; FIXME: We're _WHAT_? Testing for type equality
292 ;; with a specifier and #'EQUAL? *BOGGLE*. --
294 (ptype (cdr (assoc type-spec
*simple-array-primitive-types
*
296 (if (and (consp dims
) (null (rest dims
)) ptype
)
297 (values (primitive-type-or-lose ptype
)
298 (eq (first dims
) '*))
301 (if (type= type
(specifier-type 'list
))
303 (let ((types (union-type-types type
)))
304 (multiple-value-bind (res exact
) (primitive-type (first types
))
305 (dolist (type (rest types
) (values res exact
))
306 (multiple-value-bind (ptype ptype-exact
)
307 (primitive-type type
)
308 (unless ptype-exact
(setq exact nil
))
309 (unless (eq ptype res
)
311 (or (maybe-numeric-type-union res ptype
)
312 (maybe-numeric-type-union ptype res
))))
315 (return (any)))))))))))
317 (let ((types (intersection-type-types type
))
319 ;; why NIL for the exact? Well, we assume that the
320 ;; intersection type is in fact doing something for us:
321 ;; that is, that each of the types in the intersection is
322 ;; in fact cutting off some of the type lattice. Since no
323 ;; intersection type is represented by a primitive type and
324 ;; primitive types are mutually exclusive, it follows that
325 ;; no intersection type can represent the entirety of the
326 ;; primitive type. (And NIL is the conservative answer,
327 ;; anyway). -- CSR, 2006-09-14
328 (dolist (type types
(values res nil
))
329 (multiple-value-bind (ptype)
330 (primitive-type type
)
332 ;; if the result so far is (any), any improvement on
333 ;; the specificity of the primitive type is valid.
336 ;; if the primitive type returned is (any), the
337 ;; result so far is valid. Likewise, if the
338 ;; primitive type is the same as the result so far,
339 ;; everything is fine.
340 ((or (eq ptype
(any)) (eq ptype res
)))
341 ;; otherwise, we have something hairy and confusing,
342 ;; such as (and condition funcallable-instance).
344 (t (return (any))))))))
348 (mapc-member-type-members
350 (let ((ptype (primitive-type-of member
)))
352 (unless (eq ptype res
)
353 (let ((new-ptype (or (maybe-numeric-type-union res ptype
)
354 (maybe-numeric-type-union ptype res
))))
362 (ecase (named-type-name type
)
363 ((t *) (values *backend-t-primitive-type
* t
))
364 ((instance) (exactly instance
))
365 ((funcallable-instance) (part-of function
))
366 ((extended-sequence) (any))
369 (let ((pairs (character-set-type-pairs type
)))
370 (if (and (= (length pairs
) 1)
372 (= (cdar pairs
) (1- sb
!xc
:char-code-limit
)))
374 (part-of character
))))
376 (case (classoid-name type
)
377 ((complex function system-area-pointer weak-pointer
)
378 (values (primitive-type-or-lose (classoid-name type
)) t
))
386 (if (csubtypep type
(specifier-type 'function
))
390 (if (csubtypep type
(specifier-type 'function
))
394 (/show0
"primtype.lisp end of file")