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 29))
27 (/show0 "primtype.lisp 27")
29 (!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
30 :type (unsigned-byte 31))
31 (/show0 "primtype.lisp 31")
33 (!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
34 :type (unsigned-byte 32))
35 (/show0 "primtype.lisp 35")
37 (!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
38 :type (unsigned-byte 63))
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 30))
45 (!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
46 :type (signed-byte 32))
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))
55 (!def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32
56 #!-alpha unsigned-byte-31
57 #!+alpha unsigned-byte-64
58 #!+alpha unsigned-byte-63
60 (!def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32
61 #!+alpha signed-byte-64
63 #!-alpha unsigned-byte-31
64 #!+alpha unsigned-byte-63
67 ;;; other primitive immediate types
68 (/show0 "primtype.lisp 68")
69 (!def-primitive-type base-char (base-char-reg any-reg))
71 ;;; primitive pointer types
72 (/show0 "primtype.lisp 73")
73 (!def-primitive-type function (descriptor-reg))
74 (!def-primitive-type list (descriptor-reg))
75 (!def-primitive-type instance (descriptor-reg))
77 (/show0 "primtype.lisp 77")
78 (!def-primitive-type funcallable-instance (descriptor-reg))
80 ;;; primitive other-pointer number types
81 (/show0 "primtype.lisp 81")
82 (!def-primitive-type bignum (descriptor-reg))
83 (!def-primitive-type ratio (descriptor-reg))
84 (!def-primitive-type complex (descriptor-reg))
85 (/show0 "about to !DEF-PRIMITIVE-TYPE SINGLE-FLOAT")
86 (!def-primitive-type single-float (single-reg descriptor-reg))
87 (/show0 "about to !DEF-PRIMITIVE-TYPE DOUBLE-FLOAT")
88 (!def-primitive-type double-float (double-reg descriptor-reg))
90 (!def-primitive-type long-float (long-reg descriptor-reg))
91 (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-SINGLE-FLOAT")
92 (!def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
93 :type (complex single-float))
94 (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
95 (!def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
96 :type (complex double-float))
98 (!def-primitive-type complex-long-float (complex-long-reg descriptor-reg)
99 :type (complex long-float))
101 ;;; primitive other-pointer array types
102 (/show0 "primtype.lisp 96")
103 (!def-primitive-type simple-array-nil (descriptor-reg)
104 :type (simple-array nil (*)))
105 (!def-primitive-type simple-string (descriptor-reg)
106 :type simple-base-string)
107 (!def-primitive-type simple-bit-vector (descriptor-reg))
108 (!def-primitive-type simple-vector (descriptor-reg))
109 (!def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
110 :type (simple-array (unsigned-byte 2) (*)))
111 (!def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
112 :type (simple-array (unsigned-byte 4) (*)))
113 (!def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
114 :type (simple-array (unsigned-byte 8) (*)))
115 (!def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
116 :type (simple-array (unsigned-byte 16) (*)))
117 (!def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
118 :type (simple-array (unsigned-byte 32) (*)))
119 (!def-primitive-type simple-array-signed-byte-8 (descriptor-reg)
120 :type (simple-array (signed-byte 8) (*)))
121 (!def-primitive-type simple-array-signed-byte-16 (descriptor-reg)
122 :type (simple-array (signed-byte 16) (*)))
123 (!def-primitive-type simple-array-signed-byte-30 (descriptor-reg)
124 :type (simple-array (signed-byte 30) (*)))
125 (!def-primitive-type simple-array-signed-byte-32 (descriptor-reg)
126 :type (simple-array (signed-byte 32) (*)))
127 (!def-primitive-type simple-array-single-float (descriptor-reg)
128 :type (simple-array single-float (*)))
129 (!def-primitive-type simple-array-double-float (descriptor-reg)
130 :type (simple-array double-float (*)))
132 (!def-primitive-type simple-array-long-float (descriptor-reg)
133 :type (simple-array long-float (*)))
134 (!def-primitive-type simple-array-complex-single-float (descriptor-reg)
135 :type (simple-array (complex single-float) (*)))
136 (!def-primitive-type simple-array-complex-double-float (descriptor-reg)
137 :type (simple-array (complex double-float) (*)))
139 (!def-primitive-type simple-array-complex-long-float (descriptor-reg)
140 :type (simple-array (complex long-float) (*)))
142 ;;; Note: The complex array types are not included, 'cause it is
143 ;;; pointless to restrict VOPs to them.
145 ;;; other primitive other-pointer types
146 (!def-primitive-type system-area-pointer (sap-reg descriptor-reg))
147 (!def-primitive-type weak-pointer (descriptor-reg))
149 ;;; miscellaneous primitive types that don't exist at the LISP level
150 (!def-primitive-type catch-block (catch-block) :type nil)
152 ;;;; PRIMITIVE-TYPE-OF and friends
154 ;;; Return the most restrictive primitive type that contains OBJECT.
155 (/show0 "primtype.lisp 147")
156 (!def-vm-support-routine primitive-type-of (object)
157 (let ((type (ctype-of object)))
158 (cond ((not (member-type-p type)) (primitive-type type))
159 ((equal (member-type-members type) '(nil))
160 (primitive-type-or-lose 'list))
162 *backend-t-primitive-type*))))
164 (defvar *simple-array-primitive-types*
165 '((nil . simple-array-nil)
166 (base-char . simple-string)
167 (bit . simple-bit-vector)
168 ((unsigned-byte 2) . simple-array-unsigned-byte-2)
169 ((unsigned-byte 4) . simple-array-unsigned-byte-4)
170 ((unsigned-byte 8) . simple-array-unsigned-byte-8)
171 ((unsigned-byte 16) . simple-array-unsigned-byte-16)
172 ((unsigned-byte 32) . simple-array-unsigned-byte-32)
173 ((signed-byte 8) . simple-array-signed-byte-8)
174 ((signed-byte 16) . simple-array-signed-byte-16)
175 (fixnum . simple-array-signed-byte-30)
176 ((signed-byte 32) . simple-array-signed-byte-32)
177 (single-float . simple-array-single-float)
178 (double-float . simple-array-double-float)
179 #!+long-float (long-float . simple-array-long-float)
180 ((complex single-float) . simple-array-complex-single-float)
181 ((complex double-float) . simple-array-complex-double-float)
183 ((complex long-float) . simple-array-complex-long-float)
186 "An a-list for mapping simple array element types to their
187 corresponding primitive types.")
189 ;;; Return the primitive type corresponding to a type descriptor
190 ;;; structure. The second value is true when the primitive type is
191 ;;; exactly equivalent to the argument Lisp type.
193 ;;; In a bootstrapping situation, we should be careful to use the
194 ;;; correct values for the system parameters.
196 ;;; We need an aux function because we need to use both
197 ;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
198 (/show0 "primtype.lisp 188")
199 (!def-vm-support-routine primitive-type (type)
200 (primitive-type-aux type))
201 (/show0 "primtype.lisp 191")
202 (defun-cached (primitive-type-aux
203 :hash-function (lambda (x)
204 (logand (type-hash-value x) #x1FF))
207 :default (values nil :empty))
209 (declare (type ctype type))
210 (macrolet ((any () '(values *backend-t-primitive-type* nil))
212 `(values (primitive-type-or-lose ',type) t))
214 `(values (primitive-type-or-lose ',type) nil)))
215 (flet ((maybe-numeric-type-union (t1 t2)
216 (let ((t1-name (primitive-type-name t1))
217 (t2-name (primitive-type-name t2)))
220 (if (or (eq t2-name 'fixnum)
221 (eq t2-name #!-alpha 'signed-byte-32
222 #!+alpha 'signed-byte-64)
223 (eq t2-name #!-alpha 'unsigned-byte-31
224 #!+alpha 'unsigned-byte-63)
225 (eq t2-name #!-alpha 'unsigned-byte-32
226 #!+alpha 'unsigned-byte-64))
230 (#!-alpha signed-byte-32
231 #!+alpha signed-byte-64 t2)
232 (#!-alpha unsigned-byte-31
233 #!+alpha unsigned-byte-63
234 (primitive-type-or-lose
235 #!-alpha 'signed-byte-32
236 #!+alpha 'signed-byte-64))))
237 (#!-alpha signed-byte-32
238 #!+alpha signed-byte-64
239 (if (eq t2-name #!-alpha 'unsigned-byte-31
240 #!+alpha 'unsigned-byte-63)
242 (#!-alpha unsigned-byte-31
243 #!+alpha unsigned-byte-63
244 (if (eq t2-name #!-alpha 'unsigned-byte-32
245 #!+alpha 'unsigned-byte-64)
249 (let ((lo (numeric-type-low type))
250 (hi (numeric-type-high type)))
251 (case (numeric-type-complexp type)
253 (case (numeric-type-class type)
257 `((positive-fixnum 0 ,(1- (ash 1 29)))
259 (unsigned-byte-31 0 ,(1- (ash 1 31)))
261 (unsigned-byte-32 0 ,(1- (ash 1 32)))
263 (unsigned-byte-63 0 ,(1- (ash 1 63)))
265 (unsigned-byte-64 0 ,(1- (ash 1 64)))
269 (signed-byte-32 ,(ash -1 31)
272 (signed-byte-64 ,(ash -1 63)
274 (if (or (< hi (ash -1 29))
275 (> lo (1- (ash 1 29))))
278 (let ((type (car spec))
281 (when (<= min lo hi max)
283 (primitive-type-or-lose type)
284 (and (= lo min) (= hi max))))))))
285 ((or (and hi (< hi most-negative-fixnum))
286 (and lo (> lo most-positive-fixnum)))
291 (let ((exact (and (null lo) (null hi))))
292 (case (numeric-type-format type)
293 ((short-float single-float)
294 (values (primitive-type-or-lose 'single-float)
296 ((double-float #!-long-float long-float)
297 (values (primitive-type-or-lose 'double-float)
301 (values (primitive-type-or-lose 'long-float)
308 (if (eq (numeric-type-class type) 'float)
309 (let ((exact (and (null lo) (null hi))))
310 (case (numeric-type-format type)
311 ((short-float single-float)
312 (values (primitive-type-or-lose 'complex-single-float)
314 ((double-float #!-long-float long-float)
315 (values (primitive-type-or-lose 'complex-double-float)
319 (values (primitive-type-or-lose 'complex-long-float)
327 (if (array-type-complexp type)
329 (let* ((dims (array-type-dimensions type))
330 (etype (array-type-specialized-element-type type))
331 (type-spec (type-specifier etype))
332 (ptype (cdr (assoc type-spec *simple-array-primitive-types*
334 (if (and (consp dims) (null (rest dims)) ptype)
335 (values (primitive-type-or-lose ptype)
336 (eq (first dims) '*))
339 (if (type= type (specifier-type 'list))
341 (let ((types (union-type-types type)))
342 (multiple-value-bind (res exact) (primitive-type (first types))
343 (dolist (type (rest types) (values res exact))
344 (multiple-value-bind (ptype ptype-exact)
345 (primitive-type type)
346 (unless ptype-exact (setq exact nil))
347 (unless (eq ptype res)
349 (or (maybe-numeric-type-union res ptype)
350 (maybe-numeric-type-union ptype res))))
353 (return (any)))))))))))
355 (let* ((members (member-type-members type))
356 (res (primitive-type-of (first members))))
357 (dolist (mem (rest members) (values res nil))
358 (let ((ptype (primitive-type-of mem)))
359 (unless (eq ptype res)
360 (let ((new-ptype (or (maybe-numeric-type-union res ptype)
361 (maybe-numeric-type-union ptype res))))
364 (return (any)))))))))
366 (ecase (named-type-name type)
367 ((t *) (values *backend-t-primitive-type* t))
370 (case (classoid-name type)
371 ((complex function instance
372 system-area-pointer weak-pointer)
373 (values (primitive-type-or-lose (classoid-name type)) t))
374 (funcallable-instance
385 (if (csubtypep type (specifier-type 'function))
389 (if (csubtypep type (specifier-type 'function))
393 (/show0 "primtype.lisp end of file")