src/compiler/hppa/arith.lisp

   1 (in-package "SB!VM")
   2
   3
   4 \f
   5 ;;;; Unary operations.
   6
   7 (define-vop (fixnum-unop)
   8   (:args (x :scs (any-reg)))
   9   (:results (res :scs (any-reg)))
  10   (:note "inline fixnum arithmetic")
  11   (:arg-types tagged-num)
  12   (:result-types tagged-num)
  13   (:policy :fast-safe))
  14
  15 (define-vop (signed-unop)
  16   (:args (x :scs (signed-reg)))
  17   (:results (res :scs (signed-reg)))
  18   (:note "inline (signed-byte 32) arithmetic")
  19   (:arg-types signed-num)
  20   (:result-types signed-num)
  21   (:policy :fast-safe))
  22
  23 (define-vop (fast-negate/fixnum fixnum-unop)
  24   (:translate %negate)
  25   (:generator 1
  26     (inst sub zero-tn x res)))
  27
  28 (define-vop (fast-negate/signed signed-unop)
  29   (:translate %negate)
  30   (:generator 2
  31     (inst sub zero-tn x res)))
  32
  33 (define-vop (fast-lognot/fixnum fixnum-unop)
  34   (:temporary (:scs (any-reg) :type fixnum :to (:result 0))
  35               temp)
  36   (:translate lognot)
  37   (:generator 2
  38     (inst li (fixnumize -1) temp)
  39     (inst xor x temp res)))
  40
  41 (define-vop (fast-lognot/signed signed-unop)
  42   (:translate lognot)
  43   (:generator 1
  44     (inst uaddcm zero-tn x res)))
  45
  46
  47 \f
  48 ;;;; Binary fixnum operations.
  49
  50 ;;; Assume that any constant operand is the second arg...
  51
  52 (define-vop (fast-fixnum-binop)
  53   (:args (x :target r :scs (any-reg))
  54          (y :target r :scs (any-reg)))
  55   (:arg-types tagged-num tagged-num)
  56   (:results (r :scs (any-reg)))
  57   (:result-types tagged-num)
  58   (:note "inline fixnum arithmetic")
  59   (:effects)
  60   (:affected)
  61   (:policy :fast-safe))
  62
  63 (define-vop (fast-unsigned-binop)
  64   (:args (x :target r :scs (unsigned-reg))
  65          (y :target r :scs (unsigned-reg)))
  66   (:arg-types unsigned-num unsigned-num)
  67   (:results (r :scs (unsigned-reg)))
  68   (:result-types unsigned-num)
  69   (:note "inline (unsigned-byte 32) arithmetic")
  70   (:effects)
  71   (:affected)
  72   (:policy :fast-safe))
  73
  74 (define-vop (fast-signed-binop)
  75   (:args (x :target r :scs (signed-reg))
  76          (y :target r :scs (signed-reg)))
  77   (:arg-types signed-num signed-num)
  78   (:results (r :scs (signed-reg)))
  79   (:result-types signed-num)
  80   (:note "inline (signed-byte 32) arithmetic")
  81   (:effects)
  82   (:affected)
  83   (:policy :fast-safe))
  84
  85 (defmacro define-binop (translate cost untagged-cost op)
  86   `(progn
  87      (define-vop (,(symbolicate "FAST-" translate "/FIXNUM=>FIXNUM")
  88                   fast-fixnum-binop)
  89        (:args (x :target r :scs (any-reg))
  90               (y :target r :scs (any-reg)))
  91        (:translate ,translate)
  92        (:generator ,cost
  93          (inst ,op x y r)))
  94      (define-vop (,(symbolicate "FAST-" translate "/SIGNED=>SIGNED")
  95                   fast-signed-binop)
  96        (:args (x :target r :scs (signed-reg))
  97               (y :target r :scs (signed-reg)))
  98        (:translate ,translate)
  99        (:generator ,untagged-cost
 100          (inst ,op x y r)))
 101      (define-vop (,(symbolicate "FAST-" translate "/UNSIGNED=>UNSIGNED")
 102                   fast-unsigned-binop)
 103        (:args (x :target r :scs (unsigned-reg))
 104               (y :target r :scs (unsigned-reg)))
 105        (:translate ,translate)
 106        (:generator ,untagged-cost
 107          (inst ,op x y r)))))
 108
 109 (define-binop + 2 6 add)
 110 (define-binop - 2 6 sub)
 111 (define-binop logior 1 2 or)
 112 (define-binop logand 1 2 and)
 113 (define-binop logandc2 1 2 andcm)
 114 (define-binop logxor 1 2 xor)
 115
 116 (define-vop (fast-fixnum-c-binop fast-fixnum-binop)
 117   (:args (x :target r :scs (any-reg)))
 118   (:info y)
 119   (:arg-types tagged-num (:constant integer)))
 120
 121 (define-vop (fast-signed-c-binop fast-signed-binop)
 122   (:args (x :target r :scs (signed-reg)))
 123   (:info y)
 124   (:arg-types tagged-num (:constant integer)))
 125
 126 (define-vop (fast-unsigned-c-binop fast-unsigned-binop)
 127   (:args (x :target r :scs (unsigned-reg)))
 128   (:info y)
 129   (:arg-types tagged-num (:constant integer)))
 130
 131 (defmacro define-c-binop (translate cost untagged-cost tagged-type
 132                                     untagged-type inst)
 133   `(progn
 134      (define-vop (,(symbolicate "FAST-" translate "-C/FIXNUM=>FIXNUM")
 135                   fast-fixnum-c-binop)
 136        (:arg-types tagged-num (:constant ,tagged-type))
 137        (:translate ,translate)
 138        (:generator ,cost
 139          (let ((y (fixnumize y)))
 140            ,inst)))
 141      (define-vop (,(symbolicate "FAST-" translate "-C/SIGNED=>SIGNED")
 142                   fast-signed-c-binop)
 143        (:arg-types signed-num (:constant ,untagged-type))
 144        (:translate ,translate)
 145        (:generator ,untagged-cost
 146          ,inst))
 147      (define-vop (,(symbolicate "FAST-" translate "-C/UNSIGNED=>UNSIGNED")
 148                   fast-unsigned-c-binop)
 149        (:arg-types unsigned-num (:constant ,untagged-type))
 150        (:translate ,translate)
 151        (:generator ,untagged-cost
 152          ,inst))))
 153
 154 (define-c-binop + 1 3 (signed-byte 9) (signed-byte 11)
 155   (inst addi y x r))
 156 (define-c-binop - 1 3
 157   (integer #.(- (1- (ash 1 9))) #.(ash 1 9))
 158   (integer #.(- (1- (ash 1 11))) #.(ash 1 11))
 159   (inst addi (- y) x r))
 160
 161 ;;; Special case fixnum + and - that trap on overflow.  Useful when we don't
 162 ;;; know that the result is going to be a fixnum.
 163
 164 (define-vop (fast-+/fixnum fast-+/fixnum=>fixnum)
 165   (:results (r :scs (any-reg descriptor-reg)))
 166   (:result-types (:or signed-num unsigned-num))
 167   (:note nil)
 168   (:generator 4
 169     (inst addo x y r)))
 170
 171 (define-vop (fast-+-c/fixnum fast-+-c/fixnum=>fixnum)
 172   (:results (r :scs (any-reg descriptor-reg)))
 173   (:result-types (:or signed-num unsigned-num))
 174   (:note nil)
 175   (:generator 3
 176     (inst addio (fixnumize y) x r)))
 177
 178 (define-vop (fast--/fixnum fast--/fixnum=>fixnum)
 179   (:results (r :scs (any-reg descriptor-reg)))
 180   (:result-types (:or signed-num unsigned-num))
 181   (:note nil)
 182   (:generator 4
 183     (inst subo x y r)))
 184
 185 (define-vop (fast---c/fixnum fast---c/fixnum=>fixnum)
 186   (:results (r :scs (any-reg descriptor-reg)))
 187   (:result-types (:or signed-num unsigned-num))
 188   (:note nil)
 189   (:generator 3
 190     (inst addio (- (fixnumize y)) x r)))
 191
 192 ;;; Shifting
 193
 194 (define-vop (fast-ash/unsigned=>unsigned)
 195   (:policy :fast-safe)
 196   (:translate ash)
 197   (:note "inline word ASH")
 198   (:args (number :scs (unsigned-reg))
 199          (count :scs (signed-reg)))
 200   (:arg-types unsigned-num tagged-num)
 201   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 202   (:results (result :scs (unsigned-reg)))
 203   (:result-types unsigned-num)
 204   (:generator 8
 205     (inst comb :>= count zero-tn positive :nullify t)
 206     (inst sub zero-tn count temp)
 207     (inst comiclr 31 temp zero-tn :>=)
 208     (inst li 31 temp)
 209     (inst mtctl temp :sar)
 210     (inst extrs number 0 1 temp)
 211     (inst b done)
 212     (inst shd temp number :variable result)
 213     POSITIVE
 214     (inst subi 31 count temp)
 215     (inst mtctl temp :sar)
 216     (inst zdep number :variable 32 result)
 217     DONE))
 218
 219 (define-vop (fast-ash/signed=>signed)
 220   (:policy :fast-safe)
 221   (:translate ash)
 222   (:note "inline word ASH")
 223   (:args (number :scs (signed-reg))
 224          (count :scs (signed-reg)))
 225   (:arg-types signed-num tagged-num)
 226   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 227   (:results (result :scs (signed-reg)))
 228   (:result-types signed-num)
 229   (:generator 8
 230     (inst comb :>= count zero-tn positive :nullify t)
 231     (inst sub zero-tn count temp)
 232     (inst comiclr 31 temp zero-tn :>=)
 233     (inst li 31 temp)
 234     (inst mtctl temp :sar)
 235     (inst extrs number 0 1 temp)
 236     (inst b done)
 237     (inst shd temp number :variable result)
 238     POSITIVE
 239     (inst subi 31 count temp)
 240     (inst mtctl temp :sar)
 241     (inst zdep number :variable 32 result)
 242     DONE))
 243
 244 (define-vop (fast-ash-c/unsigned=>unsigned)
 245   (:policy :fast-safe)
 246   (:translate ash)
 247   (:note nil)
 248   (:args (number :scs (unsigned-reg)))
 249   (:info count)
 250   (:arg-types unsigned-num (:constant integer))
 251   (:results (result :scs (unsigned-reg)))
 252   (:result-types unsigned-num)
 253   (:generator 1
 254     (cond ((< count 0)
 255            ;; It is a right shift.
 256            (inst srl number (min (- count) 31) result))
 257           ((> count 0)
 258            ;; It is a left shift.
 259            (inst sll number (min count 31) result))
 260           (t
 261            ;; Count=0?  Shouldn't happen, but it's easy:
 262            (move number result)))))
 263
 264 (define-vop (fast-ash-c/signed=>signed)
 265   (:policy :fast-safe)
 266   (:translate ash)
 267   (:note nil)
 268   (:args (number :scs (signed-reg)))
 269   (:info count)
 270   (:arg-types signed-num (:constant integer))
 271   (:results (result :scs (signed-reg)))
 272   (:result-types signed-num)
 273   (:generator 1
 274     (cond ((< count 0)
 275            ;; It is a right shift.
 276            (inst sra number (min (- count) 31) result))
 277           ((> count 0)
 278            ;; It is a left shift.
 279            (inst sll number (min count 31) result))
 280           (t
 281            ;; Count=0?  Shouldn't happen, but it's easy:
 282            (move number result)))))
 283
 284
 285 (define-vop (signed-byte-32-len)
 286   (:translate integer-length)
 287   (:note "inline (signed-byte 32) integer-length")
 288   (:policy :fast-safe)
 289   (:args (arg :scs (signed-reg) :target shift))
 290   (:arg-types signed-num)
 291   (:results (res :scs (any-reg)))
 292   (:result-types positive-fixnum)
 293   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) shift)
 294   (:generator 30
 295     (inst move arg shift :>=)
 296     (inst uaddcm zero-tn shift shift)
 297     (inst comb := shift zero-tn done)
 298     (inst li 0 res)
 299     LOOP
 300     (inst srl shift 1 shift)
 301     (inst comb :<> shift zero-tn loop)
 302     (inst addi (fixnumize 1) res res)
 303     DONE))
 304
 305 (define-vop (unsigned-byte-32-count)
 306   (:translate logcount)
 307   (:note "inline (unsigned-byte 32) logcount")
 308   (:policy :fast-safe)
 309   (:args (arg :scs (unsigned-reg) :target num))
 310   (:arg-types unsigned-num)
 311   (:results (res :scs (unsigned-reg)))
 312   (:result-types positive-fixnum)
 313   (:temporary (:scs (non-descriptor-reg) :from (:argument 0) :to (:result 0)
 314                     :target res) num)
 315   (:temporary (:scs (non-descriptor-reg)) mask temp)
 316   (:generator 30
 317     (inst li #x55555555 mask)
 318     (inst srl arg 1 temp)
 319     (inst and arg mask num)
 320     (inst and temp mask temp)
 321     (inst add num temp num)
 322     (inst li #x33333333 mask)
 323     (inst srl num 2 temp)
 324     (inst and num mask num)
 325     (inst and temp mask temp)
 326     (inst add num temp num)
 327     (inst li #x0f0f0f0f mask)
 328     (inst srl num 4 temp)
 329     (inst and num mask num)
 330     (inst and temp mask temp)
 331     (inst add num temp num)
 332     (inst li #x00ff00ff mask)
 333     (inst srl num 8 temp)
 334     (inst and num mask num)
 335     (inst and temp mask temp)
 336     (inst add num temp num)
 337     (inst li #x0000ffff mask)
 338     (inst srl num 16 temp)
 339     (inst and num mask num)
 340     (inst and temp mask temp)
 341     (inst add num temp res)))
 342
 343 ;;; Multiply and Divide.
 344
 345 (define-vop (fast-*/fixnum=>fixnum fast-fixnum-binop)
 346   (:args (x :scs (any-reg) :target x-pass)
 347          (y :scs (any-reg) :target y-pass))
 348   (:temporary (:sc signed-reg :offset nl0-offset
 349                    :from (:argument 0) :to (:result 0)) x-pass)
 350   (:temporary (:sc signed-reg :offset nl1-offset
 351                    :from (:argument 1) :to (:result 0)) y-pass)
 352   (:temporary (:sc signed-reg :offset nl2-offset :target r
 353                    :from (:argument 1) :to (:result 0)) res-pass)
 354   (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
 355   (:temporary (:sc signed-reg :offset nl4-offset
 356                    :from (:argument 1) :to (:result 0)) sign)
 357   (:temporary (:sc interior-reg :offset lip-offset) lip)
 358   (:ignore lip sign)
 359   (:translate *)
 360   (:generator 30
 361     (unless (location= y y-pass)
 362       (inst sra x 2 x-pass))
 363     (let ((fixup (make-fixup 'multiply :assembly-routine)))
 364       (inst ldil fixup tmp)
 365       (inst ble fixup lisp-heap-space tmp))
 366     (if (location= y y-pass)
 367         (inst sra x 2 x-pass)
 368         (inst move y y-pass))
 369     (move res-pass r)))
 370
 371 (define-vop (fast-*/signed=>signed fast-signed-binop)
 372   (:translate *)
 373   (:args (x :scs (signed-reg) :target x-pass)
 374          (y :scs (signed-reg) :target y-pass))
 375   (:temporary (:sc signed-reg :offset nl0-offset
 376                    :from (:argument 0) :to (:result 0)) x-pass)
 377   (:temporary (:sc signed-reg :offset nl1-offset
 378                    :from (:argument 1) :to (:result 0)) y-pass)
 379   (:temporary (:sc signed-reg :offset nl2-offset :target r
 380                    :from (:argument 1) :to (:result 0)) res-pass)
 381   (:temporary (:sc signed-reg :offset nl3-offset :to (:result 0)) tmp)
 382   (:temporary (:sc signed-reg :offset nl4-offset
 383                    :from (:argument 1) :to (:result 0)) sign)
 384   (:temporary (:sc interior-reg :offset lip-offset) lip)
 385   (:ignore lip sign)
 386   (:translate *)
 387   (:generator 31
 388     (let ((fixup (make-fixup 'multiply :assembly-routine)))
 389       (move x x-pass)
 390       (move y y-pass)
 391       (inst ldil fixup tmp)
 392       (inst ble fixup lisp-heap-space tmp :nullify t)
 393       (inst nop)
 394       (move res-pass r))))
 395
 396 (define-vop (fast-truncate/fixnum fast-fixnum-binop)
 397   (:translate truncate)
 398   (:args (x :scs (any-reg) :target x-pass)
 399          (y :scs (any-reg) :target y-pass))
 400   (:temporary (:sc signed-reg :offset nl0-offset
 401                    :from (:argument 0) :to (:result 0)) x-pass)
 402   (:temporary (:sc signed-reg :offset nl1-offset
 403                    :from (:argument 1) :to (:result 0)) y-pass)
 404   (:temporary (:sc signed-reg :offset nl2-offset :target q
 405                    :from (:argument 1) :to (:result 0)) q-pass)
 406   (:temporary (:sc signed-reg :offset nl3-offset :target r
 407                    :from (:argument 1) :to (:result 1)) r-pass)
 408   (:results (q :scs (signed-reg))
 409             (r :scs (any-reg)))
 410   (:result-types tagged-num tagged-num)
 411   (:vop-var vop)
 412   (:save-p :compute-only)
 413   (:generator 30
 414     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 415       (inst bc := nil y zero-tn zero))
 416     (move x x-pass)
 417     (move y y-pass)
 418     (let ((fixup (make-fixup 'truncate :assembly-routine)))
 419       (inst ldil fixup q-pass)
 420       (inst ble fixup lisp-heap-space q-pass :nullify t))
 421     (inst nop)
 422     (move q-pass q)
 423     (move r-pass r)))
 424
 425 (define-vop (fast-truncate/signed fast-signed-binop)
 426   (:translate truncate)
 427   (:args (x :scs (signed-reg) :target x-pass)
 428          (y :scs (signed-reg) :target y-pass))
 429   (:temporary (:sc signed-reg :offset nl0-offset
 430                    :from (:argument 0) :to (:result 0)) x-pass)
 431   (:temporary (:sc signed-reg :offset nl1-offset
 432                    :from (:argument 1) :to (:result 0)) y-pass)
 433   (:temporary (:sc signed-reg :offset nl2-offset :target q
 434                    :from (:argument 1) :to (:result 0)) q-pass)
 435   (:temporary (:sc signed-reg :offset nl3-offset :target r
 436                    :from (:argument 1) :to (:result 1)) r-pass)
 437   (:results (q :scs (signed-reg))
 438             (r :scs (signed-reg)))
 439   (:result-types signed-num signed-num)
 440   (:vop-var vop)
 441   (:save-p :compute-only)
 442   (:generator 35
 443     (let ((zero (generate-error-code vop division-by-zero-error x y)))
 444       (inst bc := nil y zero-tn zero))
 445     (move x x-pass)
 446     (move y y-pass)
 447     (let ((fixup (make-fixup 'truncate :assembly-routine)))
 448       (inst ldil fixup q-pass)
 449       (inst ble fixup lisp-heap-space q-pass :nullify t))
 450     (inst nop)
 451     (move q-pass q)
 452     (move r-pass r)))
 453
 454 \f
 455 ;;;; Binary conditional VOPs:
 456
 457 (define-vop (fast-conditional)
 458   (:conditional)
 459   (:info target not-p)
 460   (:effects)
 461   (:affected)
 462   (:policy :fast-safe))
 463
 464 (define-vop (fast-conditional/fixnum fast-conditional)
 465   (:args (x :scs (any-reg))
 466          (y :scs (any-reg)))
 467   (:arg-types tagged-num tagged-num)
 468   (:note "inline fixnum comparison"))
 469
 470 (define-vop (fast-conditional-c/fixnum fast-conditional/fixnum)
 471   (:args (x :scs (any-reg)))
 472   (:arg-types tagged-num (:constant (signed-byte 9)))
 473   (:info target not-p y))
 474
 475 (define-vop (fast-conditional/signed fast-conditional)
 476   (:args (x :scs (signed-reg))
 477          (y :scs (signed-reg)))
 478   (:arg-types signed-num signed-num)
 479   (:note "inline (signed-byte 32) comparison"))
 480
 481 (define-vop (fast-conditional-c/signed fast-conditional/signed)
 482   (:args (x :scs (signed-reg)))
 483   (:arg-types signed-num (:constant (signed-byte 11)))
 484   (:info target not-p y))
 485
 486 (define-vop (fast-conditional/unsigned fast-conditional)
 487   (:args (x :scs (unsigned-reg))
 488          (y :scs (unsigned-reg)))
 489   (:arg-types unsigned-num unsigned-num)
 490   (:note "inline (unsigned-byte 32) comparison"))
 491
 492 (define-vop (fast-conditional-c/unsigned fast-conditional/unsigned)
 493   (:args (x :scs (unsigned-reg)))
 494   (:arg-types unsigned-num (:constant (signed-byte 11)))
 495   (:info target not-p y))
 496
 497
 498 (defmacro define-conditional-vop (translate signed-cond unsigned-cond)
 499   `(progn
 500      ,@(mapcar #'(lambda (suffix cost signed imm)
 501                    (unless (and (member suffix '(/fixnum -c/fixnum))
 502                                 (eq translate 'eql))
 503                      `(define-vop (,(intern (format nil "~:@(FAST-IF-~A~A~)"
 504                                                     translate suffix))
 505                                    ,(intern
 506                                      (format nil "~:@(FAST-CONDITIONAL~A~)"
 507                                              suffix)))
 508                         (:translate ,translate)
 509                         (:generator ,cost
 510                           (inst ,(if imm 'bci 'bc)
 511                                 ,(if signed signed-cond unsigned-cond)
 512                                 not-p
 513                                 ,(if (eq suffix '-c/fixnum)
 514                                      '(fixnumize y)
 515                                      'y)
 516                                 x
 517                                 target)))))
 518                '(/fixnum -c/fixnum /signed -c/signed /unsigned -c/unsigned)
 519                '(3 2 5 4 5 4)
 520                '(t t t t nil nil)
 521                '(nil t nil t nil t))))
 522
 523 ;; We switch < and > because the immediate has to come first.
 524
 525 (define-conditional-vop < :> :>>)
 526 (define-conditional-vop > :< :<<)
 527
 528 ;;; EQL/FIXNUM is funny because the first arg can be of any type, not just a
 529 ;;; known fixnum.
 530 ;;;
 531 (define-conditional-vop eql := :=)
 532
 533 ;;; These versions specify a fixnum restriction on their first arg.  We have
 534 ;;; also generic-eql/fixnum VOPs which are the same, but have no restriction on
 535 ;;; the first arg and a higher cost.  The reason for doing this is to prevent
 536 ;;; fixnum specific operations from being used on word integers, spuriously
 537 ;;; consing the argument.
 538 ;;;
 539 (define-vop (fast-eql/fixnum fast-conditional)
 540   (:args (x :scs (any-reg descriptor-reg))
 541          (y :scs (any-reg)))
 542   (:arg-types tagged-num tagged-num)
 543   (:note "inline fixnum comparison")
 544   (:translate eql)
 545   (:generator 3
 546     (inst bc := not-p x y target)))
 547 ;;;
 548 (define-vop (generic-eql/fixnum fast-eql/fixnum)
 549   (:arg-types * tagged-num)
 550   (:variant-cost 7))
 551
 552 (define-vop (fast-eql-c/fixnum fast-conditional/fixnum)
 553   (:args (x :scs (any-reg descriptor-reg)))
 554   (:arg-types tagged-num (:constant (signed-byte 9)))
 555   (:info target not-p y)
 556   (:translate eql)
 557   (:generator 2
 558     (inst bci := not-p (fixnumize y) x target)))
 559 ;;;
 560 (define-vop (generic-eql-c/fixnum fast-eql-c/fixnum)
 561   (:arg-types * (:constant (signed-byte 9)))
 562   (:variant-cost 6))
 563
 564 \f
 565 ;;;; 32-bit logical operations
 566
 567 (define-vop (32bit-logical)
 568   (:args (x :scs (unsigned-reg))
 569          (y :scs (unsigned-reg)))
 570   (:arg-types unsigned-num unsigned-num)
 571   (:results (r :scs (unsigned-reg)))
 572   (:result-types unsigned-num)
 573   (:policy :fast-safe))
 574
 575 (define-vop (32bit-logical-not 32bit-logical)
 576   (:translate 32bit-logical-not)
 577   (:args (x :scs (unsigned-reg)))
 578   (:arg-types unsigned-num)
 579   (:generator 1
 580     (inst uaddcm zero-tn x r)))
 581
 582 (define-vop (32bit-logical-and 32bit-logical)
 583   (:translate 32bit-logical-and)
 584   (:generator 1
 585     (inst and x y r)))
 586
 587 (deftransform 32bit-logical-nand ((x y) (* *))
 588   '(32bit-logical-not (32bit-logical-and x y)))
 589
 590 (define-vop (32bit-logical-or 32bit-logical)
 591   (:translate 32bit-logical-or)
 592   (:generator 1
 593     (inst or x y r)))
 594
 595 (deftransform 32bit-logical-nor ((x y) (* *))
 596   '(32bit-logical-not (32bit-logical-or x y)))
 597
 598 (define-vop (32bit-logical-xor 32bit-logical)
 599   (:translate 32bit-logical-xor)
 600   (:generator 1
 601     (inst xor x y r)))
 602
 603 (deftransform 32bit-logical-eqv ((x y) (* *))
 604   '(32bit-logical-not (32bit-logical-xor x y)))
 605
 606 (deftransform 32bit-logical-andc1 ((x y) (* *))
 607   '(32bit-logical-and (32bit-logical-not x) y))
 608
 609 (define-vop (32bit-logical-andc2 32bit-logical)
 610   (:translate 32bit-logical-andc2)
 611   (:generator 1
 612     (inst andcm x y r)))
 613
 614 (deftransform 32bit-logical-orc1 ((x y) (* *))
 615   '(32bit-logical-or (32bit-logical-not x) y))
 616
 617 (deftransform 32bit-logical-orc2 ((x y) (* *))
 618   '(32bit-logical-or x (32bit-logical-not y)))
 619
 620
 621 (define-vop (shift-towards-someplace)
 622   (:policy :fast-safe)
 623   (:args (num :scs (unsigned-reg))
 624          (amount :scs (signed-reg)))
 625   (:arg-types unsigned-num tagged-num)
 626   (:results (r :scs (unsigned-reg)))
 627   (:result-types unsigned-num))
 628
 629 (define-vop (shift-towards-start shift-towards-someplace)
 630   (:translate shift-towards-start)
 631   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 632   (:note "SHIFT-TOWARDS-START")
 633   (:generator 1
 634     (inst subi 31 amount temp)
 635     (inst mtctl temp :sar)
 636     (inst zdep num :variable 32 r)))
 637
 638 (define-vop (shift-towards-end shift-towards-someplace)
 639   (:translate shift-towards-end)
 640   (:note "SHIFT-TOWARDS-END")
 641   (:generator 1
 642     (inst mtctl amount :sar)
 643     (inst shd zero-tn num :variable r)))
 644
 645
 646 \f
 647 ;;;; Bignum stuff.
 648
 649 (define-vop (bignum-length get-header-data)
 650   (:translate sb!bignum::%bignum-length)
 651   (:policy :fast-safe))
 652
 653 (define-vop (bignum-set-length set-header-data)
 654   (:translate sb!bignum::%bignum-set-length)
 655   (:policy :fast-safe))
 656
 657 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
 658   (unsigned-reg) unsigned-num sb!bignum::%bignum-ref)
 659
 660 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
 661   (unsigned-reg) unsigned-num sb!bignum::%bignum-set)
 662
 663 (define-vop (digit-0-or-plus)
 664   (:translate sb!bignum::%digit-0-or-plusp)
 665   (:policy :fast-safe)
 666   (:args (digit :scs (unsigned-reg)))
 667   (:arg-types unsigned-num)
 668   (:conditional)
 669   (:info target not-p)
 670   (:effects)
 671   (:affected)
 672   (:generator 1
 673     (inst bc :>= not-p digit zero-tn target)))
 674
 675 (define-vop (add-w/carry)
 676   (:translate sb!bignum::%add-with-carry)
 677   (:policy :fast-safe)
 678   (:args (a :scs (unsigned-reg))
 679          (b :scs (unsigned-reg))
 680          (c :scs (unsigned-reg)))
 681   (:arg-types unsigned-num unsigned-num positive-fixnum)
 682   (:results (result :scs (unsigned-reg))
 683             (carry :scs (unsigned-reg)))
 684   (:result-types unsigned-num positive-fixnum)
 685   (:generator 3
 686     (inst addi -1 c zero-tn)
 687     (inst addc a b result)
 688     (inst addc zero-tn zero-tn carry)))
 689
 690 (define-vop (sub-w/borrow)
 691   (:translate sb!bignum::%subtract-with-borrow)
 692   (:policy :fast-safe)
 693   (:args (a :scs (unsigned-reg))
 694          (b :scs (unsigned-reg))
 695          (c :scs (unsigned-reg)))
 696   (:arg-types unsigned-num unsigned-num positive-fixnum)
 697   (:results (result :scs (unsigned-reg))
 698             (borrow :scs (unsigned-reg)))
 699   (:result-types unsigned-num positive-fixnum)
 700   (:generator 4
 701     (inst addi -1 c zero-tn)
 702     (inst subb a b result)
 703     (inst addc zero-tn zero-tn borrow)))
 704
 705 (define-vop (bignum-mult)
 706   (:translate sb!bignum::%multiply)
 707   (:policy :fast-safe)
 708   (:args (x-arg :scs (unsigned-reg) :target x)
 709          (y-arg :scs (unsigned-reg) :target y))
 710   (:arg-types unsigned-num unsigned-num)
 711   (:temporary (:scs (signed-reg) :from (:argument 0)) x)
 712   (:temporary (:scs (signed-reg) :from (:argument 1)) y)
 713   (:temporary (:scs (signed-reg)) tmp)
 714   (:results (hi :scs (unsigned-reg))
 715             (lo :scs (unsigned-reg)))
 716   (:result-types unsigned-num unsigned-num)
 717   (:generator 3
 718     ;; Make sure X is less then Y.
 719     (inst comclr x-arg y-arg tmp :<<)
 720     (inst xor x-arg y-arg tmp)
 721     (inst xor x-arg tmp x)
 722     (inst xor y-arg tmp y)
 723
 724     ;; Blow out of here if the result is zero.
 725     (inst li 0 hi)
 726     (inst comb := x zero-tn done)
 727     (inst li 0 lo)
 728     (inst li 0 tmp)
 729
 730     LOOP
 731     (inst comb :ev x zero-tn next-bit)
 732     (inst srl x 1 x)
 733     (inst add lo y lo)
 734     (inst addc hi tmp hi)
 735     NEXT-BIT
 736     (inst add y y y)
 737     (inst comb :<> x zero-tn loop)
 738     (inst addc tmp tmp tmp)
 739
 740     DONE))
 741
 742 (define-source-transform sb!bignum:%multiply-and-add (x y carry &optional (extra 0))
 743   #+nil ;; This would be greate if it worked, but it doesn't.
 744   (if (eql extra 0)
 745       `(multiple-value-call #'sb!bignum::%dual-word-add
 746          (sb!bignum:%multiply ,x ,y)
 747          (values ,carry))
 748       `(multiple-value-call #'sb!bignum::%dual-word-add
 749          (multiple-value-call #'sb!bignum::%dual-word-add
 750            (sb!bignum:%multiply ,x ,y)
 751            (values ,carry))
 752          (values ,extra)))
 753   (with-unique-names (hi lo)
 754     (if (eql extra 0)
 755         `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
 756            (sb!bignum::%dual-word-add ,hi ,lo ,carry))
 757         `(multiple-value-bind (,hi ,lo) (sb!bignum:%multiply ,x ,y)
 758            (multiple-value-bind
 759                (,hi ,lo)
 760                (sb!bignum::%dual-word-add ,hi ,lo ,carry)
 761              (sb!bignum::%dual-word-add ,hi ,lo ,extra))))))
 762
 763 (defknown sb!bignum::%dual-word-add
 764           (sb!bignum:bignum-element-type sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
 765   (values sb!bignum:bignum-element-type sb!bignum:bignum-element-type)
 766   (flushable movable))
 767
 768 (define-vop (dual-word-add)
 769   (:policy :fast-safe)
 770   (:translate sb!bignum::%dual-word-add)
 771   (:args (hi :scs (unsigned-reg) :to (:result 1))
 772          (lo :scs (unsigned-reg))
 773          (extra :scs (unsigned-reg)))
 774   (:arg-types unsigned-num unsigned-num unsigned-num)
 775   (:results (hi-res :scs (unsigned-reg) :from (:result 1))
 776             (lo-res :scs (unsigned-reg) :from (:result 0)))
 777   (:result-types unsigned-num unsigned-num)
 778   (:affected)
 779   (:effects)
 780   (:generator 3
 781     (inst add lo extra lo-res)
 782     (inst addc hi zero-tn hi-res)))
 783
 784 (define-vop (bignum-lognot)
 785   (:translate sb!bignum::%lognot)
 786   (:policy :fast-safe)
 787   (:args (x :scs (unsigned-reg)))
 788   (:arg-types unsigned-num)
 789   (:results (r :scs (unsigned-reg)))
 790   (:result-types unsigned-num)
 791   (:generator 1
 792     (inst uaddcm zero-tn x r)))
 793
 794 (define-vop (fixnum-to-digit)
 795   (:translate sb!bignum::%fixnum-to-digit)
 796   (:policy :fast-safe)
 797   (:args (fixnum :scs (signed-reg)))
 798   (:arg-types tagged-num)
 799   (:results (digit :scs (unsigned-reg)))
 800   (:result-types unsigned-num)
 801   (:generator 1
 802     (move fixnum digit)))
 803
 804 (define-vop (bignum-floor)
 805   (:translate sb!bignum::%floor)
 806   (:policy :fast-safe)
 807   (:args (hi :scs (unsigned-reg) :to (:argument 1))
 808          (lo :scs (unsigned-reg) :to (:argument 0))
 809          (divisor :scs (unsigned-reg)))
 810   (:arg-types unsigned-num unsigned-num unsigned-num)
 811   (:temporary (:scs (unsigned-reg) :to (:argument 1)) temp)
 812   (:results (quo :scs (unsigned-reg) :from (:argument 0))
 813             (rem :scs (unsigned-reg) :from (:argument 1)))
 814   (:result-types unsigned-num unsigned-num)
 815   (:generator 65
 816     (inst sub zero-tn divisor temp)
 817     (inst ds zero-tn temp zero-tn)
 818     (inst add lo lo quo)
 819     (inst ds hi divisor rem)
 820     (inst addc quo quo quo)
 821     (dotimes (i 31)
 822       (inst ds rem divisor rem)
 823       (inst addc quo quo quo))
 824     (inst comclr rem zero-tn zero-tn :>=)
 825     (inst add divisor rem rem)))
 826
 827 (define-vop (signify-digit)
 828   (:translate sb!bignum::%fixnum-digit-with-correct-sign)
 829   (:policy :fast-safe)
 830   (:args (digit :scs (unsigned-reg) :target res))
 831   (:arg-types unsigned-num)
 832   (:results (res :scs (signed-reg)))
 833   (:result-types signed-num)
 834   (:generator 1
 835     (move digit res)))
 836
 837 (define-vop (digit-lshr)
 838   (:translate sb!bignum::%digit-logical-shift-right)
 839   (:policy :fast-safe)
 840   (:args (digit :scs (unsigned-reg))
 841          (count :scs (unsigned-reg)))
 842   (:arg-types unsigned-num positive-fixnum)
 843   (:results (result :scs (unsigned-reg)))
 844   (:result-types unsigned-num)
 845   (:generator 2
 846     (inst mtctl count :sar)
 847     (inst shd zero-tn digit :variable result)))
 848
 849 (define-vop (digit-ashr digit-lshr)
 850   (:translate sb!bignum::%ashr)
 851   (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)
 852   (:generator 1
 853     (inst extrs digit 0 1 temp)
 854     (inst mtctl count :sar)
 855     (inst shd temp digit :variable result)))
 856
 857 (define-vop (digit-ashl digit-ashr)
 858   (:translate sb!bignum::%ashl)
 859   (:generator 1
 860     (inst subi 31 count temp)
 861     (inst mtctl temp :sar)
 862     (inst zdep digit :variable 32 result)))
 863
 864 \f
 865 ;;;; Static functions.
 866
 867 (define-static-fun two-arg-gcd (x y) :translate gcd)
 868 (define-static-fun two-arg-lcm (x y) :translate lcm)
 869
 870 (define-static-fun two-arg-* (x y) :translate *)
 871 (define-static-fun two-arg-/ (x y) :translate /)
 872
 873 (define-static-fun %negate (x) :translate %negate)
 874
 875 (define-static-fun two-arg-and (x y) :translate logand)
 876 (define-static-fun two-arg-ior (x y) :translate logior)
 877 (define-static-fun two-arg-xor (x y) :translate logxor)