src/compiler/sparc/arith.lisp

   1 ;;;; the VM definition arithmetic VOPs for the Alpha
   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 ;;;; unary operations.
  15
  16 (define-vop (fast-safe-arith-op)
  17   (:policy :fast-safe)
  18   (:effects)
  19   (:affected))
  20
  21 (define-vop (fixnum-unop fast-safe-arith-op)
  22   (:args (x :scs (any-reg)))
  23   (:results (res :scs (any-reg)))
  24   (:note "inline fixnum arithmetic")
  25   (:arg-types tagged-num)
  26   (:result-types tagged-num))
  27
  28 (define-vop (signed-unop fast-safe-arith-op)
  29   (:args (x :scs (signed-reg)))
  30   (:results (res :scs (signed-reg)))
  31   (:note "inline (signed-byte 32) arithmetic")
  32   (:arg-types signed-num)
  33   (:result-types signed-num))
  34
  35 (define-vop (fast-negate/fixnum fixnum-unop)
  36   (:translate %negate)
  37   (:generator 1
  38     (inst neg res x)))
  39
  40 (define-vop (fast-negate/signed signed-unop)
  41   (:translate %negate)
  42   (:generator 2
  43     (inst neg res x)))
  44
  45 (define-vop (fast-lognot/fixnum fixnum-unop)
  46   (:translate lognot)
  47   (:generator 2
  48     (inst xor res x (fixnumize -1))))
  49
  50 (define-vop (fast-lognot/signed signed-unop)
  51   (:translate lognot)
  52   (:generator 1
  53     (inst not res x)))
  54 \f
  55 ;;;; Binary fixnum operations.
  56
  57 ;;; Assume that any constant operand is the second arg...
  58
  59 (define-vop (fast-fixnum-binop fast-safe-arith-op)
  60   (:args (x :target r :scs (any-reg zero))
  61          (y :target r :scs (any-reg zero)))
  62   (:arg-types tagged-num tagged-num)
  63   (:results (r :scs (any-reg)))
  64   (:result-types tagged-num)
  65   (:note "inline fixnum arithmetic"))
  66
  67 (define-vop (fast-unsigned-binop fast-safe-arith-op)
  68   (:args (x :target r :scs (unsigned-reg zero))
  69          (y :target r :scs (unsigned-reg zero)))
  70   (:arg-types unsigned-num unsigned-num)
  71   (:results (r :scs (unsigned-reg)))
  72   (:result-types unsigned-num)
  73   (:note "inline (unsigned-byte 32) arithmetic"))
  74
  75 (define-vop (fast-signed-binop fast-safe-arith-op)
  76   (:args (x :target r :scs (signed-reg zero))
  77          (y :target r :scs (signed-reg zero)))
  78   (:arg-types signed-num signed-num)
  79   (:results (r :scs (signed-reg)))
  80   (:result-types signed-num)
  81   (:note "inline (signed-byte 32) arithmetic"))
  82
  83
  84 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
  85   (:args (x :target r :scs (any-reg zero)))
  86   (:info y)
  87   (:arg-types tagged-num
  88               (:constant (and (signed-byte 11) (not (integer 0 0)))))
  89   (:results (r :scs (any-reg)))
  90   (:result-types tagged-num)
  91   (:note "inline fixnum arithmetic"))
  92
  93 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
  94   (:args (x :target r :scs (unsigned-reg zero)))
  95   (:info y)
  96   (:arg-types unsigned-num
  97               (:constant (and (signed-byte 13) (not (integer 0 0)))))
  98   (:results (r :scs (unsigned-reg)))
  99   (:result-types unsigned-num)
 100   (:note "inline (unsigned-byte 32) arithmetic"))
 101
 102 (define-vop (fast-signed-binop-c fast-safe-arith-op)
 103   (:args (x :target r :scs (signed-reg zero)))
 104   (:info y)
 105   (:arg-types signed-num
 106               (:constant (and (signed-byte 13) (not (integer 0 0)))))
 107   (:results (r :scs (signed-reg)))
 108   (:result-types signed-num)
 109   (:note "inline (signed-byte 32) arithmetic"))
 110
 111
 112 (eval-when (:compile-toplevel :load-toplevel :execute)
 113
 114 (defmacro define-binop (translate untagged-penalty op)
 115   `(progn
 116      (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
 117                   fast-fixnum-binop)
 118        (:translate ,translate)
 119        (:generator 2
 120          (inst ,op r x y)))
 121      (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
 122                   fast-fixnum-binop-c)
 123        (:translate ,translate)
 124        (:generator 1
 125          (inst ,op r x (fixnumize y))))
 126      (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 127                   fast-signed-binop)
 128        (:translate ,translate)
 129        (:generator ,(1+ untagged-penalty)
 130          (inst ,op r x y)))
 131      (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
 132                   fast-signed-binop-c)
 133        (:translate ,translate)
 134        (:generator ,untagged-penalty
 135          (inst ,op r x y)))
 136      (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
 137                   fast-unsigned-binop)
 138        (:translate ,translate)
 139        (:generator ,(1+ untagged-penalty)
 140          (inst ,op r x y)))
 141      (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
 142                   fast-unsigned-binop-c)
 143        (:translate ,translate)
 144        (:generator ,untagged-penalty
 145          (inst ,op r x y)))))
 146
 147 ); eval-when
 148
 149 (define-binop + 4 add)
 150 (define-binop - 4 sub)
 151 (define-binop logand 2 and)
 152 (define-binop logandc2 2 andn)
 153 (define-binop logior 2 or)
 154 (define-binop logorc2 2 orn)
 155 (define-binop logxor 2 xor)
 156 (define-binop logeqv 2 xnor)
 157
 158 ;;; Special logand cases: (logand signed unsigned) => unsigned
 159
 160 (define-vop (fast-logand/signed-unsigned=>unsigned
 161              fast-logand/unsigned=>unsigned)
 162     (:args (x :target r :scs (signed-reg))
 163            (y :scs (unsigned-reg unsigned-stack)))
 164   (:arg-types signed-num unsigned-num))
 165
 166 (define-vop (fast-logand/unsigned-signed=>unsigned
 167              fast-logand/unsigned=>unsigned)
 168     (:args (x :target r :scs (unsigned-reg))
 169            (y :scs (signed-reg signed-stack)))
 170   (:arg-types unsigned-num signed-num))
 171
 172 ;;; Special case fixnum + and - that trap on overflow.  Useful when we
 173 ;;; don't know that the output type is a fixnum.
 174
 175 ;;; I (toy@rtp.ericsson.se) took these out.  They don't seem to be
 176 ;;; used anywhere at all.
 177 #+nil
 178 (progn
 179 (define-vop (+/fixnum fast-+/fixnum=>fixnum)
 180   (:policy :safe)
 181   (:results (r :scs (any-reg descriptor-reg)))
 182   (:result-types tagged-num)
 183   (:note "safe inline fixnum arithmetic")
 184   (:generator 4
 185     (inst taddcctv r x y)))
 186
 187 (define-vop (+-c/fixnum fast-+-c/fixnum=>fixnum)
 188   (:policy :safe)
 189   (:results (r :scs (any-reg descriptor-reg)))
 190   (:result-types tagged-num)
 191   (:note "safe inline fixnum arithmetic")
 192   (:generator 3
 193     (inst taddcctv r x (fixnumize y))))
 194
 195 (define-vop (-/fixnum fast--/fixnum=>fixnum)
 196   (:policy :safe)
 197   (:results (r :scs (any-reg descriptor-reg)))
 198   (:result-types tagged-num)
 199   (:note "safe inline fixnum arithmetic")
 200   (:generator 4
 201     (inst tsubcctv r x y)))
 202
 203 (define-vop (--c/fixnum fast---c/fixnum=>fixnum)
 204   (:policy :safe)
 205   (:results (r :scs (any-reg descriptor-reg)))
 206   (:result-types tagged-num)
 207   (:note "safe inline fixnum arithmetic")
 208   (:generator 3
 209     (inst tsubcctv r x (fixnumize y))))
 210
 211 )
 212
 213 ;;; Truncate
 214
 215 ;; This doesn't work for some reason.
 216 #+nil
 217 (define-vop (fast-v8-truncate/fixnum=>fixnum fast-safe-arith-op)
 218   (:translate truncate)
 219   (:args (x :scs (any-reg))
 220          (y :scs (any-reg)))
 221   (:arg-types tagged-num tagged-num)
 222   (:results (quo :scs (any-reg))
 223             (rem :scs (any-reg)))
 224   (:result-types tagged-num tagged-num)
 225   (:note "inline fixnum arithmetic")
 226   (:temporary (:scs (any-reg) :target quo) q)
 227   (:temporary (:scs (any-reg)) r)
 228   (:temporary (:scs (signed-reg)) y-int)
 229   (:vop-var vop)
 230   (:save-p :compute-only)
 231   (:guard (or (member :sparc-v8 *backend-subfeatures*)
 232               (and (member :sparc-v9 *backend-subfeatures*)
 233                    (not (member :sparc-64 *backend-subfeatures*)))))
 234   (:generator 12
 235     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 236       (inst cmp y zero-tn)
 237       (inst b :eq zero)
 238       ;; Extend the sign of X into the Y register
 239         (inst sra r x 31)
 240       (inst wry r)
 241       ;; Remove tag bits so Q and R will be tagged correctly.
 242       (inst sra y-int y n-fixnum-tag-bits)
 243       (inst nop)
 244       (inst nop)
 245
 246       (inst sdiv q x y-int)             ; Q is tagged.
 247       ;; We have the quotient so we need to compute the remainder
 248       (inst smul r q y-int)             ; R is tagged
 249       (inst sub rem x r)
 250       (unless (location= quo q)
 251         (move quo q)))))
 252
 253 (define-vop (fast-v8-truncate/signed=>signed fast-safe-arith-op)
 254   (:translate truncate)
 255   (:args (x :scs (signed-reg))
 256          (y :scs (signed-reg)))
 257   (:arg-types signed-num signed-num)
 258   (:results (quo :scs (signed-reg))
 259             (rem :scs (signed-reg)))
 260   (:result-types signed-num signed-num)
 261   (:note "inline (signed-byte 32) arithmetic")
 262   (:temporary (:scs (signed-reg) :target quo) q)
 263   (:temporary (:scs (signed-reg)) r)
 264   (:vop-var vop)
 265   (:save-p :compute-only)
 266   (:guard (or (member :sparc-v8 *backend-subfeatures*)
 267               (and (member :sparc-v9 *backend-subfeatures*)
 268                    (not (member :sparc-64 *backend-subfeatures*)))))
 269   (:generator 12
 270     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 271       (inst cmp y zero-tn)
 272       (if (member :sparc-v9 *backend-subfeatures*)
 273           (inst b :eq zero :pn)
 274           (inst b :eq zero))
 275       ;; Extend the sign of X into the Y register
 276       (inst sra r x 31)
 277       (inst wry r)
 278       (inst nop)
 279       (inst nop)
 280       (inst nop)
 281
 282       (inst sdiv q x y)
 283       ;; We have the quotient so we need to compue the remainder
 284       (inst smul r q y)         ; rem
 285       (inst sub rem x r)
 286       (unless (location= quo q)
 287         (move quo q)))))
 288
 289 (define-vop (fast-v8-truncate/unsigned=>unsigned fast-safe-arith-op)
 290   (:translate truncate)
 291   (:args (x :scs (unsigned-reg))
 292          (y :scs (unsigned-reg)))
 293   (:arg-types unsigned-num unsigned-num)
 294   (:results (quo :scs (unsigned-reg))
 295             (rem :scs (unsigned-reg)))
 296   (:result-types unsigned-num unsigned-num)
 297   (:note "inline (unsigned-byte 32) arithmetic")
 298   (:temporary (:scs (unsigned-reg) :target quo) q)
 299   (:temporary (:scs (unsigned-reg)) r)
 300   (:vop-var vop)
 301   (:save-p :compute-only)
 302   (:guard (or (member :sparc-v8 *backend-subfeatures*)
 303               (and (member :sparc-v9 *backend-subfeatures*)
 304                    (not (member :sparc-64 *backend-subfeatures*)))))
 305   (:generator 8
 306     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 307       (inst cmp y zero-tn)
 308       (if (member :sparc-v9 *backend-subfeatures*)
 309           (inst b :eq zero :pn)
 310           (inst b :eq zero))
 311       (inst wry zero-tn)                ; Clear out high part
 312       (inst nop)
 313       (inst nop)
 314       (inst nop)
 315
 316       (inst udiv q x y)
 317       ;; Compute remainder
 318       (inst umul r q y)
 319       (inst sub rem x r)
 320       (unless (location= quo q)
 321         (inst move quo q)))))
 322
 323 (define-vop (fast-v9-truncate/signed=>signed fast-safe-arith-op)
 324   (:translate truncate)
 325   (:args (x :scs (signed-reg))
 326          (y :scs (signed-reg)))
 327   (:arg-types signed-num signed-num)
 328   (:results (quo :scs (signed-reg))
 329             (rem :scs (signed-reg)))
 330   (:result-types signed-num signed-num)
 331   (:note "inline (signed-byte 32) arithmetic")
 332   (:temporary (:scs (signed-reg) :target quo) q)
 333   (:temporary (:scs (signed-reg)) r)
 334   (:vop-var vop)
 335   (:save-p :compute-only)
 336   (:guard (member :sparc-64 *backend-subfeatures*))
 337   (:generator 8
 338     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 339       (inst cmp y zero-tn)
 340       (inst b :eq zero :pn)
 341       ;; Sign extend the numbers, just in case.
 342       (inst sra x 0)
 343       (inst sra y 0)
 344       (inst sdivx q x y)
 345       ;; Compute remainder
 346       (inst mulx r q y)
 347       (inst sub rem x r)
 348       (unless (location= quo q)
 349         (inst move quo q)))))
 350
 351 (define-vop (fast-v9-truncate/unsigned=>unsigned fast-safe-arith-op)
 352   (:translate truncate)
 353   (:args (x :scs (unsigned-reg))
 354          (y :scs (unsigned-reg)))
 355   (:arg-types unsigned-num unsigned-num)
 356   (:results (quo :scs (unsigned-reg))
 357             (rem :scs (unsigned-reg)))
 358   (:result-types unsigned-num unsigned-num)
 359   (:note "inline (unsigned-byte 32) arithmetic")
 360   (:temporary (:scs (unsigned-reg) :target quo) q)
 361   (:temporary (:scs (unsigned-reg)) r)
 362   (:vop-var vop)
 363   (:save-p :compute-only)
 364   (:guard (member :sparc-64 *backend-subfeatures*))
 365   (:generator 8
 366     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 367       (inst cmp y zero-tn)
 368       (inst b :eq zero :pn)
 369       ;; Zap the higher 32 bits, just in case
 370       (inst srl x 0)
 371       (inst srl y 0)
 372       (inst udivx q x y)
 373       ;; Compute remainder
 374       (inst mulx r q y)
 375       (inst sub rem x r)
 376       (unless (location= quo q)
 377         (inst move quo q)))))
 378
 379 ;;; Shifting
 380
 381 (macrolet
 382     ((frob (name sc-type type shift-right-inst)
 383        `(define-vop (,name)
 384           (:note "inline ASH")
 385           (:args (number :scs (,sc-type) :to :save)
 386                  (amount :scs (signed-reg immediate)))
 387           (:arg-types ,type signed-num)
 388           (:results (result :scs (,sc-type)))
 389           (:result-types ,type)
 390           (:translate ash)
 391           (:policy :fast-safe)
 392           (:temporary (:sc non-descriptor-reg) ndesc)
 393           (:generator 5
 394             (sc-case amount
 395              (signed-reg
 396               (cond
 397                 ;; FIXME: These two don't look different enough.
 398                 ((member :sparc-v9 *backend-subfeatures*)
 399                  (let ((done (gen-label))
 400                        (positive (gen-label)))
 401                    (inst cmp amount)
 402                    (inst b :ge positive)
 403                    (inst neg ndesc amount)
 404                    ;; ndesc = max(-amount, 31)
 405                    (inst cmp ndesc 31)
 406                    (inst cmove :ge ndesc 31)
 407                    (inst b done)
 408                    (inst ,shift-right-inst result number ndesc)
 409                    (emit-label positive)
 410                    ;; The result-type assures us that this shift will
 411                    ;; not overflow.
 412                    (inst sll result number amount)
 413                    ;; We want a right shift of the appropriate size.
 414                    (emit-label done)))
 415                 (t
 416                  (let ((positive (gen-label))
 417                        (done (gen-label)))
 418                    (inst cmp amount)
 419                    (inst b :ge positive)
 420                    (inst neg ndesc amount)
 421                    (inst cmp ndesc 31)
 422                    (inst b :le done)
 423                    (inst ,shift-right-inst result number ndesc)
 424                    (inst b done)
 425                    (inst ,shift-right-inst result number 31)
 426                    (emit-label positive)
 427                    ;; The result-type assures us that this shift will
 428                    ;; not overflow.
 429                    (inst sll result number amount)
 430                    (emit-label done)))))
 431              (immediate
 432               (let ((amount (tn-value amount)))
 433                 (if (minusp amount)
 434                     (let ((amount (min 31 (- amount))))
 435                       (inst ,shift-right-inst result number amount))
 436                     (inst sll result number amount)))))))))
 437   (frob fast-ash/signed=>signed signed-reg signed-num sra)
 438   (frob fast-ash/unsigned=>unsigned unsigned-reg unsigned-num srl))
 439
 440 ;; Some special cases where we know we want a left shift.  Just do the
 441 ;; shift, instead of checking for the sign of the shift.
 442 (macrolet
 443     ((frob (name sc-type type result-type cost)
 444        `(define-vop (,name)
 445          (:note "inline ASH")
 446          (:translate ash)
 447          (:args (number :scs (,sc-type))
 448                 (amount :scs (signed-reg unsigned-reg immediate)))
 449          (:arg-types ,type positive-fixnum)
 450          (:results (result :scs (,result-type)))
 451          (:result-types ,type)
 452          (:policy :fast-safe)
 453          (:generator ,cost
 454           ;; The result-type assures us that this shift will not
 455           ;; overflow. And for fixnum's, the zero bits that get
 456           ;; shifted in are just fine for the fixnum tag.
 457           (sc-case amount
 458            ((signed-reg unsigned-reg)
 459             (inst sll result number amount))
 460            (immediate
 461             (let ((amount (tn-value amount)))
 462               (assert (>= amount 0))
 463               (inst sll result number amount))))))))
 464   (frob fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
 465   (frob fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
 466   (frob fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
 467
 468 (defknown ash-right-signed ((signed-byte #.sb!vm:n-word-bits)
 469                             (and fixnum unsigned-byte))
 470   (signed-byte #.sb!vm:n-word-bits)
 471   (movable foldable flushable))
 472
 473 (defknown ash-right-unsigned ((unsigned-byte #.sb!vm:n-word-bits)
 474                               (and fixnum unsigned-byte))
 475   (unsigned-byte #.sb!vm:n-word-bits)
 476   (movable foldable flushable))
 477
 478 ;; Some special cases where we want a right shift.  Just do the shift.
 479 ;; (Needs appropriate deftransforms to call these, though.)
 480
 481 (macrolet
 482     ((frob (trans name sc-type type shift-inst cost)
 483        `(define-vop (,name)
 484          (:note "inline right ASH")
 485          (:translate ,trans)
 486          (:args (number :scs (,sc-type))
 487                 (amount :scs (signed-reg unsigned-reg immediate)))
 488          (:arg-types ,type positive-fixnum)
 489          (:results (result :scs (,sc-type)))
 490          (:result-types ,type)
 491          (:policy :fast-safe)
 492          (:generator ,cost
 493             (sc-case amount
 494              ((signed-reg unsigned-reg)
 495                 (inst ,shift-inst result number amount))
 496              (immediate
 497               (let ((amt (tn-value amount)))
 498                 (inst ,shift-inst result number amt))))))))
 499   (frob ash-right-signed fast-ash-right/signed=>signed
 500         signed-reg signed-num sra 3)
 501   (frob ash-right-unsigned fast-ash-right/unsigned=>unsigned
 502         unsigned-reg unsigned-num srl 3))
 503
 504 (define-vop (fast-ash-right/fixnum=>fixnum)
 505     (:note "inline right ASH")
 506   (:translate ash-right-signed)
 507   (:args (number :scs (any-reg))
 508          (amount :scs (signed-reg unsigned-reg immediate)))
 509   (:arg-types tagged-num positive-fixnum)
 510   (:results (result :scs (any-reg)))
 511   (:result-types tagged-num)
 512   (:temporary (:sc non-descriptor-reg :target result) temp)
 513   (:policy :fast-safe)
 514   (:generator 2
 515     ;; Shift the fixnum right by the desired amount.  Then zap out the
 516     ;; 2 LSBs to make it a fixnum again.  (Those bits are junk.)
 517     (sc-case amount
 518       ((signed-reg unsigned-reg)
 519        (inst sra temp number amount))
 520       (immediate
 521        (inst sra temp number (tn-value amount))))
 522     (inst andn result temp fixnum-tag-mask)))
 523
 524
 525
 526 \f
 527 (define-vop (signed-byte-32-len)
 528   (:translate integer-length)
 529   (:note "inline (signed-byte 32) integer-length")
 530   (:policy :fast-safe)
 531   (:args (arg :scs (signed-reg) :target shift))
 532   (:arg-types signed-num)
 533   (:results (res :scs (any-reg)))
 534   (:result-types positive-fixnum)
 535   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
 536   (:generator 30
 537     (let ((loop (gen-label))
 538           (test (gen-label)))
 539       (inst addcc shift zero-tn arg)
 540       (inst b :ge test)
 541       (move res zero-tn)
 542       (inst b test)
 543       (inst not shift)
 544
 545       (emit-label loop)
 546       (inst add res (fixnumize 1))
 547
 548       (emit-label test)
 549       (inst cmp shift)
 550       (inst b :ne loop)
 551       (inst srl shift 1))))
 552
 553 (define-vop (unsigned-byte-32-count)
 554   (:translate logcount)
 555   (:note "inline (unsigned-byte 32) logcount")
 556   (:policy :fast-safe)
 557   (:args (arg :scs (unsigned-reg)))
 558   (:arg-types unsigned-num)
 559   (:results (res :scs (unsigned-reg)))
 560   (:result-types positive-fixnum)
 561   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) mask temp)
 562   (:generator 35
 563       (move res arg)
 564
 565       (dolist (stuff '((1 #x55555555) (2 #x33333333) (4 #x0f0f0f0f)
 566                        (8 #x00ff00ff) (16 #x0000ffff)))
 567         (destructuring-bind (shift bit-mask)
 568             stuff
 569           ;; Set mask
 570           (inst sethi mask (ldb (byte 22 10) bit-mask))
 571           (inst add mask (ldb (byte 10 0) bit-mask))
 572
 573           (inst and temp res mask)
 574           (inst srl res shift)
 575           (inst and res mask)
 576           (inst add res temp)))))
 577
 578
 579 ;;; Multiply and Divide.
 580
 581 (define-vop (fast-v8-*/fixnum=>fixnum fast-fixnum-binop)
 582   (:temporary (:scs (non-descriptor-reg)) temp)
 583   (:translate *)
 584   (:guard (or (member :sparc-v8 *backend-subfeatures*)
 585               (and (member :sparc-v9 *backend-subfeatures*)
 586                    (not (member :sparc-64 *backend-subfeatures*)))))
 587   (:generator 2
 588     ;; The cost here should be less than the cost for
 589     ;; */signed=>signed.  Why?  A fixnum product using signed=>signed
 590     ;; has to convert both args to signed-nums.  But using this, we
 591     ;; don't have to and that saves an instruction.
 592     (inst sra temp y n-fixnum-tag-bits)
 593     (inst smul r x temp)))
 594
 595 (define-vop (fast-v8-*/signed=>signed fast-signed-binop)
 596   (:translate *)
 597   (:guard (or (member :sparc-v8 *backend-subfeatures*)
 598               (and (member :sparc-v9 *backend-subfeatures*)
 599                    (not (member :sparc-64 *backend-subfeatures*)))))
 600   (:generator 3
 601     (inst smul r x y)))
 602
 603 (define-vop (fast-v8-*/unsigned=>unsigned fast-unsigned-binop)
 604   (:translate *)
 605   (:guard (or (member :sparc-v8 *backend-subfeatures*)
 606               (and (member :sparc-v9 *backend-subfeatures*)
 607                    (not (member :sparc-64 *backend-subfeatures*)))))
 608   (:generator 3
 609     (inst umul r x y)))
 610
 611 ;; The smul and umul instructions are deprecated on the Sparc V9.  Use
 612 ;; mulx instead.
 613 (define-vop (fast-v9-*/fixnum=>fixnum fast-fixnum-binop)
 614   (:temporary (:scs (non-descriptor-reg)) temp)
 615   (:translate *)
 616   (:guard (member :sparc-64 *backend-subfeatures*))
 617   (:generator 4
 618     (inst sra temp y n-fixnum-tag-bits)
 619     (inst mulx r x temp)))
 620
 621 (define-vop (fast-v9-*/signed=>signed fast-signed-binop)
 622   (:translate *)
 623   (:guard (member :sparc-64 *backend-subfeatures*))
 624   (:generator 3
 625     (inst mulx r x y)))
 626
 627 (define-vop (fast-v9-*/unsigned=>unsigned fast-unsigned-binop)
 628   (:translate *)
 629   (:guard (member :sparc-64 *backend-subfeatures*))
 630   (:generator 3
 631     (inst mulx r x y)))
 632
 633 \f
 634 ;;;; Binary conditional VOPs:
 635
 636 (define-vop (fast-conditional)
 637   (:conditional)
 638   (:info target not-p)
 639   (:effects)
 640   (:affected)
 641   (:policy :fast-safe))
 642
 643 (define-vop (fast-conditional/fixnum fast-conditional)
 644   (:args (x :scs (any-reg zero))
 645          (y :scs (any-reg zero)))
 646   (:arg-types tagged-num tagged-num)
 647   (:note "inline fixnum comparison"))
 648
 649 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
 650   (:args (x :scs (any-reg zero)))
 651   (:arg-types tagged-num (:constant (signed-byte 11)))
 652   (:info target not-p y))
 653
 654 (define-vop (fast-conditional/signed fast-conditional)
 655   (:args (x :scs (signed-reg zero))
 656          (y :scs (signed-reg zero)))
 657   (:arg-types signed-num signed-num)
 658   (:note "inline (signed-byte 32) comparison"))
 659
 660 (define-vop (fast-conditional-c/signed fast-conditional/signed)
 661   (:args (x :scs (signed-reg zero)))
 662   (:arg-types signed-num (:constant (signed-byte 13)))
 663   (:info target not-p y))
 664
 665 (define-vop (fast-conditional/unsigned fast-conditional)
 666   (:args (x :scs (unsigned-reg zero))
 667          (y :scs (unsigned-reg zero)))
 668   (:arg-types unsigned-num unsigned-num)
 669   (:note "inline (unsigned-byte 32) comparison"))
 670
 671 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
 672   (:args (x :scs (unsigned-reg zero)))
 673   (:arg-types unsigned-num (:constant (unsigned-byte 12)))
 674   (:info target not-p y))
 675
 676
 677 (defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned)
 678   `(progn
 679      ,@(mapcar (lambda (suffix cost signed)
 680                  (unless (and (member suffix '(/fixnum -c/fixnum))
 681                               (eq tran 'eql))
 682                    `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
 683                                                   tran suffix))
 684                                  ,(intern
 685                                    (format nil "~:@(FAST-CONDITIONAL~A~)"
 686                                            suffix)))
 687                      (:translate ,tran)
 688                      (:generator ,cost
 689                       (inst cmp x
 690                        ,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y))
 691                       (inst b (if not-p
 692                                   ,(if signed not-cond not-unsigned)
 693                                   ,(if signed cond unsigned))
 694                        target)
 695                       (inst nop)))))
 696                '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
 697                '(4 3 6 5 6 5)
 698                '(t t t t nil nil))))
 699
 700 (define-conditional-vop < :lt :ltu :ge :geu)
 701
 702 (define-conditional-vop > :gt :gtu :le :leu)
 703
 704 (define-conditional-vop eql :eq :eq :ne :ne)
 705
 706 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
 707 ;;; known fixnum.
 708
 709 ;;; These versions specify a fixnum restriction on their first arg.  We have
 710 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
 711 ;;; the first arg and a higher cost.  The reason for doing this is to prevent
 712 ;;; fixnum specific operations from being used on word integers, spuriously
 713 ;;; consing the argument.
 714 ;;;
 715
 716 (define-vop (fast-eql/fixnum fast-conditional)
 717   (:args (x :scs (any-reg descriptor-reg zero))
 718          (y :scs (any-reg zero)))
 719   (:arg-types tagged-num tagged-num)
 720   (:note "inline fixnum comparison")
 721   (:translate eql)
 722   (:generator 4
 723     (inst cmp x y)
 724     (inst b (if not-p :ne :eq) target)
 725     (inst nop)))
 726 ;;;
 727 (define-vop (generic-eql/fixnum fast-eql/fixnum)
 728   (:arg-types * tagged-num)
 729   (:variant-cost 7))
 730
 731 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
 732   (:args (x :scs (any-reg descriptor-reg zero)))
 733   (:arg-types tagged-num (:constant (signed-byte 11)))
 734   (:info target not-p y)
 735   (:translate eql)
 736   (:generator 2
 737     (inst cmp x (fixnumize y))
 738     (inst b (if not-p :ne :eq) target)
 739     (inst nop)))
 740 ;;;
 741 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
 742   (:arg-types * (:constant (signed-byte 11)))
 743   (:variant-cost 6))
 744
 745 \f
 746 ;;;; 32-bit logical operations
 747
 748 (define-vop (merge-bits)
 749   (:translate merge-bits)
 750   (:args (shift :scs (signed-reg unsigned-reg))
 751          (prev :scs (unsigned-reg))
 752          (next :scs (unsigned-reg)))
 753   (:arg-types tagged-num unsigned-num unsigned-num)
 754   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 755   (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
 756   (:results (result :scs (unsigned-reg)))
 757   (:result-types unsigned-num)
 758   (:policy :fast-safe)
 759   (:generator 4
 760     (let ((done (gen-label)))
 761       (inst cmp shift)
 762       (inst b :eq done)
 763       (inst srl res next shift)
 764       (inst sub temp zero-tn shift)
 765       (inst sll temp prev temp)
 766       (inst or res temp)
 767       (emit-label done)
 768       (move result res))))
 769
 770
 771 (define-vop (32bit-logical)
 772   (:args (x :scs (unsigned-reg zero))
 773          (y :scs (unsigned-reg zero)))
 774   (:arg-types unsigned-num unsigned-num)
 775   (:results (r :scs (unsigned-reg)))
 776   (:result-types unsigned-num)
 777   (:policy :fast-safe))
 778
 779 (define-vop (32bit-logical-not 32bit-logical)
 780   (:translate 32bit-logical-not)
 781   (:args (x :scs (unsigned-reg zero)))
 782   (:arg-types unsigned-num)
 783   (:generator 1
 784     (inst not r x)))
 785
 786 (define-vop (32bit-logical-and 32bit-logical)
 787   (:translate 32bit-logical-and)
 788   (:generator 1
 789     (inst and r x y)))
 790
 791 (deftransform 32bit-logical-nand ((x y) (* *))
 792   '(32bit-logical-not (32bit-logical-and x y)))
 793
 794 (define-vop (32bit-logical-or 32bit-logical)
 795   (:translate 32bit-logical-or)
 796   (:generator 1
 797     (inst or r x y)))
 798
 799 (deftransform 32bit-logical-nor ((x y) (* *))
 800   '(32bit-logical-not (32bit-logical-or x y)))
 801
 802 (define-vop (32bit-logical-xor 32bit-logical)
 803   (:translate 32bit-logical-xor)
 804   (:generator 1
 805     (inst xor r x y)))
 806
 807 (define-vop (32bit-logical-eqv 32bit-logical)
 808   (:translate 32bit-logical-eqv)
 809   (:generator 1
 810     (inst xnor r x y)))
 811
 812 (define-vop (32bit-logical-orc2 32bit-logical)
 813   (:translate 32bit-logical-orc2)
 814   (:generator 1
 815     (inst orn r x y)))
 816
 817 (deftransform 32bit-logical-orc1 ((x y) (* *))
 818   '(32bit-logical-orc2 y x))
 819
 820 (define-vop (32bit-logical-andc2 32bit-logical)
 821   (:translate 32bit-logical-andc2)
 822   (:generator 1
 823     (inst andn r x y)))
 824
 825 (deftransform 32bit-logical-andc1 ((x y) (* *))
 826   '(32bit-logical-andc2 y x))
 827
 828
 829 (define-vop (shift-towards-someplace)
 830   (:policy :fast-safe)
 831   (:args (num :scs (unsigned-reg))
 832          (amount :scs (signed-reg)))
 833   (:arg-types unsigned-num tagged-num)
 834   (:results (r :scs (unsigned-reg)))
 835   (:result-types unsigned-num))
 836
 837 (define-vop (shift-towards-start shift-towards-someplace)
 838   (:translate shift-towards-start)
 839   (:note "shift-towards-start")
 840   (:generator 1
 841     (inst sll r num amount)))
 842
 843 (define-vop (shift-towards-end shift-towards-someplace)
 844   (:translate shift-towards-end)
 845   (:note "shift-towards-end")
 846   (:generator 1
 847     (inst srl r num amount)))
 848
 849
 850
 851 \f
 852 ;;;; Bignum stuff.
 853
 854 (define-vop (bignum-length get-header-data)
 855   (:translate sb!bignum::%bignum-length)
 856   (:policy :fast-safe))
 857
 858 (define-vop (bignum-set-length set-header-data)
 859   (:translate sb!bignum::%bignum-set-length)
 860   (:policy :fast-safe))
 861
 862 (define-vop (bignum-ref word-index-ref)
 863   (:variant bignum-digits-offset other-pointer-lowtag)
 864   (:translate sb!bignum::%bignum-ref)
 865   (:results (value :scs (unsigned-reg)))
 866   (:result-types unsigned-num))
 867
 868 (define-vop (bignum-set word-index-set)
 869   (:variant bignum-digits-offset other-pointer-lowtag)
 870   (:translate sb!bignum::%bignum-set)
 871   (:args (object :scs (descriptor-reg))
 872          (index :scs (any-reg immediate zero))
 873          (value :scs (unsigned-reg)))
 874   (:arg-types t positive-fixnum unsigned-num)
 875   (:results (result :scs (unsigned-reg)))
 876   (:result-types unsigned-num))
 877
 878 (define-vop (digit-0-or-plus)
 879   (:translate sb!bignum::%digit-0-or-plusp)
 880   (:policy :fast-safe)
 881   (:args (digit :scs (unsigned-reg)))
 882   (:arg-types unsigned-num)
 883   (:results (result :scs (descriptor-reg)))
 884   (:guard (not (member :sparc-v9 *backend-subfeatures*)))
 885   (:generator 3
 886     (let ((done (gen-label)))
 887       (inst cmp digit)
 888       (inst b :lt done)
 889       (move result null-tn)
 890       (load-symbol result t)
 891       (emit-label done))))
 892
 893 (define-vop (v9-digit-0-or-plus-cmove)
 894   (:translate sb!bignum::%digit-0-or-plusp)
 895   (:policy :fast-safe)
 896   (:args (digit :scs (unsigned-reg)))
 897   (:arg-types unsigned-num)
 898   (:results (result :scs (descriptor-reg)))
 899   (:guard (member :sparc-v9 *backend-subfeatures*))
 900   (:generator 3
 901     (inst cmp digit)
 902     (load-symbol result t)
 903     (inst cmove :lt result null-tn)))
 904
 905 ;; This doesn't work?
 906 #+nil
 907 (define-vop (v9-digit-0-or-plus-movr)
 908   (:translate sb!bignum::%digit-0-or-plusp)
 909   (:policy :fast-safe)
 910   (:args (digit :scs (unsigned-reg)))
 911   (:arg-types unsigned-num)
 912   (:results (result :scs (descriptor-reg)))
 913   (:temporary (:scs (descriptor-reg)) temp)
 914   (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
 915   (:generator 2
 916     (load-symbol temp t)
 917     (inst movr result null-tn digit :lz)
 918     (inst movr result temp digit :gez)))
 919
 920
 921 (define-vop (add-w/carry)
 922   (:translate sb!bignum::%add-with-carry)
 923   (:policy :fast-safe)
 924   (:args (a :scs (unsigned-reg))
 925          (b :scs (unsigned-reg))
 926          (c :scs (any-reg)))
 927   (:arg-types unsigned-num unsigned-num positive-fixnum)
 928   (:results (result :scs (unsigned-reg))
 929             (carry :scs (unsigned-reg)))
 930   (:result-types unsigned-num positive-fixnum)
 931   (:generator 3
 932     (inst addcc zero-tn c -1)
 933     (inst addxcc result a b)
 934     (inst addx carry zero-tn zero-tn)))
 935
 936 (define-vop (sub-w/borrow)
 937   (:translate sb!bignum::%subtract-with-borrow)
 938   (:policy :fast-safe)
 939   (:args (a :scs (unsigned-reg))
 940          (b :scs (unsigned-reg))
 941          (c :scs (any-reg)))
 942   (:arg-types unsigned-num unsigned-num positive-fixnum)
 943   (:results (result :scs (unsigned-reg))
 944             (borrow :scs (unsigned-reg)))
 945   (:result-types unsigned-num positive-fixnum)
 946   (:generator 4
 947     (inst subcc zero-tn c 1)
 948     (inst subxcc result a b)
 949     (inst addx borrow zero-tn zero-tn)
 950     (inst xor borrow 1)))
 951
 952 ;;; EMIT-MULTIPLY -- This is used both for bignum stuff and in assembly
 953 ;;; routines.
 954 ;;;
 955 (defun emit-multiply (multiplier multiplicand result-high result-low)
 956   "Emit code to multiply MULTIPLIER with MULTIPLICAND, putting the result
 957   in RESULT-HIGH and RESULT-LOW.  KIND is either :signed or :unsigned.
 958   Note: the lifetimes of MULTIPLICAND and RESULT-HIGH overlap."
 959   (declare (type tn multiplier result-high result-low)
 960            (type (or tn (signed-byte 13)) multiplicand))
 961   ;; It seems that emit-multiply is only used to do an unsigned
 962   ;; multiply, so the code only does an unsigned multiply.
 963   (cond
 964     ((member :sparc-64 *backend-subfeatures*)
 965      ;; Take advantage of V9's 64-bit multiplier.
 966      ;;
 967      ;; Make sure the multiplier and multiplicand are really
 968      ;; unsigned 64-bit numbers.
 969      (inst srl multiplier 0)
 970      (inst srl multiplicand 0)
 971
 972      ;; Multiply the two numbers and put the result in
 973      ;; result-high.  Copy the low 32-bits to result-low.  Then
 974      ;; shift result-high so the high 32-bits end up in the low
 975      ;; 32-bits.
 976      (inst mulx result-high multiplier multiplicand)
 977      (inst move result-low result-high)
 978      (inst srax result-high 32))
 979     ((or (member :sparc-v8 *backend-subfeatures*)
 980          (member :sparc-v9 *backend-subfeatures*))
 981      ;; V8 has a multiply instruction.  This should also work for
 982      ;; the V9, but umul and the Y register is deprecated on the
 983      ;; V9.
 984      (inst umul result-low multiplier multiplicand)
 985      (inst rdy result-high))
 986     (t
 987      (let ((label (gen-label)))
 988        (inst wry multiplier)
 989        (inst andcc result-high zero-tn)
 990        ;; Note: we can't use the Y register until three insts
 991        ;; after it's written.
 992        (inst nop)
 993        (inst nop)
 994        (dotimes (i 32)
 995          (inst mulscc result-high multiplicand))
 996        (inst mulscc result-high zero-tn)
 997        (inst cmp multiplicand)
 998        (inst b :ge label)
 999        (inst nop)
1000        (inst add result-high multiplier)
1001        (emit-label label)
1002        (inst rdy result-low)))))
1003
1004 (define-vop (bignum-mult-and-add-3-arg)
1005   (:translate sb!bignum::%multiply-and-add)
1006   (:policy :fast-safe)
1007   (:args (x :scs (unsigned-reg) :to (:eval 1))
1008          (y :scs (unsigned-reg) :to (:eval 1))
1009          (carry-in :scs (unsigned-reg) :to (:eval 2)))
1010   (:arg-types unsigned-num unsigned-num unsigned-num)
1011   (:results (hi :scs (unsigned-reg) :from (:eval 0))
1012             (lo :scs (unsigned-reg) :from (:eval 1)))
1013   (:result-types unsigned-num unsigned-num)
1014   (:generator 40
1015     (emit-multiply x y hi lo)
1016     (inst addcc lo carry-in)
1017     (inst addx hi zero-tn)))
1018
1019 (define-vop (bignum-mult-and-add-4-arg)
1020   (:translate sb!bignum::%multiply-and-add)
1021   (:policy :fast-safe)
1022   (:args (x :scs (unsigned-reg) :to (:eval 1))
1023          (y :scs (unsigned-reg) :to (:eval 1))
1024          (prev :scs (unsigned-reg) :to (:eval 2))
1025          (carry-in :scs (unsigned-reg) :to (:eval 2)))
1026   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1027   (:results (hi :scs (unsigned-reg) :from (:eval 0))
1028             (lo :scs (unsigned-reg) :from (:eval 1)))
1029   (:result-types unsigned-num unsigned-num)
1030   (:generator 40
1031     (emit-multiply x y hi lo)
1032     (inst addcc lo carry-in)
1033     (inst addx hi zero-tn)
1034     (inst addcc lo prev)
1035     (inst addx hi zero-tn)))
1036
1037 (define-vop (bignum-mult)
1038   (:translate sb!bignum::%multiply)
1039   (:policy :fast-safe)
1040   (:args (x :scs (unsigned-reg) :to (:result 1))
1041          (y :scs (unsigned-reg) :to (:result 1)))
1042   (:arg-types unsigned-num unsigned-num)
1043   (:results (hi :scs (unsigned-reg))
1044             (lo :scs (unsigned-reg)))
1045   (:result-types unsigned-num unsigned-num)
1046   (:generator 40
1047     (emit-multiply x y hi lo)))
1048
1049 (define-vop (bignum-lognot)
1050   (:translate sb!bignum::%lognot)
1051   (:policy :fast-safe)
1052   (:args (x :scs (unsigned-reg)))
1053   (:arg-types unsigned-num)
1054   (:results (r :scs (unsigned-reg)))
1055   (:result-types unsigned-num)
1056   (:generator 1
1057     (inst not r x)))
1058
1059 (define-vop (fixnum-to-digit)
1060   (:translate sb!bignum::%fixnum-to-digit)
1061   (:policy :fast-safe)
1062   (:args (fixnum :scs (any-reg)))
1063   (:arg-types tagged-num)
1064   (:results (digit :scs (unsigned-reg)))
1065   (:result-types unsigned-num)
1066   (:generator 1
1067     (inst sra digit fixnum n-fixnum-tag-bits)))
1068
1069 (define-vop (bignum-floor)
1070   (:translate sb!bignum::%floor)
1071   (:policy :fast-safe)
1072   (:args (div-high :scs (unsigned-reg) :target rem)
1073          (div-low :scs (unsigned-reg) :target quo)
1074          (divisor :scs (unsigned-reg)))
1075   (:arg-types unsigned-num unsigned-num unsigned-num)
1076   (:results (quo :scs (unsigned-reg) :from (:argument 1))
1077             (rem :scs (unsigned-reg) :from (:argument 0)))
1078   (:result-types unsigned-num unsigned-num)
1079   (:generator 300
1080     (move rem div-high)
1081     (move quo div-low)
1082     (dotimes (i 33)
1083       (let ((label (gen-label)))
1084         (inst cmp rem divisor)
1085         (inst b :ltu label)
1086         (inst addxcc quo quo)
1087         (inst sub rem divisor)
1088         (emit-label label)
1089         (unless (= i 32)
1090           (inst addx rem rem))))
1091     (inst not quo)))
1092
1093 (define-vop (bignum-floor-v8)
1094   (:translate sb!bignum::%floor)
1095   (:policy :fast-safe)
1096   (:args (div-high :scs (unsigned-reg) :target rem)
1097          (div-low :scs (unsigned-reg) :target quo)
1098          (divisor :scs (unsigned-reg)))
1099   (:arg-types unsigned-num unsigned-num unsigned-num)
1100   (:results (quo :scs (unsigned-reg) :from (:argument 1))
1101             (rem :scs (unsigned-reg) :from (:argument 0)))
1102   (:result-types unsigned-num unsigned-num)
1103   (:temporary (:scs (unsigned-reg) :target quo) q)
1104   ;; This vop is for a v8 or v9, provided we're also not using
1105   ;; sparc-64, for which there a special sparc-64 vop.
1106   (:guard (or (member :sparc-v8 *backend-subfeatures*)
1107               (member :sparc-v9 *backend-subfeatures*)))
1108   (:generator 15
1109     (inst wry div-high)
1110     (inst nop)
1111     (inst nop)
1112     (inst nop)
1113     ;; Compute the quotient [Y, div-low] / divisor
1114     (inst udiv q div-low divisor)
1115     ;; Compute the remainder.  The high part of the result is in the Y
1116     ;; register.
1117     (inst umul rem q divisor)
1118     (inst sub rem div-low rem)
1119     (unless (location= quo q)
1120       (move quo q))))
1121
1122 (define-vop (bignum-floor-v9)
1123   (:translate sb!bignum::%floor)
1124   (:policy :fast-safe)
1125   (:args (div-high :scs (unsigned-reg))
1126          (div-low :scs (unsigned-reg))
1127          (divisor :scs (unsigned-reg) :to (:result 1)))
1128   (:arg-types unsigned-num unsigned-num unsigned-num)
1129   (:temporary (:sc unsigned-reg :from (:argument 0)) dividend)
1130   (:results (quo :scs (unsigned-reg))
1131             (rem :scs (unsigned-reg)))
1132   (:result-types unsigned-num unsigned-num)
1133   (:guard (member :sparc-64 *backend-subfeatures*))
1134   (:generator 5
1135     ;; Set dividend to be div-high and div-low
1136     (inst sllx dividend div-high 32)
1137     (inst add dividend div-low)
1138     ;; Compute quotient
1139     (inst udivx quo dividend divisor)
1140     ;; Compute the remainder
1141     (inst mulx rem quo divisor)
1142     (inst sub rem dividend rem)))
1143
1144 (define-vop (signify-digit)
1145   (:translate sb!bignum::%fixnum-digit-with-correct-sign)
1146   (:policy :fast-safe)
1147   (:args (digit :scs (unsigned-reg) :target res))
1148   (:arg-types unsigned-num)
1149   (:results (res :scs (any-reg signed-reg)))
1150   (:result-types signed-num)
1151   (:generator 1
1152     (sc-case res
1153       (any-reg
1154        (inst sll res digit n-fixnum-tag-bits))
1155       (signed-reg
1156        (move res digit)))))
1157
1158
1159 (define-vop (digit-ashr)
1160   (:translate sb!bignum::%ashr)
1161   (:policy :fast-safe)
1162   (:args (digit :scs (unsigned-reg))
1163          (count :scs (unsigned-reg)))
1164   (:arg-types unsigned-num positive-fixnum)
1165   (:results (result :scs (unsigned-reg)))
1166   (:result-types unsigned-num)
1167   (:generator 1
1168     (inst sra result digit count)))
1169
1170 (define-vop (digit-lshr digit-ashr)
1171   (:translate sb!bignum::%digit-logical-shift-right)
1172   (:generator 1
1173     (inst srl result digit count)))
1174
1175 (define-vop (digit-ashl digit-ashr)
1176   (:translate sb!bignum::%ashl)
1177   (:generator 1
1178     (inst sll result digit count)))
1179
1180 \f
1181 ;;;; Static functions.
1182
1183 (define-static-fun two-arg-gcd (x y) :translate gcd)
1184 (define-static-fun two-arg-lcm (x y) :translate lcm)
1185
1186 (define-static-fun two-arg-+ (x y) :translate +)
1187 (define-static-fun two-arg-- (x y) :translate -)
1188 (define-static-fun two-arg-* (x y) :translate *)
1189 (define-static-fun two-arg-/ (x y) :translate /)
1190
1191 (define-static-fun two-arg-< (x y) :translate <)
1192 (define-static-fun two-arg-<= (x y) :translate <=)
1193 (define-static-fun two-arg-> (x y) :translate >)
1194 (define-static-fun two-arg->= (x y) :translate >=)
1195 (define-static-fun two-arg-= (x y) :translate =)
1196 (define-static-fun two-arg-/= (x y) :translate /=)
1197
1198 (define-static-fun %negate (x) :translate %negate)
1199
1200 (define-static-fun two-arg-and (x y) :translate logand)
1201 (define-static-fun two-arg-ior (x y) :translate logior)
1202 (define-static-fun two-arg-xor (x y) :translate logxor)
1203
1204 \f
1205 ;; Need these so constant folding works with the deftransform.
1206
1207 (defun ash-right-signed (num shift)
1208   (declare (type (signed-byte #.sb!vm:n-word-bits) num)
1209            (type (integer 0 #.(1- sb!vm:n-word-bits)) shift))
1210   (ash-right-signed num shift))
1211
1212 (defun ash-right-unsigned (num shift)
1213   (declare (type (unsigned-byte #.sb!vm:n-word-bits) num)
1214            (type (integer 0 #.(1- sb!vm:n-word-bits)) shift))
1215   (ash-right-unsigned num shift))
1216
1217 ;; If we can prove that we have a right shift, just do the right shift
1218 ;; instead of calling the inline ASH which has to check for the
1219 ;; direction of the shift at run-time.
1220 (in-package "SB!C")
1221
1222 (deftransform ash ((num shift) (integer integer))
1223   (let ((num-type (continuation-type num))
1224         (shift-type (continuation-type shift)))
1225     ;; Can only handle right shifts
1226     (unless (csubtypep shift-type (specifier-type '(integer * 0)))
1227       (give-up-ir1-transform))
1228
1229     ;; If we can prove the shift is so large that all bits are shifted
1230     ;; out, return the appropriate constant.  If the shift is small
1231     ;; enough, call the VOP.  Otherwise, check for the shift size and
1232     ;; do the appropriate thing.  (Hmm, could we just leave the IF
1233     ;; s-expr and depend on other parts of the compiler to delete the
1234     ;; unreachable parts, if any?)
1235     (cond ((csubtypep num-type (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
1236            ;; A right shift by 31 is the same as a right shift by
1237            ;; larger amount.  We get just the sign.
1238            (if (csubtypep shift-type (specifier-type '(integer #.(- 1 sb!vm:n-word-bits) 0)))
1239                ;; FIXME: ash-right-{un,}signed package problems
1240                `(sb!vm::ash-right-signed num (- shift))
1241                `(sb!vm::ash-right-signed num (min (- shift) #.(1- sb!vm:n-word-bits)))))
1242           ((csubtypep num-type (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
1243            (if (csubtypep shift-type (specifier-type '(integer #.(- 1 sb!vm:n-word-bits) 0)))
1244                `(sb!vm::ash-right-unsigned num (- shift))
1245                `(if (<= shift #.(- sb!vm:n-word-bits))
1246                  0
1247                  (sb!vm::ash-right-unsigned num (- shift)))))
1248           (t
1249            (give-up-ir1-transform)))))
1250