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 .
#.
(print (union (cdr '#1#) (cdr '#2#))))))
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
))
99 (/show0
"about to !DEF-PRIMITIVE-TYPE XMM")
100 (!def-primitive-type xmm
(xmm-reg descriptor-reg
))
102 ;;; primitive other-pointer array types
103 (/show0
"primtype.lisp 96")
104 (macrolet ((define-simple-array-primitive-types ()
108 `(!def-primitive-type
109 ,(saetp-primitive-type-name saetp
)
111 :type
(simple-array ,(saetp-specifier saetp
) (*))))
112 *specialized-array-element-type-properties
*))))
113 (define-simple-array-primitive-types))
114 ;;; Note: The complex array types are not included, 'cause it is
115 ;;; pointless to restrict VOPs to them.
117 ;;; other primitive other-pointer types
118 (!def-primitive-type system-area-pointer
(sap-reg descriptor-reg
))
119 (!def-primitive-type weak-pointer
(descriptor-reg))
121 ;;; miscellaneous primitive types that don't exist at the LISP level
122 (!def-primitive-type catch-block
(catch-block) :type nil
)
124 ;;;; PRIMITIVE-TYPE-OF and friends
126 ;;; Return the most restrictive primitive type that contains OBJECT.
127 (/show0
"primtype.lisp 147")
128 (!def-vm-support-routine primitive-type-of
(object)
129 (let ((type (ctype-of object
)))
130 (cond ((not (member-type-p type
)) (primitive-type type
))
131 ((and (eql 1 (member-type-size type
))
132 (equal (member-type-members type
) '(nil)))
133 (primitive-type-or-lose 'list
))
135 *backend-t-primitive-type
*))))
137 ;;; Return the primitive type corresponding to a type descriptor
138 ;;; structure. The second value is true when the primitive type is
139 ;;; exactly equivalent to the argument Lisp type.
141 ;;; In a bootstrapping situation, we should be careful to use the
142 ;;; correct values for the system parameters.
144 ;;; We need an aux function because we need to use both
145 ;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
146 (/show0
"primtype.lisp 188")
147 (!def-vm-support-routine primitive-type
(type)
148 (primitive-type-aux type
))
149 (/show0
"primtype.lisp 191")
150 (defun-cached (primitive-type-aux
151 :hash-function
(lambda (x)
152 (logand (type-hash-value x
) #x1FF
))
155 :default
(values nil
:empty
))
157 (declare (type ctype type
))
158 (macrolet ((any () '(values *backend-t-primitive-type
* nil
))
160 `(values (primitive-type-or-lose ',type
) t
))
162 `(values (primitive-type-or-lose ',type
) nil
)))
163 (flet ((maybe-numeric-type-union (t1 t2
)
164 (let ((t1-name (primitive-type-name t1
))
165 (t2-name (primitive-type-name t2
)))
168 (if (or (eq t2-name
'fixnum
)
170 (ecase sb
!vm
::n-machine-word-bits
172 (64 'signed-byte-64
)))
174 (ecase sb
!vm
::n-machine-word-bits
175 (32 'unsigned-byte-31
)
176 (64 'unsigned-byte-63
)))
178 (ecase sb
!vm
::n-machine-word-bits
179 (32 'unsigned-byte-32
)
180 (64 'unsigned-byte-64
))))
184 (#.
(ecase sb
!vm
::n-machine-word-bits
186 (64 'signed-byte-64
))
188 (#.
(ecase sb
!vm
::n-machine-word-bits
189 (32 'unsigned-byte-31
)
190 (64 'unsigned-byte-63
))
191 (primitive-type-or-lose
192 (ecase sb
!vm
::n-machine-word-bits
194 (64 'signed-byte-64
))))))
195 (#.
(ecase sb
!vm
::n-machine-word-bits
197 (64 'signed-byte-64
))
199 (ecase sb
!vm
::n-machine-word-bits
200 (32 'unsigned-byte-31
)
201 (64 'unsigned-byte-63
)))
203 (#.
(ecase sb
!vm
::n-machine-word-bits
204 (32 'unsigned-byte-31
)
205 (64 'unsigned-byte-63
))
207 (ecase sb
!vm
::n-machine-word-bits
208 (32 'unsigned-byte-32
)
209 (64 'unsigned-byte-64
)))
213 (let ((lo (numeric-type-low type
))
214 (hi (numeric-type-high type
)))
215 (case (numeric-type-complexp type
)
217 (case (numeric-type-class type
)
221 `((positive-fixnum 0 ,sb
!xc
:most-positive-fixnum
)
222 ,@(ecase sb
!vm
::n-machine-word-bits
227 0 ,(1- (ash 1 32)))))
232 0 ,(1- (ash 1 64))))))
233 (fixnum ,sb
!xc
:most-negative-fixnum
234 ,sb
!xc
:most-positive-fixnum
)
235 ,(ecase sb
!vm
::n-machine-word-bits
237 `(signed-byte-32 ,(ash -
1 31)
240 `(signed-byte-64 ,(ash -
1 63)
242 (if (or (< hi sb
!xc
:most-negative-fixnum
)
243 (> lo sb
!xc
:most-positive-fixnum
))
246 (let ((type (car spec
))
249 (when (<= min lo hi max
)
251 (primitive-type-or-lose type
)
252 (and (= lo min
) (= hi max
))))))))
253 ((or (and hi
(< hi sb
!xc
:most-negative-fixnum
))
254 (and lo
(> lo sb
!xc
:most-positive-fixnum
)))
259 (let ((exact (and (null lo
) (null hi
))))
260 (case (numeric-type-format type
)
261 ((short-float single-float
)
262 (values (primitive-type-or-lose 'single-float
)
265 (values (primitive-type-or-lose 'double-float
)
272 (if (eq (numeric-type-class type
) 'float
)
273 (let ((exact (and (null lo
) (null hi
))))
274 (case (numeric-type-format type
)
275 ((short-float single-float
)
276 (values (primitive-type-or-lose 'complex-single-float
)
278 ((double-float long-float
)
279 (values (primitive-type-or-lose 'complex-double-float
)
287 (if (array-type-complexp type
)
289 (let* ((dims (array-type-dimensions type
))
290 (etype (array-type-specialized-element-type type
))
291 (type-spec (type-specifier etype
))
292 ;; FIXME: We're _WHAT_? Testing for type equality
293 ;; with a specifier and #'EQUAL? *BOGGLE*. --
295 (ptype (cdr (assoc type-spec
*simple-array-primitive-types
*
297 (if (and (consp dims
) (null (rest dims
)) ptype
)
298 (values (primitive-type-or-lose ptype
)
299 (eq (first dims
) '*))
302 (if (type= type
(specifier-type 'list
))
304 (let ((types (union-type-types type
)))
305 (multiple-value-bind (res exact
) (primitive-type (first types
))
306 (dolist (type (rest types
) (values res exact
))
307 (multiple-value-bind (ptype ptype-exact
)
308 (primitive-type type
)
309 (unless ptype-exact
(setq exact nil
))
310 (unless (eq ptype res
)
312 (or (maybe-numeric-type-union res ptype
)
313 (maybe-numeric-type-union ptype res
))))
316 (return (any)))))))))))
318 (let ((types (intersection-type-types type
))
320 ;; why NIL for the exact? Well, we assume that the
321 ;; intersection type is in fact doing something for us:
322 ;; that is, that each of the types in the intersection is
323 ;; in fact cutting off some of the type lattice. Since no
324 ;; intersection type is represented by a primitive type and
325 ;; primitive types are mutually exclusive, it follows that
326 ;; no intersection type can represent the entirety of the
327 ;; primitive type. (And NIL is the conservative answer,
328 ;; anyway). -- CSR, 2006-09-14
329 (dolist (type types
(values res nil
))
330 (multiple-value-bind (ptype)
331 (primitive-type type
)
333 ;; if the result so far is (any), any improvement on
334 ;; the specificity of the primitive type is valid.
337 ;; if the primitive type returned is (any), the
338 ;; result so far is valid. Likewise, if the
339 ;; primitive type is the same as the result so far,
340 ;; everything is fine.
341 ((or (eq ptype
(any)) (eq ptype res
)))
342 ;; otherwise, we have something hairy and confusing,
343 ;; such as (and condition funcallable-instance).
345 (t (return (any))))))))
349 (mapc-member-type-members
351 (let ((ptype (primitive-type-of member
)))
353 (unless (eq ptype res
)
354 (let ((new-ptype (or (maybe-numeric-type-union res ptype
)
355 (maybe-numeric-type-union ptype res
))))
363 (ecase (named-type-name type
)
364 ((t *) (values *backend-t-primitive-type
* t
))
365 ((instance) (exactly instance
))
366 ((funcallable-instance) (part-of function
))
367 ((extended-sequence) (any))
370 (let ((pairs (character-set-type-pairs type
)))
371 (if (and (= (length pairs
) 1)
373 (= (cdar pairs
) (1- sb
!xc
:char-code-limit
)))
375 (part-of character
))))
377 (case (classoid-name type
)
378 ((complex function system-area-pointer weak-pointer
)
379 (values (primitive-type-or-lose (classoid-name type
)) t
))
387 (if (csubtypep type
(specifier-type 'function
))
391 (if (csubtypep type
(specifier-type 'function
))
395 (/show0
"primtype.lisp end of file")