src/compiler/hppa/arith.lisp

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