src/compiler/ppc/arith.lisp

   1 ;;;; the VM definition arithmetic VOPs for the PPC
   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 1
  48     (inst subfic res x (fixnumize -1))))
  49
  50 (define-vop (fast-lognot/signed signed-unop)
  51   (:translate lognot)
  52   (:generator 2
  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 (define-vop (fast-fixnum-binop-c fast-safe-arith-op)
  84   (:args (x :target r :scs (any-reg zero)))
  85   (:info y)
  86   (:arg-types tagged-num
  87               (:constant (and (signed-byte 14) (not (integer 0 0)))))
  88   (:results (r :scs (any-reg)))
  89   (:result-types tagged-num)
  90   (:note "inline fixnum arithmetic"))
  91
  92 (define-vop (fast-fixnum-binop30-c fast-safe-arith-op)
  93   (:args (x :target r :scs (any-reg zero)))
  94   (:info y)
  95   (:arg-types tagged-num
  96               (:constant (and (signed-byte 30) (not (integer 0 0)))))
  97   (:results (r :scs (any-reg)))
  98   (:result-types tagged-num)
  99   (:note "inline fixnum arithmetic"))
 100
 101 (define-vop (fast-fixnum-logop-c fast-safe-arith-op)
 102   (:args (x :target r :scs (any-reg zero)))
 103   (:info y)
 104   (:arg-types tagged-num
 105               (:constant (and (unsigned-byte 14) (not (integer 0 0)))))
 106   (:results (r :scs (any-reg)))
 107   (:result-types tagged-num)
 108   (:note "inline fixnum logical op"))
 109
 110 (define-vop (fast-fixnum-logop30-c fast-safe-arith-op)
 111   (:args (x :target r :scs (any-reg zero)))
 112   (:info y)
 113   (:arg-types tagged-num
 114               (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
 115   (:results (r :scs (any-reg)))
 116   (:result-types tagged-num)
 117   (:note "inline fixnum logical op"))
 118
 119 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
 120   (:args (x :target r :scs (unsigned-reg zero)))
 121   (:info y)
 122   (:arg-types unsigned-num
 123               (:constant (and (signed-byte 16) (not (integer 0 0)))))
 124   (:results (r :scs (unsigned-reg)))
 125   (:result-types unsigned-num)
 126   (:note "inline (unsigned-byte 32) arithmetic"))
 127
 128 (define-vop (fast-unsigned-binop32-c fast-safe-arith-op)
 129   (:args (x :target r :scs (unsigned-reg zero)))
 130   (:info y)
 131   (:arg-types unsigned-num
 132               (:constant (and (unsigned-byte 32) (not (integer 0 0)))))
 133   (:results (r :scs (unsigned-reg)))
 134   (:result-types unsigned-num)
 135   (:note "inline (unsigned-byte 32) arithmetic"))
 136
 137 (define-vop (fast-signed-binop32-c fast-safe-arith-op)
 138   (:args (x :target r :scs (signed-reg zero)))
 139   (:info y)
 140   (:arg-types signed-num
 141               (:constant (and (signed-byte 32) (not (integer 0 0)))))
 142   (:results (r :scs (signed-reg)))
 143   (:result-types signed-num)
 144   (:note "inline (signed-byte 32) arithmetic"))
 145
 146 (define-vop (fast-unsigned-logop-c fast-safe-arith-op)
 147   (:args (x :target r :scs (unsigned-reg zero)))
 148   (:info y)
 149   (:arg-types unsigned-num
 150               (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
 151   (:results (r :scs (unsigned-reg)))
 152   (:result-types unsigned-num)
 153   (:note "inline (unsigned-byte 32) logical op"))
 154
 155 (define-vop (fast-unsigned-logop32-c fast-safe-arith-op)
 156   (:args (x :target r :scs (unsigned-reg zero)))
 157   (:info y)
 158   (:arg-types unsigned-num
 159               (:constant (and (unsigned-byte 32) (not (integer 0 0)))))
 160   (:results (r :scs (unsigned-reg)))
 161   (:result-types unsigned-num)
 162   (:note "inline (unsigned-byte 32) logical op"))
 163
 164 (define-vop (fast-signed-logop32-c fast-safe-arith-op)
 165   (:args (x :target r :scs (signed-reg zero)))
 166   (:info y)
 167   (:arg-types signed-num
 168               (:constant (and (unsigned-byte 32) (not (integer 0 0)))))
 169   (:results (r :scs (signed-reg)))
 170   (:result-types signed-num)
 171   (:note "inline (signed-byte 32) logical op"))
 172
 173 (define-vop (fast-signed-binop-c fast-safe-arith-op)
 174   (:args (x :target r :scs (signed-reg zero)))
 175   (:info y)
 176   (:arg-types signed-num
 177               (:constant (and (signed-byte 16) (not (integer 0 0)))))
 178   (:results (r :scs (signed-reg)))
 179   (:result-types signed-num)
 180   (:note "inline (signed-byte 32) arithmetic"))
 181
 182 (define-vop (fast-signed-logop-c fast-safe-arith-op)
 183   (:args (x :target r :scs (signed-reg zero)))
 184   (:info y)
 185   (:arg-types signed-num
 186               (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
 187   (:results (r :scs (signed-reg)))
 188   (:result-types signed-num)
 189   (:note "inline (signed-byte 32) logical op"))
 190
 191 (eval-when (:compile-toplevel :load-toplevel :execute)
 192
 193 (defmacro !define-var-binop (translate untagged-penalty op
 194                              &optional arg-swap restore-fixnum-mask)
 195   `(progn
 196      (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
 197                   fast-fixnum-binop)
 198        ,@(when restore-fixnum-mask
 199            `((:temporary (:sc non-descriptor-reg) temp)))
 200        (:translate ,translate)
 201        (:generator 2
 202          ,(if arg-swap
 203              `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
 204              `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
 205          ;; FIXME: remind me what convention we used for 64bitizing
 206          ;; stuff?  -- CSR, 2003-08-27
 207          ,@(when restore-fixnum-mask
 208              `((inst clrrwi r temp (1- n-lowtag-bits))))))
 209      (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 210                   fast-signed-binop)
 211        (:translate ,translate)
 212        (:generator ,(1+ untagged-penalty)
 213          ,(if arg-swap
 214              `(inst ,op r y x)
 215              `(inst ,op r x y))))
 216      (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
 217                   fast-unsigned-binop)
 218        (:translate ,translate)
 219        (:generator ,(1+ untagged-penalty)
 220          ,(if arg-swap
 221              `(inst ,op r y x)
 222              `(inst ,op r x y))))))
 223
 224 ;;; FIXME: the code has really only been checked for adds; we could do
 225 ;;; subtracts, too, but my brain is not up to the task of figuring out
 226 ;;; signs and borrows.
 227 (defmacro !define-const-binop (translate untagged-penalty op &optional (shifted-op nil))
 228   `(progn
 229      (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
 230                   ,(if shifted-op
 231                        'fast-fixnum-binop30-c
 232                        'fast-fixnum-binop-c))
 233        (:translate ,translate)
 234        ,@(when shifted-op
 235           `((:temporary (:sc any-reg :target r) temp)))
 236        (:generator 1
 237         ,(if shifted-op
 238              `(let* ((y (fixnumize y))
 239                      (high-half (ldb (byte 16 16) y))
 240                      (low-half (ldb (byte 16 0) y)))
 241                ;; Compare %LR in insts.lisp.
 242                (cond
 243                  ((and (logbitp 15 low-half) (= high-half #xffff))
 244                   ;; Let sign-extension do the work for us, but make sure
 245                   ;; to turn LOW-HALF into a signed integer.
 246                   (inst ,op r x (dpb low-half (byte 16 0) -1)))
 247                  ((and (not (logbitp 15 low-half)) (zerop high-half))
 248                   (inst ,op r x low-half))
 249                  ((zerop low-half)
 250                   (inst ,shifted-op r x (if (logbitp 15 high-half)
 251                                             (dpb high-half (byte 16 0) -1)
 252                                             high-half)))
 253                  (t
 254                   ;; Check to see whether compensating for the sign bit
 255                   ;; of LOW-HALF is necessary.
 256                   (let ((high-half (let ((top (if (logbitp 15 low-half)
 257                                                   (ldb (byte 16 0)
 258                                                        (1+ high-half))
 259                                                   high-half)))
 260                                      (if (logbitp 15 top)
 261                                          (dpb top (byte 16 0) -1)
 262                                          top))))
 263                     (inst ,shifted-op temp x high-half)
 264                     (inst ,op r temp low-half)))))
 265              `(inst ,op r x (fixnumize y)))))
 266      (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
 267                   ,(if shifted-op
 268                        'fast-signed-binop32-c
 269                        'fast-signed-binop-c))
 270        (:translate ,translate)
 271        ,@(when shifted-op
 272           `((:temporary (:sc non-descriptor-reg :target r) temp)))
 273        (:generator ,untagged-penalty
 274         ,(if shifted-op
 275              `(let ((high-half (ldb (byte 16 16) y))
 276                     (low-half (ldb (byte 16 0) y)))
 277                ;; Compare %LR in insts.lisp.
 278                (cond
 279                  ((and (logbitp 15 low-half) (= high-half #xffff))
 280                   ;; Let sign-extension do the work for us, but make sure
 281                   ;; to turn LOW-HALF into a signed integer.
 282                   (inst ,op r x (dpb low-half (byte 16 0) -1)))
 283                  ((and (not (logbitp 15 low-half)) (zerop high-half))
 284                   (inst ,op r x low-half))
 285                  ((zerop low-half)
 286                   (inst ,shifted-op r x (if (logbitp 15 high-half)
 287                                             (dpb high-half (byte 16 0) -1)
 288                                             high-half)))
 289                  (t
 290                   ;; Check to see whether compensating for the sign bit
 291                   ;; of LOW-HALF is necessary.
 292                   (let ((high-half (let ((top (if (logbitp 15 low-half)
 293                                                   (ldb (byte 16 0)
 294                                                        (1+ high-half))
 295                                                   high-half)))
 296                                      (if (logbitp 15 top)
 297                                          (dpb top (byte 16 0) -1)
 298                                          top))))
 299                     (inst ,shifted-op temp x high-half)
 300                     (inst ,op r temp low-half)))))
 301              `(inst ,op r x y))))
 302      (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
 303                   ,(if shifted-op
 304                        'fast-unsigned-binop32-c
 305                        'fast-unsigned-binop-c))
 306        (:translate ,translate)
 307        ,@(when shifted-op
 308           `((:temporary (:sc non-descriptor-reg :target r) temp)))
 309        (:generator ,untagged-penalty
 310         ,(if shifted-op
 311              `(let ((high-half (ldb (byte 16 16) y))
 312                     (low-half (ldb (byte 16 0) y)))
 313                ;; Compare %LR in insts.lisp.
 314                (cond
 315                  ((and (logbitp 15 low-half) (= high-half #xffff))
 316                   ;; Let sign-extension do the work for us, but make sure
 317                   ;; to turn LOW-HALF into a signed integer.
 318                   (inst ,op r x (dpb low-half (byte 16 0) -1)))
 319                  ((and (not (logbitp 15 low-half)) (zerop high-half))
 320                   (inst ,op r x low-half))
 321                  ((zerop low-half)
 322                   (inst ,shifted-op r x (if (logbitp 15 high-half)
 323                                             (dpb high-half (byte 16 0) -1)
 324                                             high-half)))
 325                  (t
 326                   ;; Check to see whether compensating for the sign bit
 327                   ;; of LOW-HALF is necessary.
 328                   (let ((high-half (let ((top (if (logbitp 15 low-half)
 329                                                   (ldb (byte 16 0)
 330                                                        (1+ high-half))
 331                                                   high-half)))
 332                                      (if (logbitp 15 top)
 333                                          (dpb top (byte 16 0) -1)
 334                                          top))))
 335                     (inst ,shifted-op temp x high-half)
 336                     (inst ,op r temp low-half)))))
 337              `(inst ,op r x y))))))
 338
 339 ;;; For logical operations, we don't have to worry about signed bit
 340 ;;; propagation from the lower half of a 32-bit operand.
 341 (defmacro !define-const-logop (translate untagged-penalty op &optional (shifted-op nil))
 342   `(progn
 343      (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
 344                   ,(if shifted-op
 345                        'fast-fixnum-logop30-c
 346                        'fast-fixnum-logop-c))
 347        (:translate ,translate)
 348        ,@(when shifted-op
 349           `((:temporary (:sc any-reg :target r) temp)))
 350        (:generator 1
 351         ,(if shifted-op
 352              `(let* ((y (fixnumize y))
 353                      (high-half (ldb (byte 16 16) y))
 354                      (low-half (ldb (byte 16 0) y)))
 355                (cond
 356                  ((zerop high-half) (inst ,op r x low-half))
 357                  ((zerop low-half) (inst ,shifted-op r x high-half))
 358                  (t
 359                   (inst ,shifted-op temp x high-half)
 360                   (inst ,op r temp low-half))))
 361              `(inst ,op r x (fixnumize y)))))
 362      (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
 363                   ,(if shifted-op
 364                        'fast-signed-logop32-c
 365                        'fast-signed-logop-c))
 366        (:translate ,translate)
 367        ,@(when shifted-op
 368           `((:temporary (:sc non-descriptor-reg :target r) temp)))
 369        (:generator ,untagged-penalty
 370         ,(if shifted-op
 371              `(let ((high-half (ldb (byte 16 16) y))
 372                     (low-half (ldb (byte 16 0) y)))
 373                (cond
 374                  ((zerop high-half) (inst ,op r x low-half))
 375                  ((zerop low-half) (inst ,shifted-op r x high-half))
 376                  (t
 377                   (inst ,shifted-op temp x high-half)
 378                   (inst ,op r temp low-half))))
 379              `(inst ,op r x y))))
 380      (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
 381                   ,(if shifted-op
 382                        'fast-unsigned-logop32-c
 383                        'fast-unsigned-logop-c))
 384        (:translate ,translate)
 385        ,@(when shifted-op
 386           `((:temporary (:sc non-descriptor-reg :target r) temp)))
 387        (:generator ,untagged-penalty
 388         ,(if shifted-op
 389              `(let ((high-half (ldb (byte 16 16) y))
 390                     (low-half (ldb (byte 16 0) y)))
 391                (cond
 392                  ((zerop high-half) (inst ,op r x low-half))
 393                  ((zerop low-half) (inst ,shifted-op r x high-half))
 394                  (t
 395                   (inst ,shifted-op temp x high-half)
 396                   (inst ,op r temp low-half))))
 397              `(inst ,op r x y))))))
 398
 399 ); eval-when
 400
 401 (!define-var-binop + 4 add)
 402 (!define-var-binop - 4 sub)
 403 (!define-var-binop logand 2 and)
 404 (!define-var-binop logandc1 2 andc t)
 405 (!define-var-binop logandc2 2 andc)
 406 (!define-var-binop logior 2 or)
 407 (!define-var-binop logorc1 2 orc t t)
 408 (!define-var-binop logorc2 2 orc nil t)
 409 (!define-var-binop logxor 2 xor)
 410 (!define-var-binop logeqv 2 eqv nil t)
 411 (!define-var-binop lognand 2 nand nil t)
 412 (!define-var-binop lognor 2 nor nil t)
 413
 414 (!define-const-binop + 4 addi addis)
 415 (!define-const-binop - 4 subi)
 416 ;;; Implementing a 32-bit immediate version of LOGAND wouldn't be any
 417 ;;; better than loading the 32-bit constant via LR and then performing
 418 ;;; an /AND/.  So don't bother.  (It would be better in some cases, such
 419 ;;; as when one half of the word is zeros--we save a register--but we
 420 ;;; would have specified one temporary register in the VOP, so we lose
 421 ;;; any possible advantage.)
 422 (!define-const-logop logand 2 andi.)
 423 (!define-const-logop logior 2 ori oris)
 424 (!define-const-logop logxor 2 xori xoris)
 425
 426
 427 ;;; Special case fixnum + and - that trap on overflow.  Useful when we
 428 ;;; don't know that the output type is a fixnum.
 429 ;;;
 430 (define-vop (+/fixnum fast-+/fixnum=>fixnum)
 431   (:policy :safe)
 432   (:results (r :scs (any-reg descriptor-reg)))
 433   (:result-types tagged-num)
 434   (:note "safe inline fixnum arithmetic")
 435   (:generator 4
 436     (let* ((no-overflow (gen-label)))
 437       (inst mtxer zero-tn)
 438       (inst addo. r x y)
 439       (inst bns no-overflow)
 440       (inst unimp (logior (ash (reg-tn-encoding r) 5)
 441                           fixnum-additive-overflow-trap))
 442       (emit-label no-overflow))))
 443
 444 (define-vop (-/fixnum fast--/fixnum=>fixnum)
 445   (:policy :safe)
 446   (:results (r :scs (any-reg descriptor-reg)))
 447   (:result-types tagged-num)
 448   (:note "safe inline fixnum arithmetic")
 449   (:generator 4
 450     (let* ((no-overflow (gen-label)))
 451       (inst mtxer zero-tn)
 452       (inst subo. r x y)
 453       (inst bns no-overflow)
 454       (inst unimp (logior (ash (reg-tn-encoding r) 5)
 455                           fixnum-additive-overflow-trap))
 456       (emit-label no-overflow))))
 457
 458 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
 459   (:temporary (:scs (non-descriptor-reg)) temp)
 460   (:translate *)
 461   (:generator 2
 462     (inst srawi temp y n-fixnum-tag-bits)
 463     (inst mullw r x temp)))
 464
 465 (define-vop (fast-*-c/fixnum=>fixnum fast-fixnum-binop-c)
 466   (:translate *)
 467   (:arg-types tagged-num
 468               (:constant (and (signed-byte 16) (not (integer 0 0)))))
 469   (:generator 1
 470     (inst mulli r x y)))
 471
 472 (define-vop (fast-*-bigc/fixnum=>fixnum fast-fixnum-binop-c)
 473   (:translate *)
 474   (:arg-types tagged-num
 475               (:constant (and fixnum (not (signed-byte 16)))))
 476   (:temporary (:scs (non-descriptor-reg)) temp)
 477   (:generator 1
 478     (inst lr temp y)
 479     (inst mullw r x temp)))
 480
 481 (define-vop (fast-*/signed=>signed fast-signed-binop)
 482   (:translate *)
 483   (:generator 4
 484     (inst mullw r x y)))
 485
 486 (define-vop (fast-*-c/signed=>signed fast-signed-binop-c)
 487   (:translate *)
 488   (:generator 3
 489     (inst mulli r x y)))
 490
 491 (define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
 492   (:translate *)
 493   (:generator 4
 494     (inst mullw r x y)))
 495
 496 (define-vop (fast-*-c/unsigned=>unsigned fast-unsigned-binop-c)
 497   (:translate *)
 498   (:generator 3
 499     (inst mulli r x y)))
 500 \f
 501 ;;; Shifting
 502
 503 (macrolet ((def (name sc-type type result-type cost)
 504              `(define-vop (,name)
 505                 (:note "inline ASH")
 506                 (:translate ash)
 507                 (:args (number :scs (,sc-type))
 508                        (amount :scs (signed-reg unsigned-reg immediate)))
 509                 (:arg-types ,type positive-fixnum)
 510                 (:results (result :scs (,result-type)))
 511                 (:result-types ,type)
 512                 (:policy :fast-safe)
 513                 (:generator ,cost
 514                    (sc-case amount
 515                      ((signed-reg unsigned-reg)
 516                       (inst slw result number amount))
 517                      (immediate
 518                       (let ((amount (tn-value amount)))
 519                         (aver (> amount 0))
 520                         (inst slwi result number amount))))))))
 521   ;; FIXME: There's the opportunity for a sneaky optimization here, I
 522   ;; think: a FAST-ASH-LEFT-C/FIXNUM=>SIGNED vop.  -- CSR, 2003-09-03
 523   (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
 524   (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
 525   (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
 526
 527 (define-vop (fast-ash/unsigned=>unsigned)
 528   (:note "inline ASH")
 529   (:args (number :scs (unsigned-reg) :to :save)
 530          (amount :scs (signed-reg)))
 531   (:arg-types (:or unsigned-num) signed-num)
 532   (:results (result :scs (unsigned-reg)))
 533   (:result-types unsigned-num)
 534   (:translate ash)
 535   (:policy :fast-safe)
 536   (:temporary (:sc non-descriptor-reg) ndesc)
 537   (:generator 5
 538     (let ((positive (gen-label))
 539           (done (gen-label)))
 540       (inst cmpwi amount 0)
 541       (inst neg ndesc amount)
 542       (inst bge positive)
 543       (inst cmpwi ndesc 31)
 544       (inst srw result number ndesc)
 545       (inst ble done)
 546       (move result zero-tn)
 547       (inst b done)
 548
 549       (emit-label positive)
 550       ;; The result-type assures us that this shift will not overflow.
 551       (inst slw result number amount)
 552
 553       (emit-label done))))
 554
 555 (define-vop (fast-ash-c/unsigned=>unsigned)
 556   (:note "inline constant ASH")
 557   (:args (number :scs (unsigned-reg)))
 558   (:info amount)
 559   (:arg-types unsigned-num (:constant integer))
 560   (:results (result :scs (unsigned-reg)))
 561   (:result-types unsigned-num)
 562   (:translate ash)
 563   (:policy :fast-safe)
 564   (:generator 4
 565     (cond
 566       ((and (minusp amount) (< amount -31)) (move result zero-tn))
 567       ((minusp amount) (inst srwi result number (- amount)))
 568       ;; possible because this is used in the modular version too
 569       ((> amount 31) (move result zero-tn))
 570       (t (inst slwi result number amount)))))
 571
 572 (define-vop (fast-ash/signed=>signed)
 573   (:note "inline ASH")
 574   (:args (number :scs (signed-reg) :to :save)
 575          (amount :scs (signed-reg immediate)))
 576   (:arg-types (:or signed-num) signed-num)
 577   (:results (result :scs (signed-reg)))
 578   (:result-types (:or signed-num))
 579   (:translate ash)
 580   (:policy :fast-safe)
 581   (:temporary (:sc non-descriptor-reg) ndesc)
 582   (:generator 3
 583     (sc-case amount
 584       (signed-reg
 585        (let ((positive (gen-label))
 586              (done (gen-label)))
 587          (inst cmpwi amount 0)
 588          (inst neg ndesc amount)
 589          (inst bge positive)
 590          (inst cmpwi ndesc 31)
 591          (inst sraw result number ndesc)
 592          (inst ble done)
 593          (inst srawi result number 31)
 594          (inst b done)
 595
 596          (emit-label positive)
 597          ;; The result-type assures us that this shift will not overflow.
 598          (inst slw result number amount)
 599
 600          (emit-label done)))
 601
 602       (immediate
 603        (let ((amount (tn-value amount)))
 604          (if (minusp amount)
 605              (let ((amount (min 31 (- amount))))
 606                (inst srawi result number amount))
 607              (inst slwi result number amount)))))))
 608
 609 (define-vop (signed-byte-32-len)
 610   (:translate integer-length)
 611   (:note "inline (signed-byte 32) integer-length")
 612   (:policy :fast-safe)
 613   (:args (arg :scs (signed-reg)))
 614   (:arg-types signed-num)
 615   (:results (res :scs (unsigned-reg) :from :load))
 616   (:result-types unsigned-num)
 617   (:generator 6
 618     ; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg))))
 619     (let ((nonneg (gen-label)))
 620       (inst cntlzw. res arg)
 621       (inst bne nonneg)
 622       (inst not res arg)
 623       (inst cntlzw res res)
 624       (emit-label nonneg)
 625       (inst subfic res res 32))))
 626
 627 (define-vop (unsigned-byte-32-len)
 628   (:translate integer-length)
 629   (:note "inline (unsigned-byte 32) integer-length")
 630   (:policy :fast-safe)
 631   (:args (arg :scs (unsigned-reg)))
 632   (:arg-types unsigned-num)
 633   (:results (res :scs (unsigned-reg)))
 634   (:result-types unsigned-num)
 635   (:generator 4
 636     (inst cntlzw res arg)
 637     (inst subfic res res 32)))
 638
 639 (define-vop (unsigned-byte-32-count)
 640   (:translate logcount)
 641   (:note "inline (unsigned-byte 32) logcount")
 642   (:policy :fast-safe)
 643   (:args (arg :scs (unsigned-reg) :target shift))
 644   (:arg-types unsigned-num)
 645   (:results (res :scs (any-reg)))
 646   (:result-types positive-fixnum)
 647   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp)
 648   (:generator 30
 649     (let ((loop (gen-label))
 650           (done (gen-label)))
 651       (inst add. shift zero-tn arg)
 652       (move res zero-tn)
 653       (inst beq done)
 654
 655       (emit-label loop)
 656       (inst subi temp shift 1)
 657       (inst and. shift shift temp)
 658       (inst addi res res (fixnumize 1))
 659       (inst bne loop)
 660
 661       (emit-label done))))
 662
 663 \f
 664 ;;;; %LDB
 665
 666 (defknown %%ldb (integer unsigned-byte unsigned-byte) unsigned-byte
 667   (movable foldable flushable always-translatable))
 668
 669 ;;; only for constant folding within the compiler
 670 (defun %%ldb (integer size posn)
 671   (%ldb size posn integer))
 672
 673 (define-vop (ldb-c/fixnum)
 674   (:translate %%ldb)
 675   (:args (x :scs (any-reg)))
 676   (:arg-types tagged-num (:constant (integer 1 29)) (:constant (integer 0 29)))
 677   (:info size posn)
 678   (:results (res :scs (any-reg)))
 679   (:result-types tagged-num)
 680   (:policy :fast-safe)
 681   (:generator 2
 682     (let ((phantom-bits (- (+ size posn) 30)))
 683       (cond
 684         ((plusp phantom-bits)
 685          ;; The byte to be loaded into RES includes sign bits which are not
 686          ;; present in the input X physically.  RLWINM as used below would
 687          ;; mask these out with 0 even for negative inputs.
 688          (inst srawi res x phantom-bits)
 689          (inst rlwinm res x
 690                (mod (- 32 posn (- phantom-bits)) 32)
 691                (- 32 size n-fixnum-tag-bits)
 692                (- 31 n-fixnum-tag-bits)))
 693         (t
 694          (inst rlwinm res x
 695                (mod (- 32 posn) 32)     ; effectively rotate right
 696                (- 32 size n-fixnum-tag-bits)
 697                (- 31 n-fixnum-tag-bits)))))))
 698
 699 (define-vop (ldb-c/signed)
 700   (:translate %%ldb)
 701   (:args (x :scs (signed-reg)))
 702   (:arg-types signed-num (:constant (integer 1 29)) (:constant (integer 0 31)))
 703   (:info size posn)
 704   (:results (res :scs (any-reg)))
 705   (:result-types tagged-num)
 706   (:policy :fast-safe)
 707   (:generator 3
 708     (inst rlwinm res x
 709           (mod (- (+ 32 n-fixnum-tag-bits) posn) 32)
 710           (- 32 size n-fixnum-tag-bits)
 711           (- 31 n-fixnum-tag-bits))))
 712
 713 (define-vop (ldb-c/unsigned)
 714   (:translate %%ldb)
 715   (:args (x :scs (unsigned-reg)))
 716   (:arg-types unsigned-num (:constant (integer 1 29)) (:constant (integer 0 31)))
 717   (:info size posn)
 718   (:results (res :scs (any-reg)))
 719   (:result-types tagged-num)
 720   (:policy :fast-safe)
 721   (:generator 3
 722     (inst rlwinm res x
 723           (mod (- (+ 32 n-fixnum-tag-bits) posn) 32)
 724           (- 32 size n-fixnum-tag-bits)
 725           (- 31 n-fixnum-tag-bits))))
 726 \f
 727 ;;;; Modular functions:
 728 (define-modular-fun lognot-mod32 (x) lognot :untagged nil 32)
 729 (define-vop (lognot-mod32/unsigned=>unsigned)
 730   (:translate lognot-mod32)
 731   (:args (x :scs (unsigned-reg)))
 732   (:arg-types unsigned-num)
 733   (:results (res :scs (unsigned-reg)))
 734   (:result-types unsigned-num)
 735   (:policy :fast-safe)
 736   (:generator 1
 737     (inst not res x)))
 738
 739 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
 740              fast-ash-c/unsigned=>unsigned)
 741   (:translate ash-left-mod32))
 742
 743 (define-vop (fast-ash-left-mod32/unsigned=>unsigned
 744              fast-ash-left/unsigned=>unsigned))
 745 (deftransform ash-left-mod32 ((integer count)
 746                               ((unsigned-byte 32) (unsigned-byte 5)))
 747   (when (sb!c::constant-lvar-p count)
 748     (sb!c::give-up-ir1-transform))
 749   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 750
 751 (macrolet
 752     ((define-modular-backend (fun &optional constantp)
 753        (let ((mfun-name (symbolicate fun '-mod32))
 754              (modvop (symbolicate 'fast- fun '-mod32/unsigned=>unsigned))
 755              (modcvop (symbolicate 'fast- fun 'mod32-c/unsigned=>unsigned))
 756              (vop (symbolicate 'fast- fun '/unsigned=>unsigned))
 757              (cvop (symbolicate 'fast- fun '-c/unsigned=>unsigned)))
 758          `(progn
 759             (define-modular-fun ,mfun-name (x y) ,fun :untagged nil 32)
 760             (define-vop (,modvop ,vop)
 761               (:translate ,mfun-name))
 762             ,@(when constantp
 763                 `((define-vop (,modcvop ,cvop)
 764                     (:translate ,mfun-name))))))))
 765   (define-modular-backend + t)
 766   (define-modular-backend - t)
 767   (define-modular-backend * t)
 768   (define-modular-backend logeqv)
 769   (define-modular-backend lognand)
 770   (define-modular-backend lognor)
 771   (define-modular-backend logandc1)
 772   (define-modular-backend logandc2)
 773   (define-modular-backend logorc1)
 774   (define-modular-backend logorc2))
 775 \f
 776 ;;;; Binary conditional VOPs:
 777
 778 (define-vop (fast-conditional)
 779   (:conditional)
 780   (:info target not-p)
 781   (:effects)
 782   (:affected)
 783   (:policy :fast-safe))
 784
 785 (define-vop (fast-conditional/fixnum fast-conditional)
 786   (:args (x :scs (any-reg zero))
 787          (y :scs (any-reg zero)))
 788   (:arg-types tagged-num tagged-num)
 789   (:note "inline fixnum comparison"))
 790
 791 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
 792   (:args (x :scs (any-reg zero)))
 793   (:arg-types tagged-num (:constant (signed-byte 14)))
 794   (:info target not-p y))
 795
 796 (define-vop (fast-conditional/signed fast-conditional)
 797   (:args (x :scs (signed-reg zero))
 798          (y :scs (signed-reg zero)))
 799   (:arg-types signed-num signed-num)
 800   (:note "inline (signed-byte 32) comparison"))
 801
 802 (define-vop (fast-conditional-c/signed fast-conditional/signed)
 803   (:args (x :scs (signed-reg zero)))
 804   (:arg-types signed-num (:constant (signed-byte 16)))
 805   (:info target not-p y))
 806
 807 (define-vop (fast-conditional/unsigned fast-conditional)
 808   (:args (x :scs (unsigned-reg zero))
 809          (y :scs (unsigned-reg zero)))
 810   (:arg-types unsigned-num unsigned-num)
 811   (:note "inline (unsigned-byte 32) comparison"))
 812
 813 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
 814   (:args (x :scs (unsigned-reg zero)))
 815   (:arg-types unsigned-num (:constant (unsigned-byte 16)))
 816   (:info target not-p y))
 817
 818 (macrolet ((define-logtest-vops ()
 819              `(progn
 820                ,@(loop for suffix in '(/fixnum -c/fixnum
 821                                        /signed -c/signed
 822                                        /unsigned -c/unsigned)
 823                        for sc in '(any-reg any-reg
 824                                    signed-reg signed-reg
 825                                    unsigned-reg unsigned-reg)
 826                        for cost in '(4 3 6 5 6 5)
 827                        collect
 828                        `(define-vop (,(symbolicate "FAST-LOGTEST" suffix)
 829                                      ,(symbolicate "FAST-CONDITIONAL" suffix))
 830                          (:translate logtest)
 831                          (:temporary (:scs (,sc) :to (:result 0)) test)
 832                          (:generator ,cost
 833                           ;; We could be a lot more sophisticated here and
 834                           ;; check for possibilities with ANDIS..
 835                           ,(if (string= "-C" suffix :end2 2)
 836                                `(inst andi. test x ,(if (eq suffix '-c/fixnum)
 837                                                         '(fixnumize y)
 838                                                         'y))
 839                                `(inst and. test x y))
 840                           (inst b? (if not-p :eq :ne) target)))))))
 841   (define-logtest-vops))
 842
 843 (defknown %logbitp (integer unsigned-byte) boolean
 844   (movable foldable flushable always-translatable))
 845
 846 ;;; only for constant folding within the compiler
 847 (defun %logbitp (integer index)
 848   (logbitp index integer))
 849
 850 ;;; We only handle the constant cases because those are the only ones
 851 ;;; guaranteed to make it past COMBINATION-IMPLEMENTATION-STYLE.
 852 ;;;  --njf, 06-02-2006
 853 (define-vop (fast-logbitp-c/fixnum fast-conditional-c/fixnum)
 854   (:translate %logbitp)
 855   (:arg-types tagged-num (:constant (integer 0 29)))
 856   (:temporary (:scs (any-reg) :to (:result 0)) test)
 857   (:generator 4
 858     (if (< y 14)
 859         (inst andi. test x (ash 1 (+ y n-fixnum-tag-bits)))
 860         (inst andis. test x (ash 1 (- y 14))))
 861     (inst b? (if not-p :eq :ne) target)))
 862
 863 (define-vop (fast-logbitp-c/signed fast-conditional-c/signed)
 864   (:translate %logbitp)
 865   (:arg-types signed-num (:constant (integer 0 31)))
 866   (:temporary (:scs (signed-reg) :to (:result 0)) test)
 867   (:generator 4
 868     (if (< y 16)
 869         (inst andi. test x (ash 1 y))
 870         (inst andis. test x (ash 1 (- y 16))))
 871     (inst b? (if not-p :eq :ne) target)))
 872
 873 (define-vop (fast-logbitp-c/unsigned fast-conditional-c/unsigned)
 874   (:translate %logbitp)
 875   (:arg-types unsigned-num (:constant (integer 0 31)))
 876   (:temporary (:scs (unsigned-reg) :to (:result 0)) test)
 877   (:generator 4
 878     (if (< y 16)
 879         (inst andi. test x (ash 1 y))
 880         (inst andis. test x (ash 1 (- y 16))))
 881     (inst b? (if not-p :eq :ne) target)))
 882
 883 (define-vop (fast-if-</fixnum fast-conditional/fixnum)
 884   (:translate <)
 885   (:generator 4
 886     (inst cmpw x y)
 887     (inst b? (if not-p :ge :lt) target)))
 888
 889 (define-vop (fast-if-<-c/fixnum fast-conditional-c/fixnum)
 890   (:translate <)
 891   (:generator 3
 892     (inst cmpwi x (fixnumize y))
 893     (inst b? (if not-p :ge :lt) target)))
 894
 895 (define-vop (fast-if-</signed fast-conditional/signed)
 896   (:translate <)
 897   (:generator 6
 898     (inst cmpw x y)
 899     (inst b? (if not-p :ge :lt) target)))
 900
 901 (define-vop (fast-if-<-c/signed fast-conditional-c/signed)
 902   (:translate <)
 903   (:generator 5
 904     (inst cmpwi x y)
 905     (inst b? (if not-p :ge :lt) target)))
 906
 907 (define-vop (fast-if-</unsigned fast-conditional/unsigned)
 908   (:translate <)
 909   (:generator 6
 910     (inst cmplw x y)
 911     (inst b? (if not-p :ge :lt) target)))
 912
 913 (define-vop (fast-if-<-c/unsigned fast-conditional-c/unsigned)
 914   (:translate <)
 915   (:generator 5
 916     (inst cmplwi x y)
 917     (inst b? (if not-p :ge :lt) target)))
 918
 919 (define-vop (fast-if->/fixnum fast-conditional/fixnum)
 920   (:translate >)
 921   (:generator 4
 922     (inst cmpw x y)
 923     (inst b? (if not-p :le :gt) target)))
 924
 925 (define-vop (fast-if->-c/fixnum fast-conditional-c/fixnum)
 926   (:translate >)
 927   (:generator 3
 928     (inst cmpwi x (fixnumize y))
 929     (inst b? (if not-p :le :gt) target)))
 930
 931 (define-vop (fast-if->/signed fast-conditional/signed)
 932   (:translate >)
 933   (:generator 6
 934     (inst cmpw x y)
 935     (inst b? (if not-p :le :gt) target)))
 936
 937 (define-vop (fast-if->-c/signed fast-conditional-c/signed)
 938   (:translate >)
 939   (:generator 5
 940     (inst cmpwi x y)
 941     (inst b? (if not-p :le :gt) target)))
 942
 943 (define-vop (fast-if->/unsigned fast-conditional/unsigned)
 944   (:translate >)
 945   (:generator 6
 946     (inst cmplw x y)
 947     (inst b? (if not-p :le :gt) target)))
 948
 949 (define-vop (fast-if->-c/unsigned fast-conditional-c/unsigned)
 950   (:translate >)
 951   (:generator 5
 952     (inst cmplwi x y)
 953     (inst b? (if not-p :le :gt) target)))
 954
 955 (define-vop (fast-if-eql/signed fast-conditional/signed)
 956   (:translate eql)
 957   (:generator 6
 958     (inst cmpw x y)
 959     (inst b? (if not-p :ne :eq) target)))
 960
 961 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
 962   (:translate eql)
 963   (:generator 5
 964     (inst cmpwi x y)
 965     (inst b? (if not-p :ne :eq) target)))
 966
 967 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
 968   (:translate eql)
 969   (:generator 6
 970     (inst cmplw x y)
 971     (inst b? (if not-p :ne :eq) target)))
 972
 973 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
 974   (:translate eql)
 975   (:generator 5
 976     (inst cmplwi x y)
 977     (inst b? (if not-p :ne :eq) target)))
 978
 979
 980 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
 981 ;;; known fixnum.
 982
 983 ;;; These versions specify a fixnum restriction on their first arg.  We have
 984 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
 985 ;;; the first arg and a higher cost.  The reason for doing this is to prevent
 986 ;;; fixnum specific operations from being used on word integers, spuriously
 987 ;;; consing the argument.
 988 ;;;
 989
 990 (define-vop (fast-eql/fixnum fast-conditional)
 991   (:args (x :scs (any-reg descriptor-reg zero))
 992          (y :scs (any-reg zero)))
 993   (:arg-types tagged-num tagged-num)
 994   (:note "inline fixnum comparison")
 995   (:translate eql)
 996   (:generator 4
 997     (inst cmpw x y)
 998     (inst b? (if not-p :ne :eq) target)))
 999 ;;;
1000 (define-vop (generic-eql/fixnum fast-eql/fixnum)
1001   (:arg-types * tagged-num)
1002   (:variant-cost 7))
1003
1004 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
1005   (:args (x :scs (any-reg descriptor-reg zero)))
1006   (:arg-types tagged-num (:constant (signed-byte 14)))
1007   (:info target not-p y)
1008   (:translate eql)
1009   (:generator 2
1010     (inst cmpwi x (fixnumize y))
1011     (inst b? (if not-p :ne :eq) target)))
1012 ;;;
1013 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
1014   (:arg-types * (:constant (signed-byte 11)))
1015   (:variant-cost 6))
1016
1017 \f
1018 ;;;; 32-bit logical operations
1019
1020 (define-vop (shift-towards-someplace)
1021   (:policy :fast-safe)
1022   (:args (num :scs (unsigned-reg))
1023          (amount :scs (signed-reg)))
1024   (:arg-types unsigned-num tagged-num)
1025   (:results (r :scs (unsigned-reg)))
1026   (:result-types unsigned-num))
1027
1028 (define-vop (shift-towards-start shift-towards-someplace)
1029   (:translate shift-towards-start)
1030   (:note "shift-towards-start")
1031   (:generator 1
1032     (inst rlwinm amount amount 0 27 31)
1033     (inst slw r num amount)))
1034
1035 (define-vop (shift-towards-end shift-towards-someplace)
1036   (:translate shift-towards-end)
1037   (:note "shift-towards-end")
1038   (:generator 1
1039     (inst rlwinm amount amount 0 27 31)
1040     (inst srw r num amount)))
1041 \f
1042 ;;;; Bignum stuff.
1043
1044 (define-vop (bignum-length get-header-data)
1045   (:translate sb!bignum:%bignum-length)
1046   (:policy :fast-safe))
1047
1048 (define-vop (bignum-set-length set-header-data)
1049   (:translate sb!bignum:%bignum-set-length)
1050   (:policy :fast-safe))
1051
1052 (define-vop (bignum-ref word-index-ref)
1053   (:variant bignum-digits-offset other-pointer-lowtag)
1054   (:translate sb!bignum:%bignum-ref)
1055   (:results (value :scs (unsigned-reg)))
1056   (:result-types unsigned-num))
1057
1058 (define-vop (bignum-set word-index-set)
1059   (:variant bignum-digits-offset other-pointer-lowtag)
1060   (:translate sb!bignum:%bignum-set)
1061   (:args (object :scs (descriptor-reg))
1062          (index :scs (any-reg immediate zero))
1063          (value :scs (unsigned-reg)))
1064   (:arg-types t positive-fixnum unsigned-num)
1065   (:results (result :scs (unsigned-reg)))
1066   (:result-types unsigned-num))
1067
1068 (define-vop (digit-0-or-plus)
1069   (:translate sb!bignum:%digit-0-or-plusp)
1070   (:policy :fast-safe)
1071   (:args (digit :scs (unsigned-reg)))
1072   (:arg-types unsigned-num)
1073   (:results (result :scs (descriptor-reg)))
1074   (:generator 3
1075     (let ((done (gen-label)))
1076       (inst cmpwi digit 0)
1077       (move result null-tn)
1078       (inst blt done)
1079       (load-symbol result t)
1080       (emit-label done))))
1081
1082 (define-vop (add-w/carry)
1083   (:translate sb!bignum:%add-with-carry)
1084   (:policy :fast-safe)
1085   (:args (a :scs (unsigned-reg))
1086          (b :scs (unsigned-reg))
1087          (c :scs (any-reg)))
1088   (:arg-types unsigned-num unsigned-num positive-fixnum)
1089   (:temporary (:scs (unsigned-reg)) temp)
1090   (:results (result :scs (unsigned-reg))
1091             (carry :scs (unsigned-reg)))
1092   (:result-types unsigned-num positive-fixnum)
1093   (:generator 3
1094     (inst addic temp c -1)
1095     (inst adde result a b)
1096     (inst addze carry zero-tn)))
1097
1098 (define-vop (sub-w/borrow)
1099   (:translate sb!bignum:%subtract-with-borrow)
1100   (:policy :fast-safe)
1101   (:args (a :scs (unsigned-reg))
1102          (b :scs (unsigned-reg))
1103          (c :scs (any-reg)))
1104   (:arg-types unsigned-num unsigned-num positive-fixnum)
1105   (:temporary (:scs (unsigned-reg)) temp)
1106   (:results (result :scs (unsigned-reg))
1107             (borrow :scs (unsigned-reg)))
1108   (:result-types unsigned-num positive-fixnum)
1109   (:generator 4
1110     (inst addic temp c -1)
1111     (inst sube result a b)
1112     (inst addze borrow zero-tn)))
1113
1114 (define-vop (bignum-mult-and-add-3-arg)
1115   (:translate sb!bignum:%multiply-and-add)
1116   (:policy :fast-safe)
1117   (:args (x :scs (unsigned-reg))
1118          (y :scs (unsigned-reg))
1119          (carry-in :scs (unsigned-reg) :to (:eval 1)))
1120   (:arg-types unsigned-num unsigned-num unsigned-num)
1121   (:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp)
1122   (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
1123                     :target lo) lo-temp)
1124   (:results (hi :scs (unsigned-reg))
1125             (lo :scs (unsigned-reg)))
1126   (:result-types unsigned-num unsigned-num)
1127   (:generator 40
1128     (inst mulhwu hi-temp x y)
1129     (inst mullw lo-temp x y)
1130     (inst addc lo lo-temp carry-in)
1131     (inst addze hi hi-temp)))
1132
1133 (define-vop (bignum-mult-and-add-4-arg)
1134   (:translate sb!bignum:%multiply-and-add)
1135   (:policy :fast-safe)
1136   (:args (x :scs (unsigned-reg))
1137          (y :scs (unsigned-reg))
1138          (prev :scs (unsigned-reg) :to (:eval 1))
1139          (carry-in :scs (unsigned-reg) :to (:eval 1)))
1140   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
1141   (:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp)
1142   (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
1143                     :target lo) lo-temp)
1144   (:results (hi :scs (unsigned-reg))
1145             (lo :scs (unsigned-reg)))
1146   (:result-types unsigned-num unsigned-num)
1147   (:generator 40
1148     (inst mulhwu hi-temp x y)
1149     (inst mullw lo-temp x y)
1150     (inst addc lo-temp lo-temp carry-in)
1151     (inst addze hi-temp hi-temp)
1152     (inst addc lo lo-temp prev)
1153     (inst addze hi hi-temp)))
1154
1155 (define-vop (bignum-mult)
1156   (:translate sb!bignum:%multiply)
1157   (:policy :fast-safe)
1158   (:args (x :scs (unsigned-reg) :to (:eval 1))
1159          (y :scs (unsigned-reg) :to (:eval 1)))
1160   (:arg-types unsigned-num unsigned-num)
1161   (:results (hi :scs (unsigned-reg) :from (:eval 1))
1162             (lo :scs (unsigned-reg) :from (:eval 0)))
1163   (:result-types unsigned-num unsigned-num)
1164   (:generator 40
1165     (inst mullw lo x y)
1166     (inst mulhwu hi x y)))
1167
1168 #!+multiply-high-vops
1169 (define-vop (mulhi)
1170   (:translate %multiply-high)
1171   (:policy :fast-safe)
1172   (:args (x :scs (unsigned-reg))
1173          (y :scs (unsigned-reg)))
1174   (:arg-types unsigned-num unsigned-num)
1175   (:results (hi :scs (unsigned-reg)))
1176   (:result-types unsigned-num)
1177   (:generator 20
1178     (inst mulhwu hi x y)))
1179
1180 #!+multiply-high-vops
1181 (define-vop (mulhi/fx)
1182   (:translate %multiply-high)
1183   (:policy :fast-safe)
1184   (:args (x :scs (any-reg))
1185          (y :scs (unsigned-reg)))
1186   (:arg-types positive-fixnum unsigned-num)
1187   (:temporary (:sc non-descriptor-reg :from :eval :to :result) temp)
1188   (:temporary (:sc non-descriptor-reg :from :eval :to :result) mask)
1189   (:results (hi :scs (any-reg)))
1190   (:result-types positive-fixnum)
1191   (:generator 15
1192     (inst mulhwu temp x y)
1193     (inst lr mask fixnum-tag-mask)
1194     (inst andc hi temp mask)))
1195
1196 (define-vop (bignum-lognot lognot-mod32/unsigned=>unsigned)
1197   (:translate sb!bignum:%lognot))
1198
1199 (define-vop (fixnum-to-digit)
1200   (:translate sb!bignum:%fixnum-to-digit)
1201   (:policy :fast-safe)
1202   (:args (fixnum :scs (any-reg)))
1203   (:arg-types tagged-num)
1204   (:results (digit :scs (unsigned-reg)))
1205   (:result-types unsigned-num)
1206   (:generator 1
1207     (inst srawi digit fixnum n-fixnum-tag-bits)))
1208
1209
1210 (define-vop (bignum-floor)
1211   (:translate sb!bignum:%bigfloor)
1212   (:policy :fast-safe)
1213   (:args (num-high :scs (unsigned-reg) :target rem)
1214          (num-low :scs (unsigned-reg) :target rem-low)
1215          (denom :scs (unsigned-reg) :to (:eval 1)))
1216   (:arg-types unsigned-num unsigned-num unsigned-num)
1217   (:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low)
1218   (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
1219   (:results (quo :scs (unsigned-reg) :from (:eval 0))
1220             (rem :scs (unsigned-reg) :from (:argument 0)))
1221   (:result-types unsigned-num unsigned-num)
1222   (:generator 325 ; number of inst assuming targeting works.
1223     (move rem num-high)
1224     (move rem-low num-low)
1225     (flet ((maybe-subtract (&optional (guess temp))
1226              (inst subi temp guess 1)
1227              (inst and temp temp denom)
1228              (inst sub rem rem temp))
1229            (sltu (res x y)
1230              (inst subfc res y x)
1231              (inst subfe res res res)
1232              (inst neg res res)))
1233       (sltu quo rem denom)
1234       (maybe-subtract quo)
1235       (dotimes (i 32)
1236         (inst slwi rem rem 1)
1237         (inst srwi temp rem-low 31)
1238         (inst or rem rem temp)
1239         (inst slwi rem-low rem-low 1)
1240         (sltu temp rem denom)
1241         (inst slwi quo quo 1)
1242         (inst or quo quo temp)
1243         (maybe-subtract)))
1244     (inst not quo quo)))
1245
1246 #|
1247
1248 (define-vop (bignum-floor)
1249   (:translate sb!bignum:%bigfloor)
1250   (:policy :fast-safe)
1251   (:args (div-high :scs (unsigned-reg) :target rem)
1252          (div-low :scs (unsigned-reg) :target quo)
1253          (divisor :scs (unsigned-reg)))
1254   (:arg-types unsigned-num unsigned-num unsigned-num)
1255   (:results (quo :scs (unsigned-reg) :from (:argument 1))
1256             (rem :scs (unsigned-reg) :from (:argument 0)))
1257   (:result-types unsigned-num unsigned-num)
1258   (:generator 300
1259     (inst mtmq div-low)
1260     (inst div quo div-high divisor)
1261     (inst mfmq rem)))
1262 |#
1263
1264 (define-vop (signify-digit)
1265   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
1266   (:policy :fast-safe)
1267   (:args (digit :scs (unsigned-reg) :target res))
1268   (:arg-types unsigned-num)
1269   (:results (res :scs (any-reg signed-reg)))
1270   (:result-types signed-num)
1271   (:generator 1
1272     (sc-case res
1273       (any-reg
1274        (inst slwi res digit n-fixnum-tag-bits))
1275       (signed-reg
1276        (move res digit)))))
1277
1278
1279 (define-vop (digit-ashr)
1280   (:translate sb!bignum:%ashr)
1281   (:policy :fast-safe)
1282   (:args (digit :scs (unsigned-reg))
1283          (count :scs (unsigned-reg)))
1284   (:arg-types unsigned-num positive-fixnum)
1285   (:results (result :scs (unsigned-reg)))
1286   (:result-types unsigned-num)
1287   (:generator 1
1288     (inst sraw result digit count)))
1289
1290 (define-vop (digit-lshr digit-ashr)
1291   (:translate sb!bignum:%digit-logical-shift-right)
1292   (:generator 1
1293     (inst srw result digit count)))
1294
1295 (define-vop (digit-ashl digit-ashr)
1296   (:translate sb!bignum:%ashl)
1297   (:generator 1
1298     (inst slw result digit count)))
1299
1300 \f
1301 ;;;; Static funs.
1302
1303 (define-static-fun two-arg-gcd (x y) :translate gcd)
1304 (define-static-fun two-arg-lcm (x y) :translate lcm)
1305
1306 (define-static-fun two-arg-+ (x y) :translate +)
1307 (define-static-fun two-arg-- (x y) :translate -)
1308 (define-static-fun two-arg-* (x y) :translate *)
1309 (define-static-fun two-arg-/ (x y) :translate /)
1310
1311 (define-static-fun two-arg-< (x y) :translate <)
1312 (define-static-fun two-arg-<= (x y) :translate <=)
1313 (define-static-fun two-arg-> (x y) :translate >)
1314 (define-static-fun two-arg->= (x y) :translate >=)
1315 (define-static-fun two-arg-= (x y) :translate =)
1316 (define-static-fun two-arg-/= (x y) :translate /=)
1317
1318 (define-static-fun %negate (x) :translate %negate)
1319
1320 (define-static-fun two-arg-and (x y) :translate logand)
1321 (define-static-fun two-arg-ior (x y) :translate logior)
1322 (define-static-fun two-arg-xor (x y) :translate logxor)
1323 (define-static-fun two-arg-eqv (x y) :translate logeqv)
1324 \f
1325 (in-package "SB!C")
1326
1327 (deftransform * ((x y)
1328                  ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
1329                  (unsigned-byte 32))
1330   "recode as shifts and adds"
1331   (let ((y (lvar-value y)))
1332     (multiple-value-bind (result adds shifts)
1333         (ub32-strength-reduce-constant-multiply 'x y)
1334       (cond
1335        ((typep y '(signed-byte 16))
1336         ;; a mulli instruction has a latency of 5.
1337         (when (> (+ adds shifts) 4)
1338           (give-up-ir1-transform)))
1339        (t
1340         ;; a mullw instruction also has a latency of 5, plus two
1341         ;; instructions (in general) to load the immediate into a
1342         ;; register.
1343         (when (> (+ adds shifts) 6)
1344           (give-up-ir1-transform))))
1345       (or result 0))))