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.
16 ;;;; Test generation utilities.
18 (eval-when (:compile-toplevel :execute)
20 (defparameter immediate-types
21 (list unbound-marker-type base-char-type))
23 (defparameter function-header-types
24 (list funcallable-instance-header-type
25 byte-code-function-type byte-code-closure-type
26 function-header-type closure-function-header-type
29 (defun canonicalize-headers (headers)
33 (delta (- other-immediate-1-type other-immediate-0-type)))
35 (results (if (= start prev)
38 (dolist (header (sort headers #'<))
42 ((= header (+ prev delta))
53 (macrolet ((test-type (value temp target not-p &rest type-codes)
54 ;; Determine what interesting combinations we need to test for.
55 (let* ((type-codes (mapcar #'eval type-codes))
56 (fixnump (and (member even-fixnum-type type-codes)
57 (member odd-fixnum-type type-codes)
59 (lowtags (remove lowtag-limit type-codes :test #'<))
60 (extended (remove lowtag-limit type-codes :test #'>))
61 (immediates (intersection extended immediate-types :test #'eql))
62 (headers (set-difference extended immediate-types :test #'eql))
63 (function-p (if (intersection headers function-header-types)
64 (if (subsetp headers function-header-types)
66 (error "Can't test for mix of function subtypes ~
67 and normal header types."))
70 (error "Must supply at least on type for test-type."))
73 (when (remove-if #'(lambda (x)
74 (or (= x even-fixnum-type)
75 (= x odd-fixnum-type)))
77 (error "Can't mix fixnum testing with other lowtags."))
79 (error "Can't mix fixnum testing with function subtype testing."))
81 (error "Can't mix fixnum testing with other immediates."))
83 `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
84 ',(canonicalize-headers headers))
85 `(%test-fixnum ,value ,temp ,target ,not-p)))
88 (error "Can't mix testing of immediates with testing of headers."))
90 (error "Can't mix testing of immediates with testing of lowtags."))
91 (when (cdr immediates)
92 (error "Can't test multiple immediates at the same time."))
93 `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
96 (error "Can't test multiple lowtags at the same time."))
98 `(%test-lowtag-and-headers
99 ,value ,temp ,target ,not-p ,(car lowtags)
100 ,function-p ',(canonicalize-headers headers))
101 `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
103 `(%test-headers ,value ,temp ,target ,not-p ,function-p
104 ',(canonicalize-headers headers)))
106 (error "Nothing to test?"))))))
108 (defun %test-fixnum (value temp target not-p)
110 (inst and value 3 temp)
112 (inst bne temp target)
113 (inst beq temp target))))
115 (defun %test-fixnum-and-headers (value temp target not-p headers)
116 (let ((drop-through (gen-label)))
118 (inst and value 3 temp)
119 (inst beq temp (if not-p drop-through target)))
120 (%test-headers value temp target not-p nil headers drop-through)))
122 (defun %test-immediate (value temp target not-p immediate)
124 (inst and value 255 temp)
125 (inst xor temp immediate temp)
127 (inst bne temp target)
128 (inst beq temp target))))
130 (defun %test-lowtag (value temp target not-p lowtag)
132 (inst and value lowtag-mask temp)
133 (inst xor temp lowtag temp)
135 (inst bne temp target)
136 (inst beq temp target))))
138 (defun %test-lowtag-and-headers (value temp target not-p lowtag
140 (let ((drop-through (gen-label)))
141 (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
142 (%test-headers value temp target not-p function-p headers drop-through)))
144 (defun %test-headers (value temp target not-p function-p headers
145 &optional (drop-through (gen-label)))
146 (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
148 (when-true when-false)
149 ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
150 ;; we know it's true and when we know it's false respectively.
152 (values drop-through target)
153 (values target drop-through))
155 (%test-lowtag value temp when-false t lowtag)
156 (load-type temp value (- lowtag))
158 (do ((remaining headers (cdr remaining)))
160 (let ((header (car remaining))
161 (last (null (cdr remaining))))
164 (inst subq temp (- header delta) temp)
168 (inst bne temp target)
169 (inst beq temp target))
170 (inst beq temp when-true)))
172 (let ((start (car header))
174 (unless (= start bignum-type)
175 (inst subq temp (- start delta) temp)
177 (inst blt temp when-false))
178 (inst subq temp (- end delta) temp)
182 (inst bgt temp target)
183 (inst ble temp target))
184 (inst ble temp when-true))))))))
185 (emit-label drop-through)))))
189 ;;;; Type checking and testing:
191 (define-vop (check-type)
192 (:args (value :target result :scs (any-reg descriptor-reg)))
193 (:results (result :scs (any-reg descriptor-reg)))
194 (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
196 (:save-p :compute-only))
198 (define-vop (type-predicate)
199 (:args (value :scs (any-reg descriptor-reg)))
200 (:temporary (:scs (non-descriptor-reg)) temp)
203 (:policy :fast-safe))
206 (eval-when (:compile-toplevel :execute)
209 (defun cost-to-test-types (type-codes)
210 (+ (* 2 (length type-codes))
211 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
214 (defmacro def-type-vops (pred-name check-name ptype error-code
216 (let ((cost #+sb-xc-host (cost-to-test-types (mapcar #'eval type-codes))
220 `((define-vop (,pred-name type-predicate)
221 (:translate ,pred-name)
223 (test-type value temp target not-p ,@type-codes)))))
225 `((define-vop (,check-name check-type)
228 (generate-error-code vop ,error-code value)))
229 (test-type value temp err-lab t ,@type-codes)
230 (move value result))))))
232 `((primitive-type-vop ,check-name (:check) ,ptype))))))
235 (def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
236 even-fixnum-type odd-fixnum-type)
238 (def-type-vops functionp check-function function
239 object-not-function-error function-pointer-type)
241 (def-type-vops listp check-list list object-not-list-error
244 (def-type-vops %instancep check-instance instance object-not-instance-error
245 instance-pointer-type)
247 (def-type-vops bignump check-bignum bignum
248 object-not-bignum-error bignum-type)
250 (def-type-vops ratiop check-ratio ratio
251 object-not-ratio-error ratio-type)
253 (def-type-vops complexp check-complex complex
254 object-not-complex-error complex-type
255 complex-single-float-type complex-double-float-type)
257 (def-type-vops complex-rational-p check-complex-rational nil
258 object-not-complex-rational-error complex-type)
260 (def-type-vops complex-float-p check-complex-float nil
261 object-not-complex-float-error
262 complex-single-float-type complex-double-float-type)
264 (def-type-vops complex-single-float-p check-complex-single-float
265 complex-single-float object-not-complex-single-float-error
266 complex-single-float-type)
268 (def-type-vops complex-double-float-p check-complex-double-float
269 complex-double-float object-not-complex-double-float-error
270 complex-double-float-type)
272 (def-type-vops single-float-p check-single-float single-float
273 object-not-single-float-error single-float-type)
275 (def-type-vops double-float-p check-double-float double-float
276 object-not-double-float-error double-float-type)
278 (def-type-vops simple-string-p check-simple-string simple-string
279 object-not-simple-string-error simple-string-type)
281 (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
282 object-not-simple-bit-vector-error simple-bit-vector-type)
284 (def-type-vops simple-vector-p check-simple-vector simple-vector
285 object-not-simple-vector-error simple-vector-type)
287 (def-type-vops simple-array-unsigned-byte-2-p
288 check-simple-array-unsigned-byte-2
289 simple-array-unsigned-byte-2
290 object-not-simple-array-unsigned-byte-2-error
291 simple-array-unsigned-byte-2-type)
293 (def-type-vops simple-array-unsigned-byte-4-p
294 check-simple-array-unsigned-byte-4
295 simple-array-unsigned-byte-4
296 object-not-simple-array-unsigned-byte-4-error
297 simple-array-unsigned-byte-4-type)
299 (def-type-vops simple-array-unsigned-byte-8-p
300 check-simple-array-unsigned-byte-8
301 simple-array-unsigned-byte-8
302 object-not-simple-array-unsigned-byte-8-error
303 simple-array-unsigned-byte-8-type)
305 (def-type-vops simple-array-unsigned-byte-16-p
306 check-simple-array-unsigned-byte-16
307 simple-array-unsigned-byte-16
308 object-not-simple-array-unsigned-byte-16-error
309 simple-array-unsigned-byte-16-type)
311 (def-type-vops simple-array-unsigned-byte-32-p
312 check-simple-array-unsigned-byte-32
313 simple-array-unsigned-byte-32
314 object-not-simple-array-unsigned-byte-32-error
315 simple-array-unsigned-byte-32-type)
317 (def-type-vops simple-array-signed-byte-8-p
318 check-simple-array-signed-byte-8
319 simple-array-signed-byte-8
320 object-not-simple-array-signed-byte-8-error
321 simple-array-signed-byte-8-type)
323 (def-type-vops simple-array-signed-byte-16-p
324 check-simple-array-signed-byte-16
325 simple-array-signed-byte-16
326 object-not-simple-array-signed-byte-16-error
327 simple-array-signed-byte-16-type)
329 (def-type-vops simple-array-signed-byte-30-p
330 check-simple-array-signed-byte-30
331 simple-array-signed-byte-30
332 object-not-simple-array-signed-byte-30-error
333 simple-array-signed-byte-30-type)
335 (def-type-vops simple-array-signed-byte-32-p
336 check-simple-array-signed-byte-32
337 simple-array-signed-byte-32
338 object-not-simple-array-signed-byte-32-error
339 simple-array-signed-byte-32-type)
341 (def-type-vops simple-array-single-float-p check-simple-array-single-float
342 simple-array-single-float object-not-simple-array-single-float-error
343 simple-array-single-float-type)
345 (def-type-vops simple-array-double-float-p check-simple-array-double-float
346 simple-array-double-float object-not-simple-array-double-float-error
347 simple-array-double-float-type)
349 (def-type-vops simple-array-complex-single-float-p
350 check-simple-array-complex-single-float
351 simple-array-complex-single-float
352 object-not-simple-array-complex-single-float-error
353 simple-array-complex-single-float-type)
355 (def-type-vops simple-array-complex-double-float-p
356 check-simple-array-complex-double-float
357 simple-array-complex-double-float
358 object-not-simple-array-complex-double-float-error
359 simple-array-complex-double-float-type)
361 (def-type-vops base-char-p check-base-char base-char
362 object-not-base-char-error base-char-type)
364 (def-type-vops system-area-pointer-p check-system-area-pointer
365 system-area-pointer object-not-sap-error sap-type)
367 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
368 object-not-weak-pointer-error weak-pointer-type)
373 (def-type-vops scavenger-hook-p nil nil nil
374 #-gengc 0 #+gengc scavenger-hook-type)
377 (def-type-vops code-component-p nil nil nil
380 (def-type-vops lra-p nil nil nil
381 #-gengc return-pc-header-type #+gengc 0)
383 (def-type-vops fdefn-p nil nil nil
386 (def-type-vops funcallable-instance-p nil nil nil
387 funcallable-instance-header-type)
389 (def-type-vops array-header-p nil nil nil
390 simple-array-type complex-string-type complex-bit-vector-type
391 complex-vector-type complex-array-type)
393 (def-type-vops nil check-function-or-symbol nil
394 object-not-function-or-symbol-error
395 function-pointer-type symbol-header-type)
397 (def-type-vops stringp check-string nil object-not-string-error
398 simple-string-type complex-string-type)
400 ;;; XXX surely just sticking this in here is not all that's required
401 ;;; to create the vop? But I can't find out any other info
402 (def-type-vops complex-vector-p check-complex-vector nil
403 object-not-complex-vector-error complex-vector-type)
405 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
406 simple-bit-vector-type complex-bit-vector-type)
408 (def-type-vops vectorp check-vector nil object-not-vector-error
409 simple-string-type simple-bit-vector-type simple-vector-type
410 simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
411 simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
412 simple-array-unsigned-byte-32-type
413 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
414 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
415 simple-array-single-float-type simple-array-double-float-type
416 simple-array-complex-single-float-type
417 simple-array-complex-double-float-type
418 complex-string-type complex-bit-vector-type complex-vector-type)
420 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
421 simple-array-type simple-string-type simple-bit-vector-type
422 simple-vector-type simple-array-unsigned-byte-2-type
423 simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
424 simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
425 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
426 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
427 simple-array-single-float-type simple-array-double-float-type
428 simple-array-complex-single-float-type
429 simple-array-complex-double-float-type)
431 (def-type-vops arrayp check-array nil object-not-array-error
432 simple-array-type simple-string-type simple-bit-vector-type
433 simple-vector-type simple-array-unsigned-byte-2-type
434 simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
435 simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
436 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
437 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
438 simple-array-single-float-type simple-array-double-float-type
439 simple-array-complex-single-float-type
440 simple-array-complex-double-float-type
441 complex-string-type complex-bit-vector-type complex-vector-type
444 (def-type-vops numberp check-number nil object-not-number-error
445 even-fixnum-type odd-fixnum-type bignum-type ratio-type
446 single-float-type double-float-type complex-type
447 complex-single-float-type complex-double-float-type)
449 (def-type-vops rationalp check-rational nil object-not-rational-error
450 even-fixnum-type odd-fixnum-type ratio-type bignum-type)
452 (def-type-vops integerp check-integer nil object-not-integer-error
453 even-fixnum-type odd-fixnum-type bignum-type)
455 (def-type-vops floatp check-float nil object-not-float-error
456 single-float-type double-float-type)
458 (def-type-vops realp check-real nil object-not-real-error
459 even-fixnum-type odd-fixnum-type ratio-type bignum-type
460 single-float-type double-float-type)
463 ;;;; Other integer ranges.
465 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
466 ;;; exactly one digit.
469 (defun signed-byte-32-test (value temp temp1 not-p target not-target)
473 (values not-target target)
474 (values target not-target))
476 (inst and value 3 temp)
478 (inst and value lowtag-mask temp)
479 (inst xor temp other-pointer-type temp)
481 (loadw temp value 0 other-pointer-type)
482 (inst li (+ (ash 1 type-bits) bignum-type) temp1)
483 (inst xor temp temp1 temp)
485 (inst bne temp target)
486 (inst beq temp target))))
489 (define-vop (signed-byte-32-p type-predicate)
490 (:translate signed-byte-32-p)
491 (:temporary (:scs (non-descriptor-reg)) temp1)
493 (signed-byte-32-test value temp temp1 not-p target not-target)
496 (define-vop (check-signed-byte-32 check-type)
497 (:temporary (:scs (non-descriptor-reg)) temp1)
499 (let ((loose (generate-error-code vop object-not-signed-byte-32-error
501 (signed-byte-32-test value temp temp1 t loose okay))
503 (move value result)))
505 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
506 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
507 ;;; and the second digit all zeros.
509 (defun unsigned-byte-32-test (value temp temp1 not-p target not-target)
510 (multiple-value-bind (yep nope)
512 (values not-target target)
513 (values target not-target))
516 (inst and value 3 temp1)
517 (inst move value temp)
518 (inst beq temp1 fixnum)
520 ;; If not, is it an other pointer?
521 (inst and value lowtag-mask temp)
522 (inst xor temp other-pointer-type temp)
525 (loadw temp value 0 other-pointer-type)
527 (inst li (+ (ash 1 type-bits) bignum-type) temp1)
528 (inst xor temp temp1 temp)
529 (inst beq temp single-word)
530 ;; If it's other than two, we can't be an (unsigned-byte 32)
531 (inst li (logxor (+ (ash 1 type-bits) bignum-type)
532 (+ (ash 2 type-bits) bignum-type))
534 (inst xor temp temp1 temp)
536 ;; Get the second digit.
537 (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
538 ;; All zeros, its an (unsigned-byte 32).
540 (inst br zero-tn nope)
543 ;; Get the single digit.
544 (loadw temp value bignum-digits-offset other-pointer-type)
546 ;; positive implies (unsigned-byte 32).
549 (inst blt temp target)
550 (inst bge temp target))))
553 (define-vop (unsigned-byte-32-p type-predicate)
554 (:translate unsigned-byte-32-p)
555 (:temporary (:scs (non-descriptor-reg)) temp1)
557 (unsigned-byte-32-test value temp temp1 not-p target not-target)
560 (define-vop (check-unsigned-byte-32 check-type)
561 (:temporary (:scs (non-descriptor-reg)) temp1)
563 (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
565 (unsigned-byte-32-test value temp temp1 t loose okay))
567 (move value result)))
571 ;;;; List/symbol types:
573 ;;; symbolp (or symbol (eq nil))
574 ;;; consp (and list (not (eq nil)))
576 (define-vop (symbolp type-predicate)
578 (:temporary (:scs (non-descriptor-reg)) temp)
580 (inst cmpeq value null-tn temp)
581 (inst bne temp (if not-p drop-thru target))
582 (test-type value temp target not-p symbol-header-type)
585 (define-vop (check-symbol check-type)
586 (:temporary (:scs (non-descriptor-reg)) temp)
588 (inst cmpeq value null-tn temp)
589 (inst bne temp drop-thru)
590 (let ((error (generate-error-code vop object-not-symbol-error value)))
591 (test-type value temp error t symbol-header-type))
593 (move value result)))
595 (define-vop (consp type-predicate)
597 (:temporary (:scs (non-descriptor-reg)) temp)
599 (inst cmpeq value null-tn temp)
600 (inst bne temp (if not-p target drop-thru))
601 (test-type value temp target not-p list-pointer-type)
604 (define-vop (check-cons check-type)
605 (:temporary (:scs (non-descriptor-reg)) temp)
607 (let ((error (generate-error-code vop object-not-cons-error value)))
608 (inst cmpeq value null-tn temp)
609 (inst bne temp error)
610 (test-type value temp error t list-pointer-type))
611 (move value result)))