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