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