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))
55 (!def-primitive-type-alias unsigned-num
56 #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
57 (:or unsigned-byte-64 unsigned-byte-63 positive-fixnum)
58 #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
59 (:or unsigned-byte-32 unsigned-byte-31 positive-fixnum))
60 (!def-primitive-type-alias signed-num
61 #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
62 (:or signed-byte-64 fixnum unsigned-byte-63 positive-fixnum)
63 #!-#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
64 (:or signed-byte-32 fixnum unsigned-byte-31 positive-fixnum))
66 ;;; other primitive immediate types
67 (/show0 "primtype.lisp 68")
68 (!def-primitive-type character (character-reg any-reg))
70 ;;; primitive pointer types
71 (/show0 "primtype.lisp 73")
72 (!def-primitive-type function (descriptor-reg))
73 (!def-primitive-type list (descriptor-reg))
74 (!def-primitive-type instance (descriptor-reg))
76 (/show0 "primtype.lisp 77")
77 (!def-primitive-type funcallable-instance (descriptor-reg))
79 ;;; primitive other-pointer number types
80 (/show0 "primtype.lisp 81")
81 (!def-primitive-type bignum (descriptor-reg))
82 (!def-primitive-type ratio (descriptor-reg))
83 (!def-primitive-type complex (descriptor-reg))
84 (/show0 "about to !DEF-PRIMITIVE-TYPE SINGLE-FLOAT")
85 (!def-primitive-type single-float (single-reg descriptor-reg))
86 (/show0 "about to !DEF-PRIMITIVE-TYPE DOUBLE-FLOAT")
87 (!def-primitive-type double-float (double-reg descriptor-reg))
89 (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-SINGLE-FLOAT")
90 (!def-primitive-type complex-single-float (complex-single-reg descriptor-reg)
91 :type (complex single-float))
92 (/show0 "about to !DEF-PRIMITIVE-TYPE COMPLEX-DOUBLE-FLOAT")
93 (!def-primitive-type complex-double-float (complex-double-reg descriptor-reg)
94 :type (complex double-float))
97 ;;; primitive other-pointer array types
98 (/show0 "primtype.lisp 96")
99 (macrolet ((define-simple-array-primitive-types ()
103 `(!def-primitive-type
104 ,(saetp-primitive-type-name saetp)
106 :type (simple-array ,(saetp-specifier saetp) (*))))
107 *specialized-array-element-type-properties*))))
108 (define-simple-array-primitive-types))
109 ;;; Note: The complex array types are not included, 'cause it is
110 ;;; pointless to restrict VOPs to them.
112 ;;; other primitive other-pointer types
113 (!def-primitive-type system-area-pointer (sap-reg descriptor-reg))
114 (!def-primitive-type weak-pointer (descriptor-reg))
116 ;;; miscellaneous primitive types that don't exist at the LISP level
117 (!def-primitive-type catch-block (catch-block) :type nil)
119 ;;;; PRIMITIVE-TYPE-OF and friends
121 ;;; Return the most restrictive primitive type that contains OBJECT.
122 (/show0 "primtype.lisp 147")
123 (!def-vm-support-routine primitive-type-of (object)
124 (let ((type (ctype-of object)))
125 (cond ((not (member-type-p type)) (primitive-type type))
126 ((equal (member-type-members type) '(nil))
127 (primitive-type-or-lose 'list))
129 *backend-t-primitive-type*))))
131 ;;; Return the primitive type corresponding to a type descriptor
132 ;;; structure. The second value is true when the primitive type is
133 ;;; exactly equivalent to the argument Lisp type.
135 ;;; In a bootstrapping situation, we should be careful to use the
136 ;;; correct values for the system parameters.
138 ;;; We need an aux function because we need to use both
139 ;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
140 (/show0 "primtype.lisp 188")
141 (!def-vm-support-routine primitive-type (type)
142 (primitive-type-aux type))
143 (/show0 "primtype.lisp 191")
144 (defun-cached (primitive-type-aux
145 :hash-function (lambda (x)
146 (logand (type-hash-value x) #x1FF))
149 :default (values nil :empty))
151 (declare (type ctype type))
152 (macrolet ((any () '(values *backend-t-primitive-type* nil))
154 `(values (primitive-type-or-lose ',type) t))
156 `(values (primitive-type-or-lose ',type) nil)))
157 (flet ((maybe-numeric-type-union (t1 t2)
158 (let ((t1-name (primitive-type-name t1))
159 (t2-name (primitive-type-name t2)))
162 (if (or (eq t2-name 'fixnum)
164 (ecase sb!vm::n-machine-word-bits
166 (64 'signed-byte-64)))
168 (ecase sb!vm::n-machine-word-bits
169 (32 'unsigned-byte-31)
170 (64 'unsigned-byte-63)))
172 (ecase sb!vm::n-machine-word-bits
173 (32 'unsigned-byte-32)
174 (64 'unsigned-byte-64))))
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))
185 (primitive-type-or-lose
186 (ecase sb!vm::n-machine-word-bits
188 (64 'signed-byte-64))))))
189 (#.(ecase sb!vm::n-machine-word-bits
191 (64 'signed-byte-64))
193 (ecase sb!vm::n-machine-word-bits
194 (32 'unsigned-byte-31)
195 (64 'unsigned-byte-63)))
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-32)
203 (64 'unsigned-byte-64)))
207 (let ((lo (numeric-type-low type))
208 (hi (numeric-type-high type)))
209 (case (numeric-type-complexp type)
211 (case (numeric-type-class type)
215 `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
216 ,@(ecase sb!vm::n-machine-word-bits
221 0 ,(1- (ash 1 32)))))
226 0 ,(1- (ash 1 64))))))
227 (fixnum ,sb!xc:most-negative-fixnum
228 ,sb!xc:most-positive-fixnum)
229 ,(ecase sb!vm::n-machine-word-bits
231 `(signed-byte-32 ,(ash -1 31)
234 `(signed-byte-64 ,(ash -1 63)
236 (if (or (< hi sb!xc:most-negative-fixnum)
237 (> lo sb!xc:most-positive-fixnum))
240 (let ((type (car spec))
243 (when (<= min lo hi max)
245 (primitive-type-or-lose type)
246 (and (= lo min) (= hi max))))))))
247 ((or (and hi (< hi sb!xc:most-negative-fixnum))
248 (and lo (> lo sb!xc:most-positive-fixnum)))
253 (let ((exact (and (null lo) (null hi))))
254 (case (numeric-type-format type)
255 ((short-float single-float)
256 (values (primitive-type-or-lose 'single-float)
259 (values (primitive-type-or-lose 'double-float)
266 (if (eq (numeric-type-class type) 'float)
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 'complex-single-float)
272 ((double-float long-float)
273 (values (primitive-type-or-lose 'complex-double-float)
281 (if (array-type-complexp type)
283 (let* ((dims (array-type-dimensions type))
284 (etype (array-type-specialized-element-type type))
285 (type-spec (type-specifier etype))
286 ;; FIXME: We're _WHAT_? Testing for type equality
287 ;; with a specifier and #'EQUAL? *BOGGLE*. --
289 (ptype (cdr (assoc type-spec *simple-array-primitive-types*
291 (if (and (consp dims) (null (rest dims)) ptype)
292 (values (primitive-type-or-lose ptype)
293 (eq (first dims) '*))
296 (if (type= type (specifier-type 'list))
298 (let ((types (union-type-types type)))
299 (multiple-value-bind (res exact) (primitive-type (first types))
300 (dolist (type (rest types) (values res exact))
301 (multiple-value-bind (ptype ptype-exact)
302 (primitive-type type)
303 (unless ptype-exact (setq exact nil))
304 (unless (eq ptype res)
306 (or (maybe-numeric-type-union res ptype)
307 (maybe-numeric-type-union ptype res))))
310 (return (any)))))))))))
312 (let ((types (intersection-type-types type))
315 (dolist (type types (values res exact))
316 (when (eq type (specifier-type 'function))
317 ;; KLUDGE: Deal with (and function instance), both of which
318 ;; have an exact primitive type.
319 (return (part-of function)))
320 (multiple-value-bind (ptype ptype-exact)
321 (primitive-type type)
323 ;; Apart from the previous kludge exact primitive
324 ;; types should match, if indeed there are any. It
325 ;; may be that this assumption isn't really safe,
326 ;; but at least we'll see what breaks. -- NS 20041104
327 (aver (or (not exact) (eq ptype res)))
329 (when (or ptype-exact (and (not exact) (eq res (any))))
330 ;; Try to find a narrower representation then
331 ;; (any). Takes care of undecidable types in
332 ;; intersections with decidable ones.
333 (setq res ptype))))))
335 (let* ((members (member-type-members type))
336 (res (primitive-type-of (first members))))
337 (dolist (mem (rest members) (values res nil))
338 (let ((ptype (primitive-type-of mem)))
339 (unless (eq ptype res)
340 (let ((new-ptype (or (maybe-numeric-type-union res ptype)
341 (maybe-numeric-type-union ptype res))))
344 (return (any)))))))))
346 (ecase (named-type-name type)
347 ((t *) (values *backend-t-primitive-type* t))
350 (let ((pairs (character-set-type-pairs type)))
351 (if (and (= (length pairs) 1)
353 (= (cdar pairs) (1- sb!xc:char-code-limit)))
355 (part-of character))))
357 (case (classoid-name type)
358 ((complex function instance
359 system-area-pointer weak-pointer)
360 (values (primitive-type-or-lose (classoid-name type)) t))
361 (funcallable-instance
370 (if (csubtypep type (specifier-type 'function))
374 (if (csubtypep type (specifier-type 'function))
378 (/show0 "primtype.lisp end of file")