1;;;; machine-independent aspects of the object representation and
2;;;; primitive types
3
4;;;; This software is part of the SBCL system. See the README file for
5;;;; more information.
6;;;;
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.
12
13(in-package "SB!VM")
14
15;;;; primitive type definitions
16
17(/show0 "primtype.lisp 17")
18
19(!def-primitive-type t (descriptor-reg))
20(/show0 "primtype.lisp 20")
21(setf *backend-t-primitive-type* (primitive-type-or-lose t))
22
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#!-64-bit-registers
29(!def-primitive-type unsigned-byte-31 (signed-reg unsigned-reg descriptor-reg)
30  :type (unsigned-byte 31))
31(/show0 "primtype.lisp 31")
32#!-64-bit-registers
33(!def-primitive-type unsigned-byte-32 (unsigned-reg descriptor-reg)
34  :type (unsigned-byte 32))
35(/show0 "primtype.lisp 35")
36#!+64-bit-registers
37(!def-primitive-type unsigned-byte-63 (signed-reg unsigned-reg descriptor-reg)
38  :type (unsigned-byte 63))
39#!+64-bit-registers
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+ n-positive-fixnum-bits)))
44#!-64-bit-registers
45(!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
46  :type (signed-byte 32))
47#!+64-bit-registers
48(!def-primitive-type signed-byte-64 (signed-reg descriptor-reg)
49  :type (signed-byte 64))
50
51(defvar *fixnum-primitive-type* (primitive-type-or-lose 'fixnum))
52
53(/show0 "primtype.lisp 53")
54(!def-primitive-type-alias tagged-num '(:or positive-fixnum fixnum))
55(multiple-value-bind (unsigned signed)
56    (case sb!vm::n-machine-word-bits
57      (64 (values '(unsigned-byte-64 unsigned-byte-63 positive-fixnum)
58                  '(signed-byte-64 fixnum unsigned-byte-63 positive-fixnum)))
59      (32 (values '(unsigned-byte-32 unsigned-byte-31 positive-fixnum)
60                  '(signed-byte-32 fixnum unsigned-byte-31 positive-fixnum))))
61  (!def-primitive-type-alias unsigned-num `(:or ,@unsigned))
62  (!def-primitive-type-alias signed-num `(:or ,@signed))
63  (!def-primitive-type-alias untagged-num
64    `(:or ,@(sort (copy-list (union unsigned signed)) #'string<))))
65
66;;; other primitive immediate types
67(/show0 "primtype.lisp 68")
68(!def-primitive-type character (character-reg any-reg))
69
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))
75
76(/show0 "primtype.lisp 77")
77(!def-primitive-type funcallable-instance (descriptor-reg))
78
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))
88
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))
95#!+sb-simd-pack
96(progn
97  (/show0 "about to !DEF-PRIMITIVE-TYPE SIMD-PACK")
98  (!def-primitive-type simd-pack-single (single-sse-reg descriptor-reg)
99    :type (simd-pack single-float))
100  (!def-primitive-type simd-pack-double (double-sse-reg descriptor-reg)
101    :type (simd-pack double-float))
102  (!def-primitive-type simd-pack-int (int-sse-reg descriptor-reg)
103   :type (simd-pack integer))
104  (!def-primitive-type-alias simd-pack
105   '(:or simd-pack-single simd-pack-double simd-pack-int)))
106
107;;; primitive other-pointer array types
108(/show0 "primtype.lisp 96")
109(macrolet ((define-simple-array-primitive-types ()
110               `(progn
111                 ,@(map 'list
112                        (lambda (saetp)
113                          `(!def-primitive-type
114                            ,(saetp-primitive-type-name saetp)
115                            (descriptor-reg)
116                            :type (simple-array ,(saetp-specifier saetp) (*))))
117                        *specialized-array-element-type-properties*))))
118  (define-simple-array-primitive-types))
119;;; Note: The complex array types are not included, 'cause it is
120;;; pointless to restrict VOPs to them.
121
122;;; other primitive other-pointer types
123(!def-primitive-type system-area-pointer (sap-reg descriptor-reg))
124(!def-primitive-type weak-pointer (descriptor-reg))
125
126;;; miscellaneous primitive types that don't exist at the LISP level
127(!def-primitive-type catch-block (catch-block) :type nil)
128(!def-primitive-type unwind-block (unwind-block) :type nil)
129
130;;;; PRIMITIVE-TYPE-OF and friends
131
132;;; Return the most restrictive primitive type that contains OBJECT.
133(/show0 "primtype.lisp 147")
134(defun primitive-type-of (object)
135  (let ((type (ctype-of object)))
136    (cond ((not (member-type-p type)) (primitive-type type))
137          ((and (eql 1 (member-type-size type))
138                (equal (member-type-members type) '(nil)))
139           (primitive-type-or-lose 'list))
140          (t
141           *backend-t-primitive-type*))))
142
143;;; Return the primitive type corresponding to a type descriptor
144;;; structure. The second value is true when the primitive type is
145;;; exactly equivalent to the argument Lisp type.
146;;;
147;;; In a bootstrapping situation, we should be careful to use the
148;;; correct values for the system parameters.
149;;;
150;;; Meta: the following comment is not true. Should remove the AUX fn.
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 #'type-hash-value
160               :hash-bits 9
161               :values 2)
162              ((type eq))
163  (declare (type ctype type))
164  (macrolet ((any () '(values *backend-t-primitive-type* nil))
165             (exactly (type)
166               `(values (primitive-type-or-lose ',type) t))
167             (part-of (type)
168               `(values (primitive-type-or-lose ',type) nil)))
169    (flet ((maybe-numeric-type-union (t1 t2)
170             (let ((t1-name (primitive-type-name t1))
171                   (t2-name (primitive-type-name t2)))
172               (case t1-name
173                 (positive-fixnum
174                  (if (or (eq t2-name 'fixnum)
175                          (eq t2-name
176                              (ecase n-machine-word-bits
177                                (32 'signed-byte-32)
178                                (64 'signed-byte-64)))
179                          (eq t2-name
180                              (ecase n-machine-word-bits
181                                (32 'unsigned-byte-31)
182                                (64 'unsigned-byte-63)))
183                          (eq t2-name
184                              (ecase n-machine-word-bits
185                                (32 'unsigned-byte-32)
186                                (64 'unsigned-byte-64))))
187                      t2))
188                 (fixnum
189                  (case t2-name
190                    (#.(ecase n-machine-word-bits
191                         (32 'signed-byte-32)
192                         (64 'signed-byte-64))
193                       t2)
194                    (#.(ecase n-machine-word-bits
195                         (32 'unsigned-byte-31)
196                         (64 'unsigned-byte-63))
197                       (primitive-type-or-lose
198                        (ecase n-machine-word-bits
199                          (32 'signed-byte-32)
200                          (64 'signed-byte-64))))))
201                 (#.(ecase n-machine-word-bits
202                      (32 'signed-byte-32)
203                      (64 'signed-byte-64))
204                  (if (eq t2-name
205                          (ecase n-machine-word-bits
206                            (32 'unsigned-byte-31)
207                            (64 'unsigned-byte-63)))
208                      t1))
209                 (#.(ecase n-machine-word-bits
210                      (32 'unsigned-byte-31)
211                      (64 'unsigned-byte-63))
212                    (if (eq t2-name
213                            (ecase n-machine-word-bits
214                              (32 'unsigned-byte-32)
215                              (64 'unsigned-byte-64)))
216                        t2))))))
217      (etypecase type
218        (numeric-type
219         (let ((lo (numeric-type-low type))
220               (hi (numeric-type-high type)))
221           (case (numeric-type-complexp type)
222             (:real
223              (case (numeric-type-class type)
224                (integer
225                 (cond ((and hi lo)
226                        (dolist (spec
227                                  `((positive-fixnum 0 ,sb!xc:most-positive-fixnum)
228                                    ,@(ecase n-machine-word-bits
229                                        (32
230                                         `((unsigned-byte-31
231                                            0 ,(1- (ash 1 31)))
232                                           (unsigned-byte-32
233                                            0 ,(1- (ash 1 32)))))
234                                        (64
235                                         `((unsigned-byte-63
236                                            0 ,(1- (ash 1 63)))
237                                           (unsigned-byte-64
238                                            0 ,(1- (ash 1 64))))))
239                                    (fixnum ,sb!xc:most-negative-fixnum
240                                            ,sb!xc:most-positive-fixnum)
241                                    ,(ecase n-machine-word-bits
242                                       (32
243                                        `(signed-byte-32 ,(ash -1 31)
244                                                         ,(1- (ash 1 31))))
245                                       (64
246                                        `(signed-byte-64 ,(ash -1 63)
247                                                         ,(1- (ash 1 63))))))
248                                 (if (or (< hi sb!xc:most-negative-fixnum)
249                                         (> lo sb!xc:most-positive-fixnum))
250                                     (part-of bignum)
251                                     (any)))
252                          (let ((type (car spec))
253                                (min (cadr spec))
254                                (max (caddr spec)))
255                            (when (<= min lo hi max)
256                              (return (values
257                                       (primitive-type-or-lose type)
258                                       (and (= lo min) (= hi max))))))))
259                       ((or (and hi (< hi sb!xc:most-negative-fixnum))
260                            (and lo (> lo sb!xc:most-positive-fixnum)))
261                        (part-of bignum))
262                       (t
263                        (any))))
264                (float
265                 (let ((exact (and (null lo) (null hi))))
266                   (case (numeric-type-format type)
267                     ((short-float single-float)
268                      (values (primitive-type-or-lose 'single-float)
269                              exact))
270                     ((double-float)
271                      (values (primitive-type-or-lose 'double-float)
272                              exact))
273                     (t
274                      (any)))))
275                (t
276                 (any))))
277             (:complex
278              (if (eq (numeric-type-class type) 'float)
279                  (let ((exact (and (null lo) (null hi))))
280                    (case (numeric-type-format type)
281                      ((short-float single-float)
282                       (values (primitive-type-or-lose 'complex-single-float)
283                               exact))
284                      ((double-float long-float)
285                       (values (primitive-type-or-lose 'complex-double-float)
286                               exact))
287                      (t
288                       (part-of complex))))
289                  (part-of complex)))
290             (t
291              (any)))))
292        (array-type
293         (if (or (array-type-complexp type)
294                 (not (singleton-p (array-type-dimensions type))))
295             (any)
296             ;; EQ is ok to compare by because all CTYPEs representing
297             ;; array specializations are interned objects.
298             (let ((saetp (find (array-type-specialized-element-type type)
299                                *specialized-array-element-type-properties*
300                                :key #'saetp-ctype :test #'eq)))
301               (if saetp
302                   (values (primitive-type-or-lose
303                            (saetp-primitive-type-name saetp))
304                           (eq (first (array-type-dimensions type)) '*))
305                   (any)))))
306        (union-type
307         (if (type= type (specifier-type 'list))
308             (exactly list)
309             (let ((types (union-type-types type)))
310               (multiple-value-bind (res exact) (primitive-type (first types))
311                 (dolist (type (rest types) (values res exact))
312                   (multiple-value-bind (ptype ptype-exact)
313                       (primitive-type type)
314                     (unless ptype-exact (setq exact nil))
315                     (unless (eq ptype res)
316                       (let ((new-ptype
317                              (or (maybe-numeric-type-union res ptype)
318                                  (maybe-numeric-type-union ptype res))))
319                         (if new-ptype
320                             (setq res new-ptype)
321                             (return (any)))))))))))
322        (intersection-type
323         (let ((types (intersection-type-types type))
324               (res (any)))
325           ;; why NIL for the exact?  Well, we assume that the
326           ;; intersection type is in fact doing something for us:
327           ;; that is, that each of the types in the intersection is
328           ;; in fact cutting off some of the type lattice.  Since no
329           ;; intersection type is represented by a primitive type and
330           ;; primitive types are mutually exclusive, it follows that
331           ;; no intersection type can represent the entirety of the
332           ;; primitive type.  (And NIL is the conservative answer,
333           ;; anyway).  -- CSR, 2006-09-14
334           (dolist (type types (values res nil))
335             (multiple-value-bind (ptype)
336                 (primitive-type type)
337               (cond
338                 ;; if the result so far is (any), any improvement on
339                 ;; the specificity of the primitive type is valid.
340                 ((eq res (any))
341                  (setq res ptype))
342                 ;; if the primitive type returned is (any), the
343                 ;; result so far is valid.  Likewise, if the
344                 ;; primitive type is the same as the result so far,
345                 ;; everything is fine.
346                 ((or (eq ptype (any)) (eq ptype res)))
347                 ;; otherwise, we have something hairy and confusing,
348                 ;; such as (and condition funcallable-instance).
349                 ;; Punt.
350                 (t (return (any))))))))
351        (member-type
352         (let (res)
353           (block nil
354             (mapc-member-type-members
355              (lambda (member)
356                (let ((ptype (primitive-type-of member)))
357                  (if res
358                      (unless (eq ptype res)
359                        (let ((new-ptype (or (maybe-numeric-type-union res ptype)
360                                             (maybe-numeric-type-union ptype res))))
361                          (if new-ptype
362                              (setq res new-ptype)
363                              (return (any)))))
364                      (setf res ptype))))
365              type)
366             res)))
367        (named-type
368         (ecase (named-type-name type)
369           ((t *) (values *backend-t-primitive-type* t))
370           ((instance) (exactly instance))
371           ((funcallable-instance) (part-of function))
372           ((extended-sequence) (any))
373           ((nil) (any))))
374        (character-set-type
375         (if (eq type (specifier-type 'character))
376             (exactly character)
377             (part-of character)))
378        #!+sb-simd-pack
379        (simd-pack-type
380         (let ((eltypes (simd-pack-type-element-type type)))
381           (cond ((member 'integer eltypes)
382                  (exactly simd-pack-int))
383                 ((member 'single-float eltypes)
384                  (exactly simd-pack-single))
385                 ((member 'double-float eltypes)
386                  (exactly simd-pack-double)))))
387        (built-in-classoid
388         (case (classoid-name type)
389           #!+sb-simd-pack
390           ;; Can't tell what specific type; assume integers.
391           (simd-pack
392            (exactly simd-pack-int))
393           ((complex function system-area-pointer weak-pointer)
394            (values (primitive-type-or-lose (classoid-name type)) t))
395           (cons-type
396            (part-of list))
397           (t
398            (any))))
399        (fun-type
400         (exactly function))
401        (classoid
402         (if (csubtypep type (specifier-type 'function))
403             (part-of function)
404             (part-of instance)))
405        (ctype
406         (if (csubtypep type (specifier-type 'function))
407             (part-of function)
408             (any)))))))
409
410(/show0 "primtype.lisp end of file")
411