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 (def-primitive-type t (descriptor-reg))
18 (setf *backend-t-primitive-type* (primitive-type-or-lose 't))
20 ;;; primitive integer types that fit in registers
21 (def-primitive-type positive-fixnum (any-reg signed-reg unsigned-reg)
22 :type (unsigned-byte 29))
24 (def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
25 :type (unsigned-byte 31))
27 (def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
28 :type (unsigned-byte 32))
30 (def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
31 :type (unsigned-byte 63))
33 (def-primitive-type unsigned-byte-64 (unsigned-reg descriptor-reg)
34 :type (unsigned-byte 64))
35 (def-primitive-type fixnum (any-reg signed-reg)
36 :type (signed-byte 30))
38 (def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
39 :type (signed-byte 32))
41 (def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
42 :type (signed-byte 64))
44 (defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
46 (def-primitive-type-alias tagged-num (:or positive-fixnum fixnum))
47 (def-primitive-type-alias unsigned-num (:or #!-alpha unsigned-byte-32
48 #!-alpha unsigned-byte-31
49 #!+alpha unsigned-byte-64
50 #!+alpha unsigned-byte-63
52 (def-primitive-type-alias signed-num (:or #!-alpha signed-byte-32
53 #!+alpha signed-byte-64
55 #!-alpha unsigned-byte-31
56 #!+alpha unsigned-byte-63
59 ;;; other primitive immediate types
60 (def-primitive-type base-char (base-char-reg any-reg))
62 ;;; primitive pointer types
63 (def-primitive-type function (descriptor-reg))
64 (def-primitive-type list (descriptor-reg))
65 (def-primitive-type instance (descriptor-reg))
67 (def-primitive-type funcallable-instance (descriptor-reg))
69 ;;; primitive other-pointer number types
70 (def-primitive-type bignum (descriptor-reg))
71 (def-primitive-type ratio (descriptor-reg))
72 (def-primitive-type complex (descriptor-reg))
73 (def-primitive-type single-float (single-reg descriptor-reg))
74 (def-primitive-type double-float (double-reg descriptor-reg))
76 (def-primitive-type long-float (long-reg descriptor-reg))
77 (def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
78 :type (complex single-float))
79 (def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
80 :type (complex double-float))
82 (def-primitive-type complex-long-float (complex-long-reg descriptor-reg)
83 :type (complex long-float))
85 ;;; primitive other-pointer array types
86 (def-primitive-type simple-string (descriptor-reg)
87 :type simple-base-string)
88 (def-primitive-type simple-bit-vector (descriptor-reg))
89 (def-primitive-type simple-vector (descriptor-reg))
90 (def-primitive-type simple-array-unsigned-byte-2 (descriptor-reg)
91 :type (simple-array (unsigned-byte 2) (*)))
92 (def-primitive-type simple-array-unsigned-byte-4 (descriptor-reg)
93 :type (simple-array (unsigned-byte 4) (*)))
94 (def-primitive-type simple-array-unsigned-byte-8 (descriptor-reg)
95 :type (simple-array (unsigned-byte 8) (*)))
96 (def-primitive-type simple-array-unsigned-byte-16 (descriptor-reg)
97 :type (simple-array (unsigned-byte 16) (*)))
98 (def-primitive-type simple-array-unsigned-byte-32 (descriptor-reg)
99 :type (simple-array (unsigned-byte 32) (*)))
100 (def-primitive-type simple-array-signed-byte-8 (descriptor-reg)
101 :type (simple-array (signed-byte 8) (*)))
102 (def-primitive-type simple-array-signed-byte-16 (descriptor-reg)
103 :type (simple-array (signed-byte 16) (*)))
104 (def-primitive-type simple-array-signed-byte-30 (descriptor-reg)
105 :type (simple-array (signed-byte 30) (*)))
106 (def-primitive-type simple-array-signed-byte-32 (descriptor-reg)
107 :type (simple-array (signed-byte 32) (*)))
108 (def-primitive-type simple-array-single-float (descriptor-reg)
109 :type (simple-array single-float (*)))
110 (def-primitive-type simple-array-double-float (descriptor-reg)
111 :type (simple-array double-float (*)))
113 (def-primitive-type simple-array-long-float (descriptor-reg)
114 :type (simple-array long-float (*)))
115 (def-primitive-type simple-array-complex-single-float (descriptor-reg)
116 :type (simple-array (complex single-float) (*)))
117 (def-primitive-type simple-array-complex-double-float (descriptor-reg)
118 :type (simple-array (complex double-float) (*)))
120 (def-primitive-type simple-array-complex-long-float (descriptor-reg)
121 :type (simple-array (complex long-float) (*)))
123 ;;; Note: The complex array types are not included, 'cause it is pointless to
124 ;;; restrict VOPs to them.
126 ;;; other primitive other-pointer types
127 (def-primitive-type system-area-pointer (sap-reg descriptor-reg))
128 (def-primitive-type weak-pointer (descriptor-reg))
130 ;;; miscellaneous primitive types that don't exist at the LISP level
131 (def-primitive-type catch-block (catch-block) :type nil)
133 ;;;; PRIMITIVE-TYPE-OF and friends
135 ;;; Return the most restrictive primitive type that contains Object.
136 (def-vm-support-routine primitive-type-of (object)
137 (let ((type (ctype-of object)))
138 (cond ((not (member-type-p type)) (primitive-type type))
139 ((equal (member-type-members type) '(nil))
140 (primitive-type-or-lose 'list))
142 *backend-t-primitive-type*))))
144 (defvar *simple-array-primitive-types*
145 '((base-char . simple-string)
146 (bit . simple-bit-vector)
147 ((unsigned-byte 2) . simple-array-unsigned-byte-2)
148 ((unsigned-byte 4) . simple-array-unsigned-byte-4)
149 ((unsigned-byte 8) . simple-array-unsigned-byte-8)
150 ((unsigned-byte 16) . simple-array-unsigned-byte-16)
151 ((unsigned-byte 32) . simple-array-unsigned-byte-32)
152 ((signed-byte 8) . simple-array-signed-byte-8)
153 ((signed-byte 16) . simple-array-signed-byte-16)
154 (fixnum . simple-array-signed-byte-30)
155 ((signed-byte 32) . simple-array-signed-byte-32)
156 (single-float . simple-array-single-float)
157 (double-float . simple-array-double-float)
158 #!+long-float (long-float . simple-array-long-float)
159 ((complex single-float) . simple-array-complex-single-float)
160 ((complex double-float) . simple-array-complex-double-float)
162 ((complex long-float) . simple-array-complex-long-float)
165 "An a-list for mapping simple array element types to their
166 corresponding primitive types.")
168 ;;; Return the primitive type corresponding to a type descriptor
169 ;;; structure. The second value is true when the primitive type is
170 ;;; exactly equivalent to the argument Lisp type.
172 ;;; In a bootstrapping situation, we should be careful to use the
173 ;;; correct values for the system parameters.
175 ;;; We need an aux function because we need to use both def-vm-support-routine
176 ;;; and defun-cached.
177 (def-vm-support-routine primitive-type (type)
178 (primitive-type-aux type))
179 (defun-cached (primitive-type-aux
180 :hash-function (lambda (x)
181 (logand (type-hash-value x) #x1FF))
184 :default (values nil :empty))
186 (declare (type ctype type))
187 (macrolet ((any () '(values *backend-t-primitive-type* nil))
189 `(values (primitive-type-or-lose ',type) t))
191 `(values (primitive-type-or-lose ',type) nil)))
192 (flet ((maybe-numeric-type-union (t1 t2)
193 (let ((t1-name (primitive-type-name t1))
194 (t2-name (primitive-type-name t2)))
197 (if (or (eq t2-name 'fixnum)
198 (eq t2-name #!-alpha 'signed-byte-32
199 #!+alpha 'signed-byte-64)
200 (eq t2-name #!-alpha 'unsigned-byte-31
201 #!+alpha 'unsigned-byte-63)
202 (eq t2-name #!-alpha 'unsigned-byte-32
203 #!+alpha 'unsigned-byte-64))
207 (#!-alpha signed-byte-32
208 #!+alpha signed-byte-64 t2)
209 (#!-alpha unsigned-byte-31
210 #!+alpha unsigned-byte-63
211 (primitive-type-or-lose
212 #!-alpha 'signed-byte-32
213 #!+alpha 'signed-byte-64))))
214 (#!-alpha signed-byte-32
215 #!+alpha signed-byte-64
216 (if (eq t2-name #!-alpha 'unsigned-byte-31
217 #!+alpha 'unsigned-byte-63)
219 (#!-alpha unsigned-byte-31
220 #!+alpha unsigned-byte-63
221 (if (eq t2-name #!-alpha 'unsigned-byte-32
222 #!+alpha 'unsigned-byte-64)
226 (let ((lo (numeric-type-low type))
227 (hi (numeric-type-high type)))
228 (case (numeric-type-complexp type)
230 (case (numeric-type-class type)
234 `((positive-fixnum 0 ,(1- (ash 1 29)))
236 (unsigned-byte-31 0 ,(1- (ash 1 31)))
238 (unsigned-byte-32 0 ,(1- (ash 1 32)))
240 (unsigned-byte-63 0 ,(1- (ash 1 63)))
242 (unsigned-byte-64 0 ,(1- (ash 1 64)))
246 (signed-byte-32 ,(ash -1 31)
249 (signed-byte-64 ,(ash -1 63)
251 (if (or (< hi (ash -1 29))
252 (> lo (1- (ash 1 29))))
255 (let ((type (car spec))
258 (when (<= min lo hi max)
260 (primitive-type-or-lose type)
261 (and (= lo min) (= hi max))))))))
262 ((or (and hi (< hi most-negative-fixnum))
263 (and lo (> lo most-positive-fixnum)))
268 (let ((exact (and (null lo) (null hi))))
269 (case (numeric-type-format type)
270 ((short-float single-float)
271 (values (primitive-type-or-lose 'single-float)
273 ((double-float #!-long-float long-float)
274 (values (primitive-type-or-lose 'double-float)
278 (values (primitive-type-or-lose 'long-float)
285 (if (eq (numeric-type-class type) 'float)
286 (let ((exact (and (null lo) (null hi))))
287 (case (numeric-type-format type)
288 ((short-float single-float)
289 (values (primitive-type-or-lose 'complex-single-float)
291 ((double-float #!-long-float long-float)
292 (values (primitive-type-or-lose 'complex-double-float)
296 (values (primitive-type-or-lose 'complex-long-float)
304 (if (array-type-complexp type)
306 (let* ((dims (array-type-dimensions type))
307 (etype (array-type-specialized-element-type type))
308 (type-spec (type-specifier etype))
309 (ptype (cdr (assoc type-spec *simple-array-primitive-types*
311 (if (and (consp dims) (null (rest dims)) ptype)
312 (values (primitive-type-or-lose ptype)
313 (eq (first dims) '*))
316 (if (type= type (specifier-type 'list))
318 (let ((types (union-type-types type)))
319 (multiple-value-bind (res exact) (primitive-type (first types))
320 (dolist (type (rest types) (values res exact))
321 (multiple-value-bind (ptype ptype-exact)
322 (primitive-type type)
323 (unless ptype-exact (setq exact nil))
324 (unless (eq ptype res)
326 (or (maybe-numeric-type-union res ptype)
327 (maybe-numeric-type-union ptype res))))
330 (return (any)))))))))))
332 (let* ((members (member-type-members type))
333 (res (primitive-type-of (first members))))
334 (dolist (mem (rest members) (values res nil))
335 (let ((ptype (primitive-type-of mem)))
336 (unless (eq ptype res)
337 (let ((new-ptype (or (maybe-numeric-type-union res ptype)
338 (maybe-numeric-type-union ptype res))))
341 (return (any)))))))))
343 (ecase (named-type-name type)
344 ((t *) (values *backend-t-primitive-type* t))
346 (sb!xc:built-in-class
347 (case (sb!xc:class-name type)
348 ((complex function instance
349 system-area-pointer weak-pointer)
350 (values (primitive-type-or-lose (sb!xc:class-name type)) t))
351 (funcallable-instance
355 ;; MNA: cons compound-type patch
356 ;; FIXIT: all commented out
366 (if (csubtypep type (specifier-type 'function))