src/compiler/sparc/type-vops.lisp

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