1 ;;;; type testing and checking VOPs for the Alpha VM
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
14 ;;;; test generation utilities
16 (eval-when (:compile-toplevel :execute)
18 (defparameter *immediate-types*
19 (list unbound-marker-type base-char-type))
21 (defparameter *fun-header-types*
22 (list funcallable-instance-header-type
23 simple-fun-header-type
24 closure-fun-header-type
27 (defun canonicalize-headers (headers)
31 (delta (- other-immediate-1-type other-immediate-0-type)))
33 (results (if (= start prev)
36 (dolist (header (sort headers #'<))
40 ((= header (+ prev delta))
51 (macrolet ((test-type (value temp target not-p &rest type-codes)
52 ;; Determine what interesting combinations we need to test for.
53 (let* ((type-codes (mapcar #'eval type-codes))
54 (fixnump (and (member even-fixnum-type type-codes)
55 (member odd-fixnum-type type-codes)
57 (lowtags (remove lowtag-limit type-codes :test #'<))
58 (extended (remove lowtag-limit type-codes :test #'>))
59 (immediates (intersection extended *immediate-types* :test #'eql))
60 (headers (set-difference extended *immediate-types* :test #'eql))
61 (function-p (if (intersection headers *fun-header-types*)
62 (if (subsetp headers *fun-header-types*)
64 (error "Can't test for mix of function subtypes ~
65 and normal header types."))
68 (error "Must supply at least on type for test-type."))
71 (when (remove-if #'(lambda (x)
72 (or (= x even-fixnum-type)
73 (= x odd-fixnum-type)))
75 (error "Can't mix fixnum testing with other lowtags."))
77 (error "Can't mix fixnum testing with function subtype testing."))
79 (error "Can't mix fixnum testing with other immediates."))
81 `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
82 ',(canonicalize-headers headers))
83 `(%test-fixnum ,value ,temp ,target ,not-p)))
86 (error "Can't mix testing of immediates with testing of headers."))
88 (error "Can't mix testing of immediates with testing of lowtags."))
89 (when (cdr immediates)
90 (error "Can't test multiple immediates at the same time."))
91 `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
94 (error "Can't test multiple lowtags at the same time."))
96 `(%test-lowtag-and-headers
97 ,value ,temp ,target ,not-p ,(car lowtags)
98 ,function-p ',(canonicalize-headers headers))
99 `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
101 `(%test-headers ,value ,temp ,target ,not-p ,function-p
102 ',(canonicalize-headers headers)))
104 (error "Nothing to test?"))))))
106 (defun %test-fixnum (value temp target not-p)
108 (inst and value 3 temp)
110 (inst bne temp target)
111 (inst beq temp target))))
113 (defun %test-fixnum-and-headers (value temp target not-p headers)
114 (let ((drop-through (gen-label)))
116 (inst and value 3 temp)
117 (inst beq temp (if not-p drop-through target)))
118 (%test-headers value temp target not-p nil headers drop-through)))
120 (defun %test-immediate (value temp target not-p immediate)
122 (inst and value 255 temp)
123 (inst xor temp immediate temp)
125 (inst bne temp target)
126 (inst beq temp target))))
128 (defun %test-lowtag (value temp target not-p lowtag)
130 (inst and value lowtag-mask temp)
131 (inst xor temp lowtag temp)
133 (inst bne temp target)
134 (inst beq temp target))))
136 (defun %test-lowtag-and-headers (value temp target not-p lowtag
138 (let ((drop-through (gen-label)))
139 (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
140 (%test-headers value temp target not-p function-p headers drop-through)))
142 (defun %test-headers (value temp target not-p function-p headers
143 &optional (drop-through (gen-label)))
144 (let ((lowtag (if function-p fun-pointer-type other-pointer-type)))
146 (when-true when-false)
147 ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
148 ;; we know it's true and when we know it's false respectively.
150 (values drop-through target)
151 (values target drop-through))
153 (%test-lowtag value temp when-false t lowtag)
154 (load-type temp value (- lowtag))
156 (do ((remaining headers (cdr remaining)))
158 (let ((header (car remaining))
159 (last (null (cdr remaining))))
162 (inst subq temp (- header delta) temp)
166 (inst bne temp target)
167 (inst beq temp target))
168 (inst beq temp when-true)))
170 (let ((start (car header))
172 (unless (= start bignum-type)
173 (inst subq temp (- start delta) temp)
175 (inst blt temp when-false))
176 (inst subq temp (- end delta) temp)
180 (inst bgt temp target)
181 (inst ble temp target))
182 (inst ble temp when-true))))))))
183 (emit-label drop-through)))))
187 ;;;; Type checking and testing:
189 (define-vop (check-type)
190 (:args (value :target result :scs (any-reg descriptor-reg)))
191 (:results (result :scs (any-reg descriptor-reg)))
192 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
194 (:save-p :compute-only))
196 (define-vop (type-predicate)
197 (:args (value :scs (any-reg descriptor-reg)))
198 (:temporary (:scs (non-descriptor-reg)) temp)
201 (:policy :fast-safe))
204 (eval-when (:compile-toplevel :execute)
207 (defun cost-to-test-types (type-codes)
208 (+ (* 2 (length type-codes))
209 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
212 (defmacro def-type-vops (pred-name check-name ptype error-code
214 (let ((cost #+sb-xc-host (cost-to-test-types (mapcar #'eval type-codes))
218 `((define-vop (,pred-name type-predicate)
219 (:translate ,pred-name)
221 (test-type value temp target not-p ,@type-codes)))))
223 `((define-vop (,check-name check-type)
226 (generate-error-code vop ,error-code value)))
227 (test-type value temp err-lab t ,@type-codes)
228 (move value result))))))
230 `((primitive-type-vop ,check-name (:check) ,ptype))))))
233 (def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
234 even-fixnum-type odd-fixnum-type)
236 (def-type-vops functionp check-function function
237 object-not-function-error fun-pointer-type)
239 (def-type-vops listp check-list list object-not-list-error
242 (def-type-vops %instancep check-instance instance object-not-instance-error
243 instance-pointer-type)
245 (def-type-vops bignump check-bignum bignum
246 object-not-bignum-error bignum-type)
248 (def-type-vops ratiop check-ratio ratio
249 object-not-ratio-error ratio-type)
251 (def-type-vops complexp check-complex complex
252 object-not-complex-error complex-type
253 complex-single-float-type complex-double-float-type)
255 (def-type-vops complex-rational-p check-complex-rational nil
256 object-not-complex-rational-error complex-type)
258 (def-type-vops complex-float-p check-complex-float nil
259 object-not-complex-float-error
260 complex-single-float-type complex-double-float-type)
262 (def-type-vops complex-single-float-p check-complex-single-float
263 complex-single-float object-not-complex-single-float-error
264 complex-single-float-type)
266 (def-type-vops complex-double-float-p check-complex-double-float
267 complex-double-float object-not-complex-double-float-error
268 complex-double-float-type)
270 (def-type-vops single-float-p check-single-float single-float
271 object-not-single-float-error single-float-type)
273 (def-type-vops double-float-p check-double-float double-float
274 object-not-double-float-error double-float-type)
276 (def-type-vops simple-string-p check-simple-string simple-string
277 object-not-simple-string-error simple-string-type)
279 (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
280 object-not-simple-bit-vector-error simple-bit-vector-type)
282 (def-type-vops simple-vector-p check-simple-vector simple-vector
283 object-not-simple-vector-error simple-vector-type)
285 (def-type-vops simple-array-unsigned-byte-2-p
286 check-simple-array-unsigned-byte-2
287 simple-array-unsigned-byte-2
288 object-not-simple-array-unsigned-byte-2-error
289 simple-array-unsigned-byte-2-type)
291 (def-type-vops simple-array-unsigned-byte-4-p
292 check-simple-array-unsigned-byte-4
293 simple-array-unsigned-byte-4
294 object-not-simple-array-unsigned-byte-4-error
295 simple-array-unsigned-byte-4-type)
297 (def-type-vops simple-array-unsigned-byte-8-p
298 check-simple-array-unsigned-byte-8
299 simple-array-unsigned-byte-8
300 object-not-simple-array-unsigned-byte-8-error
301 simple-array-unsigned-byte-8-type)
303 (def-type-vops simple-array-unsigned-byte-16-p
304 check-simple-array-unsigned-byte-16
305 simple-array-unsigned-byte-16
306 object-not-simple-array-unsigned-byte-16-error
307 simple-array-unsigned-byte-16-type)
309 (def-type-vops simple-array-unsigned-byte-32-p
310 check-simple-array-unsigned-byte-32
311 simple-array-unsigned-byte-32
312 object-not-simple-array-unsigned-byte-32-error
313 simple-array-unsigned-byte-32-type)
315 (def-type-vops simple-array-signed-byte-8-p
316 check-simple-array-signed-byte-8
317 simple-array-signed-byte-8
318 object-not-simple-array-signed-byte-8-error
319 simple-array-signed-byte-8-type)
321 (def-type-vops simple-array-signed-byte-16-p
322 check-simple-array-signed-byte-16
323 simple-array-signed-byte-16
324 object-not-simple-array-signed-byte-16-error
325 simple-array-signed-byte-16-type)
327 (def-type-vops simple-array-signed-byte-30-p
328 check-simple-array-signed-byte-30
329 simple-array-signed-byte-30
330 object-not-simple-array-signed-byte-30-error
331 simple-array-signed-byte-30-type)
333 (def-type-vops simple-array-signed-byte-32-p
334 check-simple-array-signed-byte-32
335 simple-array-signed-byte-32
336 object-not-simple-array-signed-byte-32-error
337 simple-array-signed-byte-32-type)
339 (def-type-vops simple-array-single-float-p check-simple-array-single-float
340 simple-array-single-float object-not-simple-array-single-float-error
341 simple-array-single-float-type)
343 (def-type-vops simple-array-double-float-p check-simple-array-double-float
344 simple-array-double-float object-not-simple-array-double-float-error
345 simple-array-double-float-type)
347 (def-type-vops simple-array-complex-single-float-p
348 check-simple-array-complex-single-float
349 simple-array-complex-single-float
350 object-not-simple-array-complex-single-float-error
351 simple-array-complex-single-float-type)
353 (def-type-vops simple-array-complex-double-float-p
354 check-simple-array-complex-double-float
355 simple-array-complex-double-float
356 object-not-simple-array-complex-double-float-error
357 simple-array-complex-double-float-type)
359 (def-type-vops base-char-p check-base-char base-char
360 object-not-base-char-error base-char-type)
362 (def-type-vops system-area-pointer-p check-system-area-pointer
363 system-area-pointer object-not-sap-error sap-type)
365 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
366 object-not-weak-pointer-error weak-pointer-type)
371 (def-type-vops scavenger-hook-p nil nil nil
372 #-gengc 0 #+gengc scavenger-hook-type)
375 (def-type-vops code-component-p nil nil nil
378 (def-type-vops lra-p nil nil nil
379 #-gengc return-pc-header-type #+gengc 0)
381 (def-type-vops fdefn-p nil nil nil
384 (def-type-vops funcallable-instance-p nil nil nil
385 funcallable-instance-header-type)
387 (def-type-vops array-header-p nil nil nil
388 simple-array-type complex-string-type complex-bit-vector-type
389 complex-vector-type complex-array-type)
391 (def-type-vops stringp check-string nil object-not-string-error
392 simple-string-type complex-string-type)
394 ;;; XXX surely just sticking this in here is not all that's required
395 ;;; to create the vop? But I can't find out any other info
396 (def-type-vops complex-vector-p check-complex-vector nil
397 object-not-complex-vector-error complex-vector-type)
399 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
400 simple-bit-vector-type complex-bit-vector-type)
402 (def-type-vops vectorp check-vector nil object-not-vector-error
403 simple-string-type simple-bit-vector-type simple-vector-type
404 simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
405 simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
406 simple-array-unsigned-byte-32-type
407 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
408 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
409 simple-array-single-float-type simple-array-double-float-type
410 simple-array-complex-single-float-type
411 simple-array-complex-double-float-type
412 complex-string-type complex-bit-vector-type complex-vector-type)
414 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
415 simple-array-type simple-string-type simple-bit-vector-type
416 simple-vector-type simple-array-unsigned-byte-2-type
417 simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
418 simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
419 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
420 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
421 simple-array-single-float-type simple-array-double-float-type
422 simple-array-complex-single-float-type
423 simple-array-complex-double-float-type)
425 (def-type-vops arrayp check-array nil object-not-array-error
426 simple-array-type simple-string-type simple-bit-vector-type
427 simple-vector-type simple-array-unsigned-byte-2-type
428 simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
429 simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
430 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
431 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
432 simple-array-single-float-type simple-array-double-float-type
433 simple-array-complex-single-float-type
434 simple-array-complex-double-float-type
435 complex-string-type complex-bit-vector-type complex-vector-type
438 (def-type-vops numberp check-number nil object-not-number-error
439 even-fixnum-type odd-fixnum-type bignum-type ratio-type
440 single-float-type double-float-type complex-type
441 complex-single-float-type complex-double-float-type)
443 (def-type-vops rationalp check-rational nil object-not-rational-error
444 even-fixnum-type odd-fixnum-type ratio-type bignum-type)
446 (def-type-vops integerp check-integer nil object-not-integer-error
447 even-fixnum-type odd-fixnum-type bignum-type)
449 (def-type-vops floatp check-float nil object-not-float-error
450 single-float-type double-float-type)
452 (def-type-vops realp check-real nil object-not-real-error
453 even-fixnum-type odd-fixnum-type ratio-type bignum-type
454 single-float-type double-float-type)
457 ;;;; Other integer ranges.
459 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
460 ;;; exactly one digit.
463 (defun signed-byte-32-test (value temp temp1 not-p target not-target)
467 (values not-target target)
468 (values target not-target))
470 (inst and value 3 temp)
472 (inst and value lowtag-mask temp)
473 (inst xor temp other-pointer-type temp)
475 (loadw temp value 0 other-pointer-type)
476 (inst li (+ (ash 1 type-bits) bignum-type) temp1)
477 (inst xor temp temp1 temp)
479 (inst bne temp target)
480 (inst beq temp target))))
483 (define-vop (signed-byte-32-p type-predicate)
484 (:translate signed-byte-32-p)
485 (:temporary (:scs (non-descriptor-reg)) temp1)
487 (signed-byte-32-test value temp temp1 not-p target not-target)
490 (define-vop (check-signed-byte-32 check-type)
491 (:temporary (:scs (non-descriptor-reg)) temp1)
493 (let ((loose (generate-error-code vop object-not-signed-byte-32-error
495 (signed-byte-32-test value temp temp1 t loose okay))
497 (move value result)))
499 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
500 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
501 ;;; and the second digit all zeros.
503 (defun unsigned-byte-32-test (value temp temp1 not-p target not-target)
504 (multiple-value-bind (yep nope)
506 (values not-target target)
507 (values target not-target))
510 (inst and value 3 temp1)
511 (inst move value temp)
512 (inst beq temp1 fixnum)
514 ;; If not, is it an other pointer?
515 (inst and value lowtag-mask temp)
516 (inst xor temp other-pointer-type temp)
519 (loadw temp value 0 other-pointer-type)
521 (inst li (+ (ash 1 type-bits) bignum-type) temp1)
522 (inst xor temp temp1 temp)
523 (inst beq temp single-word)
524 ;; If it's other than two, we can't be an (unsigned-byte 32)
525 (inst li (logxor (+ (ash 1 type-bits) bignum-type)
526 (+ (ash 2 type-bits) bignum-type))
528 (inst xor temp temp1 temp)
530 ;; Get the second digit.
531 (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
532 ;; All zeros, its an (unsigned-byte 32).
534 (inst br zero-tn nope)
537 ;; Get the single digit.
538 (loadw temp value bignum-digits-offset other-pointer-type)
540 ;; positive implies (unsigned-byte 32).
543 (inst blt temp target)
544 (inst bge temp target))))
547 (define-vop (unsigned-byte-32-p type-predicate)
548 (:translate unsigned-byte-32-p)
549 (:temporary (:scs (non-descriptor-reg)) temp1)
551 (unsigned-byte-32-test value temp temp1 not-p target not-target)
554 (define-vop (check-unsigned-byte-32 check-type)
555 (:temporary (:scs (non-descriptor-reg)) temp1)
557 (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
559 (unsigned-byte-32-test value temp temp1 t loose okay))
561 (move value result)))
565 ;;;; List/symbol types:
567 ;;; symbolp (or symbol (eq nil))
568 ;;; consp (and list (not (eq nil)))
570 (define-vop (symbolp type-predicate)
572 (:temporary (:scs (non-descriptor-reg)) temp)
574 (inst cmpeq value null-tn temp)
575 (inst bne temp (if not-p drop-thru target))
576 (test-type value temp target not-p symbol-header-type)
579 (define-vop (check-symbol check-type)
580 (:temporary (:scs (non-descriptor-reg)) temp)
582 (inst cmpeq value null-tn temp)
583 (inst bne temp drop-thru)
584 (let ((error (generate-error-code vop object-not-symbol-error value)))
585 (test-type value temp error t symbol-header-type))
587 (move value result)))
589 (define-vop (consp type-predicate)
591 (:temporary (:scs (non-descriptor-reg)) temp)
593 (inst cmpeq value null-tn temp)
594 (inst bne temp (if not-p target drop-thru))
595 (test-type value temp target not-p list-pointer-type)
598 (define-vop (check-cons check-type)
599 (:temporary (:scs (non-descriptor-reg)) temp)
601 (let ((error (generate-error-code vop object-not-cons-error value)))
602 (inst cmpeq value null-tn temp)
603 (inst bne temp error)
604 (test-type value temp error t list-pointer-type))
605 (move value result)))