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 (/show0 "about to !DEF-PRIMITIVE-TYPE SIMD-PACK")
101 (!def-primitive-type simd-pack-single (single-sse-reg descriptor-reg)
102 :type (simd-pack single-float))
103 (!def-primitive-type simd-pack-double (double-sse-reg descriptor-reg)
104 :type (simd-pack double-float))
105 (!def-primitive-type simd-pack-int (int-sse-reg descriptor-reg)
106 :type (simd-pack integer))
107 (!def-primitive-type-alias simd-pack (:or simd-pack-single simd-pack-double simd-pack-int)))
109 ;;; primitive other-pointer array types
110 (/show0 "primtype.lisp 96")
111 (macrolet ((define-simple-array-primitive-types ()
115 `(!def-primitive-type
116 ,(saetp-primitive-type-name saetp)
118 :type (simple-array ,(saetp-specifier saetp) (*))))
119 *specialized-array-element-type-properties*))))
120 (define-simple-array-primitive-types))
121 ;;; Note: The complex array types are not included, 'cause it is
122 ;;; pointless to restrict VOPs to them.
124 ;;; other primitive other-pointer types
125 (!def-primitive-type system-area-pointer (sap-reg descriptor-reg))
126 (!def-primitive-type weak-pointer (descriptor-reg))
128 ;;; miscellaneous primitive types that don't exist at the LISP level
129 (!def-primitive-type catch-block (catch-block) :type nil)
131 ;;;; PRIMITIVE-TYPE-OF and friends
133 ;;; Return the most restrictive primitive type that contains OBJECT.
134 (/show0 "primtype.lisp 147")
135 (defun primitive-type-of (object)
136 (let ((type (ctype-of object)))
137 (cond ((not (member-type-p type)) (primitive-type type))
138 ((and (eql 1 (member-type-size type))
139 (equal (member-type-members type) '(nil)))
140 (primitive-type-or-lose 'list))
142 *backend-t-primitive-type*))))
144 ;;; Return the primitive type corresponding to a type descriptor
145 ;;; structure. The second value is true when the primitive type is
146 ;;; exactly equivalent to the argument Lisp type.
148 ;;; In a bootstrapping situation, we should be careful to use the
149 ;;; correct values for the system parameters.
151 ;;; We need an aux function because we need to use both
152 ;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
153 (/show0 "primtype.lisp 188")
154 (defun primitive-type (type)
155 (sb!kernel::maybe-reparse-specifier! type)
156 (primitive-type-aux type))
157 (/show0 "primtype.lisp 191")
158 (defun-cached (primitive-type-aux
159 :hash-function (lambda (x)
160 (logand (type-hash-value x) #x1FF))
163 :default (values nil :empty))
165 (declare (type ctype type))
166 (macrolet ((any () '(values *backend-t-primitive-type* nil))
168 `(values (primitive-type-or-lose ',type) t))
170 `(values (primitive-type-or-lose ',type) nil)))
171 (flet ((maybe-numeric-type-union (t1 t2)
172 (let ((t1-name (primitive-type-name t1))
173 (t2-name (primitive-type-name t2)))
176 (if (or (eq t2-name 'fixnum)
178 (ecase sb!vm::n-machine-word-bits
180 (64 'signed-byte-64)))
182 (ecase sb!vm::n-machine-word-bits
183 (32 'unsigned-byte-31)
184 (64 'unsigned-byte-63)))
186 (ecase sb!vm::n-machine-word-bits
187 (32 'unsigned-byte-32)
188 (64 'unsigned-byte-64))))
192 (#.(ecase sb!vm::n-machine-word-bits
194 (64 'signed-byte-64))
196 (#.(ecase sb!vm::n-machine-word-bits
197 (32 'unsigned-byte-31)
198 (64 'unsigned-byte-63))
199 (primitive-type-or-lose
200 (ecase sb!vm::n-machine-word-bits
202 (64 'signed-byte-64))))))
203 (#.(ecase sb!vm::n-machine-word-bits
205 (64 'signed-byte-64))
207 (ecase sb!vm::n-machine-word-bits
208 (32 'unsigned-byte-31)
209 (64 'unsigned-byte-63)))
211 (#.(ecase sb!vm::n-machine-word-bits
212 (32 'unsigned-byte-31)
213 (64 'unsigned-byte-63))
215 (ecase sb!vm::n-machine-word-bits
216 (32 'unsigned-byte-32)
217 (64 'unsigned-byte-64)))
221 (let ((lo (numeric-type-low type))
222 (hi (numeric-type-high type)))
223 (case (numeric-type-complexp type)
225 (case (numeric-type-class type)
229 `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
230 ,@(ecase sb!vm::n-machine-word-bits
235 0 ,(1- (ash 1 32)))))
240 0 ,(1- (ash 1 64))))))
241 (fixnum ,sb!xc:most-negative-fixnum
242 ,sb!xc:most-positive-fixnum)
243 ,(ecase sb!vm::n-machine-word-bits
245 `(signed-byte-32 ,(ash -1 31)
248 `(signed-byte-64 ,(ash -1 63)
250 (if (or (< hi sb!xc:most-negative-fixnum)
251 (> lo sb!xc:most-positive-fixnum))
254 (let ((type (car spec))
257 (when (<= min lo hi max)
259 (primitive-type-or-lose type)
260 (and (= lo min) (= hi max))))))))
261 ((or (and hi (< hi sb!xc:most-negative-fixnum))
262 (and lo (> lo sb!xc:most-positive-fixnum)))
267 (let ((exact (and (null lo) (null hi))))
268 (case (numeric-type-format type)
269 ((short-float single-float)
270 (values (primitive-type-or-lose 'single-float)
273 (values (primitive-type-or-lose 'double-float)
280 (if (eq (numeric-type-class type) 'float)
281 (let ((exact (and (null lo) (null hi))))
282 (case (numeric-type-format type)
283 ((short-float single-float)
284 (values (primitive-type-or-lose 'complex-single-float)
286 ((double-float long-float)
287 (values (primitive-type-or-lose 'complex-double-float)
295 (if (array-type-complexp type)
297 (let* ((dims (array-type-dimensions type))
298 (etype (array-type-specialized-element-type type))
299 (type-spec (type-specifier etype))
300 ;; FIXME: We're _WHAT_? Testing for type equality
301 ;; with a specifier and #'EQUAL? *BOGGLE*. --
303 (ptype (cdr (assoc type-spec *simple-array-primitive-types*
305 (if (and (consp dims) (null (rest dims)) ptype)
306 (values (primitive-type-or-lose ptype)
307 (eq (first dims) '*))
310 (if (type= type (specifier-type 'list))
312 (let ((types (union-type-types type)))
313 (multiple-value-bind (res exact) (primitive-type (first types))
314 (dolist (type (rest types) (values res exact))
315 (multiple-value-bind (ptype ptype-exact)
316 (primitive-type type)
317 (unless ptype-exact (setq exact nil))
318 (unless (eq ptype res)
320 (or (maybe-numeric-type-union res ptype)
321 (maybe-numeric-type-union ptype res))))
324 (return (any)))))))))))
326 (let ((types (intersection-type-types type))
328 ;; why NIL for the exact? Well, we assume that the
329 ;; intersection type is in fact doing something for us:
330 ;; that is, that each of the types in the intersection is
331 ;; in fact cutting off some of the type lattice. Since no
332 ;; intersection type is represented by a primitive type and
333 ;; primitive types are mutually exclusive, it follows that
334 ;; no intersection type can represent the entirety of the
335 ;; primitive type. (And NIL is the conservative answer,
336 ;; anyway). -- CSR, 2006-09-14
337 (dolist (type types (values res nil))
338 (multiple-value-bind (ptype)
339 (primitive-type type)
341 ;; if the result so far is (any), any improvement on
342 ;; the specificity of the primitive type is valid.
345 ;; if the primitive type returned is (any), the
346 ;; result so far is valid. Likewise, if the
347 ;; primitive type is the same as the result so far,
348 ;; everything is fine.
349 ((or (eq ptype (any)) (eq ptype res)))
350 ;; otherwise, we have something hairy and confusing,
351 ;; such as (and condition funcallable-instance).
353 (t (return (any))))))))
357 (mapc-member-type-members
359 (let ((ptype (primitive-type-of member)))
361 (unless (eq ptype res)
362 (let ((new-ptype (or (maybe-numeric-type-union res ptype)
363 (maybe-numeric-type-union ptype res))))
371 (ecase (named-type-name type)
372 ((t *) (values *backend-t-primitive-type* t))
373 ((instance) (exactly instance))
374 ((funcallable-instance) (part-of function))
375 ((extended-sequence) (any))
378 (let ((pairs (character-set-type-pairs type)))
379 (if (and (= (length pairs) 1)
381 (= (cdar pairs) (1- sb!xc:char-code-limit)))
383 (part-of character))))
386 (let ((eltypes (simd-pack-type-element-type type)))
387 (cond ((member 'integer eltypes)
388 (exactly simd-pack-int))
389 ((member 'single-float eltypes)
390 (exactly simd-pack-single))
391 ((member 'double-float eltypes)
392 (exactly simd-pack-double)))))
394 (case (classoid-name type)
396 ;; Can't tell what specific type; assume integers.
398 (exactly simd-pack-int))
399 ((complex function system-area-pointer weak-pointer)
400 (values (primitive-type-or-lose (classoid-name type)) t))
408 (if (csubtypep type (specifier-type 'function))
412 (if (csubtypep type (specifier-type 'function))
416 (/show0 "primtype.lisp end of file")