src/compiler/mips/type-vops.lisp

   1 (in-package "SB!VM")
   2
   3
   4 \f
   5 ;;;; Test generation utilities.
   6
   7 (eval-when (:compile-toplevel :execute)
   8   (defparameter *immediate-types*
   9     (list unbound-marker-widetag base-char-widetag))
  10
  11   (defparameter *fun-header-widetags*
  12     (list funcallable-instance-header-widetag
  13           simple-fun-header-widetag
  14           closure-fun-header-widetag
  15           closure-header-widetag))
  16
  17   (defun canonicalize-headers (headers)
  18     (collect ((results))
  19              (let ((start nil)
  20                    (prev nil)
  21                    (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
  22                (flet ((emit-test ()
  23                         (results (if (= start prev)
  24                                      start
  25                                      (cons start prev)))))
  26                  (dolist (header (sort headers #'<))
  27                    (cond ((null start)
  28                           (setf start header)
  29                           (setf prev header))
  30                          ((= header (+ prev delta))
  31                           (setf prev header))
  32                          (t
  33                           (emit-test)
  34                           (setf start header)
  35                           (setf prev header))))
  36                  (emit-test)))
  37              (results))))
  38
  39
  40 (macrolet ((test-type (value temp target not-p &rest type-codes)
  41   ;; Determine what interesting combinations we need to test for.
  42   (let* ((type-codes (mapcar #'eval type-codes))
  43          (fixnump (and (member even-fixnum-lowtag type-codes)
  44                        (member odd-fixnum-lowtag type-codes)
  45                        t))
  46          (lowtags (remove lowtag-limit type-codes :test #'<))
  47          (extended (remove lowtag-limit type-codes :test #'>))
  48          (immediates (intersection extended *immediate-types* :test #'eql))
  49          (headers (set-difference extended *immediate-types* :test #'eql))
  50          (function-p (if (intersection headers *fun-header-widetags*)
  51                          (if (subsetp headers *fun-header-widetags*)
  52                              t
  53                              (error "Can't test for mix of function subtypes ~
  54                                      and normal header types."))
  55                          nil)))
  56     (unless type-codes
  57       (error "Must supply at least on type for test-type."))
  58     (cond
  59      (fixnump
  60       (when (remove-if #'(lambda (x)
  61                            (or (= x even-fixnum-lowtag)
  62                                (= x odd-fixnum-lowtag)))
  63                        lowtags)
  64         (error "Can't mix fixnum testing with other lowtags."))
  65       (when function-p
  66         (error "Can't mix fixnum testing with function subtype testing."))
  67       (when immediates
  68         (error "Can't mix fixnum testing with other immediates."))
  69       (if headers
  70           `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
  71                                      ',(canonicalize-headers headers))
  72           `(%test-fixnum ,value ,temp ,target ,not-p)))
  73      (immediates
  74       (when headers
  75         (error "Can't mix testing of immediates with testing of headers."))
  76       (when lowtags
  77         (error "Can't mix testing of immediates with testing of lowtags."))
  78       (when (cdr immediates)
  79         (error "Can't test multiple immediates at the same time."))
  80       `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))
  81      (lowtags
  82       (when (cdr lowtags)
  83         (error "Can't test multiple lowtags at the same time."))
  84       (if headers
  85           `(%test-lowtag-and-headers
  86             ,value ,temp ,target ,not-p ,(car lowtags)
  87             ,function-p ',(canonicalize-headers headers))
  88           `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
  89      (headers
  90       `(%test-headers ,value ,temp ,target ,not-p ,function-p
  91                       ',(canonicalize-headers headers)))
  92      (t
  93       (error "Nothing to test?"))))))
  94
  95 (defun %test-fixnum (value temp target not-p)
  96   (assemble ()
  97     (inst and temp value 3)
  98     (if not-p
  99         (inst bne temp zero-tn target)
 100         (inst beq temp zero-tn target))
 101     (inst nop)))
 102
 103 (defun %test-fixnum-and-headers (value temp target not-p headers)
 104   (let ((drop-through (gen-label)))
 105     (assemble ()
 106       (inst and temp value 3)
 107       (inst beq temp zero-tn (if not-p drop-through target)))
 108     (%test-headers value temp target not-p nil headers drop-through)))
 109
 110 (defun %test-immediate (value temp target not-p immediate)
 111   (assemble ()
 112     (inst and temp value 255)
 113     (inst xor temp immediate)
 114     (if not-p
 115         (inst bne temp zero-tn target)
 116         (inst beq temp zero-tn target))
 117     (inst nop)))
 118
 119 (defun %test-lowtag (value temp target not-p lowtag &optional skip-nop)
 120   (assemble ()
 121     (inst and temp value lowtag-mask)
 122     (inst xor temp lowtag)
 123     (if not-p
 124         (inst bne temp zero-tn target)
 125         (inst beq temp zero-tn target))
 126     (unless skip-nop
 127       (inst nop))))
 128
 129 (defun %test-lowtag-and-headers (value temp target not-p lowtag
 130                                        function-p headers)
 131   (let ((drop-through (gen-label)))
 132     (%test-lowtag value temp (if not-p drop-through target) nil lowtag t)
 133     (%test-headers value temp target not-p function-p headers drop-through)))
 134
 135 (defun %test-headers (value temp target not-p function-p headers
 136                             &optional (drop-through (gen-label)))
 137   (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
 138     (multiple-value-bind
 139         (when-true when-false)
 140         ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
 141         ;; we know it's true and when we know it's false respectively.
 142         (if not-p
 143             (values drop-through target)
 144             (values target drop-through))
 145       (assemble ()
 146         (%test-lowtag value temp when-false t lowtag)
 147         (load-type temp value (- lowtag))
 148         (inst nop)
 149         (let ((delta 0))
 150           (do ((remaining headers (cdr remaining)))
 151               ((null remaining))
 152             (let ((header (car remaining))
 153                   (last (null (cdr remaining))))
 154               (cond
 155                ((atom header)
 156                 (inst subu temp (- header delta))
 157                 (setf delta header)
 158                 (if last
 159                     (if not-p
 160                         (inst bne temp zero-tn target)
 161                         (inst beq temp zero-tn target))
 162                     (inst beq temp zero-tn when-true)))
 163                (t
 164                 (let ((start (car header))
 165                       (end (cdr header)))
 166                   (unless (= start bignum-widetag)
 167                     (inst subu temp (- start delta))
 168                     (setf delta start)
 169                     (inst bltz temp when-false))
 170                   (inst subu temp (- end delta))
 171                   (setf delta end)
 172                   (if last
 173                       (if not-p
 174                           (inst bgtz temp target)
 175                           (inst blez temp target))
 176                       (inst blez temp when-true))))))))
 177         (inst nop)
 178         (emit-label drop-through)))))
 179
 180
 181 \f
 182 ;;;; Type checking and testing:
 183
 184 (define-vop (check-type)
 185   (:args (value :target result :scs (any-reg descriptor-reg)))
 186   (:results (result :scs (any-reg descriptor-reg)))
 187   (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
 188   (:vop-var vop)
 189   (:save-p :compute-only))
 190
 191 (define-vop (type-predicate)
 192   (:args (value :scs (any-reg descriptor-reg)))
 193   (:temporary (:scs (non-descriptor-reg)) temp)
 194   (:conditional)
 195   (:info target not-p)
 196   (:policy :fast-safe))
 197
 198 (eval-when (:compile-toplevel :execute)
 199   (defun cost-to-test-types (type-codes)
 200     (+ (* 2 (length type-codes))
 201        (if (> (apply #'max type-codes) lowtag-limit) 7 2))))
 202
 203 (defmacro def-type-vops (pred-name check-name ptype error-code
 204                                    &rest type-codes)
 205   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
 206     `(progn
 207        ,@(when pred-name
 208            `((define-vop (,pred-name type-predicate)
 209                (:translate ,pred-name)
 210                (:generator ,cost
 211                  (test-type value temp target not-p ,@type-codes)))))
 212        ,@(when check-name
 213            `((define-vop (,check-name check-type)
 214                (:generator ,cost
 215                  (let ((err-lab
 216                         (generate-error-code vop ,error-code value)))
 217                    (test-type value temp err-lab t ,@type-codes)
 218                    (move result value))))))
 219        ,@(when ptype
 220            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 221
 222 (def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
 223   even-fixnum-lowtag odd-fixnum-lowtag)
 224
 225 (def-type-vops functionp check-fun function
 226   object-not-fun-error fun-pointer-lowtag)
 227
 228 (def-type-vops listp check-list list object-not-list-error
 229   list-pointer-lowtag)
 230
 231 (def-type-vops %instancep check-instance instance object-not-instance-error
 232   instance-pointer-lowtag)
 233
 234 (def-type-vops bignump check-bignum bignum
 235   object-not-bignum-error bignum-widetag)
 236
 237 (def-type-vops ratiop check-ratio ratio
 238   object-not-ratio-error ratio-widetag)
 239
 240 (def-type-vops complexp check-complex complex object-not-complex-error
 241   complex-widetag complex-single-float-widetag complex-double-float-widetag)
 242
 243 (def-type-vops complex-rational-p check-complex-rational nil
 244   object-not-complex-rational-error complex-widetag)
 245
 246 (def-type-vops complex-float-p check-complex-float nil
 247   object-not-complex-float-error
 248   complex-single-float-widetag complex-double-float-widetag)
 249
 250 (def-type-vops complex-single-float-p check-complex-single-float
 251   complex-single-float object-not-complex-single-float-error
 252   complex-single-float-widetag)
 253
 254 (def-type-vops complex-double-float-p check-complex-double-float
 255   complex-double-float object-not-complex-double-float-error
 256   complex-double-float-widetag)
 257
 258 (def-type-vops single-float-p check-single-float single-float
 259   object-not-single-float-error single-float-widetag)
 260
 261 (def-type-vops double-float-p check-double-float double-float
 262   object-not-double-float-error double-float-widetag)
 263
 264 (def-type-vops simple-string-p check-simple-string simple-string
 265   object-not-simple-string-error simple-string-widetag)
 266
 267 (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
 268   object-not-simple-bit-vector-error simple-bit-vector-widetag)
 269
 270 (def-type-vops simple-vector-p check-simple-vector simple-vector
 271   object-not-simple-vector-error simple-vector-widetag)
 272
 273 (def-type-vops simple-array-unsigned-byte-2-p
 274   check-simple-array-unsigned-byte-2
 275   simple-array-unsigned-byte-2
 276   object-not-simple-array-unsigned-byte-2-error
 277   simple-array-unsigned-byte-2-widetag)
 278
 279 (def-type-vops simple-array-unsigned-byte-4-p
 280   check-simple-array-unsigned-byte-4
 281   simple-array-unsigned-byte-4
 282   object-not-simple-array-unsigned-byte-4-error
 283   simple-array-unsigned-byte-4-widetag)
 284
 285 (def-type-vops simple-array-unsigned-byte-8-p
 286   check-simple-array-unsigned-byte-8
 287   simple-array-unsigned-byte-8
 288   object-not-simple-array-unsigned-byte-8-error
 289   simple-array-unsigned-byte-8-widetag)
 290
 291 (def-type-vops simple-array-unsigned-byte-16-p
 292   check-simple-array-unsigned-byte-16
 293   simple-array-unsigned-byte-16
 294   object-not-simple-array-unsigned-byte-16-error
 295   simple-array-unsigned-byte-16-widetag)
 296
 297 (def-type-vops simple-array-unsigned-byte-32-p
 298   check-simple-array-unsigned-byte-32
 299   simple-array-unsigned-byte-32
 300   object-not-simple-array-unsigned-byte-32-error
 301   simple-array-unsigned-byte-32-widetag)
 302
 303 (def-type-vops simple-array-signed-byte-8-p
 304   check-simple-array-signed-byte-8
 305   simple-array-signed-byte-8
 306   object-not-simple-array-signed-byte-8-error
 307   simple-array-signed-byte-8-widetag)
 308
 309 (def-type-vops simple-array-signed-byte-16-p
 310   check-simple-array-signed-byte-16
 311   simple-array-signed-byte-16
 312   object-not-simple-array-signed-byte-16-error
 313   simple-array-signed-byte-16-widetag)
 314
 315 (def-type-vops simple-array-signed-byte-30-p
 316   check-simple-array-signed-byte-30
 317   simple-array-signed-byte-30
 318   object-not-simple-array-signed-byte-30-error
 319   simple-array-signed-byte-30-widetag)
 320
 321 (def-type-vops simple-array-signed-byte-32-p
 322   check-simple-array-signed-byte-32
 323   simple-array-signed-byte-32
 324   object-not-simple-array-signed-byte-32-error
 325   simple-array-signed-byte-32-widetag)
 326
 327 (def-type-vops simple-array-single-float-p check-simple-array-single-float
 328   simple-array-single-float object-not-simple-array-single-float-error
 329   simple-array-single-float-widetag)
 330
 331 (def-type-vops simple-array-double-float-p check-simple-array-double-float
 332   simple-array-double-float object-not-simple-array-double-float-error
 333   simple-array-double-float-widetag)
 334
 335 (def-type-vops simple-array-complex-single-float-p
 336   check-simple-array-complex-single-float
 337   simple-array-complex-single-float
 338   object-not-simple-array-complex-single-float-error
 339   simple-array-complex-single-float-widetag)
 340
 341 (def-type-vops simple-array-complex-double-float-p
 342   check-simple-array-complex-double-float
 343   simple-array-complex-double-float
 344   object-not-simple-array-complex-double-float-error
 345   simple-array-complex-double-float-widetag)
 346
 347 (def-type-vops base-char-p check-base-char base-char
 348   object-not-base-char-error base-char-widetag)
 349
 350 (def-type-vops system-area-pointer-p check-system-area-pointer
 351   system-area-pointer object-not-sap-error sap-widetag)
 352
 353 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
 354   object-not-weak-pointer-error weak-pointer-widetag)
 355
 356 (def-type-vops code-component-p nil nil nil
 357   code-header-widetag)
 358
 359 (def-type-vops lra-p nil nil nil
 360   return-pc-header-widetag)
 361
 362 (def-type-vops fdefn-p nil nil nil
 363   fdefn-widetag)
 364
 365 (def-type-vops funcallable-instance-p nil nil nil
 366   funcallable-instance-header-widetag)
 367
 368 (def-type-vops array-header-p nil nil nil
 369   simple-array-widetag complex-string-widetag complex-bit-vector-widetag
 370   complex-vector-widetag complex-array-widetag)
 371
 372 (def-type-vops stringp check-string nil object-not-string-error
 373   simple-string-widetag complex-string-widetag)
 374
 375 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
 376   simple-bit-vector-widetag complex-bit-vector-widetag)
 377
 378 (def-type-vops vectorp check-vector nil object-not-vector-error
 379   simple-string-widetag simple-bit-vector-widetag simple-vector-widetag
 380   simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag
 381   simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag
 382   simple-array-unsigned-byte-32-widetag
 383   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 384   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 385   simple-array-single-float-widetag simple-array-double-float-widetag
 386   simple-array-complex-single-float-widetag
 387   simple-array-complex-double-float-widetag
 388   complex-string-widetag complex-bit-vector-widetag complex-vector-widetag)
 389
 390 (def-type-vops complex-vector-p check-complex-vector nil object-not-complex-vector-error
 391   complex-vector-widetag)
 392
 393 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
 394   simple-array-widetag simple-string-widetag simple-bit-vector-widetag
 395   simple-vector-widetag simple-array-unsigned-byte-2-widetag
 396   simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
 397   simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
 398   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 399   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 400   simple-array-single-float-widetag simple-array-double-float-widetag
 401   simple-array-complex-single-float-widetag
 402   simple-array-complex-double-float-widetag)
 403
 404 (def-type-vops arrayp check-array nil object-not-array-error
 405   simple-array-widetag simple-string-widetag simple-bit-vector-widetag
 406   simple-vector-widetag simple-array-unsigned-byte-2-widetag
 407   simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
 408   simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
 409   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 410   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 411   simple-array-single-float-widetag simple-array-double-float-widetag
 412   simple-array-complex-single-float-widetag
 413   simple-array-complex-double-float-widetag
 414   complex-string-widetag complex-bit-vector-widetag complex-vector-widetag
 415   complex-array-widetag)
 416
 417 (def-type-vops numberp check-number nil object-not-number-error
 418   even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag
 419   single-float-widetag double-float-widetag complex-widetag
 420   complex-single-float-widetag complex-double-float-widetag)
 421
 422 (def-type-vops rationalp check-rational nil object-not-rational-error
 423   even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag)
 424
 425 (def-type-vops integerp check-integer nil object-not-integer-error
 426   even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag)
 427
 428 (def-type-vops floatp check-float nil object-not-float-error
 429   single-float-widetag double-float-widetag)
 430
 431 (def-type-vops realp check-real nil object-not-real-error
 432   even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag
 433   single-float-widetag double-float-widetag)
 434
 435 \f
 436 ;;;; Other integer ranges.
 437
 438 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
 439 ;;; exactly one digit.
 440
 441 (defun signed-byte-32-test (value temp not-p target not-target)
 442   (multiple-value-bind
 443       (yep nope)
 444       (if not-p
 445           (values not-target target)
 446           (values target not-target))
 447     (assemble ()
 448       (inst and temp value 3)
 449       (inst beq temp zero-tn yep)
 450       (inst and temp value lowtag-mask)
 451       (inst xor temp other-pointer-lowtag)
 452       (inst bne temp zero-tn nope)
 453       (inst nop)
 454       (loadw temp value 0 other-pointer-lowtag)
 455       (inst xor temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 456       (if not-p
 457           (inst bne temp zero-tn target)
 458           (inst beq temp zero-tn target))
 459       (inst nop)))
 460   (values))
 461
 462 (define-vop (signed-byte-32-p type-predicate)
 463   (:translate signed-byte-32-p)
 464   (:generator 45
 465     (signed-byte-32-test value temp not-p target not-target)
 466     NOT-TARGET))
 467
 468 (define-vop (check-signed-byte-32 check-type)
 469   (:generator 45
 470     (let ((loose (generate-error-code vop object-not-signed-byte-32-error
 471                                       value)))
 472       (signed-byte-32-test value temp t loose okay))
 473     OKAY
 474     (move result value)))
 475
 476 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 477 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 478 ;;; and the second digit all zeros.
 479
 480 (defun unsigned-byte-32-test (value temp not-p target not-target)
 481   (multiple-value-bind (yep nope)
 482                        (if not-p
 483                            (values not-target target)
 484                            (values target not-target))
 485     (assemble ()
 486       ;; Is it a fixnum?
 487       (inst and temp value 3)
 488       (inst beq temp zero-tn fixnum)
 489       (inst move temp value)
 490
 491       ;; If not, is it an other pointer?
 492       (inst and temp value lowtag-mask)
 493       (inst xor temp other-pointer-lowtag)
 494       (inst bne temp zero-tn nope)
 495       (inst nop)
 496       ;; Get the header.
 497       (loadw temp value 0 other-pointer-lowtag)
 498       ;; Is it one?
 499       (inst xor temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 500       (inst beq temp zero-tn single-word)
 501       ;; If it's other than two, we can't be an (unsigned-byte 32)
 502       (inst xor temp (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
 503                              (+ (ash 2 n-widetag-bits) bignum-widetag)))
 504       (inst bne temp zero-tn nope)
 505       ;; Get the second digit.
 506       (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 507       ;; All zeros, its an (unsigned-byte 32).
 508       (inst beq temp zero-tn yep)
 509       (inst nop)
 510       (inst b nope)
 511
 512       SINGLE-WORD
 513       ;; Get the single digit.
 514       (loadw temp value bignum-digits-offset other-pointer-lowtag)
 515
 516       ;; positive implies (unsigned-byte 32).
 517       FIXNUM
 518       (if not-p
 519           (inst bltz temp target)
 520           (inst bgez temp target))
 521       (inst nop)))
 522   (values))
 523
 524 (define-vop (unsigned-byte-32-p type-predicate)
 525   (:translate unsigned-byte-32-p)
 526   (:generator 45
 527     (unsigned-byte-32-test value temp not-p target not-target)
 528     NOT-TARGET))
 529
 530 (define-vop (check-unsigned-byte-32 check-type)
 531   (:generator 45
 532     (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
 533                                       value)))
 534       (unsigned-byte-32-test value temp t loose okay))
 535     OKAY
 536     (move result value)))
 537
 538
 539 \f
 540 ;;;; List/symbol types:
 541 ;;;
 542 ;;; symbolp (or symbol (eq nil))
 543 ;;; consp (and list (not (eq nil)))
 544
 545 (define-vop (symbolp type-predicate)
 546   (:translate symbolp)
 547   (:generator 12
 548     (inst beq value null-tn (if not-p drop-thru target))
 549     (test-type value temp target not-p symbol-header-widetag)
 550     DROP-THRU))
 551
 552 (define-vop (check-symbol check-type)
 553   (:generator 12
 554     (inst beq value null-tn drop-thru)
 555     (let ((error (generate-error-code vop object-not-symbol-error value)))
 556       (test-type value temp error t symbol-header-widetag))
 557     DROP-THRU
 558     (move result value)))
 559
 560 (define-vop (consp type-predicate)
 561   (:translate consp)
 562   (:generator 8
 563     (inst beq value null-tn (if not-p target drop-thru))
 564     (test-type value temp target not-p list-pointer-lowtag)
 565     DROP-THRU))
 566
 567 (define-vop (check-cons check-type)
 568   (:generator 8
 569     (let ((error (generate-error-code vop object-not-cons-error value)))
 570       (inst beq value null-tn error)
 571       (test-type value temp error t list-pointer-lowtag))
 572     (move result value)))
 573
 574 ) ; MACROLET