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 function-header-types
22 (list funcallable-instance-header-type
23 byte-code-function-type byte-code-closure-type
24 function-header-type closure-function-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 function-header-types)
62 (if (subsetp headers function-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 function-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 function-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 nil check-function-or-symbol nil
392 object-not-function-or-symbol-error
393 function-pointer-type symbol-header-type)
395 (def-type-vops stringp check-string nil object-not-string-error
396 simple-string-type complex-string-type)
398 ;;; XXX surely just sticking this in here is not all that's required
399 ;;; to create the vop? But I can't find out any other info
400 (def-type-vops complex-vector-p check-complex-vector nil
401 object-not-complex-vector-error complex-vector-type)
403 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
404 simple-bit-vector-type complex-bit-vector-type)
406 (def-type-vops vectorp check-vector nil object-not-vector-error
407 simple-string-type simple-bit-vector-type simple-vector-type
408 simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
409 simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
410 simple-array-unsigned-byte-32-type
411 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
412 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
413 simple-array-single-float-type simple-array-double-float-type
414 simple-array-complex-single-float-type
415 simple-array-complex-double-float-type
416 complex-string-type complex-bit-vector-type complex-vector-type)
418 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
419 simple-array-type simple-string-type simple-bit-vector-type
420 simple-vector-type simple-array-unsigned-byte-2-type
421 simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
422 simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
423 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
424 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
425 simple-array-single-float-type simple-array-double-float-type
426 simple-array-complex-single-float-type
427 simple-array-complex-double-float-type)
429 (def-type-vops arrayp check-array nil object-not-array-error
430 simple-array-type simple-string-type simple-bit-vector-type
431 simple-vector-type simple-array-unsigned-byte-2-type
432 simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
433 simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
434 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
435 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
436 simple-array-single-float-type simple-array-double-float-type
437 simple-array-complex-single-float-type
438 simple-array-complex-double-float-type
439 complex-string-type complex-bit-vector-type complex-vector-type
442 (def-type-vops numberp check-number nil object-not-number-error
443 even-fixnum-type odd-fixnum-type bignum-type ratio-type
444 single-float-type double-float-type complex-type
445 complex-single-float-type complex-double-float-type)
447 (def-type-vops rationalp check-rational nil object-not-rational-error
448 even-fixnum-type odd-fixnum-type ratio-type bignum-type)
450 (def-type-vops integerp check-integer nil object-not-integer-error
451 even-fixnum-type odd-fixnum-type bignum-type)
453 (def-type-vops floatp check-float nil object-not-float-error
454 single-float-type double-float-type)
456 (def-type-vops realp check-real nil object-not-real-error
457 even-fixnum-type odd-fixnum-type ratio-type bignum-type
458 single-float-type double-float-type)
461 ;;;; Other integer ranges.
463 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
464 ;;; exactly one digit.
467 (defun signed-byte-32-test (value temp temp1 not-p target not-target)
471 (values not-target target)
472 (values target not-target))
474 (inst and value 3 temp)
476 (inst and value lowtag-mask temp)
477 (inst xor temp other-pointer-type temp)
479 (loadw temp value 0 other-pointer-type)
480 (inst li (+ (ash 1 type-bits) bignum-type) temp1)
481 (inst xor temp temp1 temp)
483 (inst bne temp target)
484 (inst beq temp target))))
487 (define-vop (signed-byte-32-p type-predicate)
488 (:translate signed-byte-32-p)
489 (:temporary (:scs (non-descriptor-reg)) temp1)
491 (signed-byte-32-test value temp temp1 not-p target not-target)
494 (define-vop (check-signed-byte-32 check-type)
495 (:temporary (:scs (non-descriptor-reg)) temp1)
497 (let ((loose (generate-error-code vop object-not-signed-byte-32-error
499 (signed-byte-32-test value temp temp1 t loose okay))
501 (move value result)))
503 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
504 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
505 ;;; and the second digit all zeros.
507 (defun unsigned-byte-32-test (value temp temp1 not-p target not-target)
508 (multiple-value-bind (yep nope)
510 (values not-target target)
511 (values target not-target))
514 (inst and value 3 temp1)
515 (inst move value temp)
516 (inst beq temp1 fixnum)
518 ;; If not, is it an other pointer?
519 (inst and value lowtag-mask temp)
520 (inst xor temp other-pointer-type temp)
523 (loadw temp value 0 other-pointer-type)
525 (inst li (+ (ash 1 type-bits) bignum-type) temp1)
526 (inst xor temp temp1 temp)
527 (inst beq temp single-word)
528 ;; If it's other than two, we can't be an (unsigned-byte 32)
529 (inst li (logxor (+ (ash 1 type-bits) bignum-type)
530 (+ (ash 2 type-bits) bignum-type))
532 (inst xor temp temp1 temp)
534 ;; Get the second digit.
535 (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
536 ;; All zeros, its an (unsigned-byte 32).
538 (inst br zero-tn nope)
541 ;; Get the single digit.
542 (loadw temp value bignum-digits-offset other-pointer-type)
544 ;; positive implies (unsigned-byte 32).
547 (inst blt temp target)
548 (inst bge temp target))))
551 (define-vop (unsigned-byte-32-p type-predicate)
552 (:translate unsigned-byte-32-p)
553 (:temporary (:scs (non-descriptor-reg)) temp1)
555 (unsigned-byte-32-test value temp temp1 not-p target not-target)
558 (define-vop (check-unsigned-byte-32 check-type)
559 (:temporary (:scs (non-descriptor-reg)) temp1)
561 (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
563 (unsigned-byte-32-test value temp temp1 t loose okay))
565 (move value result)))
569 ;;;; List/symbol types:
571 ;;; symbolp (or symbol (eq nil))
572 ;;; consp (and list (not (eq nil)))
574 (define-vop (symbolp type-predicate)
576 (:temporary (:scs (non-descriptor-reg)) temp)
578 (inst cmpeq value null-tn temp)
579 (inst bne temp (if not-p drop-thru target))
580 (test-type value temp target not-p symbol-header-type)
583 (define-vop (check-symbol check-type)
584 (:temporary (:scs (non-descriptor-reg)) temp)
586 (inst cmpeq value null-tn temp)
587 (inst bne temp drop-thru)
588 (let ((error (generate-error-code vop object-not-symbol-error value)))
589 (test-type value temp error t symbol-header-type))
591 (move value result)))
593 (define-vop (consp type-predicate)
595 (:temporary (:scs (non-descriptor-reg)) temp)
597 (inst cmpeq value null-tn temp)
598 (inst bne temp (if not-p target drop-thru))
599 (test-type value temp target not-p list-pointer-type)
602 (define-vop (check-cons check-type)
603 (:temporary (:scs (non-descriptor-reg)) temp)
605 (let ((error (generate-error-code vop object-not-cons-error value)))
606 (inst cmpeq value null-tn temp)
607 (inst bne temp error)
608 (test-type value temp error t list-pointer-type))
609 (move value result)))