src/compiler/sparc/arith.lisp

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