src/compiler/hppa/type-vops.lisp

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