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 (primitive-type-aux type
))
147 (/show0
"primtype.lisp 191")
148 (defun-cached (primitive-type-aux
149 :hash-function
(lambda (x)
150 (logand (type-hash-value x
) #x1FF
))
153 :default
(values nil
:empty
))
155 (declare (type ctype type
))
156 (macrolet ((any () '(values *backend-t-primitive-type
* nil
))
158 `(values (primitive-type-or-lose ',type
) t
))
160 `(values (primitive-type-or-lose ',type
) nil
)))
161 (flet ((maybe-numeric-type-union (t1 t2
)
162 (let ((t1-name (primitive-type-name t1
))
163 (t2-name (primitive-type-name t2
)))
166 (if (or (eq t2-name
'fixnum
)
168 (ecase sb
!vm
::n-machine-word-bits
170 (64 'signed-byte-64
)))
172 (ecase sb
!vm
::n-machine-word-bits
173 (32 'unsigned-byte-31
)
174 (64 'unsigned-byte-63
)))
176 (ecase sb
!vm
::n-machine-word-bits
177 (32 'unsigned-byte-32
)
178 (64 'unsigned-byte-64
))))
182 (#.
(ecase sb
!vm
::n-machine-word-bits
184 (64 'signed-byte-64
))
186 (#.
(ecase sb
!vm
::n-machine-word-bits
187 (32 'unsigned-byte-31
)
188 (64 'unsigned-byte-63
))
189 (primitive-type-or-lose
190 (ecase sb
!vm
::n-machine-word-bits
192 (64 'signed-byte-64
))))))
193 (#.
(ecase sb
!vm
::n-machine-word-bits
195 (64 'signed-byte-64
))
197 (ecase sb
!vm
::n-machine-word-bits
198 (32 'unsigned-byte-31
)
199 (64 'unsigned-byte-63
)))
201 (#.
(ecase sb
!vm
::n-machine-word-bits
202 (32 'unsigned-byte-31
)
203 (64 'unsigned-byte-63
))
205 (ecase sb
!vm
::n-machine-word-bits
206 (32 'unsigned-byte-32
)
207 (64 'unsigned-byte-64
)))
211 (let ((lo (numeric-type-low type
))
212 (hi (numeric-type-high type
)))
213 (case (numeric-type-complexp type
)
215 (case (numeric-type-class type
)
219 `((positive-fixnum 0 ,sb
!xc
:most-positive-fixnum
)
220 ,@(ecase sb
!vm
::n-machine-word-bits
225 0 ,(1- (ash 1 32)))))
230 0 ,(1- (ash 1 64))))))
231 (fixnum ,sb
!xc
:most-negative-fixnum
232 ,sb
!xc
:most-positive-fixnum
)
233 ,(ecase sb
!vm
::n-machine-word-bits
235 `(signed-byte-32 ,(ash -
1 31)
238 `(signed-byte-64 ,(ash -
1 63)
240 (if (or (< hi sb
!xc
:most-negative-fixnum
)
241 (> lo sb
!xc
:most-positive-fixnum
))
244 (let ((type (car spec
))
247 (when (<= min lo hi max
)
249 (primitive-type-or-lose type
)
250 (and (= lo min
) (= hi max
))))))))
251 ((or (and hi
(< hi sb
!xc
:most-negative-fixnum
))
252 (and lo
(> lo sb
!xc
:most-positive-fixnum
)))
257 (let ((exact (and (null lo
) (null hi
))))
258 (case (numeric-type-format type
)
259 ((short-float single-float
)
260 (values (primitive-type-or-lose 'single-float
)
263 (values (primitive-type-or-lose 'double-float
)
270 (if (eq (numeric-type-class type
) 'float
)
271 (let ((exact (and (null lo
) (null hi
))))
272 (case (numeric-type-format type
)
273 ((short-float single-float
)
274 (values (primitive-type-or-lose 'complex-single-float
)
276 ((double-float long-float
)
277 (values (primitive-type-or-lose 'complex-double-float
)
285 (if (array-type-complexp type
)
287 (let* ((dims (array-type-dimensions type
))
288 (etype (array-type-specialized-element-type type
))
289 (type-spec (type-specifier etype
))
290 ;; FIXME: We're _WHAT_? Testing for type equality
291 ;; with a specifier and #'EQUAL? *BOGGLE*. --
293 (ptype (cdr (assoc type-spec
*simple-array-primitive-types
*
295 (if (and (consp dims
) (null (rest dims
)) ptype
)
296 (values (primitive-type-or-lose ptype
)
297 (eq (first dims
) '*))
300 (if (type= type
(specifier-type 'list
))
302 (let ((types (union-type-types type
)))
303 (multiple-value-bind (res exact
) (primitive-type (first types
))
304 (dolist (type (rest types
) (values res exact
))
305 (multiple-value-bind (ptype ptype-exact
)
306 (primitive-type type
)
307 (unless ptype-exact
(setq exact nil
))
308 (unless (eq ptype res
)
310 (or (maybe-numeric-type-union res ptype
)
311 (maybe-numeric-type-union ptype res
))))
314 (return (any)))))))))))
316 (let ((types (intersection-type-types type
))
318 ;; why NIL for the exact? Well, we assume that the
319 ;; intersection type is in fact doing something for us:
320 ;; that is, that each of the types in the intersection is
321 ;; in fact cutting off some of the type lattice. Since no
322 ;; intersection type is represented by a primitive type and
323 ;; primitive types are mutually exclusive, it follows that
324 ;; no intersection type can represent the entirety of the
325 ;; primitive type. (And NIL is the conservative answer,
326 ;; anyway). -- CSR, 2006-09-14
327 (dolist (type types
(values res nil
))
328 (multiple-value-bind (ptype)
329 (primitive-type type
)
331 ;; if the result so far is (any), any improvement on
332 ;; the specificity of the primitive type is valid.
335 ;; if the primitive type returned is (any), the
336 ;; result so far is valid. Likewise, if the
337 ;; primitive type is the same as the result so far,
338 ;; everything is fine.
339 ((or (eq ptype
(any)) (eq ptype res
)))
340 ;; otherwise, we have something hairy and confusing,
341 ;; such as (and condition funcallable-instance).
343 (t (return (any))))))))
347 (mapc-member-type-members
349 (let ((ptype (primitive-type-of member
)))
351 (unless (eq ptype res
)
352 (let ((new-ptype (or (maybe-numeric-type-union res ptype
)
353 (maybe-numeric-type-union ptype res
))))
361 (ecase (named-type-name type
)
362 ((t *) (values *backend-t-primitive-type
* t
))
363 ((instance) (exactly instance
))
364 ((funcallable-instance) (part-of function
))
365 ((extended-sequence) (any))
368 (let ((pairs (character-set-type-pairs type
)))
369 (if (and (= (length pairs
) 1)
371 (= (cdar pairs
) (1- sb
!xc
:char-code-limit
)))
373 (part-of character
))))
375 (case (classoid-name type
)
376 ((complex function system-area-pointer weak-pointer
)
377 (values (primitive-type-or-lose (classoid-name type
)) t
))
385 (if (csubtypep type
(specifier-type 'function
))
389 (if (csubtypep type
(specifier-type 'function
))
393 (/show0
"primtype.lisp end of file")