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 . #.(print (union (cdr '#1#) (cdr '#2#))))))
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 ((equal (member-type-members type) '(nil))
130 (primitive-type-or-lose 'list))
132 *backend-t-primitive-type*))))
134 ;;; Return the primitive type corresponding to a type descriptor
135 ;;; structure. The second value is true when the primitive type is
136 ;;; exactly equivalent to the argument Lisp type.
138 ;;; In a bootstrapping situation, we should be careful to use the
139 ;;; correct values for the system parameters.
141 ;;; We need an aux function because we need to use both
142 ;;; !DEF-VM-SUPPORT-ROUTINE and DEFUN-CACHED.
143 (/show0 "primtype.lisp 188")
144 (!def-vm-support-routine primitive-type (type)
145 (primitive-type-aux type))
146 (/show0 "primtype.lisp 191")
147 (defun-cached (primitive-type-aux
148 :hash-function (lambda (x)
149 (logand (type-hash-value x) #x1FF))
152 :default (values nil :empty))
154 (declare (type ctype type))
155 (macrolet ((any () '(values *backend-t-primitive-type* nil))
157 `(values (primitive-type-or-lose ',type) t))
159 `(values (primitive-type-or-lose ',type) nil)))
160 (flet ((maybe-numeric-type-union (t1 t2)
161 (let ((t1-name (primitive-type-name t1))
162 (t2-name (primitive-type-name t2)))
165 (if (or (eq t2-name 'fixnum)
167 (ecase sb!vm::n-machine-word-bits
169 (64 'signed-byte-64)))
171 (ecase sb!vm::n-machine-word-bits
172 (32 'unsigned-byte-31)
173 (64 'unsigned-byte-63)))
175 (ecase sb!vm::n-machine-word-bits
176 (32 'unsigned-byte-32)
177 (64 'unsigned-byte-64))))
181 (#.(ecase sb!vm::n-machine-word-bits
183 (64 'signed-byte-64))
185 (#.(ecase sb!vm::n-machine-word-bits
186 (32 'unsigned-byte-31)
187 (64 'unsigned-byte-63))
188 (primitive-type-or-lose
189 (ecase sb!vm::n-machine-word-bits
191 (64 'signed-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)))
200 (#.(ecase sb!vm::n-machine-word-bits
201 (32 'unsigned-byte-31)
202 (64 'unsigned-byte-63))
204 (ecase sb!vm::n-machine-word-bits
205 (32 'unsigned-byte-32)
206 (64 'unsigned-byte-64)))
210 (let ((lo (numeric-type-low type))
211 (hi (numeric-type-high type)))
212 (case (numeric-type-complexp type)
214 (case (numeric-type-class type)
218 `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
219 ,@(ecase sb!vm::n-machine-word-bits
224 0 ,(1- (ash 1 32)))))
229 0 ,(1- (ash 1 64))))))
230 (fixnum ,sb!xc:most-negative-fixnum
231 ,sb!xc:most-positive-fixnum)
232 ,(ecase sb!vm::n-machine-word-bits
234 `(signed-byte-32 ,(ash -1 31)
237 `(signed-byte-64 ,(ash -1 63)
239 (if (or (< hi sb!xc:most-negative-fixnum)
240 (> lo sb!xc:most-positive-fixnum))
243 (let ((type (car spec))
246 (when (<= min lo hi max)
248 (primitive-type-or-lose type)
249 (and (= lo min) (= hi max))))))))
250 ((or (and hi (< hi sb!xc:most-negative-fixnum))
251 (and lo (> lo sb!xc:most-positive-fixnum)))
256 (let ((exact (and (null lo) (null hi))))
257 (case (numeric-type-format type)
258 ((short-float single-float)
259 (values (primitive-type-or-lose 'single-float)
262 (values (primitive-type-or-lose 'double-float)
269 (if (eq (numeric-type-class type) 'float)
270 (let ((exact (and (null lo) (null hi))))
271 (case (numeric-type-format type)
272 ((short-float single-float)
273 (values (primitive-type-or-lose 'complex-single-float)
275 ((double-float long-float)
276 (values (primitive-type-or-lose 'complex-double-float)
284 (if (array-type-complexp type)
286 (let* ((dims (array-type-dimensions type))
287 (etype (array-type-specialized-element-type type))
288 (type-spec (type-specifier etype))
289 ;; FIXME: We're _WHAT_? Testing for type equality
290 ;; with a specifier and #'EQUAL? *BOGGLE*. --
292 (ptype (cdr (assoc type-spec *simple-array-primitive-types*
294 (if (and (consp dims) (null (rest dims)) ptype)
295 (values (primitive-type-or-lose ptype)
296 (eq (first dims) '*))
299 (if (type= type (specifier-type 'list))
301 (let ((types (union-type-types type)))
302 (multiple-value-bind (res exact) (primitive-type (first types))
303 (dolist (type (rest types) (values res exact))
304 (multiple-value-bind (ptype ptype-exact)
305 (primitive-type type)
306 (unless ptype-exact (setq exact nil))
307 (unless (eq ptype res)
309 (or (maybe-numeric-type-union res ptype)
310 (maybe-numeric-type-union ptype res))))
313 (return (any)))))))))))
315 (let ((types (intersection-type-types type))
318 (dolist (type types (values res exact))
319 (when (eq type (specifier-type 'function))
320 ;; KLUDGE: Deal with (and function instance), both of which
321 ;; have an exact primitive type.
322 (return (part-of function)))
323 (multiple-value-bind (ptype ptype-exact)
324 (primitive-type type)
326 ;; Apart from the previous kludge exact primitive
327 ;; types should match, if indeed there are any. It
328 ;; may be that this assumption isn't really safe,
329 ;; but at least we'll see what breaks. -- NS 20041104
330 (aver (or (not exact) (eq ptype res)))
332 (when (or ptype-exact (and (not exact) (eq res (any))))
333 ;; Try to find a narrower representation then
334 ;; (any). Takes care of undecidable types in
335 ;; intersections with decidable ones.
336 (setq res ptype))))))
338 (let* ((members (member-type-members type))
339 (res (primitive-type-of (first members))))
340 (dolist (mem (rest members) (values res nil))
341 (let ((ptype (primitive-type-of mem)))
342 (unless (eq ptype res)
343 (let ((new-ptype (or (maybe-numeric-type-union res ptype)
344 (maybe-numeric-type-union ptype res))))
347 (return (any)))))))))
349 (ecase (named-type-name type)
350 ((t *) (values *backend-t-primitive-type* t))
353 (let ((pairs (character-set-type-pairs type)))
354 (if (and (= (length pairs) 1)
356 (= (cdar pairs) (1- sb!xc:char-code-limit)))
358 (part-of character))))
360 (case (classoid-name type)
361 ((complex function instance
362 system-area-pointer weak-pointer)
363 (values (primitive-type-or-lose (classoid-name type)) t))
364 (funcallable-instance
373 (if (csubtypep type (specifier-type 'function))
377 (if (csubtypep type (specifier-type 'function))
381 (/show0 "primtype.lisp end of file")