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 :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
 232           #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
 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 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 :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
 266           #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
 267   (:generator 12
 268     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 269       (inst cmp y zero-tn)
 270       (inst b :eq zero #!+:sparc-v9 :pn)
 271       ;; Extend the sign of X into the Y register
 272         (inst sra r x 31)
 273       (inst wry r)
 274       (inst nop)
 275       (inst nop)
 276       (inst nop)
 277
 278       (inst sdiv q x y)
 279       ;; We have the quotient so we need to compue the remainder
 280       (inst smul r q y)         ; rem
 281       (inst sub rem x r)
 282       (unless (location= quo q)
 283         (move quo q)))))
 284
 285 (define-vop (fast-v8-truncate/unsigned=>unsigned fast-safe-arith-op)
 286   (:translate truncate)
 287   (:args (x :scs (unsigned-reg))
 288          (y :scs (unsigned-reg)))
 289   (:arg-types unsigned-num unsigned-num)
 290   (:results (quo :scs (unsigned-reg))
 291             (rem :scs (unsigned-reg)))
 292   (:result-types unsigned-num unsigned-num)
 293   (:note "inline (unsigned-byte 32) arithmetic")
 294   (:temporary (:scs (unsigned-reg) :target quo) q)
 295   (:temporary (:scs (unsigned-reg)) r)
 296   (:vop-var vop)
 297   (:save-p :compute-only)
 298   (:guard #!+(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
 299           #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
 300   (:generator 8
 301     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 302       (inst cmp y zero-tn)
 303       (inst b :eq zero #!+:sparc-v9 :pn)
 304         (inst wry zero-tn)              ; Clear out high part
 305       (inst nop)
 306       (inst nop)
 307       (inst nop)
 308
 309       (inst udiv q x y)
 310       ;; Compute remainder
 311       (inst umul r q y)
 312       (inst sub rem x r)
 313       (unless (location= quo q)
 314         (inst move quo q)))))
 315
 316 #!+:sparc-v9
 317 (define-vop (fast-v9-truncate/signed=>signed fast-safe-arith-op)
 318   (:translate truncate)
 319   (:args (x :scs (signed-reg))
 320          (y :scs (signed-reg)))
 321   (:arg-types signed-num signed-num)
 322   (:results (quo :scs (signed-reg))
 323             (rem :scs (signed-reg)))
 324   (:result-types signed-num signed-num)
 325   (:note "inline (signed-byte 32) arithmetic")
 326   (:temporary (:scs (signed-reg) :target quo) q)
 327   (:temporary (:scs (signed-reg)) r)
 328   (:vop-var vop)
 329   (:save-p :compute-only)
 330   (:guard #!+:sparc-64 t #!-:sparc-64 nil)
 331   (:generator 8
 332     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 333       (inst cmp y zero-tn)
 334       (inst b :eq zero #!+:sparc-v9 :pn)
 335       ;; Sign extend the numbers, just in case.
 336         (inst sra x 0)
 337       (inst sra y 0)
 338       (inst sdivx q x y)
 339       ;; Compute remainder
 340       (inst mulx r q y)
 341       (inst sub rem x r)
 342       (unless (location= quo q)
 343         (inst move quo q)))))
 344
 345 (define-vop (fast-v9-truncate/unsigned=>unsigned fast-safe-arith-op)
 346   (:translate truncate)
 347   (:args (x :scs (unsigned-reg))
 348          (y :scs (unsigned-reg)))
 349   (:arg-types unsigned-num unsigned-num)
 350   (:results (quo :scs (unsigned-reg))
 351             (rem :scs (unsigned-reg)))
 352   (:result-types unsigned-num unsigned-num)
 353   (:note "inline (unsigned-byte 32) arithmetic")
 354   (:temporary (:scs (unsigned-reg) :target quo) q)
 355   (:temporary (:scs (unsigned-reg)) r)
 356   (:vop-var vop)
 357   (:save-p :compute-only)
 358   (:guard #!+:sparc-64 t #!-:sparc-64 nil)
 359   (:generator 8
 360     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 361       (inst cmp y zero-tn)
 362       (inst b :eq zero #!+:sparc-v9 :pn)
 363       ;; Zap the higher 32 bits, just in case
 364         (inst srl x 0)
 365       (inst srl y 0)
 366       (inst udivx q x y)
 367       ;; Compute remainder
 368       (inst mulx r q y)
 369       (inst sub rem x r)
 370       (unless (location= quo q)
 371         (inst move quo q)))))
 372
 373 ;;; Shifting
 374
 375 (macrolet
 376     ((frob (name sc-type type shift-right-inst)
 377        `(define-vop (,name)
 378           (:note "inline ASH")
 379           (:args (number :scs (,sc-type) :to :save)
 380                  (amount :scs (signed-reg immediate)))
 381           (:arg-types ,type signed-num)
 382           (:results (result :scs (,sc-type)))
 383           (:result-types ,type)
 384           (:translate ash)
 385           (:policy :fast-safe)
 386           (:temporary (:sc non-descriptor-reg) ndesc)
 387           (:generator 5
 388             (sc-case amount
 389              #!+:sparc-v9
 390              (signed-reg
 391               (let ((done (gen-label))
 392                     (positive (gen-label)))
 393                 (inst cmp amount)
 394                 (inst b :ge positive)
 395                 (inst neg ndesc amount)
 396                 ;; ndesc = max(-amount, 31)
 397                 (inst cmp ndesc 31)
 398                 (inst cmove :ge ndesc 31)
 399                 (inst b done)
 400                 (inst ,shift-right-inst result number ndesc)
 401                 (emit-label positive)
 402                 ;; The result-type assures us that this shift will not
 403                 ;; overflow.
 404                 (inst sll result number amount)
 405                 ;; We want a right shift of the appropriate size.
 406                 (emit-label done)))
 407              #!-:sparc-v9
 408              (signed-reg
 409               (let ((positive (gen-label))
 410                     (done (gen-label)))
 411                 (inst cmp amount)
 412                 (inst b :ge positive)
 413                 (inst neg ndesc amount)
 414                 (inst cmp ndesc 31)
 415                 (inst b :le done)
 416                 (inst ,shift-right-inst result number ndesc)
 417                 (inst b done)
 418                 (inst ,shift-right-inst result number 31)
 419
 420                 (emit-label positive)
 421                 ;; The result-type assures us that this shift will not overflow.
 422                 (inst sll result number amount)
 423
 424                 (emit-label done)))
 425              (immediate
 426               (let ((amount (tn-value amount)))
 427                 (if (minusp amount)
 428                     (let ((amount (min 31 (- amount))))
 429                       (inst ,shift-right-inst result number amount))
 430                     (inst sll result number amount)))))))))
 431   (frob fast-ash/signed=>signed signed-reg signed-num sra)
 432   (frob fast-ash/unsigned=>unsigned unsigned-reg unsigned-num srl))
 433
 434 ;; Some special cases where we know we want a left shift.  Just do the
 435 ;; shift, instead of checking for the sign of the shift.
 436 (macrolet
 437     ((frob (name sc-type type result-type cost)
 438        `(define-vop (,name)
 439          (:note "inline ASH")
 440          (:translate ash)
 441          (:args (number :scs (,sc-type))
 442                 (amount :scs (signed-reg unsigned-reg immediate)))
 443          (:arg-types ,type positive-fixnum)
 444          (:results (result :scs (,result-type)))
 445          (:result-types ,type)
 446          (:policy :fast-safe)
 447          (:generator ,cost
 448           ;; The result-type assures us that this shift will not
 449           ;; overflow. And for fixnum's, the zero bits that get
 450           ;; shifted in are just fine for the fixnum tag.
 451           (sc-case amount
 452            ((signed-reg unsigned-reg)
 453             (inst sll result number amount))
 454            (immediate
 455             (let ((amount (tn-value amount)))
 456               (assert (>= amount 0))
 457               (inst sll result number amount))))))))
 458   (frob fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
 459   (frob fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
 460   (frob fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
 461
 462 (defknown ash-right-signed ((signed-byte #.sb!vm:n-word-bits)
 463                             (and fixnum unsigned-byte))
 464   (signed-byte #.sb!vm:n-word-bits)
 465   (movable foldable flushable))
 466
 467 (defknown ash-right-unsigned ((unsigned-byte #.sb!vm:n-word-bits)
 468                               (and fixnum unsigned-byte))
 469   (unsigned-byte #.sb!vm:n-word-bits)
 470   (movable foldable flushable))
 471
 472 ;; Some special cases where we want a right shift.  Just do the shift.
 473 ;; (Needs appropriate deftransforms to call these, though.)
 474
 475 (macrolet
 476     ((frob (trans name sc-type type shift-inst cost)
 477        `(define-vop (,name)
 478          (:note "inline right ASH")
 479          (:translate ,trans)
 480          (:args (number :scs (,sc-type))
 481                 (amount :scs (signed-reg unsigned-reg immediate)))
 482          (:arg-types ,type positive-fixnum)
 483          (:results (result :scs (,sc-type)))
 484          (:result-types ,type)
 485          (:policy :fast-safe)
 486          (:generator ,cost
 487             (sc-case amount
 488              ((signed-reg unsigned-reg)
 489                 (inst ,shift-inst result number amount))
 490              (immediate
 491               (let ((amt (tn-value amount)))
 492                 (inst ,shift-inst result number amt))))))))
 493   (frob ash-right-signed fast-ash-right/signed=>signed
 494         signed-reg signed-num sra 3)
 495   (frob ash-right-unsigned fast-ash-right/unsigned=>unsigned
 496         unsigned-reg unsigned-num srl 3))
 497
 498 (define-vop (fast-ash-right/fixnum=>fixnum)
 499     (:note "inline right ASH")
 500   (:translate ash-right-signed)
 501   (:args (number :scs (any-reg))
 502          (amount :scs (signed-reg unsigned-reg immediate)))
 503   (:arg-types tagged-num positive-fixnum)
 504   (:results (result :scs (any-reg)))
 505   (:result-types tagged-num)
 506   (:temporary (:sc non-descriptor-reg :target result) temp)
 507   (:policy :fast-safe)
 508   (:generator 2
 509     ;; Shift the fixnum right by the desired amount.  Then zap out the
 510     ;; 2 LSBs to make it a fixnum again.  (Those bits are junk.)
 511     (sc-case amount
 512       ((signed-reg unsigned-reg)
 513        (inst sra temp number amount))
 514       (immediate
 515        (inst sra temp number (tn-value amount))))
 516     (inst andn result temp fixnum-tag-mask)))
 517
 518
 519
 520 \f
 521 (define-vop (signed-byte-32-len)
 522   (:translate integer-length)
 523   (:note "inline (signed-byte 32) integer-length")
 524   (:policy :fast-safe)
 525   (:args (arg :scs (signed-reg) :target shift))
 526   (:arg-types signed-num)
 527   (:results (res :scs (any-reg)))
 528   (:result-types positive-fixnum)
 529   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
 530   (:generator 30
 531     (let ((loop (gen-label))
 532           (test (gen-label)))
 533       (inst addcc shift zero-tn arg)
 534       (inst b :ge test)
 535       (move res zero-tn)
 536       (inst b test)
 537       (inst not shift)
 538
 539       (emit-label loop)
 540       (inst add res (fixnumize 1))
 541
 542       (emit-label test)
 543       (inst cmp shift)
 544       (inst b :ne loop)
 545       (inst srl shift 1))))
 546
 547 (define-vop (unsigned-byte-32-count)
 548   (:translate logcount)
 549   (:note "inline (unsigned-byte 32) logcount")
 550   (:policy :fast-safe)
 551   (:args (arg :scs (unsigned-reg)))
 552   (:arg-types unsigned-num)
 553   (:results (res :scs (unsigned-reg)))
 554   (:result-types positive-fixnum)
 555   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) mask temp)
 556   (:generator 35
 557       (move res arg)
 558
 559       (dolist (stuff '((1 #x55555555) (2 #x33333333) (4 #x0f0f0f0f)
 560                        (8 #x00ff00ff) (16 #x0000ffff)))
 561         (destructuring-bind (shift bit-mask)
 562             stuff
 563           ;; Set mask
 564           (inst sethi mask (ldb (byte 22 10) bit-mask))
 565           (inst add mask (ldb (byte 10 0) bit-mask))
 566
 567           (inst and temp res mask)
 568           (inst srl res shift)
 569           (inst and res mask)
 570           (inst add res temp)))))
 571
 572
 573 ;;; Multiply and Divide.
 574
 575 (define-vop (fast-v8-*/fixnum=>fixnum fast-fixnum-binop)
 576   (:temporary (:scs (non-descriptor-reg)) temp)
 577   (:translate *)
 578   (:guard #!+(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
 579           #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
 580   (:generator 2
 581     ;; The cost here should be less than the cost for
 582     ;; */signed=>signed.  Why?  A fixnum product using signed=>signed
 583     ;; has to convert both args to signed-nums.  But using this, we
 584     ;; don't have to and that saves an instruction.
 585     (inst sra temp y fixnum-tag-bits)
 586     (inst smul r x temp)))
 587
 588 (define-vop (fast-v8-*/signed=>signed fast-signed-binop)
 589   (:translate *)
 590   (:guard #!+(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
 591           #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
 592   (:generator 3
 593     (inst smul r x y)))
 594
 595 (define-vop (fast-v8-*/unsigned=>unsigned fast-unsigned-binop)
 596   (:translate *)
 597   (:guard #!+(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
 598           #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
 599   (:generator 3
 600     (inst umul r x y)))
 601
 602 ;; The smul and umul instructions are deprecated on the Sparc V9.  Use
 603 ;; mulx instead.
 604 (define-vop (fast-v9-*/fixnum=>fixnum fast-fixnum-binop)
 605   (:temporary (:scs (non-descriptor-reg)) temp)
 606   (:translate *)
 607   (:guard #!+:sparc-64 t #!-:sparc-64 nil)
 608   (:generator 4
 609     (inst sra temp y fixnum-tag-bits)
 610     (inst mulx r x temp)))
 611
 612 (define-vop (fast-v9-*/signed=>signed fast-signed-binop)
 613   (:translate *)
 614   (:guard #!+:sparc-64 t #!-:sparc-64 nil)
 615   (:generator 3
 616     (inst mulx r x y)))
 617
 618 (define-vop (fast-v9-*/unsigned=>unsigned fast-unsigned-binop)
 619   (:translate *)
 620   (:guard #!+:sparc-64 t #!-:sparc-64 nil)
 621   (:generator 3
 622     (inst mulx r x y)))
 623
 624 \f
 625 ;;;; Binary conditional VOPs:
 626
 627 (define-vop (fast-conditional)
 628   (:conditional)
 629   (:info target not-p)
 630   (:effects)
 631   (:affected)
 632   (:policy :fast-safe))
 633
 634 (deftype integer-with-a-bite-out (s bite)
 635   (cond ((eq s '*) 'integer)
 636         ((and (integerp s) (> s 1))
 637          (let ((bound (ash 1 (1- s))))
 638            `(integer ,(- bound) ,(- bound bite 1))))
 639         (t
 640          (error "Bad size specified for SIGNED-BYTE type specifier: ~S." s))))
 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 #!-:sparc-v9 t #!+:sparc-v9 nil)
 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 #!+:sparc-v9 t #!-:sparc-v9 nil)
 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   #!+:sparc-64
 963   (progn
 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   #!+(and (not :sparc-64) (or :sparc-v8 :sparc-v9))
 979   (progn
 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   #!+(and (not :sparc-64) (not (or :sparc-v8 :sparc-v9)))
 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 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   (:guard #!+(not (or :sparc-v8 :sparc-v9)) t
1079           #!-(not (or :sparc-v8 :sparc-v9)) nil)
1080   (:generator 300
1081     (move rem div-high)
1082     (move quo div-low)
1083     (dotimes (i 33)
1084       (let ((label (gen-label)))
1085         (inst cmp rem divisor)
1086         (inst b :ltu label)
1087         (inst addxcc quo quo)
1088         (inst sub rem divisor)
1089         (emit-label label)
1090         (unless (= i 32)
1091           (inst addx rem rem))))
1092     (inst not quo)))
1093
1094 (define-vop (bignum-floor-v8)
1095   (:translate sb!bignum::%floor)
1096   (:policy :fast-safe)
1097   (:args (div-high :scs (unsigned-reg) :target rem)
1098          (div-low :scs (unsigned-reg) :target quo)
1099          (divisor :scs (unsigned-reg)))
1100   (:arg-types unsigned-num unsigned-num unsigned-num)
1101   (:results (quo :scs (unsigned-reg) :from (:argument 1))
1102             (rem :scs (unsigned-reg) :from (:argument 0)))
1103   (:result-types unsigned-num unsigned-num)
1104   (:temporary (:scs (unsigned-reg) :target quo) q)
1105   ;; This vop is for a v8 or v9, provided we're also not using
1106   ;; sparc-64, for which there a special sparc-64 vop.
1107   (:guard #!+(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) t
1108           #!-(or :sparc-v8 (and :sparc-v9 (not :sparc-64))) nil)
1109   (:generator 15
1110     (inst wry div-high)
1111     (inst nop)
1112     (inst nop)
1113     (inst nop)
1114     ;; Compute the quotient [Y, div-low] / divisor
1115     (inst udiv q div-low divisor)
1116     ;; Compute the remainder.  The high part of the result is in the Y
1117     ;; register.
1118     (inst umul rem q divisor)
1119     (inst sub rem div-low rem)
1120     (unless (location= quo q)
1121       (move quo q))))
1122
1123 (define-vop (bignum-floor-v9)
1124   (:translate sb!bignum::%floor)
1125   (:policy :fast-safe)
1126   (:args (div-high :scs (unsigned-reg))
1127          (div-low :scs (unsigned-reg))
1128          (divisor :scs (unsigned-reg) :to (:result 1)))
1129   (:arg-types unsigned-num unsigned-num unsigned-num)
1130   (:temporary (:sc unsigned-reg :from (:argument 0)) dividend)
1131   (:results (quo :scs (unsigned-reg))
1132             (rem :scs (unsigned-reg)))
1133   (:result-types unsigned-num unsigned-num)
1134   (:guard #!+:sparc-64 t #!-:sparc-64 nil)
1135   (:generator 5
1136     ;; Set dividend to be div-high and div-low
1137     (inst sllx dividend div-high 32)
1138     (inst add dividend div-low)
1139     ;; Compute quotient
1140     (inst udivx quo dividend divisor)
1141     ;; Compute the remainder
1142     (inst mulx rem quo divisor)
1143     (inst sub rem dividend rem)))
1144
1145 (define-vop (signify-digit)
1146   (:translate sb!bignum::%fixnum-digit-with-correct-sign)
1147   (:policy :fast-safe)
1148   (:args (digit :scs (unsigned-reg) :target res))
1149   (:arg-types unsigned-num)
1150   (:results (res :scs (any-reg signed-reg)))
1151   (:result-types signed-num)
1152   (:generator 1
1153     (sc-case res
1154       (any-reg
1155        (inst sll res digit fixnum-tag-bits))
1156       (signed-reg
1157        (move res digit)))))
1158
1159
1160 (define-vop (digit-ashr)
1161   (:translate sb!bignum::%ashr)
1162   (:policy :fast-safe)
1163   (:args (digit :scs (unsigned-reg))
1164          (count :scs (unsigned-reg)))
1165   (:arg-types unsigned-num positive-fixnum)
1166   (:results (result :scs (unsigned-reg)))
1167   (:result-types unsigned-num)
1168   (:generator 1
1169     (inst sra result digit count)))
1170
1171 (define-vop (digit-lshr digit-ashr)
1172   (:translate sb!bignum::%digit-logical-shift-right)
1173   (:generator 1
1174     (inst srl result digit count)))
1175
1176 (define-vop (digit-ashl digit-ashr)
1177   (:translate sb!bignum::%ashl)
1178   (:generator 1
1179     (inst sll result digit count)))
1180
1181 \f
1182 ;;;; Static functions.
1183
1184 (define-static-fun two-arg-gcd (x y) :translate gcd)
1185 (define-static-fun two-arg-lcm (x y) :translate lcm)
1186
1187 (define-static-fun two-arg-+ (x y) :translate +)
1188 (define-static-fun two-arg-- (x y) :translate -)
1189 (define-static-fun two-arg-* (x y) :translate *)
1190 (define-static-fun two-arg-/ (x y) :translate /)
1191
1192 (define-static-fun two-arg-< (x y) :translate <)
1193 (define-static-fun two-arg-<= (x y) :translate <=)
1194 (define-static-fun two-arg-> (x y) :translate >)
1195 (define-static-fun two-arg->= (x y) :translate >=)
1196 (define-static-fun two-arg-= (x y) :translate =)
1197 (define-static-fun two-arg-/= (x y) :translate /=)
1198
1199 (define-static-fun %negate (x) :translate %negate)
1200
1201 (define-static-fun two-arg-and (x y) :translate logand)
1202 (define-static-fun two-arg-ior (x y) :translate logior)
1203 (define-static-fun two-arg-xor (x y) :translate logxor)
1204
1205 \f
1206 ;; Need these so constant folding works with the deftransform.
1207
1208 (defun ash-right-signed (num shift)
1209   (declare (type (signed-byte #.sb!vm:n-word-bits) num)
1210            (type (integer 0 #.(1- sb!vm:n-word-bits)) shift))
1211   (ash-right-signed num shift))
1212
1213 (defun ash-right-unsigned (num shift)
1214   (declare (type (unsigned-byte #.sb!vm:n-word-bits) num)
1215            (type (integer 0 #.(1- sb!vm:n-word-bits)) shift))
1216   (ash-right-unsigned num shift))
1217
1218 ;; If we can prove that we have a right shift, just do the right shift
1219 ;; instead of calling the inline ASH which has to check for the
1220 ;; direction of the shift at run-time.
1221 (in-package "SB!C")
1222
1223 (deftransform ash ((num shift) (integer integer))
1224   (let ((num-type (continuation-type num))
1225         (shift-type (continuation-type shift)))
1226     ;; Can only handle right shifts
1227     (unless (csubtypep shift-type (specifier-type '(integer * 0)))
1228       (give-up-ir1-transform))
1229
1230     ;; If we can prove the shift is so large that all bits are shifted
1231     ;; out, return the appropriate constant.  If the shift is small
1232     ;; enough, call the VOP.  Otherwise, check for the shift size and
1233     ;; do the appropriate thing.  (Hmm, could we just leave the IF
1234     ;; s-expr and depend on other parts of the compiler to delete the
1235     ;; unreachable parts, if any?)
1236     (cond ((csubtypep num-type (specifier-type '(signed-byte #.sb!vm:n-word-bits)))
1237            ;; A right shift by 31 is the same as a right shift by
1238            ;; larger amount.  We get just the sign.
1239            (if (csubtypep shift-type (specifier-type '(integer #.(- 1 sb!vm:n-word-bits) 0)))
1240                ;; FIXME: ash-right-{un,}signed package problems
1241                `(sb!vm::ash-right-signed num (- shift))
1242                `(sb!vm::ash-right-signed num (min (- shift) #.(1- sb!vm:n-word-bits)))))
1243           ((csubtypep num-type (specifier-type '(unsigned-byte #.sb!vm:n-word-bits)))
1244            (if (csubtypep shift-type (specifier-type '(integer #.(- 1 sb!vm:n-word-bits) 0)))
1245                `(sb!vm::ash-right-unsigned num (- shift))
1246                `(if (<= shift #.(- sb!vm:n-word-bits))
1247                  0
1248                  (sb!vm::ash-right-unsigned num (- shift)))))
1249           (t
1250            (give-up-ir1-transform)))))
1251