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 2
  48     (inst xori 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 (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-logop-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 (unsigned-byte 14) (not (integer 0 0)))))
  97   (:results (r :scs (any-reg)))
  98   (:result-types tagged-num)
  99   (:note "inline fixnum logical op"))
 100
 101 (define-vop (fast-unsigned-binop-c fast-safe-arith-op)
 102   (:args (x :target r :scs (unsigned-reg zero)))
 103   (:info y)
 104   (:arg-types unsigned-num
 105               (:constant (and (signed-byte 16) (not (integer 0 0)))))
 106   (:results (r :scs (unsigned-reg)))
 107   (:result-types unsigned-num)
 108   (:note "inline (unsigned-byte 32) arithmetic"))
 109
 110 (define-vop (fast-unsigned-logop-c fast-safe-arith-op)
 111   (:args (x :target r :scs (unsigned-reg zero)))
 112   (:info y)
 113   (:arg-types unsigned-num
 114               (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
 115   (:results (r :scs (unsigned-reg)))
 116   (:result-types unsigned-num)
 117   (:note "inline (unsigned-byte 32) logical op"))
 118
 119 (define-vop (fast-signed-binop-c fast-safe-arith-op)
 120   (:args (x :target r :scs (signed-reg zero)))
 121   (:info y)
 122   (:arg-types signed-num
 123               (:constant (and (signed-byte 16) (not (integer 0 0)))))
 124   (:results (r :scs (signed-reg)))
 125   (:result-types signed-num)
 126   (:note "inline (signed-byte 32) arithmetic"))
 127
 128 (define-vop (fast-signed-logop-c fast-safe-arith-op)
 129   (:args (x :target r :scs (signed-reg zero)))
 130   (:info y)
 131   (:arg-types signed-num
 132               (:constant (and (unsigned-byte 16) (not (integer 0 0)))))
 133   (:results (r :scs (signed-reg)))
 134   (:result-types signed-num)
 135   (:note "inline (signed-byte 32) arithmetic"))
 136
 137
 138 (macrolet ((define-var-binop (translate untagged-penalty op
 139                                         &optional arg-swap restore-fixnum-mask)
 140                `(progn
 141                  (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
 142                               fast-fixnum-binop)
 143                      ,@(when restore-fixnum-mask
 144                              `((:temporary (:sc non-descriptor-reg) temp)))
 145                      (:translate ,translate)
 146                      (:generator 2
 147                       ,(if arg-swap
 148                            `(inst ,op ,(if restore-fixnum-mask 'temp 'r) y x)
 149                            `(inst ,op ,(if restore-fixnum-mask 'temp 'r) x y))
 150                       ;; FIXME: remind me what convention we used for 64bitizing
 151                       ;; stuff?  -- CSR, 2003-08-27
 152                       ,@(when restore-fixnum-mask
 153                               `((inst clrrwi r temp (1- n-lowtag-bits))))))
 154                  (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
 155                               fast-signed-binop)
 156                      (:translate ,translate)
 157                    (:generator ,(1+ untagged-penalty)
 158                     ,(if arg-swap
 159                          `(inst ,op r y x)
 160                          `(inst ,op r x y))))
 161                  (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
 162                               fast-unsigned-binop)
 163                      (:translate ,translate)
 164                    (:generator ,(1+ untagged-penalty)
 165                     ,(if arg-swap
 166                          `(inst ,op r y x)
 167                          `(inst ,op r x y))))))
 168            (define-const-binop (translate untagged-penalty op)
 169                `(progn
 170
 171                  (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
 172                               fast-fixnum-binop-c)
 173                      (:translate ,translate)
 174                    (:generator 1
 175                     (inst ,op r x (fixnumize y))))
 176                  (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
 177                               fast-signed-binop-c)
 178                      (:translate ,translate)
 179                    (:generator ,untagged-penalty
 180                     (inst ,op r x y)))
 181                  (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
 182                               fast-unsigned-binop-c)
 183                      (:translate ,translate)
 184                    (:generator ,untagged-penalty
 185                     (inst ,op r x y)))))
 186            (defmacro define-const-logop (translate untagged-penalty op)
 187              `(progn
 188
 189                (define-vop (,(symbolicate 'fast- translate '-c/fixnum=>fixnum)
 190                             fast-fixnum-logop-c)
 191                    (:translate ,translate)
 192                  (:generator 1
 193                   (inst ,op r x (fixnumize y))))
 194                (define-vop (,(symbolicate 'fast- translate '-c/signed=>signed)
 195                             fast-signed-logop-c)
 196                    (:translate ,translate)
 197                  (:generator ,untagged-penalty
 198                   (inst ,op r x y)))
 199                (define-vop (,(symbolicate 'fast- translate '-c/unsigned=>unsigned)
 200                             fast-unsigned-logop-c)
 201                    (:translate ,translate)
 202                  (:generator ,untagged-penalty
 203                   (inst ,op r x y))))))
 204   (define-var-binop + 4 add)
 205   (define-var-binop - 4 sub)
 206   (define-var-binop logand 2 and)
 207   (define-var-binop logandc1 2 andc t)
 208   (define-var-binop logandc2 2 andc)
 209   (define-var-binop logior 2 or)
 210   (define-var-binop logorc1 2 orc t t)
 211   (define-var-binop logorc2 2 orc nil t)
 212   (define-var-binop logxor 2 xor)
 213   (define-var-binop logeqv 2 eqv nil t)
 214   (define-var-binop lognand 2 nand nil t)
 215   (define-var-binop lognor 2 nor nil t)
 216
 217   (define-const-binop + 4 addi)
 218   (define-const-binop - 4 subi)
 219   (define-const-logop logand 2 andi.)
 220   (define-const-logop logior 2 ori)
 221   (define-const-logop logxor 2 xori))
 222
 223 ;;; Special case fixnum + and - that trap on overflow.  Useful when we
 224 ;;; don't know that the output type is a fixnum.
 225 ;;;
 226 (define-vop (+/fixnum fast-+/fixnum=>fixnum)
 227   (:policy :safe)
 228   (:results (r :scs (any-reg descriptor-reg)))
 229   (:result-types tagged-num)
 230   (:note "safe inline fixnum arithmetic")
 231   (:generator 4
 232     (let* ((no-overflow (gen-label)))
 233       (inst mtxer zero-tn)
 234       (inst addo. r x y)
 235       (inst bns no-overflow)
 236       (inst unimp (logior (ash (reg-tn-encoding r) 5)
 237                           fixnum-additive-overflow-trap))
 238       (emit-label no-overflow))))
 239
 240
 241 (define-vop (-/fixnum fast--/fixnum=>fixnum)
 242   (:policy :safe)
 243   (:results (r :scs (any-reg descriptor-reg)))
 244   (:result-types tagged-num)
 245   (:note "safe inline fixnum arithmetic")
 246   (:generator 4
 247     (let* ((no-overflow (gen-label)))
 248       (inst mtxer zero-tn)
 249       (inst subo. r x y)
 250       (inst bns no-overflow)
 251       (inst unimp (logior (ash (reg-tn-encoding r) 5)
 252                           fixnum-additive-overflow-trap))
 253       (emit-label no-overflow))))
 254
 255 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
 256   (:temporary (:scs (non-descriptor-reg)) temp)
 257   (:translate *)
 258   (:generator 2
 259     (inst srawi temp y 2)
 260     (inst mullw r x temp)))
 261
 262 (define-vop (fast-*-c/fixnum=>fixnum fast-fixnum-binop-c)
 263   (:translate *)
 264   (:arg-types tagged-num
 265               (:constant (and (signed-byte 16) (not (integer 0 0)))))
 266   (:generator 1
 267     (inst mulli r x y)))
 268
 269 (define-vop (fast-*-bigc/fixnum=>fixnum fast-fixnum-binop-c)
 270   (:translate *)
 271   (:arg-types tagged-num
 272               (:constant (and fixnum (not (signed-byte 16)))))
 273   (:temporary (:scs (non-descriptor-reg)) temp)
 274   (:generator 1
 275     (inst lr temp y)
 276     (inst mullw r x temp)))
 277
 278 (define-vop (fast-*/signed=>signed fast-signed-binop)
 279   (:translate *)
 280   (:generator 4
 281     (inst mullw r x y)))
 282
 283 (define-vop (fast-*-c/signed=>signed fast-signed-binop-c)
 284   (:translate *)
 285   (:generator 3
 286     (inst mulli r x y)))
 287
 288 (define-vop (fast-*/unsigned=>unsigned fast-unsigned-binop)
 289   (:translate *)
 290   (:generator 4
 291     (inst mullw r x y)))
 292
 293 (define-vop (fast-*-c/unsigned=>unsigned fast-unsigned-binop-c)
 294   (:translate *)
 295   (:generator 3
 296     (inst mulli r x y)))
 297 \f
 298 ;;; Shifting
 299
 300 (macrolet ((def (name sc-type type result-type cost)
 301              `(define-vop (,name)
 302                 (:note "inline ASH")
 303                 (:translate ash)
 304                 (:args (number :scs (,sc-type))
 305                        (amount :scs (signed-reg unsigned-reg immediate)))
 306                 (:arg-types ,type positive-fixnum)
 307                 (:results (result :scs (,result-type)))
 308                 (:result-types ,type)
 309                 (:policy :fast-safe)
 310                 (:generator ,cost
 311                    (sc-case amount
 312                      ((signed-reg unsigned-reg)
 313                       (inst slw result number amount))
 314                      (immediate
 315                       (let ((amount (tn-value amount)))
 316                         (aver (> amount 0))
 317                         (inst slwi result number amount))))))))
 318   ;; FIXME: There's the opportunity for a sneaky optimization here, I
 319   ;; think: a FAST-ASH-LEFT-C/FIXNUM=>SIGNED vop.  -- CSR, 2003-09-03
 320   (def fast-ash-left/fixnum=>fixnum any-reg tagged-num any-reg 2)
 321   (def fast-ash-left/signed=>signed signed-reg signed-num signed-reg 3)
 322   (def fast-ash-left/unsigned=>unsigned unsigned-reg unsigned-num unsigned-reg 3))
 323
 324 (define-vop (fast-ash/unsigned=>unsigned)
 325   (:note "inline ASH")
 326   (:args (number :scs (unsigned-reg) :to :save)
 327          (amount :scs (signed-reg)))
 328   (:arg-types (:or unsigned-num) signed-num)
 329   (:results (result :scs (unsigned-reg)))
 330   (:result-types unsigned-num)
 331   (:translate ash)
 332   (:policy :fast-safe)
 333   (:temporary (:sc non-descriptor-reg) ndesc)
 334   (:generator 5
 335     (let ((positive (gen-label))
 336           (done (gen-label)))
 337       (inst cmpwi amount 0)
 338       (inst neg ndesc amount)
 339       (inst bge positive)
 340       (inst cmpwi ndesc 31)
 341       (inst srw result number ndesc)
 342       (inst ble done)
 343       (move result zero-tn)
 344       (inst b done)
 345
 346       (emit-label positive)
 347       ;; The result-type assures us that this shift will not overflow.
 348       (inst slw result number amount)
 349
 350       (emit-label done))))
 351
 352 (define-vop (fast-ash-c/unsigned=>unsigned)
 353   (:note "inline constant ASH")
 354   (:args (number :scs (unsigned-reg)))
 355   (:info amount)
 356   (:arg-types unsigned-num (:constant integer))
 357   (:results (result :scs (unsigned-reg)))
 358   (:result-types unsigned-num)
 359   (:translate ash)
 360   (:policy :fast-safe)
 361   (:generator 4
 362     (cond
 363       ((and (minusp amount) (< amount -31)) (move result zero-tn))
 364       ((minusp amount) (inst srwi result number (- amount)))
 365       ;; possible because this is used in the modular version too
 366       ((> amount 31) (move result zero-tn))
 367       (t (inst slwi result number amount)))))
 368
 369 (define-vop (fast-ash/signed=>signed)
 370   (:note "inline ASH")
 371   (:args (number :scs (signed-reg) :to :save)
 372          (amount :scs (signed-reg immediate)))
 373   (:arg-types (:or signed-num) signed-num)
 374   (:results (result :scs (signed-reg)))
 375   (:result-types (:or signed-num))
 376   (:translate ash)
 377   (:policy :fast-safe)
 378   (:temporary (:sc non-descriptor-reg) ndesc)
 379   (:generator 3
 380     (sc-case amount
 381       (signed-reg
 382        (let ((positive (gen-label))
 383              (done (gen-label)))
 384          (inst cmpwi amount 0)
 385          (inst neg ndesc amount)
 386          (inst bge positive)
 387          (inst cmpwi ndesc 31)
 388          (inst sraw result number ndesc)
 389          (inst ble done)
 390          (inst srawi result number 31)
 391          (inst b done)
 392
 393          (emit-label positive)
 394          ;; The result-type assures us that this shift will not overflow.
 395          (inst slw result number amount)
 396
 397          (emit-label done)))
 398
 399       (immediate
 400        (let ((amount (tn-value amount)))
 401          (if (minusp amount)
 402              (let ((amount (min 31 (- amount))))
 403                (inst srawi result number amount))
 404              (inst slwi result number amount)))))))
 405
 406
 407
 408 (define-vop (signed-byte-32-len)
 409   (:translate integer-length)
 410   (:note "inline (signed-byte 32) integer-length")
 411   (:policy :fast-safe)
 412   (:args (arg :scs (signed-reg)))
 413   (:arg-types signed-num)
 414   (:results (res :scs (any-reg)))
 415   (:result-types positive-fixnum)
 416   (:temporary (:scs (non-descriptor-reg) :to (:argument 0)) shift)
 417   (:generator 6
 418     ; (integer-length arg) = (- 32 (cntlz (if (>= arg 0) arg (lognot arg))))
 419     (let ((nonneg (gen-label)))
 420       (inst cntlzw. shift arg)
 421       (inst bne nonneg)
 422       (inst not shift arg)
 423       (inst cntlzw shift shift)
 424       (emit-label nonneg)
 425       (inst slwi shift shift 2)
 426       (inst subfic res  shift (fixnumize 32)))))
 427
 428 (define-vop (unsigned-byte-32-count)
 429   (:translate logcount)
 430   (:note "inline (unsigned-byte 32) logcount")
 431   (:policy :fast-safe)
 432   (:args (arg :scs (unsigned-reg) :target shift))
 433   (:arg-types unsigned-num)
 434   (:results (res :scs (any-reg)))
 435   (:result-types positive-fixnum)
 436   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift temp)
 437   (:generator 30
 438     (let ((loop (gen-label))
 439           (done (gen-label)))
 440       (inst add. shift zero-tn arg)
 441       (move res zero-tn)
 442       (inst beq done)
 443
 444       (emit-label loop)
 445       (inst subi temp shift 1)
 446       (inst and. shift shift temp)
 447       (inst addi res res (fixnumize 1))
 448       (inst bne loop)
 449
 450       (emit-label done))))
 451
 452 \f
 453 ;;;; Modular functions:
 454 (define-modular-fun lognot-mod32 (x) lognot 32)
 455 (define-vop (lognot-mod32/unsigned=>unsigned)
 456   (:translate lognot-mod32)
 457   (:args (x :scs (unsigned-reg)))
 458   (:arg-types unsigned-num)
 459   (:results (res :scs (unsigned-reg)))
 460   (:result-types unsigned-num)
 461   (:policy :fast-safe)
 462   (:generator 1
 463     (inst not res x)))
 464
 465 (define-vop (fast-ash-left-mod32-c/unsigned=>unsigned
 466              fast-ash-c/unsigned=>unsigned)
 467   (:translate ash-left-mod32))
 468
 469 (define-vop (fast-ash-left-mod32/unsigned=>unsigned
 470              fast-ash-left/unsigned=>unsigned))
 471 (deftransform ash-left-mod32 ((integer count)
 472                               ((unsigned-byte 32) (unsigned-byte 5)))
 473   (when (sb!c::constant-lvar-p count)
 474     (sb!c::give-up-ir1-transform))
 475   '(%primitive fast-ash-left-mod32/unsigned=>unsigned integer count))
 476
 477 (macrolet ((define-modular-backend (fun &optional constantp)
 478              (collect ((forms))
 479                (dolist (info '((29 fixnum) (32 unsigned)))
 480                  (destructuring-bind (width regtype) info
 481                    (let ((mfun-name (intern (format nil "~A-MOD~A" fun width)))
 482                          (mvop (intern (format nil "FAST-~A-MOD~A/~A=>~A"
 483                                                fun width regtype regtype)))
 484                          (mcvop (intern (format nil "FAST-~A-MOD~A-C/~A=>~A"
 485                                                 fun width regtype regtype)))
 486                          (vop (intern (format nil "FAST-~A/~A=>~A"
 487                                               fun regtype regtype)))
 488                          (cvop (intern (format nil "FAST-~A-C/~A=>~A"
 489                                                fun regtype regtype))))
 490                      (forms `(define-modular-fun ,mfun-name (x y) ,fun ,width))
 491                      (forms `(define-vop (,mvop ,vop)
 492                               (:translate ,mfun-name)))
 493                      (when constantp
 494                        (forms `(define-vop (,mcvop ,cvop)
 495                                 (:translate ,mfun-name)))))))
 496                `(progn ,@(forms)))))
 497   (define-modular-backend + t)
 498   (define-modular-backend - t)
 499   (define-modular-backend * t)
 500   (define-modular-backend logxor t)
 501   (define-modular-backend logeqv)
 502   (define-modular-backend lognand)
 503   (define-modular-backend lognor)
 504   (define-modular-backend logandc1)
 505   (define-modular-backend logandc2)
 506   (define-modular-backend logorc1)
 507   (define-modular-backend logorc2))
 508 \f
 509 ;;;; Binary conditional VOPs:
 510
 511 (define-vop (fast-conditional)
 512   (:conditional)
 513   (:info target not-p)
 514   (:effects)
 515   (:affected)
 516   (:policy :fast-safe))
 517
 518 (define-vop (fast-conditional/fixnum fast-conditional)
 519   (:args (x :scs (any-reg zero))
 520          (y :scs (any-reg zero)))
 521   (:arg-types tagged-num tagged-num)
 522   (:note "inline fixnum comparison"))
 523
 524 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
 525   (:args (x :scs (any-reg zero)))
 526   (:arg-types tagged-num (:constant (signed-byte 14)))
 527   (:info target not-p y))
 528
 529 (define-vop (fast-conditional/signed fast-conditional)
 530   (:args (x :scs (signed-reg zero))
 531          (y :scs (signed-reg zero)))
 532   (:arg-types signed-num signed-num)
 533   (:note "inline (signed-byte 32) comparison"))
 534
 535 (define-vop (fast-conditional-c/signed fast-conditional/signed)
 536   (:args (x :scs (signed-reg zero)))
 537   (:arg-types signed-num (:constant (signed-byte 16)))
 538   (:info target not-p y))
 539
 540 (define-vop (fast-conditional/unsigned fast-conditional)
 541   (:args (x :scs (unsigned-reg zero))
 542          (y :scs (unsigned-reg zero)))
 543   (:arg-types unsigned-num unsigned-num)
 544   (:note "inline (unsigned-byte 32) comparison"))
 545
 546 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
 547   (:args (x :scs (unsigned-reg zero)))
 548   (:arg-types unsigned-num (:constant (unsigned-byte 16)))
 549   (:info target not-p y))
 550
 551
 552 (define-vop (fast-if-</fixnum fast-conditional/fixnum)
 553   (:translate <)
 554   (:generator 4
 555     (inst cmpw x y)
 556     (inst b? (if not-p :ge :lt) target)))
 557
 558 (define-vop (fast-if-<-c/fixnum fast-conditional-c/fixnum)
 559   (:translate <)
 560   (:generator 3
 561     (inst cmpwi x (fixnumize y))
 562     (inst b? (if not-p :ge :lt) target)))
 563
 564 (define-vop (fast-if-</signed fast-conditional/signed)
 565   (:translate <)
 566   (:generator 6
 567     (inst cmpw x y)
 568     (inst b? (if not-p :ge :lt) target)))
 569
 570 (define-vop (fast-if-<-c/signed fast-conditional-c/signed)
 571   (:translate <)
 572   (:generator 5
 573     (inst cmpwi x y)
 574     (inst b? (if not-p :ge :lt) target)))
 575
 576 (define-vop (fast-if-</unsigned fast-conditional/unsigned)
 577   (:translate <)
 578   (:generator 6
 579     (inst cmplw x y)
 580     (inst b? (if not-p :ge :lt) target)))
 581
 582 (define-vop (fast-if-<-c/unsigned fast-conditional-c/unsigned)
 583   (:translate <)
 584   (:generator 5
 585     (inst cmplwi x y)
 586     (inst b? (if not-p :ge :lt) target)))
 587
 588 (define-vop (fast-if->/fixnum fast-conditional/fixnum)
 589   (:translate >)
 590   (:generator 4
 591     (inst cmpw x y)
 592     (inst b? (if not-p :le :gt) target)))
 593
 594 (define-vop (fast-if->-c/fixnum fast-conditional-c/fixnum)
 595   (:translate >)
 596   (:generator 3
 597     (inst cmpwi x (fixnumize y))
 598     (inst b? (if not-p :le :gt) target)))
 599
 600 (define-vop (fast-if->/signed fast-conditional/signed)
 601   (:translate >)
 602   (:generator 6
 603     (inst cmpw x y)
 604     (inst b? (if not-p :le :gt) target)))
 605
 606 (define-vop (fast-if->-c/signed fast-conditional-c/signed)
 607   (:translate >)
 608   (:generator 5
 609     (inst cmpwi x y)
 610     (inst b? (if not-p :le :gt) target)))
 611
 612 (define-vop (fast-if->/unsigned fast-conditional/unsigned)
 613   (:translate >)
 614   (:generator 6
 615     (inst cmplw x y)
 616     (inst b? (if not-p :le :gt) target)))
 617
 618 (define-vop (fast-if->-c/unsigned fast-conditional-c/unsigned)
 619   (:translate >)
 620   (:generator 5
 621     (inst cmplwi x y)
 622     (inst b? (if not-p :le :gt) target)))
 623
 624 (define-vop (fast-if-eql/signed fast-conditional/signed)
 625   (:translate eql)
 626   (:generator 6
 627     (inst cmpw x y)
 628     (inst b? (if not-p :ne :eq) target)))
 629
 630 (define-vop (fast-if-eql-c/signed fast-conditional-c/signed)
 631   (:translate eql)
 632   (:generator 5
 633     (inst cmpwi x y)
 634     (inst b? (if not-p :ne :eq) target)))
 635
 636 (define-vop (fast-if-eql/unsigned fast-conditional/unsigned)
 637   (:translate eql)
 638   (:generator 6
 639     (inst cmplw x y)
 640     (inst b? (if not-p :ne :eq) target)))
 641
 642 (define-vop (fast-if-eql-c/unsigned fast-conditional-c/unsigned)
 643   (:translate eql)
 644   (:generator 5
 645     (inst cmplwi x y)
 646     (inst b? (if not-p :ne :eq) target)))
 647
 648
 649 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
 650 ;;; known fixnum.
 651
 652 ;;; These versions specify a fixnum restriction on their first arg.  We have
 653 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
 654 ;;; the first arg and a higher cost.  The reason for doing this is to prevent
 655 ;;; fixnum specific operations from being used on word integers, spuriously
 656 ;;; consing the argument.
 657 ;;;
 658
 659 (define-vop (fast-eql/fixnum fast-conditional)
 660   (:args (x :scs (any-reg descriptor-reg zero))
 661          (y :scs (any-reg zero)))
 662   (:arg-types tagged-num tagged-num)
 663   (:note "inline fixnum comparison")
 664   (:translate eql)
 665   (:generator 4
 666     (inst cmpw x y)
 667     (inst b? (if not-p :ne :eq) target)))
 668 ;;;
 669 (define-vop (generic-eql/fixnum fast-eql/fixnum)
 670   (:arg-types * tagged-num)
 671   (:variant-cost 7))
 672
 673 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
 674   (:args (x :scs (any-reg descriptor-reg zero)))
 675   (:arg-types tagged-num (:constant (signed-byte 14)))
 676   (:info target not-p y)
 677   (:translate eql)
 678   (:generator 2
 679     (inst cmpwi x (fixnumize y))
 680     (inst b? (if not-p :ne :eq) target)))
 681 ;;;
 682 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
 683   (:arg-types * (:constant (signed-byte 11)))
 684   (:variant-cost 6))
 685
 686 \f
 687 ;;;; 32-bit logical operations
 688
 689 (define-vop (merge-bits)
 690   (:translate merge-bits)
 691   (:args (shift :scs (signed-reg unsigned-reg))
 692          (prev :scs (unsigned-reg))
 693          (next :scs (unsigned-reg)))
 694   (:arg-types tagged-num unsigned-num unsigned-num)
 695   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 696   (:temporary (:scs (unsigned-reg) :to (:result 0) :target result) res)
 697   (:results (result :scs (unsigned-reg)))
 698   (:result-types unsigned-num)
 699   (:policy :fast-safe)
 700   (:generator 4
 701     (let ((done (gen-label)))
 702       (inst cmpwi shift 0)
 703       (inst beq done)
 704       (inst srw res next shift)
 705       (inst sub temp zero-tn shift)
 706       (inst slw temp prev temp)
 707       (inst or res res temp)
 708       (emit-label done)
 709       (move result res))))
 710
 711 (define-vop (shift-towards-someplace)
 712   (:policy :fast-safe)
 713   (:args (num :scs (unsigned-reg))
 714          (amount :scs (signed-reg)))
 715   (:arg-types unsigned-num tagged-num)
 716   (:results (r :scs (unsigned-reg)))
 717   (:result-types unsigned-num))
 718
 719 (define-vop (shift-towards-start shift-towards-someplace)
 720   (:translate shift-towards-start)
 721   (:note "shift-towards-start")
 722   (:generator 1
 723     (inst rlwinm amount amount 0 27 31)
 724     (inst slw r num amount)))
 725
 726 (define-vop (shift-towards-end shift-towards-someplace)
 727   (:translate shift-towards-end)
 728   (:note "shift-towards-end")
 729   (:generator 1
 730     (inst rlwinm amount amount 0 27 31)
 731     (inst srw r num amount)))
 732 \f
 733 ;;;; Bignum stuff.
 734
 735 (define-vop (bignum-length get-header-data)
 736   (:translate sb!bignum:%bignum-length)
 737   (:policy :fast-safe))
 738
 739 (define-vop (bignum-set-length set-header-data)
 740   (:translate sb!bignum:%bignum-set-length)
 741   (:policy :fast-safe))
 742
 743 (define-vop (bignum-ref word-index-ref)
 744   (:variant bignum-digits-offset other-pointer-lowtag)
 745   (:translate sb!bignum:%bignum-ref)
 746   (:results (value :scs (unsigned-reg)))
 747   (:result-types unsigned-num))
 748
 749 (define-vop (bignum-set word-index-set)
 750   (:variant bignum-digits-offset other-pointer-lowtag)
 751   (:translate sb!bignum:%bignum-set)
 752   (:args (object :scs (descriptor-reg))
 753          (index :scs (any-reg immediate zero))
 754          (value :scs (unsigned-reg)))
 755   (:arg-types t positive-fixnum unsigned-num)
 756   (:results (result :scs (unsigned-reg)))
 757   (:result-types unsigned-num))
 758
 759 (define-vop (digit-0-or-plus)
 760   (:translate sb!bignum:%digit-0-or-plusp)
 761   (:policy :fast-safe)
 762   (:args (digit :scs (unsigned-reg)))
 763   (:arg-types unsigned-num)
 764   (:results (result :scs (descriptor-reg)))
 765   (:generator 3
 766     (let ((done (gen-label)))
 767       (inst cmpwi digit 0)
 768       (move result null-tn)
 769       (inst blt done)
 770       (load-symbol result t)
 771       (emit-label done))))
 772
 773 (define-vop (add-w/carry)
 774   (:translate sb!bignum:%add-with-carry)
 775   (:policy :fast-safe)
 776   (:args (a :scs (unsigned-reg))
 777          (b :scs (unsigned-reg))
 778          (c :scs (any-reg)))
 779   (:arg-types unsigned-num unsigned-num positive-fixnum)
 780   (:temporary (:scs (unsigned-reg)) temp)
 781   (:results (result :scs (unsigned-reg))
 782             (carry :scs (unsigned-reg)))
 783   (:result-types unsigned-num positive-fixnum)
 784   (:generator 3
 785     (inst addic temp c -1)
 786     (inst adde result a b)
 787     (inst addze carry zero-tn)))
 788
 789 (define-vop (sub-w/borrow)
 790   (:translate sb!bignum:%subtract-with-borrow)
 791   (:policy :fast-safe)
 792   (:args (a :scs (unsigned-reg))
 793          (b :scs (unsigned-reg))
 794          (c :scs (any-reg)))
 795   (:arg-types unsigned-num unsigned-num positive-fixnum)
 796   (:temporary (:scs (unsigned-reg)) temp)
 797   (:results (result :scs (unsigned-reg))
 798             (borrow :scs (unsigned-reg)))
 799   (:result-types unsigned-num positive-fixnum)
 800   (:generator 4
 801     (inst addic temp c -1)
 802     (inst sube result a b)
 803     (inst addze borrow zero-tn)))
 804
 805 (define-vop (bignum-mult-and-add-3-arg)
 806   (:translate sb!bignum:%multiply-and-add)
 807   (:policy :fast-safe)
 808   (:args (x :scs (unsigned-reg))
 809          (y :scs (unsigned-reg))
 810          (carry-in :scs (unsigned-reg) :to (:eval 1)))
 811   (:arg-types unsigned-num unsigned-num unsigned-num)
 812   (:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp)
 813   (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
 814                     :target lo) lo-temp)
 815   (:results (hi :scs (unsigned-reg))
 816             (lo :scs (unsigned-reg)))
 817   (:result-types unsigned-num unsigned-num)
 818   (:generator 40
 819     (inst mulhwu hi-temp x y)
 820     (inst mullw lo-temp x y)
 821     (inst addc lo lo-temp carry-in)
 822     (inst addze hi hi-temp)))
 823
 824 (define-vop (bignum-mult-and-add-4-arg)
 825   (:translate sb!bignum:%multiply-and-add)
 826   (:policy :fast-safe)
 827   (:args (x :scs (unsigned-reg))
 828          (y :scs (unsigned-reg))
 829          (prev :scs (unsigned-reg) :to (:eval 1))
 830          (carry-in :scs (unsigned-reg) :to (:eval 1)))
 831   (:arg-types unsigned-num unsigned-num unsigned-num unsigned-num)
 832   (:temporary (:scs (unsigned-reg) :to (:result 0) :target hi) hi-temp)
 833   (:temporary (:scs (unsigned-reg) :from (:eval 0) :to (:result 1)
 834                     :target lo) lo-temp)
 835   (:results (hi :scs (unsigned-reg))
 836             (lo :scs (unsigned-reg)))
 837   (:result-types unsigned-num unsigned-num)
 838   (:generator 40
 839     (inst mulhwu hi-temp x y)
 840     (inst mullw lo-temp x y)
 841     (inst addc lo-temp lo-temp carry-in)
 842     (inst addze hi-temp hi-temp)
 843     (inst addc lo lo-temp prev)
 844     (inst addze hi hi-temp)))
 845
 846 (define-vop (bignum-mult)
 847   (:translate sb!bignum:%multiply)
 848   (:policy :fast-safe)
 849   (:args (x :scs (unsigned-reg) :to (:eval 1))
 850          (y :scs (unsigned-reg) :to (:eval 1)))
 851   (:arg-types unsigned-num unsigned-num)
 852   (:results (hi :scs (unsigned-reg) :from (:eval 1))
 853             (lo :scs (unsigned-reg) :from (:eval 0)))
 854   (:result-types unsigned-num unsigned-num)
 855   (:generator 40
 856     (inst mullw lo x y)
 857     (inst mulhwu hi x y)))
 858
 859 (define-vop (bignum-lognot lognot-mod32/unsigned=>unsigned)
 860   (:translate sb!bignum:%lognot))
 861
 862 (define-vop (fixnum-to-digit)
 863   (:translate sb!bignum:%fixnum-to-digit)
 864   (:policy :fast-safe)
 865   (:args (fixnum :scs (any-reg)))
 866   (:arg-types tagged-num)
 867   (:results (digit :scs (unsigned-reg)))
 868   (:result-types unsigned-num)
 869   (:generator 1
 870     (inst srawi digit fixnum 2)))
 871
 872
 873 (define-vop (bignum-floor)
 874   (:translate sb!bignum:%floor)
 875   (:policy :fast-safe)
 876   (:args (num-high :scs (unsigned-reg) :target rem)
 877          (num-low :scs (unsigned-reg) :target rem-low)
 878          (denom :scs (unsigned-reg) :to (:eval 1)))
 879   (:arg-types unsigned-num unsigned-num unsigned-num)
 880   (:temporary (:scs (unsigned-reg) :from (:argument 1)) rem-low)
 881   (:temporary (:scs (unsigned-reg) :from (:eval 0)) temp)
 882   (:results (quo :scs (unsigned-reg) :from (:eval 0))
 883             (rem :scs (unsigned-reg) :from (:argument 0)))
 884   (:result-types unsigned-num unsigned-num)
 885   (:generator 325 ; number of inst assuming targeting works.
 886     (move rem num-high)
 887     (move rem-low num-low)
 888     (flet ((maybe-subtract (&optional (guess temp))
 889              (inst subi temp guess 1)
 890              (inst and temp temp denom)
 891              (inst sub rem rem temp))
 892            (sltu (res x y)
 893              (inst subfc res y x)
 894              (inst subfe res res res)
 895              (inst neg res res)))
 896       (sltu quo rem denom)
 897       (maybe-subtract quo)
 898       (dotimes (i 32)
 899         (inst slwi rem rem 1)
 900         (inst srwi temp rem-low 31)
 901         (inst or rem rem temp)
 902         (inst slwi rem-low rem-low 1)
 903         (sltu temp rem denom)
 904         (inst slwi quo quo 1)
 905         (inst or quo quo temp)
 906         (maybe-subtract)))
 907     (inst not quo quo)))
 908
 909 #|
 910
 911 (define-vop (bignum-floor)
 912   (:translate sb!bignum:%floor)
 913   (:policy :fast-safe)
 914   (:args (div-high :scs (unsigned-reg) :target rem)
 915          (div-low :scs (unsigned-reg) :target quo)
 916          (divisor :scs (unsigned-reg)))
 917   (:arg-types unsigned-num unsigned-num unsigned-num)
 918   (:results (quo :scs (unsigned-reg) :from (:argument 1))
 919             (rem :scs (unsigned-reg) :from (:argument 0)))
 920   (:result-types unsigned-num unsigned-num)
 921   (:generator 300
 922     (inst mtmq div-low)
 923     (inst div quo div-high divisor)
 924     (inst mfmq rem)))
 925 |#
 926
 927 (define-vop (signify-digit)
 928   (:translate sb!bignum:%fixnum-digit-with-correct-sign)
 929   (:policy :fast-safe)
 930   (:args (digit :scs (unsigned-reg) :target res))
 931   (:arg-types unsigned-num)
 932   (:results (res :scs (any-reg signed-reg)))
 933   (:result-types signed-num)
 934   (:generator 1
 935     (sc-case res
 936       (any-reg
 937        (inst slwi res digit 2))
 938       (signed-reg
 939        (move res digit)))))
 940
 941
 942 (define-vop (digit-ashr)
 943   (:translate sb!bignum:%ashr)
 944   (:policy :fast-safe)
 945   (:args (digit :scs (unsigned-reg))
 946          (count :scs (unsigned-reg)))
 947   (:arg-types unsigned-num positive-fixnum)
 948   (:results (result :scs (unsigned-reg)))
 949   (:result-types unsigned-num)
 950   (:generator 1
 951     (inst sraw result digit count)))
 952
 953 (define-vop (digit-lshr digit-ashr)
 954   (:translate sb!bignum:%digit-logical-shift-right)
 955   (:generator 1
 956     (inst srw result digit count)))
 957
 958 (define-vop (digit-ashl digit-ashr)
 959   (:translate sb!bignum:%ashl)
 960   (:generator 1
 961     (inst slw result digit count)))
 962
 963 \f
 964 ;;;; Static funs.
 965
 966 (define-static-fun two-arg-gcd (x y) :translate gcd)
 967 (define-static-fun two-arg-lcm (x y) :translate lcm)
 968
 969 (define-static-fun two-arg-+ (x y) :translate +)
 970 (define-static-fun two-arg-- (x y) :translate -)
 971 (define-static-fun two-arg-* (x y) :translate *)
 972 (define-static-fun two-arg-/ (x y) :translate /)
 973
 974 (define-static-fun two-arg-< (x y) :translate <)
 975 (define-static-fun two-arg-<= (x y) :translate <=)
 976 (define-static-fun two-arg-> (x y) :translate >)
 977 (define-static-fun two-arg->= (x y) :translate >=)
 978 (define-static-fun two-arg-= (x y) :translate =)
 979 (define-static-fun two-arg-/= (x y) :translate /=)
 980
 981 (define-static-fun %negate (x) :translate %negate)
 982
 983 (define-static-fun two-arg-and (x y) :translate logand)
 984 (define-static-fun two-arg-ior (x y) :translate logior)
 985 (define-static-fun two-arg-xor (x y) :translate logxor)
 986 (define-static-fun two-arg-eqv (x y) :translate logeqv)
 987 \f
 988 (in-package "SB!C")
 989
 990 (deftransform * ((x y)
 991                  ((unsigned-byte 32) (constant-arg (unsigned-byte 32)))
 992                  (unsigned-byte 32))
 993   "recode as shifts and adds"
 994   (let ((y (lvar-value y)))
 995     (multiple-value-bind (result adds shifts)
 996         (ub32-strength-reduce-constant-multiply 'x y)
 997       (cond
 998        ((typep y '(signed-byte 16))
 999         ;; a mulli instruction has a latency of 5.
1000         (when (> (+ adds shifts) 4)
1001           (give-up-ir1-transform)))
1002        (t
1003         ;; a mullw instruction also has a latency of 5, plus two
1004         ;; instructions (in general) to load the immediate into a
1005         ;; register.
1006         (when (> (+ adds shifts) 6)
1007           (give-up-ir1-transform))))
1008       (or result 0))))