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