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 (deftype integer-with-a-bite-out (s bite)
 644   (cond ((eq s '*) 'integer)
 645         ((and (integerp s) (> s 1))
 646          (let ((bound (ash 1 (1- s))))
 647            `(integer ,(- bound) ,(- bound bite 1))))
 648         (t
 649          (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
 650
 651 (define-vop (fast-conditional/fixnum fast-conditional)
 652   (:args (x :scs (any-reg zero))
 653          (y :scs (any-reg zero)))
 654   (:arg-types tagged-num tagged-num)
 655   (:note "inline fixnum comparison"))
 656
 657 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
 658   (:args (x :scs (any-reg zero)))
 659   (:arg-types tagged-num (:constant (signed-byte 11)))
 660   (:info target not-p y))
 661
 662 (define-vop (fast-conditional/signed fast-conditional)
 663   (:args (x :scs (signed-reg zero))
 664          (y :scs (signed-reg zero)))
 665   (:arg-types signed-num signed-num)
 666   (:note "inline (signed-byte 32) comparison"))
 667
 668 (define-vop (fast-conditional-c/signed fast-conditional/signed)
 669   (:args (x :scs (signed-reg zero)))
 670   (:arg-types signed-num (:constant (signed-byte 13)))
 671   (:info target not-p y))
 672
 673 (define-vop (fast-conditional/unsigned fast-conditional)
 674   (:args (x :scs (unsigned-reg zero))
 675          (y :scs (unsigned-reg zero)))
 676   (:arg-types unsigned-num unsigned-num)
 677   (:note "inline (unsigned-byte 32) comparison"))
 678
 679 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
 680   (:args (x :scs (unsigned-reg zero)))
 681   (:arg-types unsigned-num (:constant (unsigned-byte 12)))
 682   (:info target not-p y))
 683
 684
 685 (defmacro define-conditional-vop (tran cond unsigned not-cond not-unsigned)
 686   `(progn
 687      ,@(mapcar (lambda (suffix cost signed)
 688                  (unless (and (member suffix '(/fixnum -c/fixnum))
 689                               (eq tran 'eql))
 690                    `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
 691                                                   tran suffix))
 692                                  ,(intern
 693                                    (format nil "~:@(FAST-CONDITIONAL~A~)"
 694                                            suffix)))
 695                      (:translate ,tran)
 696                      (:generator ,cost
 697                       (inst cmp x
 698                        ,(if (eq suffix '-c/fixnum) '(fixnumize y) 'y))
 699                       (inst b (if not-p
 700                                   ,(if signed not-cond not-unsigned)
 701                                   ,(if signed cond unsigned))
 702                        target)
 703                       (inst nop)))))
 704                '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
 705                '(4 3 6 5 6 5)
 706                '(t t t t nil nil))))
 707
 708 (define-conditional-vop < :lt :ltu :ge :geu)
 709
 710 (define-conditional-vop > :gt :gtu :le :leu)
 711
 712 (define-conditional-vop eql :eq :eq :ne :ne)
 713
 714 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
 715 ;;; known fixnum.
 716
 717 ;;; These versions specify a fixnum restriction on their first arg.  We have
 718 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
 719 ;;; the first arg and a higher cost.  The reason for doing this is to prevent
 720 ;;; fixnum specific operations from being used on word integers, spuriously
 721 ;;; consing the argument.
 722 ;;;
 723
 724 (define-vop (fast-eql/fixnum fast-conditional)
 725   (:args (x :scs (any-reg descriptor-reg zero))
 726          (y :scs (any-reg zero)))
 727   (:arg-types tagged-num tagged-num)
 728   (:note "inline fixnum comparison")
 729   (:translate eql)
 730   (:generator 4
 731     (inst cmp x y)
 732     (inst b (if not-p :ne :eq) target)
 733     (inst nop)))
 734 ;;;
 735 (define-vop (generic-eql/fixnum fast-eql/fixnum)
 736   (:arg-types * tagged-num)
 737   (:variant-cost 7))
 738
 739 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
 740   (:args (x :scs (any-reg descriptor-reg zero)))
 741   (:arg-types tagged-num (:constant (signed-byte 11)))
 742   (:info target not-p y)
 743   (:translate eql)
 744   (:generator 2
 745     (inst cmp x (fixnumize y))
 746     (inst b (if not-p :ne :eq) target)
 747     (inst nop)))
 748 ;;;
 749 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
 750   (:arg-types * (:constant (signed-byte 11)))
 751   (:variant-cost 6))
 752
 753 \f
 754 ;;;; 32-bit logical operations
 755
 756 (define-vop (merge-bits)
 757   (:translate merge-bits)
 758   (:args (shift :scs (signed-reg unsigned-reg))
 759          (prev :scs (unsigned-reg))
 760          (next :scs (unsigned-reg)))
 761   (:arg-types tagged-num unsigned-num unsigned-num)
 762   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 763   (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
 764   (:results (result :scs (unsigned-reg)))
 765   (:result-types unsigned-num)
 766   (:policy :fast-safe)
 767   (:generator 4
 768     (let ((done (gen-label)))
 769       (inst cmp shift)
 770       (inst b :eq done)
 771       (inst srl res next shift)
 772       (inst sub temp zero-tn shift)
 773       (inst sll temp prev temp)
 774       (inst or res temp)
 775       (emit-label done)
 776       (move result res))))
 777
 778
 779 (define-vop (32bit-logical)
 780   (:args (x :scs (unsigned-reg zero))
 781          (y :scs (unsigned-reg zero)))
 782   (:arg-types unsigned-num unsigned-num)
 783   (:results (r :scs (unsigned-reg)))
 784   (:result-types unsigned-num)
 785   (:policy :fast-safe))
 786
 787 (define-vop (32bit-logical-not 32bit-logical)
 788   (:translate 32bit-logical-not)
 789   (:args (x :scs (unsigned-reg zero)))
 790   (:arg-types unsigned-num)
 791   (:generator 1
 792     (inst not r x)))
 793
 794 (define-vop (32bit-logical-and 32bit-logical)
 795   (:translate 32bit-logical-and)
 796   (:generator 1
 797     (inst and r x y)))
 798
 799 (deftransform 32bit-logical-nand ((x y) (* *))
 800   '(32bit-logical-not (32bit-logical-and x y)))
 801
 802 (define-vop (32bit-logical-or 32bit-logical)
 803   (:translate 32bit-logical-or)
 804   (:generator 1
 805     (inst or r x y)))
 806
 807 (deftransform 32bit-logical-nor ((x y) (* *))
 808   '(32bit-logical-not (32bit-logical-or x y)))
 809
 810 (define-vop (32bit-logical-xor 32bit-logical)
 811   (:translate 32bit-logical-xor)
 812   (:generator 1
 813     (inst xor r x y)))
 814
 815 (define-vop (32bit-logical-eqv 32bit-logical)
 816   (:translate 32bit-logical-eqv)
 817   (:generator 1
 818     (inst xnor r x y)))
 819
 820 (define-vop (32bit-logical-orc2 32bit-logical)
 821   (:translate 32bit-logical-orc2)
 822   (:generator 1
 823     (inst orn r x y)))
 824
 825 (deftransform 32bit-logical-orc1 ((x y) (* *))
 826   '(32bit-logical-orc2 y x))
 827
 828 (define-vop (32bit-logical-andc2 32bit-logical)
 829   (:translate 32bit-logical-andc2)
 830   (:generator 1
 831     (inst andn r x y)))
 832
 833 (deftransform 32bit-logical-andc1 ((x y) (* *))
 834   '(32bit-logical-andc2 y x))
 835
 836
 837 (define-vop (shift-towards-someplace)
 838   (:policy :fast-safe)
 839   (:args (num :scs (unsigned-reg))
 840          (amount :scs (signed-reg)))
 841   (:arg-types unsigned-num tagged-num)
 842   (:results (r :scs (unsigned-reg)))
 843   (:result-types unsigned-num))
 844
 845 (define-vop (shift-towards-start shift-towards-someplace)
 846   (:translate shift-towards-start)
 847   (:note "shift-towards-start")
 848   (:generator 1
 849     (inst sll r num amount)))
 850
 851 (define-vop (shift-towards-end shift-towards-someplace)
 852   (:translate shift-towards-end)
 853   (:note "shift-towards-end")
 854   (:generator 1
 855     (inst srl r num amount)))
 856
 857
 858
 859 \f
 860 ;;;; Bignum stuff.
 861
 862 (define-vop (bignum-length get-header-data)
 863   (:translate sb!bignum::%bignum-length)
 864   (:policy :fast-safe))
 865
 866 (define-vop (bignum-set-length set-header-data)
 867   (:translate sb!bignum::%bignum-set-length)
 868   (:policy :fast-safe))
 869
 870 (define-vop (bignum-ref word-index-ref)
 871   (:variant bignum-digits-offset other-pointer-lowtag)
 872   (:translate sb!bignum::%bignum-ref)
 873   (:results (value :scs (unsigned-reg)))
 874   (:result-types unsigned-num))
 875
 876 (define-vop (bignum-set word-index-set)
 877   (:variant bignum-digits-offset other-pointer-lowtag)
 878   (:translate sb!bignum::%bignum-set)
 879   (:args (object :scs (descriptor-reg))
 880          (index :scs (any-reg immediate zero))
 881          (value :scs (unsigned-reg)))
 882   (:arg-types t positive-fixnum unsigned-num)
 883   (:results (result :scs (unsigned-reg)))
 884   (:result-types unsigned-num))
 885
 886 (define-vop (digit-0-or-plus)
 887   (:translate sb!bignum::%digit-0-or-plusp)
 888   (:policy :fast-safe)
 889   (:args (digit :scs (unsigned-reg)))
 890   (:arg-types unsigned-num)
 891   (:results (result :scs (descriptor-reg)))
 892   (:guard (not (member :sparc-v9 *backend-subfeatures*)))
 893   (:generator 3
 894     (let ((done (gen-label)))
 895       (inst cmp digit)
 896       (inst b :lt done)
 897       (move result null-tn)
 898       (load-symbol result t)
 899       (emit-label done))))
 900
 901 (define-vop (v9-digit-0-or-plus-cmove)
 902   (:translate sb!bignum::%digit-0-or-plusp)
 903   (:policy :fast-safe)
 904   (:args (digit :scs (unsigned-reg)))
 905   (:arg-types unsigned-num)
 906   (:results (result :scs (descriptor-reg)))
 907   (:guard (member :sparc-v9 *backend-subfeatures*))
 908   (:generator 3
 909     (inst cmp digit)
 910     (load-symbol result t)
 911     (inst cmove :lt result null-tn)))
 912
 913 ;; This doesn't work?
 914 #+nil
 915 (define-vop (v9-digit-0-or-plus-movr)
 916   (:translate sb!bignum::%digit-0-or-plusp)
 917   (:policy :fast-safe)
 918   (:args (digit :scs (unsigned-reg)))
 919   (:arg-types unsigned-num)
 920   (:results (result :scs (descriptor-reg)))
 921   (:temporary (:scs (descriptor-reg)) temp)
 922   (:guard #!+:sparc-v9 t #!-:sparc-v9 nil)
 923   (:generator 2
 924     (load-symbol temp t)
 925     (inst movr result null-tn digit :lz)
 926     (inst movr result temp digit :gez)))
 927
 928
 929 (define-vop (add-w/carry)
 930   (:translate sb!bignum::%add-with-carry)
 931   (:policy :fast-safe)
 932   (:args (a :scs (unsigned-reg))
 933          (b :scs (unsigned-reg))
 934          (c :scs (any-reg)))
 935   (:arg-types unsigned-num unsigned-num positive-fixnum)
 936   (:results (result :scs (unsigned-reg))
 937             (carry :scs (unsigned-reg)))
 938   (:result-types unsigned-num positive-fixnum)
 939   (:generator 3
 940     (inst addcc zero-tn c -1)
 941     (inst addxcc result a b)
 942     (inst addx carry zero-tn zero-tn)))
 943
 944 (define-vop (sub-w/borrow)
 945   (:translate sb!bignum::%subtract-with-borrow)
 946   (:policy :fast-safe)
 947   (:args (a :scs (unsigned-reg))
 948          (b :scs (unsigned-reg))
 949          (c :scs (any-reg)))
 950   (:arg-types unsigned-num unsigned-num positive-fixnum)
 951   (:results (result :scs (unsigned-reg))
 952             (borrow :scs (unsigned-reg)))
 953   (:result-types unsigned-num positive-fixnum)
 954   (:generator 4
 955     (inst subcc zero-tn c 1)
 956     (inst subxcc result a b)
 957     (inst addx borrow zero-tn zero-tn)
 958     (inst xor borrow 1)))
 959
 960 ;;; EMIT-MULTIPLY -- This is used both for bignum stuff and in assembly
 961 ;;; routines.
 962 ;;;
 963 (defun emit-multiply (multiplier multiplicand result-high result-low)
 964   "Emit code to multiply MULTIPLIER with MULTIPLICAND, putting the result
 965   in RESULT-HIGH and RESULT-LOW.  KIND is either :signed or :unsigned.
 966   Note: the lifetimes of MULTIPLICAND and RESULT-HIGH overlap."
 967   (declare (type tn multiplier result-high result-low)
 968            (type (or tn (signed-byte 13)) multiplicand))
 969   ;; It seems that emit-multiply is only used to do an unsigned
 970   ;; multiply, so the code only does an unsigned multiply.
 971   (cond
 972     ((member :sparc-64 *backend-subfeatures*)
 973      ;; Take advantage of V9's 64-bit multiplier.
 974      ;;
 975      ;; Make sure the multiplier and multiplicand are really
 976      ;; unsigned 64-bit numbers.
 977      (inst srl multiplier 0)
 978      (inst srl multiplicand 0)
 979
 980      ;; Multiply the two numbers and put the result in
 981      ;; result-high.  Copy the low 32-bits to result-low.  Then
 982      ;; shift result-high so the high 32-bits end up in the low
 983      ;; 32-bits.
 984      (inst mulx result-high multiplier multiplicand)
 985      (inst move result-low result-high)
 986      (inst srax result-high 32))
 987     ((or (member :sparc-v8 *backend-subfeatures*)
 988          (member :sparc-v9 *backend-subfeatures*))
 989      ;; V8 has a multiply instruction.  This should also work for
 990      ;; the V9, but umul and the Y register is deprecated on the
 991      ;; V9.
 992      (inst umul result-low multiplier multiplicand)
 993      (inst rdy result-high))
 994     (t
 995      (let ((label (gen-label)))
 996        (inst wry multiplier)
 997        (inst andcc result-high zero-tn)
 998        ;; Note: we can't use the Y register until three insts
 999        ;; after it's written.
1000        (inst nop)
1001        (inst nop)
1002        (dotimes (i 32)
1003          (inst mulscc result-high multiplicand))
1004        (inst mulscc result-high zero-tn)
1005        (inst cmp multiplicand)
1006        (inst b :ge label)
1007        (inst nop)
1008        (inst add result-high multiplier)
1009        (emit-label label)
1010        (inst rdy result-low)))))
1011
1012 (define-vop (bignum-mult-and-add-3-arg)
1013   (:translate sb!bignum::%multiply-and-add)
1014   (:policy :fast-safe)
1015   (:args (x :scs (unsigned-reg) :to (:eval 1))
1016          (y :scs (unsigned-reg) :to (:eval 1))
1017          (carry-in :scs (unsigned-reg) :to (:eval 2)))
1018   (:arg-types unsigned-num unsigned-num unsigned-num)
1019   (:results (hi :scs (unsigned-reg) :from (:eval 0))
1020             (lo :scs (unsigned-reg) :from (:eval 1)))
1021   (:result-types unsigned-num unsigned-num)
1022   (:generator 40
1023     (emit-multiply x y hi lo)
1024     (inst addcc lo carry-in)
1025     (inst addx hi zero-tn)))
1026
1027 (define-vop (bignum-mult-and-add-4-arg)
1028   (:translate sb!bignum::%multiply-and-add)
1029   (:policy :fast-safe)
1030   (:args (x :scs (unsigned-reg) :to (:eval 1))
1031          (y :scs (unsigned-reg) :to (:eval 1))
1032          (prev :scs (unsigned-reg) :to (:eval 2))
1033          (carry-in :scs (unsigned-reg) :to (:eval 2)))
1034   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1035   (:results (hi :scs (unsigned-reg) :from (:eval 0))
1036             (lo :scs (unsigned-reg) :from (:eval 1)))
1037   (:result-types unsigned-num unsigned-num)
1038   (:generator 40
1039     (emit-multiply x y hi lo)
1040     (inst addcc lo carry-in)
1041     (inst addx hi zero-tn)
1042     (inst addcc lo prev)
1043     (inst addx hi zero-tn)))
1044
1045 (define-vop (bignum-mult)
1046   (:translate sb!bignum::%multiply)
1047   (:policy :fast-safe)
1048   (:args (x :scs (unsigned-reg) :to (:result 1))
1049          (y :scs (unsigned-reg) :to (:result 1)))
1050   (:arg-types unsigned-num unsigned-num)
1051   (:results (hi :scs (unsigned-reg))
1052             (lo :scs (unsigned-reg)))
1053   (:result-types unsigned-num unsigned-num)
1054   (:generator 40
1055     (emit-multiply x y hi lo)))
1056
1057 (define-vop (bignum-lognot)
1058   (:translate sb!bignum::%lognot)
1059   (:policy :fast-safe)
1060   (:args (x :scs (unsigned-reg)))
1061   (:arg-types unsigned-num)
1062   (:results (r :scs (unsigned-reg)))
1063   (:result-types unsigned-num)
1064   (:generator 1
1065     (inst not r x)))
1066
1067 (define-vop (fixnum-to-digit)
1068   (:translate sb!bignum::%fixnum-to-digit)
1069   (:policy :fast-safe)
1070   (:args (fixnum :scs (any-reg)))
1071   (:arg-types tagged-num)
1072   (:results (digit :scs (unsigned-reg)))
1073   (:result-types unsigned-num)
1074   (:generator 1
1075     (inst sra digit fixnum n-fixnum-tag-bits)))
1076
1077 (define-vop (bignum-floor)
1078   (:translate sb!bignum::%floor)
1079   (:policy :fast-safe)
1080   (:args (div-high :scs (unsigned-reg) :target rem)
1081          (div-low :scs (unsigned-reg) :target quo)
1082          (divisor :scs (unsigned-reg)))
1083   (:arg-types unsigned-num unsigned-num unsigned-num)
1084   (:results (quo :scs (unsigned-reg) :from (:argument 1))
1085             (rem :scs (unsigned-reg) :from (:argument 0)))
1086   (:result-types unsigned-num unsigned-num)
1087   (:generator 300
1088     (move rem div-high)
1089     (move quo div-low)
1090     (dotimes (i 33)
1091       (let ((label (gen-label)))
1092         (inst cmp rem divisor)
1093         (inst b :ltu label)
1094         (inst addxcc quo quo)
1095         (inst sub rem divisor)
1096         (emit-label label)
1097         (unless (= i 32)
1098           (inst addx rem rem))))
1099     (inst not quo)))
1100
1101 (define-vop (bignum-floor-v8)
1102   (:translate sb!bignum::%floor)
1103   (:policy :fast-safe)
1104   (:args (div-high :scs (unsigned-reg) :target rem)
1105          (div-low :scs (unsigned-reg) :target quo)
1106          (divisor :scs (unsigned-reg)))
1107   (:arg-types unsigned-num unsigned-num unsigned-num)
1108   (:results (quo :scs (unsigned-reg) :from (:argument 1))
1109             (rem :scs (unsigned-reg) :from (:argument 0)))
1110   (:result-types unsigned-num unsigned-num)
1111   (:temporary (:scs (unsigned-reg) :target quo) q)
1112   ;; This vop is for a v8 or v9, provided we're also not using
1113   ;; sparc-64, for which there a special sparc-64 vop.
1114   (:guard (or (member :sparc-v8 *backend-subfeatures*)
1115               (member :sparc-v9 *backend-subfeatures*)))
1116   (:generator 15
1117     (inst wry div-high)
1118     (inst nop)
1119     (inst nop)
1120     (inst nop)
1121     ;; Compute the quotient [Y, div-low] / divisor
1122     (inst udiv q div-low divisor)
1123     ;; Compute the remainder.  The high part of the result is in the Y
1124     ;; register.
1125     (inst umul rem q divisor)
1126     (inst sub rem div-low rem)
1127     (unless (location= quo q)
1128       (move quo q))))
1129
1130 (define-vop (bignum-floor-v9)
1131   (:translate sb!bignum::%floor)
1132   (:policy :fast-safe)
1133   (:args (div-high :scs (unsigned-reg))
1134          (div-low :scs (unsigned-reg))
1135          (divisor :scs (unsigned-reg) :to (:result 1)))
1136   (:arg-types unsigned-num unsigned-num unsigned-num)
1137   (:temporary (:sc unsigned-reg :from (:argument 0)) dividend)
1138   (:results (quo :scs (unsigned-reg))
1139             (rem :scs (unsigned-reg)))
1140   (:result-types unsigned-num unsigned-num)
1141   (:guard (member :sparc-64 *backend-subfeatures*))
1142   (:generator 5
1143     ;; Set dividend to be div-high and div-low
1144     (inst sllx dividend div-high 32)
1145     (inst add dividend div-low)
1146     ;; Compute quotient
1147     (inst udivx quo dividend divisor)
1148     ;; Compute the remainder
1149     (inst mulx rem quo divisor)
1150     (inst sub rem dividend rem)))
1151
1152 (define-vop (signify-digit)
1153   (:translate sb!bignum::%fixnum-digit-with-correct-sign)
1154   (:policy :fast-safe)
1155   (:args (digit :scs (unsigned-reg) :target res))
1156   (:arg-types unsigned-num)
1157   (:results (res :scs (any-reg signed-reg)))
1158   (:result-types signed-num)
1159   (:generator 1
1160     (sc-case res
1161       (any-reg
1162        (inst sll res digit n-fixnum-tag-bits))
1163       (signed-reg
1164        (move res digit)))))
1165
1166
1167 (define-vop (digit-ashr)
1168   (:translate sb!bignum::%ashr)
1169   (:policy :fast-safe)
1170   (:args (digit :scs (unsigned-reg))
1171          (count :scs (unsigned-reg)))
1172   (:arg-types unsigned-num positive-fixnum)
1173   (:results (result :scs (unsigned-reg)))
1174   (:result-types unsigned-num)
1175   (:generator 1
1176     (inst sra result digit count)))
1177
1178 (define-vop (digit-lshr digit-ashr)
1179   (:translate sb!bignum::%digit-logical-shift-right)
1180   (:generator 1
1181     (inst srl result digit count)))
1182
1183 (define-vop (digit-ashl digit-ashr)
1184   (:translate sb!bignum::%ashl)
1185   (:generator 1
1186     (inst sll result digit count)))
1187
1188 \f
1189 ;;;; Static functions.
1190
1191 (define-static-fun two-arg-gcd (x y) :translate gcd)
1192 (define-static-fun two-arg-lcm (x y) :translate lcm)
1193
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 (define-static-fun two-arg-/ (x y) :translate /)
1198
1199 (define-static-fun two-arg-< (x y) :translate <)
1200 (define-static-fun two-arg-<= (x y) :translate <=)
1201 (define-static-fun two-arg-> (x y) :translate >)
1202 (define-static-fun two-arg->= (x y) :translate >=)
1203 (define-static-fun two-arg-= (x y) :translate =)
1204 (define-static-fun two-arg-/= (x y) :translate /=)
1205
1206 (define-static-fun %negate (x) :translate %negate)
1207
1208 (define-static-fun two-arg-and (x y) :translate logand)
1209 (define-static-fun two-arg-ior (x y) :translate logior)
1210 (define-static-fun two-arg-xor (x y) :translate logxor)
1211
1212 \f
1213 ;; Need these so constant folding works with the deftransform.
1214
1215 (defun ash-right-signed (num shift)
1216   (declare (type (signed-byte #.sb!vm:n-word-bits) num)
1217            (type (integer 0 #.(1- sb!vm:n-word-bits)) shift))
1218   (ash-right-signed num shift))
1219
1220 (defun ash-right-unsigned (num shift)
1221   (declare (type (unsigned-byte #.sb!vm:n-word-bits) num)
1222            (type (integer 0 #.(1- sb!vm:n-word-bits)) shift))
1223   (ash-right-unsigned num shift))
1224
1225 ;; If we can prove that we have a right shift, just do the right shift
1226 ;; instead of calling the inline ASH which has to check for the
1227 ;; direction of the shift at run-time.
1228 (in-package "SB!C")
1229
1230 (deftransform ash ((num shift) (integer integer))
1231   (let ((num-type (continuation-type num))
1232         (shift-type (continuation-type shift)))
1233     ;; Can only handle right shifts
1234     (unless (csubtypep shift-type (specifier-type '(integer * 0)))
1235       (give-up-ir1-transform))
1236
1237     ;; If we can prove the shift is so large that all bits are shifted
1238     ;; out, return the appropriate constant.  If the shift is small
1239     ;; enough, call the VOP.  Otherwise, check for the shift size and
1240     ;; do the appropriate thing.  (Hmm, could we just leave the IF
1241     ;; s-expr and depend on other parts of the compiler to delete the
1242     ;; unreachable parts, if any?)
1243     (cond ((csubtypep num-type (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
1244            ;; A right shift by 31 is the same as a right shift by
1245            ;; larger amount.  We get just the sign.
1246            (if (csubtypep shift-type (specifier-type '(integer #.(- 1 sb!vm:n-word-bits) 0)))
1247                ;; FIXME: ash-right-{un,}signed package problems
1248                `(sb!vm::ash-right-signed num (- shift))
1249                `(sb!vm::ash-right-signed num (min (- shift) #.(1- sb!vm:n-word-bits)))))
1250           ((csubtypep num-type (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
1251            (if (csubtypep shift-type (specifier-type '(integer #.(- 1 sb!vm:n-word-bits) 0)))
1252                `(sb!vm::ash-right-unsigned num (- shift))
1253                `(if (<= shift #.(- sb!vm:n-word-bits))
1254                  0
1255                  (sb!vm::ash-right-unsigned num (- shift)))))
1256           (t
1257            (give-up-ir1-transform)))))
1258